These are the sources Tezos imported to Coq by the current development version of coq-of-ocaml. Tezos is a crypto-currency with smart-contracts and an upgradable protocol. The market cap of Tezos is more than US $500 millions at the time of writting. Write at web [at] clarus [dot] me for more information. Work currently made at Nomadic Labs.
src/bin_attacker/attacker_main.ml 2 errors
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) let () = Attacker_minimal.main ()
src/bin_attacker/attacker_main.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations.
src/bin_attacker/attacker_minimal.ml 142 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Format
include Logging.Make (struct
let name = "attacker"
end)
module Proto = Client_embedded_proto_alpha
(* the genesis block and network *)
let genesis_block_hashed =
Block_hash.of_b58check "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"
let network = Store.Net genesis_block_hashed
let network = Store.Chain_id.Id genesis_block_hashed
(* the bootstrap accounts and actions like signing to do with them *)
let source_account = List.nth Proto.Bootstrap_storage.accounts 4
let destination_account = List.nth Proto.Bootstrap_storage.accounts 0
let wrong_account = List.nth Proto.Bootstrap_storage.accounts 1
let another_account = List.nth Proto.Bootstrap_storage.accounts 2
let signed = Ed25519.append_signature source_account.secret_key
let signed_wrong = Ed25519.append_signature wrong_account.secret_key
(* forge a block from a list of operations *)
let block_forged ?prev ops =
let from_int64 x =
[ Bytes.of_string Proto.Constants_repr.version_number;
Proto.Fitness_repr.int64_to_bytes x ]
in
let pred = match prev with None -> genesis_block_hashed | Some x -> x in
let block ops =
Store.Block_header.
{
chain_id = network;
predecessor = pred;
timestamp = Systime_os.now ();
fitness = from_int64 1L;
operations = ops;
}
in
let open Proto in
let generate_proof_of_work_nonce () =
Rand.generate Proto.Alpha_context.Constants.proof_of_work_nonce_size
in
let generate_seed_nonce () =
match
Proto.Nonce_storage.of_bytes
@@ Rand.generate Proto.Alpha_context.Constants.nonce_length
with
| Error _ ->
assert false
| Ok nonce ->
nonce
in
Block_repr.forge_header
(block ops)
Block_repr.
{
baking_slot = {level = Raw_level_repr.of_int32_exn 1l; priority = 0l};
seed_nonce_hash = Proto.Nonce_storage.hash (generate_seed_nonce ());
proof_of_work_nonce = generate_proof_of_work_nonce ();
}
(* forge a transaction *)
let tx_forged ?dest amount fee =
let open Proto.Operation_repr in
let open Proto.Tez_repr in
let open Proto.Contract_repr in
let trgt =
match dest with None -> destination_account | Some dest -> dest
in
let src = source_account in
let tx =
Transaction
{
amount = of_cents_exn amount;
parameters = None;
destination = default_contract trgt.public_key_hash;
}
in
let op =
Sourced_operations
(Manager_operations
{
source = default_contract src.public_key_hash;
public_key = Some src.public_key;
fee = of_cents_exn fee;
counter = 1l;
operations = [tx];
})
in
forge {chain_id = network} op
(* forge a list of proposals, california eat your heart out *)
let props_forged period props =
let open Proto.Operation_repr in
let src = source_account in
let props = Proposals {period; proposals = props} in
let op =
Sourced_operations
(Delegate_operations {source = src.public_key; operations = [props]})
in
forge {chain_id = network} op
(* "forge" a ballot *)
let ballot_forged period prop vote =
let open Proto.Operation_repr in
let src = source_account in
let ballot = Ballot {period; proposal = prop; ballot = vote} in
let op =
Sourced_operations
(Delegate_operations {source = src.public_key; operations = [ballot]})
in
forge {chain_id = network} op
let identity = P2p_identity.generate Crypto_box.default_target
(* connect to the network, run an action and then disconnect *)
let try_action addr port action =
let socket = Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in
let uaddr = Ipaddr_unix.V6.to_inet_addr addr in
Lwt_unix.connect socket (Lwt_unix.ADDR_INET (uaddr, port))
>>= fun () ->
let io_sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 14) () in
let conn = P2p_io_scheduler.register io_sched socket in
P2p_connection.authenticate
~proof_of_work_target:Crypto_box.default_target
~incoming:false
conn
(addr, port)
identity
Distributed_db.Raw.supported_versions
>>=? fun (_, auth_fd) ->
P2p_connection.accept auth_fd Distributed_db.Raw.encoding
>>= function
| Error _ ->
failwith "Connection rejected by peer."
| Ok conn ->
action conn
>>=? fun () -> P2p_connection.close conn >>= fun () -> return_unit
let replicate n x =
let rec replicate_acc acc n x =
if n <= 0 then acc else replicate_acc (x :: acc) (n - 1) x
in
replicate_acc [] n x
let send conn (msg : Distributed_db.Message.t) =
P2p_connection.write conn (P2p.Raw.Message msg)
let request_block_times block_hash n conn =
let open Block_hash in
lwt_log_notice "requesting %a block %d times" pp_short block_hash n
>>= fun () ->
let block_hashes = replicate n block_hash in
send conn (Get_block_headers (network, block_hashes))
let request_op_times op_signed n conn =
let open Operation_hash in
let op_hash = hash_bytes [op_signed] in
lwt_log_notice "sending %a transaction" pp_short op_hash
>>= fun () ->
send conn (Operation op_signed)
>>=? fun () ->
lwt_log_notice "requesting %a transaction %d times" pp_short op_hash n
>>= fun () ->
let op_hashes = replicate n op_hash in
send conn (Get_operations op_hashes)
let send_block_size n conn =
let bytes = Bytes.create n in
let open Block_hash in
lwt_log_notice
"propagating fake %d byte block %a"
n
pp_short
(hash_bytes [bytes])
>>= fun () -> send conn (Block bytes)
let send_protocol_size n conn =
let bytes = Bytes.create n in
let open Protocol_hash in
lwt_log_notice
"propagating fake %d byte protocol %a"
n
pp_short
(hash_bytes [bytes])
>>= fun () -> send conn (Protocol bytes)
let send_operation_size n conn =
let op_faked = Bytes.create n in
let op_hashed = Operation_hash.hash_bytes [op_faked] in
lwt_log_notice
"propagating fake %d byte operation %a"
n
Operation_hash.pp_short
op_hashed
>>= fun () ->
send conn (Operation op_faked)
>>=? fun () ->
let block = signed (block_forged [op_hashed]) in
let block_hashed = Block_hash.hash_bytes [block] in
lwt_log_notice
"propagating block %a with operation"
Block_hash.pp_short
block_hashed
>>= fun () -> send conn (Block block)
let send_operation_bad_signature () conn =
let open Operation_hash in
let signed_wrong_op = signed_wrong (tx_forged 5L 1L) in
let hashed_wrong_op = hash_bytes [signed_wrong_op] in
lwt_log_notice
"propagating operation %a with wrong signature"
pp_short
hashed_wrong_op
>>= fun () ->
send conn (Operation signed_wrong_op)
>>=? fun () ->
let block = signed (block_forged [hashed_wrong_op]) in
let block_hashed = Block_hash.hash_bytes [block] in
lwt_log_notice
"propagating block %a with operation"
Block_hash.pp_short
block_hashed
>>= fun () -> send conn (Block block)
let send_block_bad_signature () conn =
let open Block_hash in
let signed_wrong_block = signed_wrong (block_forged []) in
lwt_log_notice
"propagating block %a with wrong signature"
pp_short
(hash_bytes [signed_wrong_block])
>>= fun () -> send conn (Block signed_wrong_block)
let double_spend () conn =
let spend account =
let op_signed = signed (tx_forged ~dest:account 199999999L 1L) in
let op_hashed = Operation_hash.hash_bytes [op_signed] in
let block_signed = signed (block_forged [op_hashed]) in
let block_hashed = Block_hash.hash_bytes [block_signed] in
lwt_log_notice "propagating operation %a" Operation_hash.pp_short op_hashed
>>= fun () ->
send conn (Operation op_signed)
>>=? fun () ->
lwt_log_notice "propagating block %a" Block_hash.pp_short block_hashed
>>= fun () -> send conn (Block block_signed)
in
spend destination_account >>=? fun () -> spend another_account
let long_chain n conn =
lwt_log_notice "propogating %d blocks" n
>>= fun () ->
let prev_ref = ref genesis_block_hashed in
let rec loop k =
if k < 1 then return_unit
else
let block = signed (block_forged ~prev:!prev_ref []) in
prev_ref := Block_hash.hash_bytes [block] ;
send conn (Block block) >>=? fun () -> loop (k - 1)
in
loop n
let lots_transactions amount fee n conn =
let signed_op = signed (tx_forged amount fee) in
let rec loop k =
if k < 1 then return_unit
else send conn (Operation signed_op) >>=? fun () -> loop (k - 1)
in
let ops = replicate n (Operation_hash.hash_bytes [signed_op]) in
let signed_block = signed (block_forged ops) in
lwt_log_notice "propogating %d transactions" n
>>= fun () ->
loop n
>>=? fun () ->
lwt_log_notice
"propagating block %a with wrong signature"
Block_hash.pp_short
(Block_hash.hash_bytes [signed_block])
>>= fun () -> send conn (Block signed_block)
let main () =
let addr = Ipaddr.V6.localhost in
let port = 9732 in
let run_action action = try_action addr port action in
let run_cmd_unit lwt =
Arg.Unit
(fun () ->
Lwt_main.run
( lwt ()
>>= function
| Ok () ->
Lwt.return_unit
| Error err ->
lwt_log_error "Error: %a" pp_print_error err
>>= fun () -> Lwt.return_unit ))
in
let run_cmd_int_suffix lwt =
Arg.String
(fun str ->
let last = str.[String.length str - 1] in
let init = String.sub str 0 (String.length str - 1) in
let n =
if last == 'k' || last == 'K' then int_of_string init * (1 lsl 10)
else if last == 'm' || last == 'M' then
int_of_string init * (1 lsl 20)
else if last == 'g' || last == 'G' then
int_of_string init * (1 lsl 30)
else int_of_string str
in
Lwt_main.run
( lwt n
>>= function
| Ok () ->
Lwt.return_unit
| Error err ->
lwt_log_error "Error: %a" pp_print_error err
>>= fun () -> Lwt.return_unit ))
in
let cmds =
[ ( "-1",
run_cmd_int_suffix
(run_action << request_block_times genesis_block_hashed),
"[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}blocks."
);
( "-2",
run_cmd_int_suffix
(run_action << request_op_times (signed (tx_forged 5L 1L))),
"[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}ops."
);
( "-3",
run_cmd_int_suffix (run_action << send_block_size),
"[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake \
block." );
( "-4",
run_cmd_int_suffix (run_action << send_operation_size),
"[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake \
operation." );
( "-5",
run_cmd_int_suffix (run_action << send_protocol_size),
"[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake \
protocol." );
( "-6",
run_cmd_unit (run_action << send_operation_bad_signature),
"Attempt to propagate a transaction with a bad signature." );
( "-7",
run_cmd_unit (run_action << send_block_bad_signature),
"Attempt to propagate a block with a bad signature." );
( "-8",
run_cmd_unit (run_action << double_spend),
"Attempt to send the same transaction in two blocks" );
( "-9",
run_cmd_int_suffix (run_action << long_chain),
"[N {,K,M,G}] Attempt to send a chain of N {,kilo,mega,giga}blocks" );
( "-10",
run_cmd_int_suffix (run_action << lots_transactions 0L 0L),
"[N {,K,M,G}] Attempt to send N {,kilo,mega,giga}ops" ) ]
in
Arg.parse cmds print_endline "Tezos Evil Client"
src/bin_attacker/attacker_minimal.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Format.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition genesis_block_hashed {A : Type} : A :=
op_startypeminuserrorstar
"BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.
Definition network {A : Type} : A := op_startypeminuserrorstar.
Definition network {A : Type} : A := op_startypeminuserrorstar.
Definition source_account {A : Type} : A :=
Stdlib.List.nth op_startypeminuserrorstar 4.
Definition destination_account {A : Type} : A :=
Stdlib.List.nth op_startypeminuserrorstar 0.
Definition wrong_account {A : Type} : A :=
Stdlib.List.nth op_startypeminuserrorstar 1.
Definition another_account {A : Type} : A :=
Stdlib.List.nth op_startypeminuserrorstar 2.
Definition signed {A : Type} : A :=
op_startypeminuserrorstar (secret_key source_account).
Definition signed_wrong {A : Type} : A :=
op_startypeminuserrorstar (secret_key wrong_account).
Definition block_forged {A B C : Type} (prev : option A) (ops : B) : C :=
let from_int64 {D : Type} (x : D) : list string :=
cons (Stdlib.Bytes.of_string op_startypeminuserrorstar)
(cons (op_startypeminuserrorstar x) []) in
let pred :=
match prev with
| None => genesis_block_hashed
| Some x => x
end in
let block {D E : Type} (ops : D) : E :=
op_startypeminuserrorstar in
let generate_proof_of_work_nonce {D : Type} (function_parameter : unit) : D :=
let 'tt := function_parameter in
op_startypeminuserrorstar op_startypeminuserrorstar in
let generate_seed_nonce {D : Type} (function_parameter : unit) : D :=
let 'tt := function_parameter in
match
apply op_startypeminuserrorstar
(op_startypeminuserrorstar op_startypeminuserrorstar) with
| Stdlib.Error _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| Stdlib.Ok nonce => nonce
end in
op_startypeminuserrorstar (block ops) op_startypeminuserrorstar.
Definition tx_forged {A B C D : Type} (dest : option A) (amount : B) (fee : C)
: D := op_startypeminuserrorstar.
Definition props_forged {A B C : Type} (period : A) (props : B) : C :=
op_startypeminuserrorstar.
Definition ballot_forged {A B C D : Type} (period : A) (prop : B) (vote : C)
: D := op_startypeminuserrorstar.
Definition identity {A : Type} : A :=
op_startypeminuserrorstar op_startypeminuserrorstar.
Definition try_action {A B C D E : Type} (addr : A) (port : B) (action : C -> D)
: E :=
let socket :=
op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar 0 in
let uaddr := op_startypeminuserrorstar addr in
op_startypeminuserrorstar
(op_startypeminuserrorstar socket op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let io_sched := op_startypeminuserrorstar (Z.shiftl 1 14) tt in
let conn := op_startypeminuserrorstar io_sched socket in
op_startypeminuserrorstar
(op_startypeminuserrorstar op_startypeminuserrorstar false conn
(addr, port) identity op_startypeminuserrorstar)
(fun function_parameter =>
let '(_, auth_fd) := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar auth_fd op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ =>
OCaml.Stdlib.failwith "Connection rejected by peer." % string
| Stdlib.Ok conn =>
op_startypeminuserrorstar (action conn)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar conn)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar))
end))).
Definition replicate {A : Type} (n : Z) (x : A) : list A :=
let fix replicate_acc {B : Type} (acc : list B) (n : Z) (x : B) : list B :=
if OCaml.Stdlib.le n 0 then
acc
else
replicate_acc (cons x acc) (Z.sub n 1) x in
replicate_acc [] n x.
Definition send {A B C : Type} (conn : A) (function_parameter : B) : C :=
let '_ := function_parameter in
op_startypeminuserrorstar conn op_startypeminuserrorstar.
Definition request_block_times {A B C D : Type}
(block_hash : A) (n : B) (conn : C) : D := op_startypeminuserrorstar.
Definition request_op_times {A B C D : Type} (op_signed : A) (n : B) (conn : C)
: D := op_startypeminuserrorstar.
Definition send_block_size {A B : Type} (n : Z) (conn : A) : B :=
let bytes := Stdlib.Bytes.create n in
op_startypeminuserrorstar.
Definition send_protocol_size {A B : Type} (n : Z) (conn : A) : B :=
let bytes := Stdlib.Bytes.create n in
op_startypeminuserrorstar.
Definition send_operation_size {A B : Type} (n : Z) (conn : A) : B :=
let op_faked := Stdlib.Bytes.create n in
let op_hashed := op_startypeminuserrorstar (cons op_faked []) in
op_startypeminuserrorstar
(op_startypeminuserrorstar "propagating fake %d byte operation %a" % string
n op_startypeminuserrorstar op_hashed)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (send conn op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let block := signed (block_forged None (cons op_hashed [])) in
let block_hashed := op_startypeminuserrorstar (cons block []) in
op_startypeminuserrorstar
(op_startypeminuserrorstar
"propagating block %a with operation" % string
op_startypeminuserrorstar block_hashed)
(fun function_parameter =>
let 'tt := function_parameter in
send conn op_startypeminuserrorstar))).
Definition send_operation_bad_signature {A B : Type} (function_parameter : unit)
: A -> B :=
let 'tt := function_parameter in
fun conn => op_startypeminuserrorstar.
Definition send_block_bad_signature {A B : Type} (function_parameter : unit)
: A -> B :=
let 'tt := function_parameter in
fun conn => op_startypeminuserrorstar.
Definition double_spend {A B : Type} (function_parameter : unit) : A -> B :=
let 'tt := function_parameter in
fun conn =>
let spend {C D : Type} (account : C) : D :=
let op_signed :=
signed
(tx_forged (Some account)
(* ❌ Constant of type int64 is converted to int *)
199999999
(* ❌ Constant of type int64 is converted to int *)
1) in
let op_hashed := op_startypeminuserrorstar (cons op_signed []) in
let block_signed := signed (block_forged None (cons op_hashed [])) in
let block_hashed := op_startypeminuserrorstar (cons block_signed []) in
op_startypeminuserrorstar
(op_startypeminuserrorstar "propagating operation %a" % string
op_startypeminuserrorstar op_hashed)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (send conn op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar "propagating block %a" % string
op_startypeminuserrorstar block_hashed)
(fun function_parameter =>
let 'tt := function_parameter in
send conn op_startypeminuserrorstar))) in
op_startypeminuserrorstar (spend destination_account)
(fun function_parameter =>
let 'tt := function_parameter in
spend another_account).
Definition long_chain {A B : Type} (n : Z) (conn : A) : B :=
op_startypeminuserrorstar
(op_startypeminuserrorstar "propogating %d blocks" % string n)
(fun function_parameter =>
let 'tt := function_parameter in
let prev_ref := Stdlib.ref genesis_block_hashed in
let fix loop {C : Type} (k : Z) : C :=
if OCaml.Stdlib.lt k 1 then
op_startypeminuserrorstar
else
let block :=
signed (block_forged (Some (Stdlib.op_exclamation prev_ref)) []) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq prev_ref
(op_startypeminuserrorstar (cons block [])) in
op_startypeminuserrorstar (send conn op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
loop (Z.sub k 1)) in
loop n).
Definition lots_transactions {A B C D : Type}
(amount : A) (fee : B) (n : Z) (conn : C) : D :=
let signed_op := signed (tx_forged None amount fee) in
let fix loop {E : Type} (k : Z) : E :=
if OCaml.Stdlib.lt k 1 then
op_startypeminuserrorstar
else
op_startypeminuserrorstar (send conn op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
loop (Z.sub k 1)) in
let ops := replicate n (op_startypeminuserrorstar (cons signed_op [])) in
let signed_block := signed (block_forged None ops) in
op_startypeminuserrorstar
(op_startypeminuserrorstar "propogating %d transactions" % string n)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (loop n)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
"propagating block %a with wrong signature" % string
op_startypeminuserrorstar
(op_startypeminuserrorstar (cons signed_block [])))
(fun function_parameter =>
let 'tt := function_parameter in
send conn op_startypeminuserrorstar))).
Definition main (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let addr := op_startypeminuserrorstar in
let port := 9732 in
let run_action {A B C : Type} (action : A -> B) : C :=
try_action addr port action in
let run_cmd_unit {A : Type} (lwt : unit -> A) : Stdlib.Arg.spec :=
Stdlib.Arg.Unit
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar (lwt tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => op_startypeminuserrorstar
| Stdlib.Error err =>
op_startypeminuserrorstar
(op_startypeminuserrorstar "Error: %a" % string
op_startypeminuserrorstar err)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar)
end))) in
let run_cmd_int_suffix {A : Type} (lwt : Z -> A) : Stdlib.Arg.spec :=
Stdlib.Arg.String
(fun str =>
let last := Stdlib.String.get str (Z.sub (OCaml.String.length str) 1) in
let init := Stdlib.String.sub str 0 (Z.sub (OCaml.String.length str) 1)
in
let n :=
if
orb (Stdlib.op_eqeq last "k" % char)
(Stdlib.op_eqeq last "K" % char) then
Z.mul (OCaml.Stdlib.int_of_string init) (Z.shiftl 1 10)
else
if
orb (Stdlib.op_eqeq last "m" % char)
(Stdlib.op_eqeq last "M" % char) then
Z.mul (OCaml.Stdlib.int_of_string init) (Z.shiftl 1 20)
else
if
orb (Stdlib.op_eqeq last "g" % char)
(Stdlib.op_eqeq last "G" % char) then
Z.mul (OCaml.Stdlib.int_of_string init) (Z.shiftl 1 30)
else
OCaml.Stdlib.int_of_string str in
op_startypeminuserrorstar
(op_startypeminuserrorstar (lwt n)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => op_startypeminuserrorstar
| Stdlib.Error err =>
op_startypeminuserrorstar
(op_startypeminuserrorstar "Error: %a" % string
op_startypeminuserrorstar err)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar)
end))) in
let cmds :=
cons
("-1" % string,
(run_cmd_int_suffix
(op_startypeminuserrorstar run_action
(request_block_times genesis_block_hashed))),
"[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}blocks."
% string)
(cons
("-2" % string,
(run_cmd_int_suffix
(op_startypeminuserrorstar run_action
(request_op_times
(signed
(tx_forged None
(* ❌ Constant of type int64 is converted to int *)
5
(* ❌ Constant of type int64 is converted to int *)
1))))),
"[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}ops."
% string)
(cons
("-3" % string,
(run_cmd_int_suffix
(op_startypeminuserrorstar run_action send_block_size)),
"[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake block."
% string)
(cons
("-4" % string,
(run_cmd_int_suffix
(op_startypeminuserrorstar run_action send_operation_size)),
"[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake operation."
% string)
(cons
("-5" % string,
(run_cmd_int_suffix
(op_startypeminuserrorstar run_action send_protocol_size)),
"[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake protocol."
% string)
(cons
("-6" % string,
(run_cmd_unit
(op_startypeminuserrorstar run_action
send_operation_bad_signature)),
"Attempt to propagate a transaction with a bad signature." %
string)
(cons
("-7" % string,
(run_cmd_unit
(op_startypeminuserrorstar run_action
send_block_bad_signature)),
"Attempt to propagate a block with a bad signature." %
string)
(cons
("-8" % string,
(run_cmd_unit
(op_startypeminuserrorstar run_action double_spend)),
"Attempt to send the same transaction in two blocks" %
string)
(cons
("-9" % string,
(run_cmd_int_suffix
(op_startypeminuserrorstar run_action long_chain)),
"[N {,K,M,G}] Attempt to send a chain of N {,kilo,mega,giga}blocks"
% string)
(cons
("-10" % string,
(run_cmd_int_suffix
(op_startypeminuserrorstar run_action
(lots_transactions
(* ❌ Constant of type int64 is converted to int *)
0
(* ❌ Constant of type int64 is converted to int *)
0))),
"[N {,K,M,G}] Attempt to send N {,kilo,mega,giga}ops"
% string) []))))))))) in
Arg.parse cmds OCaml.Stdlib.print_endline "Tezos Evil Client" % string.
src/bin_client/client_protocols_commands.ml 43 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let group =
{Clic.name = "protocols"; title = "Commands for managing protocols"}
let proto_param ~name ~desc t =
Clic.param
~name
~desc
(Clic.parameter (fun _ str -> Lwt.return (Protocol_hash.of_b58check str)))
t
let commands () =
let open Clic in
let check_dir _ dn =
if Sys.is_directory dn then return dn
else failwith "%s is not a directory" dn
in
let check_dir_parameter = parameter check_dir in
[ command
~group
~desc:"List protocols known by the node."
no_options
(prefixes ["list"; "protocols"] stop)
(fun () (cctxt : #Client_context.full) ->
Shell_services.Protocol.list cctxt
>>=? fun protos ->
Lwt_list.iter_s
(fun ph -> cctxt#message "%a" Protocol_hash.pp ph)
protos
>>= fun () -> return_unit);
command
~group
~desc:"Inject a new protocol into the node."
no_options
( prefixes ["inject"; "protocol"]
@@ param
~name:"dir"
~desc:"directory containing the sources of a protocol"
check_dir_parameter
@@ stop )
(fun () dirname (cctxt : #Client_context.full) ->
Lwt.catch
(fun () ->
Tezos_base_unix.Protocol_files.read_dir dirname
>>=? fun (_hash, proto) ->
Shell_services.Injection.protocol cctxt proto
>>= function
| Ok hash ->
cctxt#message
"Injected protocol %a successfully"
Protocol_hash.pp
hash
>>= fun () -> return_unit
| Error err ->
cctxt#error
"Error while injecting protocol from %s: %a"
dirname
Error_monad.pp_print_error
err
>>= fun () -> return_unit)
(fun exn ->
cctxt#error
"Error while injecting protocol from %s: %a"
dirname
Error_monad.pp_print_error
[Error_monad.Exn exn]
>>= fun () -> return_unit));
command
~group
~desc:"Dump a protocol from the node's record of protocol."
no_options
( prefixes ["dump"; "protocol"]
@@ proto_param ~name:"protocol hash" ~desc:""
@@ stop )
(fun () ph (cctxt : #Client_context.full) ->
Shell_services.Protocol.contents cctxt ph
>>=? fun proto ->
Tezos_base_unix.Protocol_files.write_dir
(Protocol_hash.to_short_b58check ph)
~hash:ph
proto
>>=? fun () ->
cctxt#message "Extracted protocol %a" Protocol_hash.pp_short ph
>>= fun () -> return_unit);
command
~group
~desc:"Fetch a protocol from the network."
no_options
( prefixes ["fetch"; "protocol"]
@@ proto_param ~name:"protocol hash" ~desc:""
@@ stop )
(fun () hash (cctxt : #Client_context.full) ->
Shell_services.Protocol.fetch cctxt hash
>>= function
| Ok () ->
cctxt#message
"Protocol %a successfully fetched."
Protocol_hash.pp_short
hash
>>= fun () -> return_unit
| Error err ->
cctxt#error
"Error while fetching protocol: %a"
Error_monad.pp_print_error
err
>>= fun () -> return_unit) ]
src/bin_client/client_protocols_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "protocols" % string;
Clic.title := "Commands for managing protocols" % string |}.
Definition proto_param {A B : Type}
(name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
: Tezos_base__TzPervasives.Clic.params
(Tezos_base__TzPervasives.Protocol_hash.t -> A) B :=
Clic.param name desc
(Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun str => Lwt._return (Protocol_hash.of_b58check str))) t.
Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) :=
let 'tt := function_parameter in
let check_dir {J : Type} (function_parameter : J)
: string -> Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
let '_ := function_parameter in
fun dn =>
if Sys.is_directory dn then
_return dn
else
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" is not a directory" % string
CamlinternalFormatBasics.End_of_format))
"%s is not a directory" % string) dn in
let check_dir_parameter := parameter None check_dir in
cons
(command (Some group) "List protocols known by the node." % string
no_options
(prefixes (cons "list" % string (cons "protocols" % string [])) stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion (Shell_services.Protocol.list cctxt)
(fun protos =>
op_gtgteq
(Lwt_list.iter_s
(fun ph =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Protocol_hash.pp ph) protos)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group) "Inject a new protocol into the node." % string
no_options
(apply (prefixes (cons "inject" % string (cons "protocol" % string [])))
(apply
(param "dir" % string
"directory containing the sources of a protocol" % string
check_dir_parameter) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun dirname =>
fun cctxt =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Tezos_base_unix.Protocol_files.read_dir dirname)
(fun function_parameter =>
let '(_hash, proto) := function_parameter in
op_gtgteq
(Shell_services.Injection.protocol cctxt None proto)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok hash =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Injected protocol " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" successfully" % string
CamlinternalFormatBasics.End_of_format)))
"Injected protocol %a successfully" % string)
Protocol_hash.pp hash)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error err =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error while injecting protocol from " %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Error while injecting protocol from %s: %a" %
string) dirname Error_monad.pp_print_error
err)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end)))
(fun exn =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error while injecting protocol from " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Error while injecting protocol from %s: %a" % string)
dirname Error_monad.pp_print_error
(cons (Tezos_base__TzPervasives.Error_monad.Exn exn) []))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Dump a protocol from the node's record of protocol." % string
no_options
(apply (prefixes (cons "dump" % string (cons "protocol" % string [])))
(apply (proto_param "protocol hash" % string "" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun ph =>
fun cctxt =>
op_gtgteqquestion (Shell_services.Protocol.contents cctxt ph)
(fun proto =>
op_gtgteqquestion
(Tezos_base_unix.Protocol_files.write_dir
(Protocol_hash.to_short_b58check ph) (Some ph) proto)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Extracted protocol " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Extracted protocol %a" % string)
Protocol_hash.pp_short ph)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))))
(cons
(command (Some group) "Fetch a protocol from the network." % string
no_options
(apply
(prefixes (cons "fetch" % string (cons "protocol" % string [])))
(apply (proto_param "protocol hash" % string "" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun hash =>
fun cctxt =>
op_gtgteq (Shell_services.Protocol.fetch cctxt hash)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Protocol " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" successfully fetched." % string
CamlinternalFormatBasics.End_of_format)))
"Protocol %a successfully fetched." % string)
Protocol_hash.pp_short hash)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error err =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error while fetching protocol: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Error while fetching protocol: %a" % string)
Error_monad.pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end))) []))).
src/bin_client/client_rpc_commands.ml 367 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Tezos Command line interface - Generic JSON RPC interface *)
open Lwt.Infix
open Clic
open Json_schema
(*-- Assisted, schema directed input fill in --------------------------------*)
exception Unsupported_construct
type input = {
int : int -> int -> string option -> string list -> int Lwt.t;
float : string option -> string list -> float Lwt.t;
string : string option -> string list -> string Lwt.t;
bool : string option -> string list -> bool Lwt.t;
continue : string option -> string list -> bool Lwt.t;
display : string -> unit Lwt.t;
}
(* generic JSON generation from a schema with callback for random or
interactive filling *)
let fill_in ?(show_optionals = true) input schema =
let rec element path {title; kind; _} =
match kind with
| Integer {minimum; maximum; _} ->
let minimum =
match minimum with
| None ->
min_int
| Some (m, `Inclusive) ->
int_of_float m
| Some (m, `Exclusive) ->
int_of_float m + 1
in
let maximum =
match maximum with
| None ->
max_int
| Some (m, `Inclusive) ->
int_of_float m
| Some (m, `Exclusive) ->
int_of_float m - 1
in
input.int minimum maximum title path
>>= fun i -> Lwt.return (`Float (float i))
| Number _ ->
input.float title path >>= fun f -> Lwt.return (`Float f)
| Boolean ->
input.bool title path >>= fun f -> Lwt.return (`Bool f)
| String _ ->
input.string title path >>= fun f -> Lwt.return (`String f)
| Combine ((One_of | Any_of), elts) ->
let nb = List.length elts in
input.int 0 (nb - 1) (Some "Select the schema to follow") path
>>= fun n -> element path (List.nth elts n)
| Combine ((All_of | Not), _) ->
Lwt.fail Unsupported_construct
| Def_ref name ->
Lwt.return (`String (Json_query.json_pointer_of_path name))
| Id_ref _ | Ext_ref _ ->
Lwt.fail Unsupported_construct
| Array (elts, _) ->
let rec fill_loop acc n ls =
match ls with
| [] ->
Lwt.return acc
| elt :: elts ->
element (string_of_int n :: path) elt
>>= fun json -> fill_loop (json :: acc) (succ n) elts
in
fill_loop [] 0 elts >>= fun acc -> Lwt.return (`A (List.rev acc))
| Object {properties; _} ->
let properties =
if show_optionals then properties
else List.filter (fun (_, _, b, _) -> b) properties
in
let rec fill_loop acc ls =
match ls with
| [] ->
Lwt.return acc
| (n, elt, _, _) :: elts ->
element (n :: path) elt
>>= fun json -> fill_loop ((n, json) :: acc) elts
in
fill_loop [] properties >>= fun acc -> Lwt.return (`O (List.rev acc))
| Monomorphic_array (elt, specs) ->
let rec fill_loop acc min n max =
if n > max then Lwt.return acc
else
element (string_of_int n :: path) elt
>>= fun json ->
(if n < min then Lwt.return_true else input.continue title path)
>>= function
| true ->
fill_loop (json :: acc) min (succ n) max
| false ->
Lwt.return (json :: acc)
in
let max = match specs.max_items with None -> max_int | Some m -> m in
fill_loop [] specs.min_items 0 max
>>= fun acc -> Lwt.return (`A (List.rev acc))
| Any ->
Lwt.fail Unsupported_construct
| Dummy ->
Lwt.fail Unsupported_construct
| Null ->
Lwt.return `Null
in
element [] (Json_schema.root schema)
let random_fill_in ?(show_optionals = true) schema =
let display _ = Lwt.return_unit in
let int min max _ _ =
let max = Int64.of_int max and min = Int64.of_int min in
let range = Int64.sub max min in
let random_int64 = Int64.add (Random.int64 range) min in
Lwt.return (Int64.to_int random_int64)
in
let string _title _ = Lwt.return "" in
let float _ _ = Lwt.return (Random.float infinity) in
let bool _ _ = Lwt.return (Random.int 2 = 0) in
let continue _ _ = Lwt.return (Random.int 4 = 0) in
Lwt.catch
(fun () ->
fill_in
~show_optionals
{int; float; string; bool; display; continue}
schema
>>= fun json -> Lwt.return_ok json)
(fun e ->
let msg =
Printf.sprintf "Fill-in failed %s\n%!" (Printexc.to_string e)
in
Lwt.return_error msg)
let editor_fill_in ?(show_optionals = true) schema =
let tmp = Filename.temp_file "tezos_rpc_call_" ".json" in
let rec init () =
(* write a temp file with instructions *)
random_fill_in ~show_optionals schema
>>= function
| Error msg ->
Lwt.return_error msg
| Ok json ->
Lwt_io.(
with_file ~mode:Output tmp (fun fp ->
write_line fp (Data_encoding.Json.to_string json)))
>>= fun () -> edit ()
and edit () =
(* launch the user's editor on it *)
let editor_cmd =
let ed =
match (Sys.getenv_opt "EDITOR", Sys.getenv_opt "VISUAL") with
| (Some ed, _) ->
ed
| (None, Some ed) ->
ed
| (None, None) when Sys.win32 ->
(* TODO: I have no idea what I'm doing here *)
"notepad.exe"
| _ ->
(* TODO: vi on MacOSX ? *)
"nano"
in
Lwt_process.shell (ed ^ " " ^ tmp)
in
(Lwt_process.open_process_none editor_cmd)#status
>>= function
| Unix.WEXITED 0 ->
reread () >>= fun json -> delete () >>= fun () -> Lwt.return json
| Unix.WSIGNALED x | Unix.WSTOPPED x | Unix.WEXITED x ->
let msg = Printf.sprintf "FAILED %d \n%!" x in
delete () >>= fun () -> Lwt.return_error msg
and reread () =
(* finally reread the file *)
Lwt_io.(with_file ~mode:Input tmp (fun fp -> read fp))
>>= fun text ->
match Data_encoding.Json.from_string text with
| Ok r ->
Lwt.return_ok r
| Error msg ->
Lwt.return_error (Format.asprintf "bad input: %s" msg)
and delete () =
(* and delete the temp file *)
Lwt_unix.unlink tmp
in
init ()
(*-- Nice list display ------------------------------------------------------*)
let rec count =
let open RPC_description in
function
| Empty ->
0
| Dynamic _ ->
1
| Static {services; subdirs} ->
let service = RPC_service.MethMap.cardinal services in
let subdirs =
match subdirs with
| None ->
0
| Some (Suffixes subdirs) ->
Resto.StringMap.fold (fun _ t r -> r + count t) subdirs 0
| Some (Arg (_, subdir)) ->
count subdir
in
service + subdirs
(*-- Commands ---------------------------------------------------------------*)
let list url (cctxt : #Client_context.full) =
let args = String.split '/' url in
RPC_description.describe cctxt ~recurse:true args
>>=? fun tree ->
let open RPC_description in
let collected_args = ref [] in
let collect arg =
if not (arg.RPC_arg.descr <> None && List.mem arg !collected_args) then
collected_args := arg :: !collected_args
in
let display_paragraph ppf description =
Format.fprintf
ppf
"@, @[%a@]"
(fun ppf words -> List.iter (Format.fprintf ppf "%s@ ") words)
(String.split ' ' description)
in
let display_arg ppf arg =
match arg.RPC_arg.descr with
| None ->
Format.fprintf ppf "%s" arg.RPC_arg.name
| Some descr ->
Format.fprintf ppf "<%s>%a" arg.RPC_arg.name display_paragraph descr
in
let display_service ppf (_path, tpath, service) =
Format.fprintf
ppf
"- %s /%s"
(RPC_service.string_of_meth service.meth)
(String.concat "/" tpath) ;
match service.description with
| None | Some "" ->
()
| Some description ->
display_paragraph ppf description
in
let display_services ppf (_path, tpath, services) =
Format.pp_print_list
(fun ppf (_, s) -> display_service ppf (_path, tpath, s))
ppf
(RPC_service.MethMap.bindings services)
in
let rec display ppf (path, tpath, tree) =
match tree with
| Dynamic description -> (
Format.fprintf ppf "- /%s <dynamic>" (String.concat "/" tpath) ;
match description with
| None | Some "" ->
()
| Some description ->
display_paragraph ppf description )
| Empty ->
()
| Static {services; subdirs = None} ->
display_services ppf (path, tpath, services)
| Static {services; subdirs = Some (Suffixes subdirs)} -> (
match
( RPC_service.MethMap.cardinal services,
Resto.StringMap.bindings subdirs )
with
| (0, []) ->
()
| (0, [(n, solo)]) ->
display ppf (path @ [n], tpath @ [n], solo)
| (_, items) when count tree >= 3 && path <> [] ->
Format.fprintf
ppf
"@[<v 2>+ %s/@,%a@]"
(String.concat "/" path)
(display_list tpath)
items
| (_, items) when count tree >= 3 && path <> [] ->
Format.fprintf
ppf
"@[<v 2>+ %s@,%a@,%a@]"
(String.concat "/" path)
display_services
(path, tpath, services)
(display_list tpath)
items
| (0, (n, t) :: items) ->
Format.fprintf ppf "%a" display (path @ [n], tpath @ [n], t) ;
List.iter
(fun (n, t) ->
Format.fprintf ppf "@,%a" display (path @ [n], tpath @ [n], t))
items
| (_, items) ->
display_services ppf (path, tpath, services) ;
List.iter
(fun (n, t) ->
Format.fprintf ppf "@,%a" display (path @ [n], tpath @ [n], t))
items )
| Static {services; subdirs = Some (Arg (arg, solo))}
when RPC_service.MethMap.cardinal services = 0 ->
collect arg ;
let name = Printf.sprintf "<%s>" arg.RPC_arg.name in
display ppf (path @ [name], tpath @ [name], solo)
| Static {services; subdirs = Some (Arg (arg, solo))} ->
collect arg ;
display_services ppf (path, tpath, services) ;
Format.fprintf ppf "@," ;
let name = Printf.sprintf "<%s>" arg.RPC_arg.name in
display ppf (path @ [name], tpath @ [name], solo)
and display_list tpath =
Format.pp_print_list (fun ppf (n, t) -> display ppf ([n], tpath @ [n], t))
in
cctxt#message
"@ @[<v 2>Available services:@ @ %a@]@."
display
(args, args, tree)
>>= fun () ->
if !collected_args <> [] then
cctxt#message
"@,@[<v 2>Dynamic parameter description:@ @ %a@]@."
(Format.pp_print_list display_arg)
!collected_args
>>= fun () -> return_unit
else return_unit
let schema meth url (cctxt : #Client_context.full) =
let args = String.split '/' url in
let open RPC_description in
RPC_description.describe cctxt ~recurse:false args
>>=? function
| Static {services; _} -> (
match RPC_service.MethMap.find_opt meth services with
| None ->
cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!"
>>= fun () -> return_unit
| Some {input = Some input; output; _} ->
let json =
`O
[ ("input", Json_schema.to_json (fst input));
("output", Json_schema.to_json (fst output)) ]
in
cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json
>>= fun () -> return_unit
| Some {input = None; output; _} ->
let json = `O [("output", Json_schema.to_json (fst output))] in
cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json
>>= fun () -> return_unit )
| _ ->
cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!"
>>= fun () -> return_unit
let format binary meth url (cctxt : #Client_context.io_rpcs) =
let args = String.split '/' url in
let open RPC_description in
let pp =
if binary then fun ppf (_, schema) ->
Data_encoding.Binary_schema.pp ppf schema
else fun ppf (schema, _) -> Json_schema.pp ppf schema
in
RPC_description.describe cctxt ~recurse:false args
>>=? function
| Static {services; _} -> (
match RPC_service.MethMap.find_opt meth services with
| None ->
cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!"
>>= fun () -> return_unit
| Some {input = Some input; output; _} ->
cctxt#message
"@[<v 0>@[<v 2>Input format:@,%a@]@,@[<v 2>Output format:@,%a@]@,@]"
pp
input
pp
output
>>= fun () -> return_unit
| Some {input = None; output; _} ->
cctxt#message "@[<v 0>@[<v 2>Output format:@,%a@]@,@]" pp output
>>= fun () -> return_unit )
| _ ->
cctxt#message
"No service found at this URL (but this is a valid prefix)\n%!"
>>= fun () -> return_unit
let fill_in ?(show_optionals = true) schema =
let open Json_schema in
match (root schema).kind with
| Null ->
Lwt.return_ok `Null
| Any | Object {properties = []; _} ->
Lwt.return_ok (`O [])
| _ ->
editor_fill_in ~show_optionals schema
let display_answer (cctxt : #Client_context.full) = function
| `Ok json ->
cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json
>>= fun () -> return_unit
| `Not_found _ ->
cctxt#message "No service found at this URL\n%!"
>>= fun () -> return_unit
| `Error (Some json) ->
cctxt#message
"@[<v 2>Command failed :@[ %a@]@]@."
(Format.pp_print_list Error_monad.pp)
(Data_encoding.Json.destruct
(Data_encoding.list Error_monad.error_encoding)
json)
>>= fun () -> return_unit
| `Error None | `Unauthorized _ | `Forbidden _ | `Conflict _ ->
cctxt#message "Unexpected server answer\n%!" >>= fun () -> return_unit
let call meth raw_url (cctxt : #Client_context.full) =
let uri = Uri.of_string raw_url in
let args = String.split_path (Uri.path uri) in
RPC_description.describe cctxt ~recurse:false args
>>=? function
| Static {services; _} -> (
match RPC_service.MethMap.find_opt meth services with
| None ->
cctxt#message
"No service found at this URL with this method (but this is a valid \
prefix)\n\
%!"
>>= fun () -> return_unit
| Some {input = None; _} ->
cctxt#generic_json_call meth uri >>=? display_answer cctxt
| Some {input = Some input; _} -> (
fill_in ~show_optionals:false (fst input)
>>= function
| Error msg ->
cctxt#error "%s" msg >>= fun () -> return_unit
| Ok json ->
cctxt#generic_json_call meth ~body:json uri
>>=? display_answer cctxt ) )
| _ ->
cctxt#message "No service found at this URL\n%!"
>>= fun () -> return_unit
let call_with_json meth raw_url json (cctxt : #Client_context.full) =
let uri = Uri.of_string raw_url in
match Data_encoding.Json.from_string json with
| exception Assert_failure _ ->
(* Ref : https://github.com/mirage/ezjsonm/issues/31 *)
cctxt#error
"Failed to parse the provided json: unwrapped JSON value.\n%!"
| Error err ->
cctxt#error "Failed to parse the provided json: %s\n%!" err
| Ok body ->
cctxt#generic_json_call meth ~body uri >>=? display_answer cctxt
let call_with_file_or_json meth url maybe_file (cctxt : #Client_context.full) =
( match TzString.split ':' ~limit:1 maybe_file with
| ["file"; filename] ->
(* Mostly copied from src/client/client_aliases.ml *)
Lwt.catch
(fun () ->
Lwt_io.(with_file ~mode:Input filename read)
>>= fun content -> return content)
(fun exn -> failwith "cannot read file (%s)" (Printexc.to_string exn))
| _ ->
return maybe_file )
>>=? fun json -> call_with_json meth url json cctxt
let meth_params ?(name = "HTTP method") ?(desc = "") params =
param
~name
~desc
(parameter
~autocomplete:(fun _ ->
return
@@ List.map String.lowercase_ascii
@@ List.map Resto.string_of_meth
@@ [`GET; `POST; `DELETE; `PUT; `PATCH])
(fun _ name ->
match Resto.meth_of_string (String.uppercase_ascii name) with
| None ->
failwith "Unknown HTTP method: %s" name
| Some meth ->
return meth))
params
let group = {Clic.name = "rpc"; title = "Commands for the low level RPC layer"}
let commands =
[ command
~group
~desc:
"List RPCs under a given URL prefix.\n\
Some parts of the RPC service hierarchy depend on parameters,\n\
they are marked by a suffix `<dynamic>`.\n\
You can list these sub-hierarchies by providing a concrete URL \
prefix whose arguments are set to a valid value."
no_options
( prefixes ["rpc"; "list"]
@@ string ~name:"url" ~desc:"the URL prefix"
@@ stop )
(fun () -> list);
command
~group
~desc:"Alias to `rpc list /`."
no_options
(prefixes ["rpc"; "list"] @@ stop)
(fun () -> list "/");
command
~group
~desc:"Get the input and output JSON schemas of an RPC."
no_options
( prefixes ["rpc"; "schema"]
@@ meth_params
@@ string ~name:"url" ~desc:"the RPC url"
@@ stop )
(fun () -> schema);
command
~group
~desc:"Get the humanoid readable input and output formats of an RPC."
(args1 (switch ~doc:"Binary format" ~short:'b' ~long:"binary" ()))
( prefixes ["rpc"; "format"]
@@ meth_params
@@ string ~name:"url" ~desc:"the RPC URL"
@@ stop )
format;
command
~group
~desc:"Call an RPC with the GET method."
no_options
( prefixes ["rpc"; "get"]
@@ string ~name:"url" ~desc:"the RPC URL"
@@ stop )
(fun () -> call `GET);
command
~group
~desc:
"Call an RPC with the POST method.\n\
It invokes $EDITOR if input data is needed."
no_options
( prefixes ["rpc"; "post"]
@@ string ~name:"url" ~desc:"the RPC URL"
@@ stop )
(fun () -> call `POST);
command
~group
~desc:
"Call an RPC with the POST method, providing input data via the \
command line."
no_options
( prefixes ["rpc"; "post"]
@@ string ~name:"url" ~desc:"the RPC URL"
@@ prefix "with"
@@ string
~name:"input"
~desc:
"the raw JSON input to the RPC\n\
For instance, use `{}` to send the empty document.\n\
Alternatively, use `file:path` to read the JSON data from a file."
@@ stop )
(fun () -> call_with_file_or_json `POST);
command
~group
~desc:
"Call an RPC with the PUT method.\n\
It invokes $EDITOR if input data is needed."
no_options
( prefixes ["rpc"; "put"]
@@ string ~name:"url" ~desc:"the RPC URL"
@@ stop )
(fun () -> call `PUT);
command
~group
~desc:
"Call an RPC with the PUT method, providing input data via the \
command line."
no_options
( prefixes ["rpc"; "put"]
@@ string ~name:"url" ~desc:"the RPC URL"
@@ prefix "with"
@@ string
~name:"input"
~desc:
"the raw JSON input to the RPC\n\
For instance, use `{}` to send the empty document.\n\
Alternatively, use `file:path` to read the JSON data from a file."
@@ stop )
(fun () -> call_with_file_or_json `PUT);
command
~group
~desc:"Call an RPC with the DELETE method."
no_options
( prefixes ["rpc"; "delete"]
@@ string ~name:"url" ~desc:"the RPC URL"
@@ stop )
(fun () -> call `DELETE) ]
src/bin_client/client_rpc_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
Import Clic.
Import Json_schema.
(* ❌ The definition of exceptions is not handled. *)
exception
Record input := {
int : Z -> Z -> (option string) -> (list string) -> Lwt.t Z;
float : (option string) -> (list string) -> Lwt.t Z;
string : (option string) -> (list string) -> Lwt.t string;
bool : (option string) -> (list string) -> Lwt.t bool;
continue : (option string) -> (list string) -> Lwt.t bool;
display : string -> Lwt.t unit }.
Definition fill_in (op_staroptstar : option bool)
: input -> Json_schema.schema -> Lwt.t variant :=
let show_optionals :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun input =>
fun schema =>
let fix element
(path : list string) (function_parameter : Json_schema.element)
: Lwt.t variant :=
let '{| title := title; kind := kind |} := function_parameter in
match kind with
| Json_schema.Integer {| minimum := minimum; maximum := maximum |} =>
let minimum :=
match minimum with
| None => Stdlib.min_int
| Some (m, Inclusive) => Stdlib.int_of_float m
| Some (m, Exclusive) => Z.add (Stdlib.int_of_float m) 1
end in
let maximum :=
match maximum with
| None => Stdlib.max_int
| Some (m, Inclusive) => Stdlib.int_of_float m
| Some (m, Exclusive) => Z.sub (Stdlib.int_of_float m) 1
end in
op_gtgteq ((int input) minimum maximum title path)
(fun i =>
Lwt._return
(* ❌ Variants not supported *)
variant)
| Json_schema.Number _ =>
op_gtgteq ((float input) title path)
(fun f =>
Lwt._return
(* ❌ Variants not supported *)
variant)
| Json_schema.Boolean =>
op_gtgteq ((bool input) title path)
(fun f =>
Lwt._return
(* ❌ Variants not supported *)
variant)
| Json_schema.String _ =>
op_gtgteq ((string input) title path)
(fun f =>
Lwt._return
(* ❌ Variants not supported *)
variant)
| Json_schema.Combine (Json_schema.One_of | Json_schema.Any_of) elts =>
let nb := List.length elts in
op_gtgteq
((int input) 0 (Z.sub nb 1)
(Some "Select the schema to follow" % string) path)
(fun n => element path (List.nth elts n))
| Json_schema.Combine (Json_schema.All_of | Json_schema.Not) _ =>
Lwt.fail Unsupported_construct
| Json_schema.Def_ref name =>
Lwt._return
(* ❌ Variants not supported *)
variant
| Json_schema.Id_ref _ | Json_schema.Ext_ref _ =>
Lwt.fail Unsupported_construct
| Json_schema.Array elts _ =>
let fix fill_loop
(acc : list variant) (n : Z) (ls : list Json_schema.element)
: Lwt.t (list variant) :=
match ls with
| [] => Lwt._return acc
| cons elt elts =>
op_gtgteq (element (cons (OCaml.Stdlib.string_of_int n) path) elt)
(fun json => fill_loop (cons json acc) (Z.succ n) elts)
end in
op_gtgteq (fill_loop [] 0 elts)
(fun acc =>
Lwt._return
(* ❌ Variants not supported *)
variant)
| Json_schema.Object {| properties := properties |} =>
let properties :=
if show_optionals then
properties
else
List.filter
(fun function_parameter =>
let '(_, _, b, _) := function_parameter in
b) properties in
let fix fill_loop {A B : Type}
(acc : list (string * variant)) (ls :
list (string * Json_schema.element * A * B))
: Lwt.t (list (string * variant)) :=
match ls with
| [] => Lwt._return acc
| cons (n, elt, _, _) elts =>
op_gtgteq (element (cons n path) elt)
(fun json => fill_loop (cons (n, json) acc) elts)
end in
op_gtgteq (fill_loop [] properties)
(fun acc =>
Lwt._return
(* ❌ Variants not supported *)
variant)
| Json_schema.Monomorphic_array elt specs =>
let fix fill_loop (acc : list variant) (min : Z) (n : Z) (max : Z)
: Lwt.t (list variant) :=
if OCaml.Stdlib.gt n max then
Lwt._return acc
else
op_gtgteq (element (cons (OCaml.Stdlib.string_of_int n) path) elt)
(fun json =>
op_gtgteq
(if OCaml.Stdlib.lt n min then
Lwt.return_true
else
(continue input) title path)
(fun function_parameter =>
match function_parameter with
| true => fill_loop (cons json acc) min (Z.succ n) max
| false => Lwt._return (cons json acc)
end)) in
let max :=
match max_items specs with
| None => Stdlib.max_int
| Some m => m
end in
op_gtgteq (fill_loop [] (min_items specs) 0 max)
(fun acc =>
Lwt._return
(* ❌ Variants not supported *)
variant)
| Json_schema.Any => Lwt.fail Unsupported_construct
| Json_schema.Dummy => Lwt.fail Unsupported_construct
| Json_schema.Null =>
Lwt._return
(* ❌ Variants not supported *)
variant
end in
element [] (Json_schema.root schema).
Definition random_fill_in (op_staroptstar : option bool)
: Json_schema.schema -> Lwt.t (Result.result variant string) :=
let show_optionals :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun schema =>
let display {A : Type} (function_parameter : A) : Lwt.t unit :=
let '_ := function_parameter in
Lwt.return_unit in
let int {A B : Type} (min : Z) (max : Z) (function_parameter : A)
: B -> Lwt.t Z :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
let max : int64 :=
Int64.of_int max
with min : int64 :=
Int64.of_int min in
let range := Int64.sub max min in
let random_int64 := Int64.add (Random.int64 range) min in
Lwt._return (Int64.to_int random_int64) in
let string {A B : Type} (_title : A) (function_parameter : B)
: Lwt.t string :=
let '_ := function_parameter in
Lwt._return "" % string in
let float {A B : Type} (function_parameter : A) : B -> Lwt.t Z :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
Lwt._return (Random.float Stdlib.infinity) in
let bool {A B : Type} (function_parameter : A) : B -> Lwt.t bool :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
Lwt._return (equiv_decb (Random.int 2) 0) in
let continue {A B : Type} (function_parameter : A) : B -> Lwt.t bool :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
Lwt._return (equiv_decb (Random.int 4) 0) in
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(fill_in (Some show_optionals)
{| int := Z; float := Z; string := string; bool := bool;
continue := continue; display := display |} schema)
(fun json => Lwt.return_ok json))
(fun e =>
let msg :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Fill-in failed " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))))
"Fill-in failed %s
%!" % string) (Printexc.to_string e) in
Lwt.return_error msg).
Definition editor_fill_in (op_staroptstar : option bool)
: Json_schema.schema ->
Lwt.t
(Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
let show_optionals :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun schema =>
let tmp :=
Filename.temp_file None "tezos_rpc_call_" % string ".json" % string in
let fix init (function_parameter : unit)
: Lwt.t
(Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
let 'tt := function_parameter in
op_gtgteq (random_fill_in (Some show_optionals) schema)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error msg => Lwt.return_error msg
| Stdlib.Ok json =>
op_gtgteq
(with_file None None None Lwt_io.Output tmp
(fun fp =>
write_line fp (Data_encoding.Json.to_string None None json)))
(fun function_parameter =>
let 'tt := function_parameter in
edit tt)
end)
with edit (function_parameter : unit)
: Lwt.t
(Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
let 'tt := function_parameter in
let editor_cmd :=
let ed :=
match
((Sys.getenv_opt "EDITOR" % string),
(Sys.getenv_opt "VISUAL" % string)) with
| (Some ed, _) => ed
| (None, Some ed) => ed
| (None, None) => "notepad.exe" % string
| _ => "nano" % string
end in
Lwt_process.shell (String.append ed (String.append " " % string tmp)) in
op_gtgteq
(* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
match function_parameter with
| Unix.WEXITED 0 =>
op_gtgteq (reread tt)
(fun json =>
op_gtgteq (delete tt)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return json))
| Unix.WSIGNALED x | Unix.WSTOPPED x | Unix.WEXITED x =>
let msg :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "FAILED " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal "
" % string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))))
"FAILED %d
%!" % string) x in
op_gtgteq (delete tt)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_error msg)
end)
with reread (function_parameter : unit)
: Lwt.t
(Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
let 'tt := function_parameter in
op_gtgteq
(with_file None None None Lwt_io.Input tmp (fun fp => read None fp))
(fun text =>
match Data_encoding.Json.from_string text with
| Stdlib.Ok r => Lwt.return_ok r
| Stdlib.Error msg =>
Lwt.return_error
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"bad input: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"bad input: %s" % string) msg)
end)
with delete (function_parameter : unit) : Lwt.t unit :=
let 'tt := function_parameter in
Lwt_unix.unlink tmp in
init tt.
Fixpoint count {A : Type}
(function_parameter : Tezos_base__TzPervasives.RPC_description.directory A)
: Z :=
match function_parameter with
| Tezos_base__TzPervasives.RPC_description.Empty => 0
| Tezos_base__TzPervasives.RPC_description.Dynamic _ => 1
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services; subdirs := subdirs |} =>
let service := RPC_service.MethMap.cardinal services in
let subdirs :=
match subdirs with
| None => 0
| Some (Tezos_base__TzPervasives.RPC_description.Suffixes subdirs) =>
Resto.StringMap.(Stdlib__map.S.fold)
(fun function_parameter =>
let '_ := function_parameter in
fun t => fun r => Z.add r (count t)) subdirs 0
| Some (Tezos_base__TzPervasives.RPC_description.Arg _ subdir) =>
count subdir
end in
Z.add service subdirs
end.
Definition list {F G I a b i o p q : Type}
(url : string)
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let args := String.split "/" % char None None url in
op_gtgteqquestion (RPC_description.describe cctxt (Some true) args)
(fun tree =>
let collected_args := Stdlib.ref [] in
let collect (arg : Tezos_base__TzPervasives.RPC_arg.descr) : unit :=
if
negb
(andb (nequiv_decb (RPC_arg.descr arg) None)
(List.mem arg (Stdlib.op_exclamation collected_args))) then
Stdlib.op_coloneq collected_args
(cons arg (Stdlib.op_exclamation collected_args))
else
tt in
let display_paragraph
(ppf : Stdlib.Format.formatter) (description : string) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal " " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@, @[%a@]" % string)
(fun ppf =>
fun words =>
List.iter
(Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
CamlinternalFormatBasics.End_of_format)) "%s@ " % string))
words) (String.split " " % char None None description) in
let display_arg
(ppf : Stdlib.Format.formatter) (arg :
Tezos_base__TzPervasives.RPC_arg.descr) : unit :=
match RPC_arg.descr arg with
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
(RPC_arg.name arg)
| Some descr =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "<" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ">" % char
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"<%s>%a" % string) (RPC_arg.name arg) display_paragraph descr
end in
let display_service {J K : Type}
(ppf : Stdlib.Format.formatter) (function_parameter :
J * (list string) * (Tezos_base__TzPervasives.RPC_description.service K))
: unit :=
let '(_path, tpath, service) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "- " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " /" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"- %s /%s" % string) (RPC_service.string_of_meth (meth service))
(String.concat "/" % string tpath) in
match description service with
| None | Some "" % string => tt
| Some description => display_paragraph ppf description
end in
let display_services {J K : Type}
(ppf : Stdlib.Format.formatter) (function_parameter :
J * (list string) *
(Tezos_base__TzPervasives.RPC_service.MethMap.t
(Tezos_base__TzPervasives.RPC_description.service K))) : unit :=
let '(_path, tpath, services) := function_parameter in
Format.pp_print_list None
(fun ppf =>
fun function_parameter =>
let '(_, s) := function_parameter in
display_service ppf (_path, tpath, s)) ppf
(RPC_service.MethMap.bindings services) in
let fix display {J : Type}
(ppf : Stdlib.Format.formatter) (function_parameter :
(list Resto.StringMap.(Stdlib__map.S.key)) *
(list Resto.StringMap.(Stdlib__map.S.key)) *
(Tezos_base__TzPervasives.RPC_description.directory J)) : unit :=
let '(path, tpath, tree) := function_parameter in
match tree with
| Tezos_base__TzPervasives.RPC_description.Dynamic description =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "- /" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" <dynamic>" % string
CamlinternalFormatBasics.End_of_format)))
"- /%s <dynamic>" % string) (String.concat "/" % string tpath)
in
match description with
| None | Some "" % string => tt
| Some description => display_paragraph ppf description
end
| Tezos_base__TzPervasives.RPC_description.Empty => tt
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services; subdirs := None |} =>
display_services ppf (path, tpath, services)
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services;
subdirs :=
Some
(Tezos_base__TzPervasives.RPC_description.Suffixes
subdirs)
|} =>
match
((RPC_service.MethMap.cardinal services),
(Resto.StringMap.(Stdlib__map.S.bindings) subdirs)) with
| (0, []) => tt
| (0, cons (n, solo) []) =>
display ppf
((OCaml.Stdlib.app path (cons n [])),
(OCaml.Stdlib.app tpath (cons n [])), solo)
| (_, items) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "+ " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "/" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 2>+ %s/@,%a@]" % string) (String.concat "/" % string path)
(display_list tpath) items
| (_, items) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "+ " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"@[<v 2>+ %s@,%a@,%a@]" % string)
(String.concat "/" % string path) display_services
(path, tpath, services) (display_list tpath) items
| (0, cons (n, t) items) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
display
((OCaml.Stdlib.app path (cons n [])),
(OCaml.Stdlib.app tpath (cons n [])), t) in
List.iter
(fun function_parameter =>
let '(n, t) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "@,%a" % string)
display
((OCaml.Stdlib.app path (cons n [])),
(OCaml.Stdlib.app tpath (cons n [])), t)) items
| (_, items) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := display_services ppf (path, tpath, services) in
List.iter
(fun function_parameter =>
let '(n, t) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "@,%a" % string)
display
((OCaml.Stdlib.app path (cons n [])),
(OCaml.Stdlib.app tpath (cons n [])), t)) items
end
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services;
subdirs :=
Some
(Tezos_base__TzPervasives.RPC_description.Arg
arg solo)
|} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := collect arg in
let name :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "<" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ">" % char
CamlinternalFormatBasics.End_of_format))) "<%s>" % string)
(RPC_arg.name arg) in
display ppf
((OCaml.Stdlib.app path (cons name [])),
(OCaml.Stdlib.app tpath (cons name [])), solo)
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services;
subdirs :=
Some
(Tezos_base__TzPervasives.RPC_description.Arg
arg solo)
|} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := collect arg in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := display_services ppf (path, tpath, services) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string) in
let name :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "<" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ">" % char
CamlinternalFormatBasics.End_of_format))) "<%s>" % string)
(RPC_arg.name arg) in
display ppf
((OCaml.Stdlib.app path (cons name [])),
(OCaml.Stdlib.app tpath (cons name [])), solo)
end
with display_list {J : Type}
(tpath : list Resto.StringMap.(Stdlib__map.S.key))
: Stdlib.Format.formatter ->
(list
(Resto.StringMap.(Stdlib__map.S.key) *
(Tezos_base__TzPervasives.RPC_description.directory J))) -> unit :=
Format.pp_print_list None
(fun ppf =>
fun function_parameter =>
let '(n, t) := function_parameter in
display ppf ((cons n []), (OCaml.Stdlib.app tpath (cons n [])), t))
in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Available services:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))
"@ @[<v 2>Available services:@ @ %a@]@." % string) display
(args, args, tree))
(fun function_parameter =>
let 'tt := function_parameter in
if nequiv_decb (Stdlib.op_exclamation collected_args) [] then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Dynamic parameter description:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))
"@,@[<v 2>Dynamic parameter description:@ @ %a@]@." % string)
(Format.pp_print_list None display_arg)
(Stdlib.op_exclamation collected_args))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
else
return_unit)).
Definition schema {F G I a b i o p q : Type}
(meth : Tezos_base__TzPervasives.RPC_service.MethMap.key) (url : string)
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let args := String.split "/" % char None None url in
op_gtgteqquestion (RPC_description.describe cctxt (Some false) args)
(fun function_parameter =>
match function_parameter with
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services |} =>
match RPC_service.MethMap.find_opt meth services with
| None =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No service found at this URL (but this is a valid prefix)
" %
string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"No service found at this URL (but this is a valid prefix)
%!" %
string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Some {| input := Some input; output := output |} =>
let json :=
(* ❌ Variants not supported *)
variant in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
(pp None None Ezjsonm) json)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Some {| input := None; output := output |} =>
let json :=
(* ❌ Variants not supported *)
variant in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
(pp None None Ezjsonm) json)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end
| _ =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No service found at this URL (but this is a valid prefix)
" %
string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"No service found at this URL (but this is a valid prefix)
%!" %
string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end).
Definition format {E F I a b i o p q : Type}
(binary : bool) (meth : Tezos_base__TzPervasives.RPC_service.MethMap.key)
(url : string)
(cctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
* (E * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(F * p * q * i * o)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json))) *
(Uri.t *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
(a * b)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a unit)
-> a) * (a)) * I))))))))))) * I)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let args := String.split "/" % char None None url in
let pp :=
if binary then
fun ppf =>
fun function_parameter =>
let '(_, schema) := function_parameter in
Data_encoding.Binary_schema.pp ppf schema
else
fun ppf =>
fun function_parameter =>
let '(schema, _) := function_parameter in
Json_schema.pp ppf schema in
op_gtgteqquestion (RPC_description.describe cctxt (Some false) args)
(fun function_parameter =>
match function_parameter with
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services |} =>
match RPC_service.MethMap.find_opt meth services with
| None =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No service found at this URL (but this is a valid prefix)
" %
string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"No service found at this URL (but this is a valid prefix)
%!" %
string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Some {| input := Some input; output := output |} =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Input format:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Output format:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))
"@[<v 0>@[<v 2>Input format:@,%a@]@,@[<v 2>Output format:@,%a@]@,@]"
% string) pp input pp output)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Some {| input := None; output := output |} =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Output format:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"@[<v 0>@[<v 2>Output format:@,%a@]@,@]" % string) pp output)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end
| _ =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No service found at this URL (but this is a valid prefix)
" %
string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"No service found at this URL (but this is a valid prefix)
%!" %
string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end).
Definition fill_in (op_staroptstar : option bool)
: Json_schema.schema ->
Lwt.t
(Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
let show_optionals :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun schema =>
match kind (root schema) with
| Json_schema.Null =>
Lwt.return_ok
(* ❌ Variants not supported *)
variant
| Json_schema.Any | Json_schema.Object {| properties := [] |} =>
Lwt.return_ok
(* ❌ Variants not supported *)
variant
| _ => editor_fill_in (Some show_optionals) schema
end.
Definition display_answer {F G I a b i o p q : Type}
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) (function_parameter : variant)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match function_parameter with
| Ok json =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) (pp None None Ezjsonm) json)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Not_found _ =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No service found at this URL
" % string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"No service found at this URL
%!" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Error (Some json) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Command failed :" % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))
"@[<v 2>Command failed :@[ %a@]@]@." % string)
(Format.pp_print_list None Error_monad.pp)
(Data_encoding.Json.destruct
(Data_encoding.list None Error_monad.error_encoding) json))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Error None | Unauthorized _ | Forbidden _ | Conflict _ =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unexpected server answer
" % string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"Unexpected server answer
%!" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end.
Definition call {F G I a b i o p q : Type}
(meth : Tezos_base__TzPervasives.RPC_service.MethMap.key) (raw_url : string)
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let uri := Uri.of_string raw_url in
let args := String.split_path (Uri.path uri) in
op_gtgteqquestion (RPC_description.describe cctxt (Some false) args)
(fun function_parameter =>
match function_parameter with
|
Tezos_base__TzPervasives.RPC_description.Static {|
services := services |} =>
match RPC_service.MethMap.find_opt meth services with
| None =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No service found at this URL with this method (but this is a valid prefix)
"
% string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"No service found at this URL with this method (but this is a valid prefix)
%!"
% string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Some {| input := None |} =>
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send meth None uri) (display_answer cctxt)
| Some {| input := Some input |} =>
op_gtgteq (fill_in (Some false) (fst input))
(fun function_parameter =>
match function_parameter with
| Stdlib.Error msg =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
msg)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Ok json =>
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send meth (Some json) uri) (display_answer cctxt)
end)
end
| _ =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No service found at this URL
" % string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))
"No service found at this URL
%!" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end).
Definition call_with_json {F G I a b i o p q : Type}
(meth : Tezos_rpc.RPC_service.meth) (raw_url : string) (json : string)
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let uri := Uri.of_string raw_url in
match Data_encoding.Json.from_string json with
| Stdlib.Error err =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to parse the provided json: " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))))
"Failed to parse the provided json: %s
%!" % string) err
| Stdlib.Ok body =>
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send meth (Some body) uri) (display_answer cctxt)
end.
Definition call_with_file_or_json {F G I a b i o p q : Type}
(meth : Tezos_rpc.RPC_service.meth) (url : string) (maybe_file : string)
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
match TzString.split ":" % char None (Some 1) maybe_file with
| cons "file" % string (cons filename []) =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(with_file None None None Lwt_io.Input filename
(let arg := read in
fun eta => arg None eta)) (fun content => _return content))
(fun exn =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"cannot read file (" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"cannot read file (%s)" % string) (Printexc.to_string exn))
| _ => _return maybe_file
end (fun json => call_with_json meth url json cctxt).
Definition meth_params {A B : Type} (op_staroptstar : option string)
: (option string) ->
(Tezos_base__TzPervasives.Clic.params A B) ->
Tezos_base__TzPervasives.Clic.params (variant -> A) B :=
let name :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "HTTP method" % string
end in
fun op_staroptstar =>
let desc :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun params =>
param name desc
(parameter
(Some
(fun function_parameter =>
let '_ := function_parameter in
apply _return
(apply (List.map String.lowercase_ascii)
(apply (List.map Resto.string_of_meth)
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant [])))))))))
(fun function_parameter =>
let '_ := function_parameter in
fun name =>
match Resto.meth_of_string (String.uppercase_ascii name) with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown HTTP method: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Unknown HTTP method: %s" % string) name
| Some meth => _return meth
end)) params.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "rpc" % string;
Clic.title := "Commands for the low level RPC layer" % string |}.
Definition commands {F G I a b i o p q : Type}
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) :=
cons
(command (Some group)
"List RPCs under a given URL prefix.
Some parts of the RPC service hierarchy depend on parameters,
they are marked by a suffix `<dynamic>`.
You can list these sub-hierarchies by providing a concrete URL prefix whose arguments are set to a valid value."
% string no_options
(apply (prefixes (cons "rpc" % string (cons "list" % string [])))
(apply (string "url" % string "the URL prefix" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
list))
(cons
(command (Some group) "Alias to `rpc list /`." % string no_options
(apply (prefixes (cons "rpc" % string (cons "list" % string []))) stop)
(fun function_parameter =>
let 'tt := function_parameter in
list "/" % string))
(cons
(command (Some group)
"Get the input and output JSON schemas of an RPC." % string no_options
(apply (prefixes (cons "rpc" % string (cons "schema" % string [])))
(apply
(let arg := meth_params in
fun eta => arg None None eta)
(apply (string "url" % string "the RPC url" % string) stop)))
(fun function_parameter =>
let 'tt := function_parameter in
schema))
(cons
(command (Some group)
"Get the humanoid readable input and output formats of an RPC." %
string
(args1
(switch "Binary format" % string (Some "b" % char)
"binary" % string tt))
(apply (prefixes (cons "rpc" % string (cons "format" % string [])))
(apply
(let arg := meth_params in
fun eta => arg None None eta)
(apply (string "url" % string "the RPC URL" % string) stop)))
format)
(cons
(command (Some group) "Call an RPC with the GET method." % string
no_options
(apply (prefixes (cons "rpc" % string (cons "get" % string [])))
(apply (string "url" % string "the RPC URL" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
call
(* ❌ Variants not supported *)
variant))
(cons
(command (Some group)
"Call an RPC with the POST method.
It invokes $EDITOR if input data is needed."
% string no_options
(apply
(prefixes (cons "rpc" % string (cons "post" % string [])))
(apply (string "url" % string "the RPC URL" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
call
(* ❌ Variants not supported *)
variant))
(cons
(command (Some group)
"Call an RPC with the POST method, providing input data via the command line."
% string no_options
(apply
(prefixes (cons "rpc" % string (cons "post" % string [])))
(apply (string "url" % string "the RPC URL" % string)
(apply (prefix "with" % string)
(apply
(string "input" % string
"the raw JSON input to the RPC
For instance, use `{}` to send the empty document.
Alternatively, use `file:path` to read the JSON data from a file."
% string) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
call_with_file_or_json
(* ❌ Variants not supported *)
variant))
(cons
(command (Some group)
"Call an RPC with the PUT method.
It invokes $EDITOR if input data is needed."
% string no_options
(apply
(prefixes (cons "rpc" % string (cons "put" % string [])))
(apply (string "url" % string "the RPC URL" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
call
(* ❌ Variants not supported *)
variant))
(cons
(command (Some group)
"Call an RPC with the PUT method, providing input data via the command line."
% string no_options
(apply
(prefixes (cons "rpc" % string (cons "put" % string [])))
(apply (string "url" % string "the RPC URL" % string)
(apply (prefix "with" % string)
(apply
(string "input" % string
"the raw JSON input to the RPC
For instance, use `{}` to send the empty document.
Alternatively, use `file:path` to read the JSON data from a file."
% string) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
call_with_file_or_json
(* ❌ Variants not supported *)
variant))
(cons
(command (Some group)
"Call an RPC with the DELETE method." % string
no_options
(apply
(prefixes
(cons "rpc" % string (cons "delete" % string [])))
(apply (string "url" % string "the RPC URL" % string)
stop))
(fun function_parameter =>
let 'tt := function_parameter in
call
(* ❌ Variants not supported *)
variant)) []))))))))).
src/bin_client/main_admin.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Log = Internal_event.Legacy_logging.Make (struct
let name = "admin-client.main"
end)
let select_commands _ _ =
return
(List.flatten
[ Client_report_commands.commands ();
Client_admin_commands.commands ();
Client_p2p_commands.commands ();
Client_protocols_commands.commands ();
Client_rpc_commands.commands;
Client_event_logging_commands.commands () ])
let () =
Client_main_run.run
~log:(Log.fatal_error "%s")
(module Client_config)
~select_commands
src/bin_client/main_admin.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition select_commands {A B : Type} (function_parameter : A)
: B ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full))) :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
_return
(List.flatten
(cons (Client_report_commands.commands tt)
(cons (Client_admin_commands.commands tt)
(cons (Client_p2p_commands.commands tt)
(cons (Client_protocols_commands.commands tt)
(cons Client_rpc_commands.commands
(cons (Client_event_logging_commands.commands tt) []))))))).
src/bin_client/main_client.ml 25 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Log = Internal_event.Legacy_logging.Make (struct
let name = "client.main"
end)
open Client_config
let disable_disclaimer =
match Sys.getenv_opt "TEZOS_CLIENT_UNSAFE_DISABLE_DISCLAIMER" with
| Some ("yes" | "y" | "YES" | "Y") ->
true
| _ ->
false
let zeronet () =
if not disable_disclaimer then
Format.eprintf
"@[<v 2>@{<warning>@{<title>Warning@}@}@,\
@,\
\ This is @{<warning>NOT@} the Tezos Mainnet.@,\
@,\
\ The node you are connecting to claims to be running on the@,\
\ @{<warning>Tezos Zeronet DEVELOPMENT NETWORK@}.@,\
\ Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
Zeronet is a testing network, with free tokens and frequent resets.@]@\n\
@."
let alphanet () =
if not disable_disclaimer then
Format.eprintf
"@[<v 2>@{<warning>@{<title>Warning@}@}@,\
@,\
\ This is @{<warning>NOT@} the Tezos Mainnet.@,\
@,\
\ The node you are connecting to claims to be running on the@,\
\ @{<warning>Tezos Alphanet DEVELOPMENT NETWORK.@}@,\
\ Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
\ Alphanet is a testing network, with free tokens.@]@\n\
@."
let mainnet () =
if not disable_disclaimer then
Format.eprintf
"@[<v 2>@{<warning>@{<title>Disclaimer@}@}@,\
The Tezos network is a new blockchain technology.@,\
Users are solely responsible for any risks associated@,\
with usage of the Tezos network. Users should do their@,\
own research to determine if Tezos is the appropriate@,\
platform for their needs and should apply judgement and@,\
care in their network interactions.@]@\n\
@."
let sandbox () =
if not disable_disclaimer then
Format.eprintf
"@[<v 2>@{<warning>@{<title>Warning@}@}@,\
@,\
\ The node you are connecting to claims to be running in a@,\
\ @{<warning>Tezos TEST SANDBOX@}.@,\
\ Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
You should not see this message if you are not a developer.@]@\n\
@."
let check_network ctxt =
Shell_services.P2p.version ctxt
>>= function
| Error _ ->
Lwt.return_none
| Ok version ->
let has_prefix prefix =
String.has_prefix ~prefix (version.chain_name :> string)
in
if has_prefix "SANDBOXED" then (
sandbox () ;
Lwt.return_some `Sandbox )
else if has_prefix "TEZOS_ZERONET" then (
zeronet () ;
Lwt.return_some `Zeronet )
else if has_prefix "TEZOS_ALPHANET" then (
alphanet () ;
Lwt.return_some `Alphanet )
else if has_prefix "TEZOS_BETANET" || has_prefix "TEZOS_MAINNET" then (
mainnet () ;
Lwt.return_some `Mainnet )
else Lwt.return_none
let get_commands_for_version ctxt network chain block protocol =
Shell_services.Blocks.protocols ctxt ~chain ~block ()
>>= function
| Ok {next_protocol = version; _} -> (
match protocol with
| None ->
return
(Some version, Client_commands.commands_for_version version network)
| Some given_version ->
if not (Protocol_hash.equal version given_version) then
Format.eprintf
"@[<v 2>@{<warning>@{<title>Warning@}@}@,\
The protocol provided via `--protocol` (%a)@,\
is not the one retrieved from the node (%a).@]@\n\
@."
Protocol_hash.pp_short
given_version
Protocol_hash.pp_short
version ;
return
( Some version,
Client_commands.commands_for_version given_version network ) )
| Error errs -> (
match protocol with
| None ->
Format.eprintf
"@[<v 2>@{<warning>@{<title>Warning@}@}@,\
Failed to acquire the protocol version from the node@,\
%a@]@\n\
@."
(Format.pp_print_list pp)
errs ;
return (None, [])
| Some version ->
return
(Some version, Client_commands.commands_for_version version network)
)
let select_commands ctxt {chain; block; protocol; _} =
check_network ctxt
>>= fun network ->
get_commands_for_version ctxt network chain block protocol
>>|? fun (_, commands_for_version) ->
Client_rpc_commands.commands
@ Tezos_signer_backends_unix.Ledger.commands ()
@ Client_keys_commands.commands network
@ Client_helpers_commands.commands ()
@ commands_for_version
let () =
Client_main_run.run
~log:(Log.fatal_error "%s")
(module Client_config)
~select_commands
src/bin_client/main_client.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
Import Client_config.
Definition disable_disclaimer : bool :=
match Sys.getenv_opt "TEZOS_CLIENT_UNSAFE_DISABLE_DISCLAIMER" % string with
| Some ("yes" % string | "y" % string | "YES" % string | "Y" % string) => true
| _ => false
end.
Definition zeronet (function_parameter : unit) : unit :=
let 'tt := function_parameter in
if negb disable_disclaimer then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<warning>" % string
CamlinternalFormatBasics.End_of_format) "<warning>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<title>" % string
CamlinternalFormatBasics.End_of_format) "<title>" % string))
(CamlinternalFormatBasics.String_literal "Warning" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" This is " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.String_literal
"NOT" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.String_literal
" the Tezos Mainnet." % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" The node you are connecting to claims to be running on the"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.String_literal
"Tezos Zeronet DEVELOPMENT NETWORK"
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Char_literal
"." % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" Do " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" %
string
CamlinternalFormatBasics.End_of_format)
"<warning>" %
string))
(CamlinternalFormatBasics.String_literal
"NOT" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.String_literal
" use your fundraiser keys on this network."
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," %
string 0 0)
(CamlinternalFormatBasics.String_literal
"Zeronet is a testing network, with free tokens and frequent resets."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))))))))))))))))))))))))))
"@[<v 2>@{<warning>@{<title>Warning@}@}@,@, This is @{<warning>NOT@} the Tezos Mainnet.@,@, The node you are connecting to claims to be running on the@, @{<warning>Tezos Zeronet DEVELOPMENT NETWORK@}.@, Do @{<warning>NOT@} use your fundraiser keys on this network.@,Zeronet is a testing network, with free tokens and frequent resets.@]@
@."
% string)
else
tt.
Definition alphanet (function_parameter : unit) : unit :=
let 'tt := function_parameter in
if negb disable_disclaimer then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<warning>" % string
CamlinternalFormatBasics.End_of_format) "<warning>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<title>" % string
CamlinternalFormatBasics.End_of_format) "<title>" % string))
(CamlinternalFormatBasics.String_literal "Warning" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" This is " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.String_literal
"NOT" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.String_literal
" the Tezos Mainnet." % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" The node you are connecting to claims to be running on the"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.String_literal
"Tezos Alphanet DEVELOPMENT NETWORK."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" Do " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" %
string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.String_literal
"NOT" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.String_literal
" use your fundraiser keys on this network."
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string
0 0)
(CamlinternalFormatBasics.String_literal
" Alphanet is a testing network, with free tokens."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))))))))))))))))))))))))))
"@[<v 2>@{<warning>@{<title>Warning@}@}@,@, This is @{<warning>NOT@} the Tezos Mainnet.@,@, The node you are connecting to claims to be running on the@, @{<warning>Tezos Alphanet DEVELOPMENT NETWORK.@}@, Do @{<warning>NOT@} use your fundraiser keys on this network.@, Alphanet is a testing network, with free tokens.@]@
@."
% string)
else
tt.
Definition mainnet (function_parameter : unit) : unit :=
let 'tt := function_parameter in
if negb disable_disclaimer then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<warning>" % string
CamlinternalFormatBasics.End_of_format) "<warning>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<title>" % string
CamlinternalFormatBasics.End_of_format) "<title>" % string))
(CamlinternalFormatBasics.String_literal "Disclaimer" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"The Tezos network is a new blockchain technology."
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Users are solely responsible for any risks associated"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"with usage of the Tezos network. Users should do their"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string
0 0)
(CamlinternalFormatBasics.String_literal
"own research to determine if Tezos is the appropriate"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"platform for their needs and should apply judgement and"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"care in their network interactions."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))))))))))))))
"@[<v 2>@{<warning>@{<title>Disclaimer@}@}@,The Tezos network is a new blockchain technology.@,Users are solely responsible for any risks associated@,with usage of the Tezos network. Users should do their@,own research to determine if Tezos is the appropriate@,platform for their needs and should apply judgement and@,care in their network interactions.@]@
@."
% string)
else
tt.
Definition sandbox (function_parameter : unit) : unit :=
let 'tt := function_parameter in
if negb disable_disclaimer then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<warning>" % string
CamlinternalFormatBasics.End_of_format) "<warning>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<title>" % string
CamlinternalFormatBasics.End_of_format) "<title>" % string))
(CamlinternalFormatBasics.String_literal "Warning" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" The node you are connecting to claims to be running in a"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.String_literal
"Tezos TEST SANDBOX" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Char_literal
"." % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" Do " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.String_literal
"NOT" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.String_literal
" use your fundraiser keys on this network."
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"You should not see this message if you are not a developer."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))))))))))))))))))))
"@[<v 2>@{<warning>@{<title>Warning@}@}@,@, The node you are connecting to claims to be running in a@, @{<warning>Tezos TEST SANDBOX@}.@, Do @{<warning>NOT@} use your fundraiser keys on this network.@,You should not see this message if you are not a developer.@]@
@."
% string)
else
tt.
Definition check_network {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F) : Lwt.t (option variant) :=
op_gtgteq (Shell_services.P2p.version ctxt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ => Lwt.return_none
| Stdlib.Ok version =>
let has_prefix (prefix : string) : bool :=
String.has_prefix prefix (chain_name version) in
if has_prefix "SANDBOXED" % string then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := sandbox tt in
Lwt.return_some
(* ❌ Variants not supported *)
variant
else
if has_prefix "TEZOS_ZERONET" % string then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := zeronet tt in
Lwt.return_some
(* ❌ Variants not supported *)
variant
else
if has_prefix "TEZOS_ALPHANET" % string then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := alphanet tt in
Lwt.return_some
(* ❌ Variants not supported *)
variant
else
if
orb (has_prefix "TEZOS_BETANET" % string)
(has_prefix "TEZOS_MAINNET" % string) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := mainnet tt in
Lwt.return_some
(* ❌ Variants not supported *)
variant
else
Lwt.return_none
end).
Definition get_commands_for_version {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(network : option Tezos_client_commands.Client_commands.network)
(chain : Tezos_shell_services__Chain_services.chain)
(block : Tezos_shell_services.Block_services.block)
(protocol : option Tezos_base__TzPervasives.Protocol_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
((option Tezos_base__TzPervasives.Protocol_hash.t) *
(list Tezos_client_commands.Client_commands.command))) :=
op_gtgteq (Shell_services.Blocks.protocols ctxt (Some chain) (Some block) tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok {| next_protocol := version |} =>
match protocol with
| None =>
_return
((Some version),
(Client_commands.commands_for_version version network))
| Some given_version =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if negb (Protocol_hash.equal version given_version) then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<title>" % string
CamlinternalFormatBasics.End_of_format)
"<title>" % string))
(CamlinternalFormatBasics.String_literal
"Warning" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0
0)
(CamlinternalFormatBasics.String_literal
"The protocol provided via `--protocol` (" %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"is not the one retrieved from the node ("
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
")." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))))))))))
"@[<v 2>@{<warning>@{<title>Warning@}@}@,The protocol provided via `--protocol` (%a)@,is not the one retrieved from the node (%a).@]@
@."
% string) Protocol_hash.pp_short given_version
Protocol_hash.pp_short version
else
tt in
_return
((Some version),
(Client_commands.commands_for_version given_version network))
end
| Stdlib.Error errs =>
match protocol with
| None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<warning>" % string
CamlinternalFormatBasics.End_of_format)
"<warning>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<title>" % string
CamlinternalFormatBasics.End_of_format)
"<title>" % string))
(CamlinternalFormatBasics.String_literal
"Warning" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Failed to acquire the protocol version from the node"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string
0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))))))
"@[<v 2>@{<warning>@{<title>Warning@}@}@,Failed to acquire the protocol version from the node@,%a@]@
@."
% string) (Format.pp_print_list None pp) errs in
_return (None, [])
| Some version =>
_return
((Some version),
(Client_commands.commands_for_version version network))
end
end).
Definition select_commands {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(function_parameter : Tezos_client_base_unix.Client_config.cli_args)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list Tezos_client_commands.Client_commands.command)) :=
let '{| chain := chain; block := block; protocol := protocol |} :=
function_parameter in
op_gtgteq (check_network ctxt)
(fun network =>
op_gtgtpipequestion
(get_commands_for_version ctxt network chain block protocol)
(fun function_parameter =>
let '(_, commands_for_version) := function_parameter in
OCaml.Stdlib.app Client_rpc_commands.commands
(OCaml.Stdlib.app (Tezos_signer_backends_unix.Ledger.commands tt)
(OCaml.Stdlib.app (Client_keys_commands.commands network)
(OCaml.Stdlib.app (Client_helpers_commands.commands tt)
commands_for_version))))).
src/bin_client/test/proto_test_injection/main.ml 23 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type block_header_data = MBytes.t
type block_header = {
shell : Block_header.shell_header;
protocol_data : block_header_data;
}
let block_header_data_encoding =
Data_encoding.(obj1 (req "random_data" Variable.bytes))
type block_header_metadata = unit
let block_header_metadata_encoding = Data_encoding.unit
type operation_data = unit
let operation_data_encoding = Data_encoding.unit
type operation_receipt = unit
let operation_receipt_encoding = Data_encoding.unit
let operation_data_and_receipt_encoding =
Data_encoding.conv
(function ((), ()) -> ())
(fun () -> ((), ()))
Data_encoding.unit
type operation = {
shell : Operation.shell_header;
protocol_data : operation_data;
}
let max_block_length = 42
let max_operation_data_length = 42
let validation_passes = []
let acceptable_passes _op = []
let compare_operations _ _ = 0
type validation_state = {context : Context.t; fitness : Int64.t}
let current_context {context} = return context
module Fitness = struct
type error += Invalid_fitness
type error += Invalid_fitness2
let int64_to_bytes i =
let b = MBytes.create 8 in
MBytes.set_int64 b 0 i ; b
let int64_of_bytes b =
if Compare.Int.(MBytes.length b <> 8) then fail Invalid_fitness2
else return (MBytes.get_int64 b 0)
let from_int64 fitness = [int64_to_bytes fitness]
let to_int64 = function
| [fitness] ->
int64_of_bytes fitness
| [] ->
return 0L
| _ ->
fail Invalid_fitness
let get {fitness} = fitness
end
let begin_application ~chain_id:_ ~predecessor_context:context
~predecessor_timestamp:_ ~predecessor_fitness:_ (raw_block : block_header)
=
Fitness.to_int64 raw_block.shell.fitness
>>=? fun fitness -> return {context; fitness}
let begin_partial_application ~chain_id ~ancestor_context
~predecessor_timestamp ~predecessor_fitness raw_block =
begin_application
~chain_id
~predecessor_context:ancestor_context
~predecessor_timestamp
~predecessor_fitness
raw_block
let begin_construction ~chain_id:_ ~predecessor_context:context
~predecessor_timestamp:_ ~predecessor_level:_
~predecessor_fitness:pred_fitness ~predecessor:_ ~timestamp:_
?protocol_data:_ () =
Fitness.to_int64 pred_fitness
>>=? fun pred_fitness ->
let fitness = Int64.succ pred_fitness in
return {context; fitness}
let apply_operation ctxt _ = return (ctxt, ())
let finalize_block ctxt =
let fitness = Fitness.get ctxt in
let message = Some (Format.asprintf "fitness <- %Ld" fitness) in
let fitness = Fitness.from_int64 fitness in
return
( {
Updater.message;
context = ctxt.context;
fitness;
max_operations_ttl = 0;
last_allowed_fork_level = 0l;
},
() )
let rpc_services = RPC_directory.empty
let init ctxt block_header =
let fitness = block_header.Block_header.fitness in
let message = None in
return
{
Updater.message;
context = ctxt;
fitness;
max_operations_ttl = 0;
last_allowed_fork_level = 0l;
}
src/bin_client/test/proto_test_injection/main.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition block_header_data := Tezos_base__TzPervasives.MBytes.t.
Record block_header := {
shell : Tezos_base__TzPervasives.Block_header.shell_header;
protocol_data : block_header_data }.
Definition block_header_data_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
obj1 (req None None "random_data" % string Variable.bytes).
Definition block_header_metadata := unit.
Definition block_header_metadata_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding unit := Data_encoding.unit.
Definition operation_data := unit.
Definition operation_data_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding unit := Data_encoding.unit.
Definition operation_receipt := unit.
Definition operation_receipt_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding unit := Data_encoding.unit.
Definition operation_data_and_receipt_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding (unit * unit) :=
Data_encoding.conv
(fun function_parameter =>
let '(tt, tt) := function_parameter in
tt)
(fun function_parameter =>
let 'tt := function_parameter in
(tt, tt)) None Data_encoding.unit.
Record operation := {
shell : Tezos_base__TzPervasives.Operation.shell_header;
protocol_data : operation_data }.
Definition max_block_length : Z := 42.
Definition max_operation_data_length : Z := 42.
Definition validation_passes {A : Type} : list A := [].
Definition acceptable_passes {A B : Type} (_op : A) : list B := [].
Definition compare_operations {A B : Type} (function_parameter : A) : B -> Z :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
0.
Definition current_context {A B : Type} (function_parameter : A)
: Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
let '_ := function_parameter in
_return op_startypeminuserrorstar.
Module Fitness.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition int64_to_bytes (i : int64) : Tezos_base__TzPervasives.MBytes.t :=
let b := MBytes.create 8 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := MBytes.set_int64 b 0 i in
b.
Definition int64_of_bytes (b : Tezos_base__TzPervasives.MBytes.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult int64) :=
if op_ltgt (MBytes.length b) 8 then
fail Tezos_base__TzPervasives.Invalid_fitness2
else
_return (MBytes.get_int64 b 0).
Definition from_int64 (fitness : int64)
: list Tezos_base__TzPervasives.MBytes.t := cons (int64_to_bytes fitness) [].
Definition to_int64
(function_parameter : list Tezos_base__TzPervasives.MBytes.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult int64) :=
match function_parameter with
| cons fitness [] => int64_of_bytes fitness
| [] =>
_return
(* ❌ Constant of type int64 is converted to int *)
0
| _ => fail Tezos_base__TzPervasives.Invalid_fitness
end.
Definition get {A B : Type} (function_parameter : A) : B :=
let '_ := function_parameter in
op_startypeminuserrorstar.
End Fitness.
Definition begin_application {A B C D E : Type} (function_parameter : A)
: B -> C -> D -> block_header -> Lwt.t (Tezos_base__TzPervasives.tzresult E) :=
let '_ := function_parameter in
fun context =>
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun raw_block =>
op_gtgteqquestion (Fitness.to_int64 (fitness (shell raw_block)))
(fun fitness => _return op_startypeminuserrorstar).
Definition begin_partial_application {A B C D E : Type}
(chain_id : A) (ancestor_context : B) (predecessor_timestamp : C)
(predecessor_fitness : D) (raw_block : block_header)
: Lwt.t (Tezos_base__TzPervasives.tzresult E) :=
begin_application chain_id ancestor_context predecessor_timestamp
predecessor_fitness raw_block.
Definition begin_construction {A B C D E F G H : Type} (function_parameter : A)
: B ->
C ->
D ->
(list Tezos_base__TzPervasives.MBytes.t) ->
E ->
F ->
(option G) -> unit -> Lwt.t (Tezos_base__TzPervasives.tzresult H) :=
let '_ := function_parameter in
fun context =>
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun pred_fitness =>
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Fitness.to_int64 pred_fitness)
(fun pred_fitness =>
let fitness := Int64.succ pred_fitness in
_return op_startypeminuserrorstar).
Definition apply_operation {A B : Type} (ctxt : A) (function_parameter : B)
: Lwt.t (Tezos_base__TzPervasives.tzresult (A * unit)) :=
let '_ := function_parameter in
_return (ctxt, tt).
Definition finalize_block {A B : Type} (ctxt : A)
: Lwt.t (Tezos_base__TzPervasives.tzresult (B * unit)) :=
let fitness := Fitness.get ctxt in
let message :=
Some
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "fitness <- " % string
(CamlinternalFormatBasics.Int64 CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "fitness <- %Ld" % string)
fitness) in
let fitness := Fitness.from_int64 fitness in
_return (op_startypeminuserrorstar, tt).
Definition rpc_services {A : Type}
: Tezos_base__TzPervasives.RPC_directory.directory A := RPC_directory.empty.
Definition init {A B : Type}
(ctxt : A) (block_header : Tezos_base__TzPervasives.Block_header.shell_header)
: Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
let fitness := Block_header.fitness block_header in
let message := None in
_return op_startypeminuserrorstar.
src/bin_codec/codec.ml 11 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let commands = Commands.commands ()
let home = try Sys.getenv "HOME" with Not_found -> "/tmp"
let default_base_dir = Filename.concat home ".tezos-client"
let base_dir_arg =
let open Clic in
arg
~long:"base-dir"
~short:'d'
~placeholder:"path"
~doc:
( "data directory\n\
The directory where the Tezos codec will output logs.\n\
By default: '" ^ default_base_dir ^ "'." )
(parameter (fun _ctxt x -> return x))
let global_options = Clic.args1 base_dir_arg
let parse_config_args argv =
(* The context used during argument parsing. We switch to a real context
that is created based on some of the parsed arguments. *)
let ctxt = Client_context.null_printer in
Clic.parse_global_options global_options ctxt argv
>>=? fun (base_dir, argv) ->
( match base_dir with
| None ->
let base_dir = default_base_dir in
( if Sys.file_exists base_dir then Lwt.return_unit
else Lwt_utils_unix.create_dir base_dir )
>>= fun () -> return base_dir
| Some dir ->
if not (Sys.file_exists dir) then
failwith
"Specified -base-dir does not exist. Please create the directory \
and try again."
else if not (Sys.is_directory dir) then
failwith "Specified -base-dir must be a directory"
else return dir )
>>=? fun base_dir -> return (base_dir, argv)
(* Main (lwt) entry *)
let main commands =
let executable_name = Filename.basename Sys.executable_name in
let run () =
let (argv, autocomplete) =
(* for shell aliases *)
let rec move_autocomplete_token_upfront acc = function
| "bash_autocomplete" :: prev_arg :: cur_arg :: script :: args ->
let args = List.rev acc @ args in
(args, Some (prev_arg, cur_arg, script))
| x :: rest ->
move_autocomplete_token_upfront (x :: acc) rest
| [] ->
(List.rev acc, None)
in
match Array.to_list Sys.argv with
| _ :: args ->
move_autocomplete_token_upfront [] args
| [] ->
([], None)
in
Random.self_init () ;
ignore
Clic.(
setup_formatter
Format.std_formatter
(if Unix.isatty Unix.stdout then Ansi else Plain)
Short) ;
ignore
Clic.(
setup_formatter
Format.err_formatter
(if Unix.isatty Unix.stderr then Ansi else Plain)
Short) ;
Internal_event_unix.init ()
>>= fun () ->
parse_config_args argv
>>=? fun (base_dir, argv) ->
let ctxt = new Client_context_unix.unix_logger ~base_dir in
let commands =
Clic.add_manual
~executable_name
~global_options
(if Unix.isatty Unix.stdout then Clic.Ansi else Clic.Plain)
Format.std_formatter
commands
in
match autocomplete with
| Some (prev_arg, cur_arg, script) ->
Clic.autocompletion
~script
~cur_arg
~prev_arg
~args:argv
~global_options
commands
ctxt
>>=? fun completions ->
List.iter print_endline completions ;
return_unit
| None ->
Clic.dispatch commands ctxt argv
in
Pervasives.exit
(Lwt_main.run
( Lwt.catch run (function
| Failure msg ->
failwith "%s" msg
| exn ->
failwith "%s" (Printexc.to_string exn))
>>= (function
| Ok () ->
Lwt.return 0
| Error [Clic.Help command] ->
Clic.usage
Format.std_formatter
~executable_name
~global_options
(match command with None -> [] | Some c -> [c]) ;
Lwt.return 0
| Error errs ->
Clic.pp_cli_errors
Format.err_formatter
~executable_name
~global_options
~default:Error_monad.pp
errs ;
Lwt.return 1)
>>= fun retcode ->
Format.pp_print_flush Format.err_formatter () ;
Format.pp_print_flush Format.std_formatter () ;
Lwt.return retcode ))
let () = main commands
src/bin_codec/codec.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition commands
: list (Tezos_clic.Clic.command Tezos_client_base.Client_context.printer) :=
Commands.commands tt.
Definition home : string :=
(* ❌ Try-with are not handled *)
try (Sys.getenv "HOME" % string).
Definition default_base_dir : string :=
Filename.concat home ".tezos-client" % string.
Definition base_dir_arg
: Tezos_clic.Clic.arg (option string) Tezos_client_base.Client_context.printer :=
arg
(String.append
"data directory
The directory where the Tezos codec will output logs.
By default: '"
% string (String.append default_base_dir "'." % string))
(Some "d" % char) "base-dir" % string "path" % string
(parameter None (fun _ctxt => fun x => _return x)).
Definition global_options
: Tezos_clic.Clic.options (option string)
Tezos_client_base.Client_context.printer := Clic.args1 base_dir_arg.
Definition parse_config_args (argv : list string)
: Lwt.t (Tezos_base__TzPervasives.tzresult (string * (list string))) :=
let ctxt := Client_context.null_printer in
op_gtgteqquestion (Clic.parse_global_options global_options ctxt argv)
(fun function_parameter =>
let '(base_dir, argv) := function_parameter in
op_gtgteqquestion
match base_dir with
| None =>
let base_dir := default_base_dir in
op_gtgteq
(if Sys.file_exists base_dir then
Lwt.return_unit
else
Lwt_utils_unix.create_dir None base_dir)
(fun function_parameter =>
let 'tt := function_parameter in
_return base_dir)
| Some dir =>
if negb (Sys.file_exists dir) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Specified -base-dir does not exist. Please create the directory and try again."
% string CamlinternalFormatBasics.End_of_format)
"Specified -base-dir does not exist. Please create the directory and try again."
% string)
else
if negb (Sys.is_directory dir) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Specified -base-dir must be a directory" % string
CamlinternalFormatBasics.End_of_format)
"Specified -base-dir must be a directory" % string)
else
_return dir
end (fun base_dir => _return (base_dir, argv))).
Definition main {A : Type}
(commands :
list (Tezos_clic.Clic.command Tezos_client_base.Client_context.printer))
: A :=
let executable_name := Filename.basename Sys.executable_name in
let run (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let 'tt := function_parameter in
let '(argv, autocomplete) :=
let fix move_autocomplete_token_upfront
(acc : list string) (function_parameter : list string)
: (list string) * (option (string * string * string)) :=
match function_parameter with
|
cons "bash_autocomplete" % string
(cons prev_arg (cons cur_arg (cons script args))) =>
let args := OCaml.Stdlib.app (List.rev acc) args in
(args, (Some (prev_arg, cur_arg, script)))
| cons x rest => move_autocomplete_token_upfront (cons x acc) rest
| [] => ((List.rev acc), None)
end in
match Array.to_list Sys.argv with
| cons _ args => move_autocomplete_token_upfront [] args
| [] => ([], None)
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Random.self_init tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.ignore
(setup_formatter Format.std_formatter
(if Unix.isatty Unix.stdout then
Tezos_clic.Clic.Ansi
else
Tezos_clic.Clic.Plain) Tezos_clic.Clic.Short) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.ignore
(setup_formatter Format.err_formatter
(if Unix.isatty Unix.stderr then
Tezos_clic.Clic.Ansi
else
Tezos_clic.Clic.Plain) Tezos_clic.Clic.Short) in
op_gtgteq (Internal_event_unix.init None None tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (parse_config_args argv)
(fun function_parameter =>
let '(base_dir, argv) := function_parameter in
let ctxt :=
(* ❌ Creation of new objects is not handled *)
new base_dir in
let commands :=
Clic.add_manual executable_name global_options
(if Unix.isatty Unix.stdout then
Tezos_clic.Clic.Ansi
else
Tezos_clic.Clic.Plain) Format.std_formatter commands in
match autocomplete with
| Some (prev_arg, cur_arg, script) =>
op_gtgteqquestion
(Clic.autocompletion script cur_arg prev_arg argv global_options
commands ctxt)
(fun completions =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter OCaml.Stdlib.print_endline completions in
return_unit)
| None => Clic.dispatch commands ctxt argv
end)) in
Pervasives.exit
(Lwt_main.run
(op_gtgteq
(op_gtgteq
(Lwt.catch run
(fun function_parameter =>
match function_parameter with
| OCaml.Failure msg =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) msg
| exn =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
(Printexc.to_string exn)
end))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt._return 0
|
Stdlib.Error
(cons (Tezos_error_monad.Error_monad.Help command) []) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Clic.usage Format.std_formatter executable_name global_options
match command with
| None => []
| Some c => cons c []
end in
Lwt._return 0
| Stdlib.Error errs =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Clic.pp_cli_errors Format.err_formatter executable_name
global_options Error_monad.pp errs in
Lwt._return 1
end))
(fun retcode =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_flush Format.err_formatter tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_flush Format.std_formatter tt in
Lwt._return retcode))).
src/bin_codec/commands.ml 69 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Lwt.Infix
open Clic
let group = {name = "encoding"; title = "Commands to handle encodings"}
let id_parameter =
parameter (fun (cctxt : #Client_context.printer) id ->
match Data_encoding.Registration.find id with
| Some record ->
return record
| None ->
cctxt#error "Unkown encoding id: %s" id)
let json_parameter =
parameter (fun (cctxt : #Client_context.printer) file_or_data ->
Lwt_unix.file_exists file_or_data
>>= (function
| true ->
Tezos_stdlib_unix.Lwt_utils_unix.read_file file_or_data
| false ->
Lwt.return file_or_data)
>>= fun data ->
match Json.from_string data with
| Ok json ->
return json
| Error err ->
cctxt#error "%s" err)
let bytes_parameter = parameter (fun _ hex -> return (Hex.to_bytes (`Hex hex)))
let commands () =
[ command
~group
~desc:"List the registered encoding in Tezos."
no_options
(fixed ["list"; "encodings"])
(fun () (cctxt : #Client_context.printer) ->
let bindings =
Data_encoding.Registration.list ()
|> List.map (fun (id, elem) ->
(id, Data_encoding.Registration.description elem))
in
cctxt#message
"@[<v>%a@]@."
(Format.pp_print_list
~pp_sep:Format.pp_print_cut
(fun ppf (id, desc) ->
let desc =
Option.unopt ~default:"No description available." desc
in
Format.fprintf
ppf
"@[<v 2>%s:@ @[%a@]@]"
id
Format.pp_print_text
desc))
bindings
>>= fun () -> return_unit);
command
~group
~desc:"Dump a json description of all registered encodings."
( args1
@@ switch
~doc:
"Output json descriptions without extraneous whitespace characters"
~long:"compact"
() )
(fixed ["dump"; "encodings"])
(fun minify (cctxt : #Client_context.printer) ->
cctxt#message
"%s"
(Json.to_string
~minify
(`A
( Registration.list ()
|> List.map (fun (id, enc) ->
`O
[ ("id", `String id);
( "json",
Json.construct
Json.schema_encoding
(Registration.json_schema enc) );
( "binary",
Json.construct
Binary_schema.encoding
(Registration.binary_schema enc) ) ]) )))
>>= fun () -> return_unit);
(* JSON -> Binary *)
command
~group
~desc:
"Encode the given JSON data into binary using the provided encoding \
identifier."
no_options
( prefix "encode"
@@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
@@ prefix "from"
@@ param ~name:"json" ~desc:"JSON file or data" json_parameter
@@ stop )
(fun () registered_encoding json (cctxt : #Client_context.printer) ->
match
Data_encoding.Registration.bytes_of_json registered_encoding json
with
| exception exn ->
cctxt#error "%a" (fun ppf exn -> Json.print_error ppf exn) exn
| None ->
cctxt#error
"Impossible to the JSON convert to binary.@,\
This error should not happen."
| Some bytes ->
cctxt#message "%a" Hex.pp (Hex.of_bytes bytes)
>>= fun () -> return_unit);
(* Binary -> JSON *)
command
~group
~desc:
"Decode the binary encoded data into JSON using the provided encoding \
identifier."
no_options
( prefix "decode"
@@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
@@ prefix "from"
@@ param ~name:"hex" ~desc:"Binary encoded data" bytes_parameter
@@ stop )
(fun () registered_encoding bytes (cctxt : #Client_context.printer) ->
match
Data_encoding.Registration.json_of_bytes registered_encoding bytes
with
| None ->
cctxt#error "Cannot parse the binary with the given encoding"
| Some bytes ->
cctxt#message "%a" Json.pp bytes >>= fun () -> return_unit);
command
~group
~desc:
"Display the binary encoded data using the provided encoding \
identifier."
no_options
( prefix "display"
@@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
@@ prefixes ["from"; "binary"]
@@ param ~name:"hex" ~desc:"Binary encoded data" bytes_parameter
@@ stop )
(fun () registered_encoding bytes (cctxt : #Client_context.printer) ->
let pp_bytes fmt bytes =
Data_encoding.Registration.binary_pretty_printer
registered_encoding
fmt
bytes
in
cctxt#message "%a" pp_bytes bytes >>= fun () -> return_unit);
command
~group
~desc:
"Display the JSON encoded data using the provided encoding identifier."
no_options
( prefix "display"
@@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
@@ prefixes ["from"; "json"]
@@ param ~name:"json" ~desc:"JSON file or data" json_parameter
@@ stop )
(fun () registered_encoding json (cctxt : #Client_context.printer) ->
let pp_json fmt json =
Data_encoding.Registration.json_pretty_printer
registered_encoding
fmt
json
in
cctxt#message "%a" pp_json json >>= fun () -> return_unit);
command
~group
~desc:
"Describe the binary schema associated to the provided encoding \
identifier."
no_options
( prefix "describe"
@@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
@@ prefixes ["binary"; "schema"]
@@ stop )
(fun () registered_encoding (cctxt : #Client_context.printer) ->
let schema =
Data_encoding.Registration.binary_schema registered_encoding
in
cctxt#message "%a" Binary_schema.pp schema >>= fun () -> return_unit);
command
~group
~desc:
"Describe the JSON schema associated to the provided encoding \
identifier."
no_options
( prefix "describe"
@@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
@@ prefixes ["json"; "schema"]
@@ stop )
(fun () registered_encoding cctxt ->
let schema =
Data_encoding.Registration.json_schema registered_encoding
in
cctxt#message "%a" Json_schema.pp schema >>= fun () -> return_unit) ]
src/bin_codec/commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
Import Clic.
Definition group : Tezos_clic.Clic.group :=
{| name := "encoding" % string;
title := "Commands to handle encodings" % string |}.
Definition id_parameter {C a b : Type}
: Tezos_clic.Clic.parameter
Tezos_base__TzPervasives.Data_encoding.Registration.t
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C) :=
parameter None
(fun cctxt =>
fun id =>
match Data_encoding.Registration.find id with
| Some record => _return record
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unkown encoding id: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Unkown encoding id: %s" % string) id
end).
Definition json_parameter {C a b : Type}
: Tezos_clic.Clic.parameter Tezos_data_encoding.Json.json
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C) :=
parameter None
(fun cctxt =>
fun file_or_data =>
op_gtgteq
(op_gtgteq (Lwt_unix.file_exists file_or_data)
(fun function_parameter =>
match function_parameter with
| true => Tezos_stdlib_unix.Lwt_utils_unix.read_file file_or_data
| false => Lwt._return file_or_data
end))
(fun data =>
match Json.from_string data with
| Stdlib.Ok json => _return json
| Stdlib.Error err =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) err
end)).
Definition bytes_parameter {C a b : Type}
: Tezos_clic.Clic.parameter string
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C) :=
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun hex =>
_return
(Hex.to_bytes
(* ❌ Variants not supported *)
variant)).
Definition commands {C a b : Type} (function_parameter : unit)
: list
(Tezos_clic.Clic.command
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C)) :=
let 'tt := function_parameter in
cons
(command (Some group) "List the registered encoding in Tezos." % string
no_options (fixed (cons "list" % string (cons "encodings" % string [])))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
let bindings :=
OCaml.Stdlib.reverse_apply (Data_encoding.Registration.list tt)
(List.map
(fun function_parameter =>
let '(id, elem) := function_parameter in
(id, (Data_encoding.Registration.description elem)))) in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v>" % string
CamlinternalFormatBasics.End_of_format) "<v>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"@[<v>%a@]@." % string)
(Format.pp_print_list (Some Format.pp_print_cut)
(fun ppf =>
fun function_parameter =>
let '(id, desc) := function_parameter in
let desc :=
Option.unopt "No description available." % string desc in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1
0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"@[<v 2>%s:@ @[%a@]@]" % string) id Format.pp_print_text
desc)) bindings)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(cons
(command (Some group)
"Dump a json description of all registered encodings." % string
(apply args1
(switch
"Output json descriptions without extraneous whitespace characters"
% string None "compact" % string tt))
(fixed (cons "dump" % string (cons "encodings" % string [])))
(fun minify =>
fun cctxt =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
(Json.to_string None (Some minify)
(* ❌ Variants not supported *)
variant))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(cons
(command (Some group)
"Encode the given JSON data into binary using the provided encoding identifier."
% string no_options
(apply (prefix "encode" % string)
(apply
(param "id" % string "Encoding identifier" % string id_parameter)
(apply (prefix "from" % string)
(apply
(param "json" % string "JSON file or data" % string
json_parameter) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun registered_encoding =>
fun json =>
fun cctxt =>
match
Data_encoding.Registration.bytes_of_json registered_encoding
json with
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Impossible to the JSON convert to binary." % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"This error should not happen." % string
CamlinternalFormatBasics.End_of_format)))
"Impossible to the JSON convert to binary.@,This error should not happen."
% string)
| Some bytes =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Hex.pp (Hex.of_bytes None string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end))
(cons
(command (Some group)
"Decode the binary encoded data into JSON using the provided encoding identifier."
% string no_options
(apply (prefix "decode" % string)
(apply
(param "id" % string "Encoding identifier" % string id_parameter)
(apply (prefix "from" % string)
(apply
(param "hex" % string "Binary encoded data" % string
bytes_parameter) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun registered_encoding =>
fun bytes =>
fun cctxt =>
match
Data_encoding.Registration.json_of_bytes
registered_encoding string with
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot parse the binary with the given encoding" %
string CamlinternalFormatBasics.End_of_format)
"Cannot parse the binary with the given encoding" %
string)
| Some bytes =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Json.pp string)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end))
(cons
(command (Some group)
"Display the binary encoded data using the provided encoding identifier."
% string no_options
(apply (prefix "display" % string)
(apply
(param "id" % string "Encoding identifier" % string
id_parameter)
(apply
(prefixes (cons "from" % string (cons "binary" % string [])))
(apply
(param "hex" % string "Binary encoded data" % string
bytes_parameter) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun registered_encoding =>
fun bytes =>
fun cctxt =>
let pp_bytes
(fmt : Stdlib.Format.formatter) (bytes : Stdlib.Bytes.t)
: unit :=
Data_encoding.Registration.binary_pretty_printer
registered_encoding fmt string in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) pp_bytes string)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(cons
(command (Some group)
"Display the JSON encoded data using the provided encoding identifier."
% string no_options
(apply (prefix "display" % string)
(apply
(param "id" % string "Encoding identifier" % string
id_parameter)
(apply
(prefixes (cons "from" % string (cons "json" % string [])))
(apply
(param "json" % string "JSON file or data" % string
json_parameter) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun registered_encoding =>
fun json =>
fun cctxt =>
let pp_json
(fmt : Stdlib.Format.formatter) (json :
Tezos_data_encoding.Json.t) : unit :=
Data_encoding.Registration.json_pretty_printer
registered_encoding fmt json in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) pp_json json)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(cons
(command (Some group)
"Describe the binary schema associated to the provided encoding identifier."
% string no_options
(apply (prefix "describe" % string)
(apply
(param "id" % string "Encoding identifier" % string
id_parameter)
(apply
(prefixes
(cons "binary" % string (cons "schema" % string [])))
stop)))
(fun function_parameter =>
let 'tt := function_parameter in
fun registered_encoding =>
fun cctxt =>
let schema :=
Data_encoding.Registration.binary_schema
registered_encoding in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Binary_schema.pp schema)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(cons
(command (Some group)
"Describe the JSON schema associated to the provided encoding identifier."
% string no_options
(apply (prefix "describe" % string)
(apply
(param "id" % string "Encoding identifier" % string
id_parameter)
(apply
(prefixes
(cons "json" % string (cons "schema" % string [])))
stop)))
(fun function_parameter =>
let 'tt := function_parameter in
fun registered_encoding =>
fun cctxt =>
let schema :=
Data_encoding.Registration.json_schema
registered_encoding in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Json_schema.pp schema)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))) []))))))).
src/bin_node/genesis_chain.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018-2019 Nomadic Labs. <nomadic@tezcore.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let genesis : State.Chain.genesis =
{
time = Time.Protocol.of_notation_exn "2018-06-30T16:07:32Z";
block =
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisf79b5d1CoW2";
protocol =
Protocol_hash.of_b58check_exn
"ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im";
}
src/bin_node/genesis_chain.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition genesis : Tezos_shell.State.Chain.genesis :=
{| time := Time.Protocol.of_notation_exn "2018-06-30T16:07:32Z" % string;
block :=
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisf79b5d1CoW2" % string;
protocol :=
Protocol_hash.of_b58check_exn
"ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im" % string |}.
src/bin_node/main.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let () =
let log s = Node_logging.fatal_error "%s" s in
Lwt_exit.exit_on ~log Sys.sigint ;
Lwt_exit.exit_on ~log Sys.sigterm
let () =
if Filename.basename Sys.argv.(0) = Updater.compiler_name then (
try
Tezos_protocol_compiler.Compiler.main
Tezos_protocol_compiler_native.Native.driver ;
Pervasives.exit 0
with exn ->
Format.eprintf "%a\n%!" Opterrors.report_error exn ;
Pervasives.exit 1 )
let () =
if Filename.basename Sys.argv.(0) = "tezos-validator" then (
try Pervasives.exit (Lwt_main.run @@ Validator.main ())
with exn ->
Format.eprintf "%a\n%!" Opterrors.report_error exn ;
Pervasives.exit 1 )
let term =
let open Cmdliner.Term in
ret (const (`Help (`Pager, None)))
let description =
[ `S "DESCRIPTION";
`P "Entry point for initializing, configuring and running a Tezos node.";
`P Node_identity_command.Manpage.command_description;
`P Node_run_command.Manpage.command_description;
`P Node_config_command.Manpage.command_description;
`P Node_snapshot_command.Manpage.command_description ]
let man = description @ Node_run_command.Manpage.examples
let info =
let version =
Tezos_version.Current_git_info.abbreviated_commit_hash ^ " ("
^ Tezos_version.Current_git_info.committer_date ^ ")"
in
Cmdliner.Term.info ~doc:"The Tezos node" ~man ~version "tezos-node"
let commands =
[ Node_run_command.cmd;
Node_config_command.cmd;
Node_identity_command.cmd;
Node_snapshot_command.cmd ]
let () =
Random.self_init () ;
match Cmdliner.Term.eval_choice (term, info) commands with
| `Error _ ->
exit 1
| `Help ->
exit 0
| `Version ->
exit 1
| `Ok () ->
exit 0
src/bin_node/main.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition term {A : Type} : Cmdliner.Term.t A :=
ret
(const
(* ❌ Variants not supported *)
variant).
Definition description : list variant :=
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant []))))).
Definition man : list Cmdliner.Manpage.block :=
OCaml.Stdlib.app description Node_run_command.Manpage.examples.
Definition info : Cmdliner.Term.info :=
let version :=
String.append Tezos_version.Current_git_info.abbreviated_commit_hash
(String.append " (" % string
(String.append Tezos_version.Current_git_info.committer_date
")" % string)) in
Cmdliner.Term.info None (Some man) None None None None
(Some "The Tezos node" % string) (Some version) "tezos-node" % string.
Definition commands : list ((Cmdliner.Term.t unit) * Cmdliner.Term.info) :=
cons Node_run_command.cmd
(cons Node_config_command.cmd
(cons Node_identity_command.cmd (cons Node_snapshot_command.cmd []))).
src/bin_node/node_config_command.ml 24 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Commands *)
let show (args : Node_shared_arg.t) =
if not @@ Sys.file_exists args.config_file then
Format.eprintf
"\n\
Warning: no config file at %s,\n\
\ displaying the default configuration.\n\
@."
args.config_file ;
Node_shared_arg.read_and_patch_config_file args
>>=? fun cfg ->
Node_config_file.check cfg
>>= fun () ->
print_endline @@ Node_config_file.to_string cfg ;
return_unit
let reset (args : Node_shared_arg.t) =
if Sys.file_exists args.config_file then
Format.eprintf
"Ignoring previous configuration file: %s.@."
args.config_file ;
Node_shared_arg.read_and_patch_config_file args
>>=? fun cfg ->
Node_config_file.check cfg
>>= fun () -> Node_config_file.write args.config_file cfg
let init (args : Node_shared_arg.t) =
if Sys.file_exists args.config_file then
failwith "Pre-existing config file at %s, use `reset`." args.config_file
else
Node_shared_arg.read_and_patch_config_file args
>>=? fun cfg ->
Node_config_file.check cfg
>>= fun () -> Node_config_file.write args.config_file cfg
let update (args : Node_shared_arg.t) =
if not (Sys.file_exists args.config_file) then
failwith
"Missing configuration file at %s. Use `%s config init [options]` to \
generate a new file"
args.config_file
Sys.argv.(0)
else
Node_shared_arg.read_and_patch_config_file args
>>=? fun cfg ->
Node_config_file.check cfg
>>= fun () -> Node_config_file.write args.config_file cfg
(** Main *)
module Term = struct
type subcommand = Show | Reset | Init | Update
let process subcommand args =
let res =
match subcommand with
| Show ->
show args
| Reset ->
reset args
| Init ->
init args
| Update ->
update args
in
match Lwt_main.run res with
| Ok () ->
`Ok ()
| Error err ->
`Error (false, Format.asprintf "%a" pp_print_error err)
let subcommand_arg =
let parser = function
| "show" ->
`Ok Show
| "reset" ->
`Ok Reset
| "init" ->
`Ok Init
| "update" ->
`Ok Update
| s ->
`Error ("invalid argument: " ^ s)
and printer ppf = function
| Show ->
Format.fprintf ppf "show"
| Reset ->
Format.fprintf ppf "reset"
| Init ->
Format.fprintf ppf "init"
| Update ->
Format.fprintf ppf "update"
in
let open Cmdliner.Arg in
let doc =
"Operation to perform. Possible values: $(b,show), $(b,reset), \
$(b,init), $(b,update)."
in
value & pos 0 (parser, printer) Show & info [] ~docv:"OPERATION" ~doc
let term =
let open Cmdliner.Term in
ret (const process $ subcommand_arg $ Node_shared_arg.Term.args)
end
module Manpage = struct
let command_description =
"The $(b,config) command is meant to inspect and amend the configuration \
of the Tezos node. This command is complementary to manually editing the \
tezos node configuration file. Its arguments are a subset of the \
$(i,run) command ones."
let description =
[ `S "DESCRIPTION";
`P (command_description ^ " Several operations are possible: ");
`P
"$(b,show) reads, parses and displays Tezos current config file. Use \
this command to see exactly what config file will be used by Tezos. \
If additional command-line arguments are provided, the displayed \
configuration will be amended accordingly. This is the default \
operation.";
`P
"$(b,reset) will overwrite the current configuration file with a \
factory default one. If additional command-line arguments are \
provided, they will amend the generated file. It assumes that a \
configuration file already exists and will abort otherwise.";
`P
"$(b,init) is like reset but assumes that no configuration file is \
present and will abort otherwise.";
`P
"$(b,update) is the main option to edit the configuration file of \
Tezos. It will parse command line arguments and add or replace \
corresponding entries in the Tezos configuration file." ]
let options =
let schema = Data_encoding.Json.schema Node_config_file.encoding in
let schema = Format.asprintf "@[%a@]" Json_schema.pp schema in
let schema = String.concat "\\$" (String.split '$' schema) in
[`S "OPTIONS"; `P "All options available in the config file"; `Pre schema]
let man =
description @ Node_shared_arg.Manpage.args @ options
@ Node_shared_arg.Manpage.bugs
let info = Cmdliner.Term.info ~doc:"Manage node configuration" ~man "config"
end
let cmd = (Term.term, Manpage.info)
src/bin_node/node_config_command.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition show (args : Node_shared_arg.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if apply negb (Sys.file_exists (config_file args)) then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"
Warning: no config file at " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
",
displaying the default configuration.
" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"
Warning: no config file at %s,
displaying the default configuration.
@."
% string) (config_file args)
else
tt in
op_gtgteqquestion (Node_shared_arg.read_and_patch_config_file None args)
(fun cfg =>
op_gtgteq (Node_config_file.check cfg)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply OCaml.Stdlib.print_endline (Node_config_file.to_string cfg) in
return_unit)).
Definition reset (args : Node_shared_arg.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if Sys.file_exists (config_file args) then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Ignoring previous configuration file: " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Ignoring previous configuration file: %s.@." % string)
(config_file args)
else
tt in
op_gtgteqquestion (Node_shared_arg.read_and_patch_config_file None args)
(fun cfg =>
op_gtgteq (Node_config_file.check cfg)
(fun function_parameter =>
let 'tt := function_parameter in
Node_config_file.write (config_file args) cfg)).
Definition init (args : Node_shared_arg.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if Sys.file_exists (config_file args) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Pre-existing config file at " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ", use `reset`." % string
CamlinternalFormatBasics.End_of_format)))
"Pre-existing config file at %s, use `reset`." % string)
(config_file args)
else
op_gtgteqquestion (Node_shared_arg.read_and_patch_config_file None args)
(fun cfg =>
op_gtgteq (Node_config_file.check cfg)
(fun function_parameter =>
let 'tt := function_parameter in
Node_config_file.write (config_file args) cfg)).
Definition update (args : Node_shared_arg.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if negb (Sys.file_exists (config_file args)) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Missing configuration file at " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ". Use `" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" config init [options]` to generate a new file" % string
CamlinternalFormatBasics.End_of_format)))))
"Missing configuration file at %s. Use `%s config init [options]` to generate a new file"
% string) (config_file args) (Array.get Sys.argv 0)
else
op_gtgteqquestion (Node_shared_arg.read_and_patch_config_file None args)
(fun cfg =>
op_gtgteq (Node_config_file.check cfg)
(fun function_parameter =>
let 'tt := function_parameter in
Node_config_file.write (config_file args) cfg)).
Module Term.
Inductive subcommand : Type :=
| Show : subcommand
| Reset : subcommand
| Init : subcommand
| Update : subcommand.
Definition process (subcommand : subcommand) (args : Node_shared_arg.t)
: variant :=
let res :=
match subcommand with
| Show => show args
| Reset => reset args
| Init => init args
| Update => update args
end in
match Lwt_main.run res with
| Stdlib.Ok tt =>
(* ❌ Variants not supported *)
variant
| Stdlib.Error err =>
(* ❌ Variants not supported *)
variant
end.
Definition subcommand_arg : Cmdliner.Term.t subcommand :=
let parser (function_parameter : string) : variant :=
match function_parameter with
| "show" % string =>
(* ❌ Variants not supported *)
variant
| "reset" % string =>
(* ❌ Variants not supported *)
variant
| "init" % string =>
(* ❌ Variants not supported *)
variant
| "update" % string =>
(* ❌ Variants not supported *)
variant
| s =>
(* ❌ Variants not supported *)
variant
end
with printer
(ppf : Stdlib.Format.formatter) (function_parameter : subcommand)
: unit :=
match function_parameter with
| Show =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "show" % string
CamlinternalFormatBasics.End_of_format) "show" % string)
| Reset =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "reset" % string
CamlinternalFormatBasics.End_of_format) "reset" % string)
| Init =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "init" % string
CamlinternalFormatBasics.End_of_format) "init" % string)
| Update =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "update" % string
CamlinternalFormatBasics.End_of_format) "update" % string)
end in
let doc :=
"Operation to perform. Possible values: $(b,show), $(b,reset), $(b,init), $(b,update)."
% string in
op_and value
(op_and (pos None 0 (parser, printer) Show)
(info None (Some "OPERATION" % string) (Some doc) None [])).
Definition term : Cmdliner.Term.t unit :=
ret
(op_dollar (op_dollar (const process) subcommand_arg)
Node_shared_arg.Term.args).
End Term.
Module Manpage.
Definition command_description : string :=
"The $(b,config) command is meant to inspect and amend the configuration of the Tezos node. This command is complementary to manually editing the tezos node configuration file. Its arguments are a subset of the $(i,run) command ones."
% string.
Definition description : list variant :=
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant []))))).
Definition options : list variant :=
let schema := Data_encoding.Json.schema None Node_config_file.encoding in
let schema :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))) "@[%a@]" % string)
Json_schema.pp schema in
let schema :=
String.concat "\$" % string (String.split "$" % char None None schema) in
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant [])).
Definition man : list Cmdliner.Manpage.block :=
OCaml.Stdlib.app description
(OCaml.Stdlib.app Node_shared_arg.Manpage.args
(OCaml.Stdlib.app options Node_shared_arg.Manpage.bugs)).
Definition info : Cmdliner.Term.info :=
Cmdliner.Term.info None (Some man) None None None None
(Some "Manage node configuration" % string) None "config" % string.
End Manpage.
Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
(Term.term, Manpage.info).
src/bin_node/node_config_file.ml 66 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
[@@@ocaml.warning "-30"]
let ( // ) = Filename.concat
let home = try Sys.getenv "HOME" with Not_found -> "/root"
let default_data_dir = home // ".tezos-node"
let default_rpc_port = 8732
let default_p2p_port = 9732
let default_discovery_port = 10732
type t = {
data_dir : string;
p2p : p2p;
rpc : rpc;
log : Lwt_log_sink_unix.cfg;
internal_events : Internal_event_unix.Configuration.t;
shell : shell;
}
and p2p = {
expected_pow : float;
bootstrap_peers : string list;
listen_addr : string option;
discovery_addr : string option;
private_mode : bool;
limits : P2p.limits;
disable_mempool : bool;
disable_testchain : bool;
greylisting_config : P2p_point_state.Info.greylisting_config;
}
and rpc = {
listen_addrs : string list;
cors_origins : string list;
cors_headers : string list;
tls : tls option;
}
and tls = {cert : string; key : string}
and shell = {
block_validator_limits : Node.block_validator_limits;
prevalidator_limits : Node.prevalidator_limits;
peer_validator_limits : Node.peer_validator_limits;
chain_validator_limits : Node.chain_validator_limits;
history_mode : History_mode.t option;
}
let default_p2p_limits : P2p.limits =
{
connection_timeout = Time.System.Span.of_seconds_exn 10.;
authentication_timeout = Time.System.Span.of_seconds_exn 5.;
greylist_timeout = Time.System.Span.of_seconds_exn 86400. (* one day *);
maintenance_idle_time =
Time.System.Span.of_seconds_exn 120. (* two minutes *);
min_connections = 10;
expected_connections = 50;
max_connections = 100;
backlog = 20;
max_incoming_connections = 20;
max_download_speed = None;
max_upload_speed = None;
read_buffer_size = 1 lsl 14;
read_queue_size = None;
write_queue_size = None;
incoming_app_message_queue_size = None;
incoming_message_queue_size = None;
outgoing_message_queue_size = None;
known_points_history_size = 500;
known_peer_ids_history_size = 500;
max_known_points = Some (400, 300);
max_known_peer_ids = Some (400, 300);
swap_linger = Time.System.Span.of_seconds_exn 30.;
binary_chunks_size = None;
}
let default_p2p =
{
expected_pow = 26.;
bootstrap_peers = [];
listen_addr = Some ("[::]:" ^ string_of_int default_p2p_port);
discovery_addr = None;
private_mode = false;
limits = default_p2p_limits;
disable_mempool = false;
disable_testchain = false;
greylisting_config = P2p_point_state.Info.default_greylisting_config;
}
let default_rpc =
{listen_addrs = []; cors_origins = []; cors_headers = []; tls = None}
let default_shell =
{
block_validator_limits = Node.default_block_validator_limits;
prevalidator_limits = Node.default_prevalidator_limits;
peer_validator_limits = Node.default_peer_validator_limits;
chain_validator_limits = Node.default_chain_validator_limits;
history_mode = None;
}
let default_config =
{
data_dir = default_data_dir;
p2p = default_p2p;
rpc = default_rpc;
log = Lwt_log_sink_unix.default_cfg;
internal_events = Internal_event_unix.Configuration.default;
shell = default_shell;
}
let limit : P2p.limits Data_encoding.t =
let open Data_encoding in
conv
(fun { P2p.connection_timeout;
authentication_timeout;
greylist_timeout;
maintenance_idle_time;
min_connections;
expected_connections;
max_connections;
backlog;
max_incoming_connections;
max_download_speed;
max_upload_speed;
read_buffer_size;
read_queue_size;
write_queue_size;
incoming_app_message_queue_size;
incoming_message_queue_size;
outgoing_message_queue_size;
known_points_history_size;
known_peer_ids_history_size;
max_known_points;
max_known_peer_ids;
swap_linger;
binary_chunks_size } ->
( ( ( connection_timeout,
authentication_timeout,
min_connections,
expected_connections,
max_connections,
backlog,
max_incoming_connections,
max_download_speed,
max_upload_speed,
swap_linger ),
( binary_chunks_size,
read_buffer_size,
read_queue_size,
write_queue_size,
incoming_app_message_queue_size,
incoming_message_queue_size,
outgoing_message_queue_size,
known_points_history_size,
known_peer_ids_history_size,
max_known_points ) ),
(max_known_peer_ids, greylist_timeout, maintenance_idle_time) ))
(fun ( ( ( connection_timeout,
authentication_timeout,
min_connections,
expected_connections,
max_connections,
backlog,
max_incoming_connections,
max_download_speed,
max_upload_speed,
swap_linger ),
( binary_chunks_size,
read_buffer_size,
read_queue_size,
write_queue_size,
incoming_app_message_queue_size,
incoming_message_queue_size,
outgoing_message_queue_size,
known_points_history_size,
known_peer_ids_history_size,
max_known_points ) ),
(max_known_peer_ids, greylist_timeout, maintenance_idle_time) ) ->
{
connection_timeout;
authentication_timeout;
greylist_timeout;
maintenance_idle_time;
min_connections;
expected_connections;
max_connections;
backlog;
max_incoming_connections;
max_download_speed;
max_upload_speed;
read_buffer_size;
read_queue_size;
write_queue_size;
incoming_app_message_queue_size;
incoming_message_queue_size;
outgoing_message_queue_size;
known_points_history_size;
known_peer_ids_history_size;
max_known_points;
max_known_peer_ids;
swap_linger;
binary_chunks_size;
})
(merge_objs
(merge_objs
(obj10
(dft
"connection-timeout"
~description:
"Delay acceptable when initiating a connection to a new \
peer, in seconds."
Time.System.Span.encoding
default_p2p_limits.authentication_timeout)
(dft
"authentication-timeout"
~description:
"Delay granted to a peer to perform authentication, in \
seconds."
Time.System.Span.encoding
default_p2p_limits.authentication_timeout)
(dft
"min-connections"
~description:
"Strict minimum number of connections (triggers an urgent \
maintenance)."
uint16
default_p2p_limits.min_connections)
(dft
"expected-connections"
~description:
"Targeted number of connections to reach when bootstrapping \
/ maintaining."
uint16
default_p2p_limits.expected_connections)
(dft
"max-connections"
~description:
"Maximum number of connections (exceeding peers are \
disconnected)."
uint16
default_p2p_limits.max_connections)
(dft
"backlog"
~description:
"Number above which pending incoming connections are \
immediately rejected."
uint8
default_p2p_limits.backlog)
(dft
"max-incoming-connections"
~description:
"Number above which pending incoming connections are \
immediately rejected."
uint8
default_p2p_limits.max_incoming_connections)
(opt
"max-download-speed"
~description:"Max download speeds in KiB/s."
int31)
(opt
"max-upload-speed"
~description:"Max upload speeds in KiB/s."
int31)
(dft
"swap-linger"
Time.System.Span.encoding
default_p2p_limits.swap_linger))
(obj10
(opt "binary-chunks-size" uint8)
(dft
"read-buffer-size"
~description:"Size of the buffer passed to read(2)."
int31
default_p2p_limits.read_buffer_size)
(opt "read-queue-size" int31)
(opt "write-queue-size" int31)
(opt "incoming-app-message-queue-size" int31)
(opt "incoming-message-queue-size" int31)
(opt "outgoing-message-queue-size" int31)
(dft
"known_points_history_size"
uint16
default_p2p_limits.known_points_history_size)
(dft
"known_peer_ids_history_size"
uint16
default_p2p_limits.known_points_history_size)
(opt "max_known_points" (tup2 uint16 uint16))))
(obj3
(opt "max_known_peer_ids" (tup2 uint16 uint16))
(dft
"greylist-timeout"
~description:"GC delay for the greylists tables, in seconds."
Time.System.Span.encoding
default_p2p_limits.greylist_timeout)
(dft
"maintenance-idle-time"
~description:
"How long to wait at most, in seconds, before running a \
maintenance loop."
Time.System.Span.encoding
default_p2p_limits.maintenance_idle_time)))
let p2p =
let open Data_encoding in
conv
(fun { expected_pow;
bootstrap_peers;
listen_addr;
discovery_addr;
private_mode;
limits;
disable_mempool;
disable_testchain;
greylisting_config } ->
( expected_pow,
bootstrap_peers,
listen_addr,
discovery_addr,
private_mode,
limits,
disable_mempool,
disable_testchain,
greylisting_config ))
(fun ( expected_pow,
bootstrap_peers,
listen_addr,
discovery_addr,
private_mode,
limits,
disable_mempool,
disable_testchain,
greylisting_config ) ->
{
expected_pow;
bootstrap_peers;
listen_addr;
discovery_addr;
private_mode;
limits;
disable_mempool;
disable_testchain;
greylisting_config;
})
(obj9
(dft
"expected-proof-of-work"
~description:
"Floating point number between 0 and 256 that represents a \
difficulty, 24 signifies for example that at least 24 leading \
zeroes are expected in the hash."
float
default_p2p.expected_pow)
(dft
"bootstrap-peers"
~description:
"List of hosts. Tezos can connect to both IPv6 and IPv4 hosts. If \
the port is not specified, default port 9732 will be assumed."
(list string)
default_p2p.bootstrap_peers)
(opt
"listen-addr"
~description:
"Host to listen to. If the port is not specified, the default \
port 8732 will be assumed."
string)
(dft
"discovery-addr"
~description:
"Host for local peer discovery. If the port is not specified, the \
default port 10732 will be assumed."
(option string)
default_p2p.discovery_addr)
(dft
"private-mode"
~description:
"Specify if the node is in private mode or not. A node in private \
mode rejects incoming connections from untrusted peers and only \
opens outgoing connections to peers listed in 'bootstrap-peers' \
or provided with '--peer' option. Moreover, these peers will \
keep the identity and the address of the private node secret."
bool
false)
(dft "limits" ~description:"Network limits" limit default_p2p_limits)
(dft
"disable_mempool"
~description:
"If set to [true], the node will not participate in the \
propagation of pending operations (mempool). Default value is \
[false]. It can be used to decrease the memory and computation \
footprints of the node."
bool
false)
(dft
"disable_testchain"
~description:
"If set to [true], the node will not spawn a testchain during the \
protocol's testing voting period. Default value is [false]. It \
may be used used to decrease the node storage usage and \
computation by droping the validation of the test network blocks."
bool
false)
(let open P2p_point_state.Info in
dft
"greylisting_config"
~description:"The greylisting policy."
greylisting_config_encoding
default_greylisting_config))
let rpc : rpc Data_encoding.t =
let open Data_encoding in
conv
(fun {cors_origins; cors_headers; listen_addrs; tls} ->
let (cert, key) =
match tls with
| None ->
(None, None)
| Some {cert; key} ->
(Some cert, Some key)
in
(Some listen_addrs, None, cors_origins, cors_headers, cert, key))
(fun ( listen_addrs,
legacy_listen_addr,
cors_origins,
cors_headers,
cert,
key ) ->
let tls =
match (cert, key) with
| (None, _) | (_, None) ->
None
| (Some cert, Some key) ->
Some {cert; key}
in
let listen_addrs =
match (listen_addrs, legacy_listen_addr) with
| (Some addrs, None) ->
addrs
| (None, Some addr) ->
[addr]
| (None, None) ->
default_rpc.listen_addrs
| (Some _, Some _) ->
Pervasives.failwith
"Config file: Use only \"listen-addrs\" and not (legacy) \
\"listen-addr\"."
in
{listen_addrs; cors_origins; cors_headers; tls})
(obj6
(opt
"listen-addrs"
~description:
"Hosts to listen to. If the port is not specified, the default \
port 8732 will be assumed."
(list string))
(opt "listen-addr" ~description:"Legacy value: Host to listen to" string)
(dft
"cors-origin"
~description:
"Cross Origin Resource Sharing parameters, see \
https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
(list string)
default_rpc.cors_origins)
(dft
"cors-headers"
~description:
"Cross Origin Resource Sharing parameters, see \
https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
(list string)
default_rpc.cors_headers)
(opt
"crt"
~description:"Certificate file (necessary when TLS is used)."
string)
(opt "key" ~description:"Key file (necessary when TLS is used)." string))
let worker_limits_encoding default_size default_level =
let open Data_encoding in
conv
(fun {Worker_types.backlog_size; backlog_level} ->
(backlog_size, backlog_level))
(fun (backlog_size, backlog_level) -> {backlog_size; backlog_level})
(obj2
(dft "worker_backlog_size" uint16 default_size)
(dft "worker_backlog_level" Internal_event.Level.encoding default_level))
let timeout_encoding = Time.System.Span.encoding
let block_validator_limits_encoding =
let open Data_encoding in
conv
(fun {Node.protocol_timeout; worker_limits} ->
(protocol_timeout, worker_limits))
(fun (protocol_timeout, worker_limits) ->
{protocol_timeout; worker_limits})
(merge_objs
(obj1
(dft
"protocol_request_timeout"
timeout_encoding
default_shell.block_validator_limits.protocol_timeout))
(worker_limits_encoding
default_shell.block_validator_limits.worker_limits.backlog_size
default_shell.block_validator_limits.worker_limits.backlog_level))
let prevalidator_limits_encoding =
let open Data_encoding in
conv
(fun { Node.operation_timeout;
max_refused_operations;
operations_batch_size;
worker_limits } ->
( (operation_timeout, max_refused_operations, operations_batch_size),
worker_limits ))
(fun ( (operation_timeout, max_refused_operations, operations_batch_size),
worker_limits ) ->
{
operation_timeout;
max_refused_operations;
operations_batch_size;
worker_limits;
})
(merge_objs
(obj3
(dft
"operations_request_timeout"
timeout_encoding
default_shell.prevalidator_limits.operation_timeout)
(dft
"max_refused_operations"
uint16
default_shell.prevalidator_limits.max_refused_operations)
(dft
"operations_batch_size"
int31
default_shell.prevalidator_limits.operations_batch_size))
(worker_limits_encoding
default_shell.prevalidator_limits.worker_limits.backlog_size
default_shell.prevalidator_limits.worker_limits.backlog_level))
let peer_validator_limits_encoding =
let open Data_encoding in
let default_limits = default_shell.peer_validator_limits in
conv
(fun { Node.block_header_timeout;
block_operations_timeout;
protocol_timeout;
new_head_request_timeout;
worker_limits } ->
( ( block_header_timeout,
block_operations_timeout,
protocol_timeout,
new_head_request_timeout ),
worker_limits ))
(fun ( ( block_header_timeout,
block_operations_timeout,
protocol_timeout,
new_head_request_timeout ),
worker_limits ) ->
{
block_header_timeout;
block_operations_timeout;
protocol_timeout;
new_head_request_timeout;
worker_limits;
})
(merge_objs
(obj4
(dft
"block_header_request_timeout"
timeout_encoding
default_limits.block_header_timeout)
(dft
"block_operations_request_timeout"
timeout_encoding
default_limits.block_operations_timeout)
(dft
"protocol_request_timeout"
timeout_encoding
default_limits.protocol_timeout)
(dft
"new_head_request_timeout"
timeout_encoding
default_limits.new_head_request_timeout))
(worker_limits_encoding
default_limits.worker_limits.backlog_size
default_limits.worker_limits.backlog_level))
let chain_validator_limits_encoding =
let open Data_encoding in
conv
(fun {Node.bootstrap_threshold; worker_limits} ->
(bootstrap_threshold, worker_limits))
(fun (bootstrap_threshold, worker_limits) ->
{bootstrap_threshold; worker_limits})
(merge_objs
(obj1
(dft
"bootstrap_threshold"
~description:
"Set the number of peers with whom a chain synchronization \
must be completed to bootstrap the node."
uint8
default_shell.chain_validator_limits.bootstrap_threshold))
(worker_limits_encoding
default_shell.chain_validator_limits.worker_limits.backlog_size
default_shell.chain_validator_limits.worker_limits.backlog_level))
let shell =
let open Data_encoding in
conv
(fun { peer_validator_limits;
block_validator_limits;
prevalidator_limits;
chain_validator_limits;
history_mode } ->
( peer_validator_limits,
block_validator_limits,
prevalidator_limits,
chain_validator_limits,
history_mode ))
(fun ( peer_validator_limits,
block_validator_limits,
prevalidator_limits,
chain_validator_limits,
history_mode ) ->
{
peer_validator_limits;
block_validator_limits;
prevalidator_limits;
chain_validator_limits;
history_mode;
})
(obj5
(dft
"peer_validator"
peer_validator_limits_encoding
default_shell.peer_validator_limits)
(dft
"block_validator"
block_validator_limits_encoding
default_shell.block_validator_limits)
(dft
"prevalidator"
prevalidator_limits_encoding
default_shell.prevalidator_limits)
(dft
"chain_validator"
chain_validator_limits_encoding
default_shell.chain_validator_limits)
(opt "history_mode" History_mode.encoding))
let encoding =
let open Data_encoding in
conv
(fun {data_dir; rpc; p2p; log; internal_events; shell} ->
(data_dir, rpc, p2p, log, internal_events, shell))
(fun (data_dir, rpc, p2p, log, internal_events, shell) ->
{data_dir; rpc; p2p; log; internal_events; shell})
(obj6
(dft
"data-dir"
~description:"Location of the data dir on disk."
string
default_data_dir)
(dft
"rpc"
~description:"Configuration of rpc parameters"
rpc
default_rpc)
(req "p2p" ~description:"Configuration of network parameters" p2p)
(dft
"log"
~description:
"Configuration of the Lwt-log sink (part of the logging framework)"
Lwt_log_sink_unix.cfg_encoding
Lwt_log_sink_unix.default_cfg)
(dft
"internal-events"
~description:"Configuration of the structured logging framework"
Internal_event_unix.Configuration.encoding
Internal_event_unix.Configuration.default)
(dft
"shell"
~description:"Configuration of network parameters"
shell
default_shell))
let read fp =
if Sys.file_exists fp then
Lwt_utils_unix.Json.read_file fp
>>=? fun json ->
try return (Data_encoding.Json.destruct encoding json)
with exn -> fail (Exn exn)
else return default_config
let write fp cfg =
Node_data_version.ensure_data_dir (Filename.dirname fp)
>>=? fun () ->
Lwt_utils_unix.Json.write_file fp (Data_encoding.Json.construct encoding cfg)
let to_string cfg =
Data_encoding.Json.to_string (Data_encoding.Json.construct encoding cfg)
let update ?data_dir ?min_connections ?expected_connections ?max_connections
?max_download_speed ?max_upload_speed ?binary_chunks_size ?peer_table_size
?expected_pow ?bootstrap_peers ?listen_addr ?discovery_addr
?(rpc_listen_addrs = []) ?(private_mode = false) ?(disable_mempool = false)
?(disable_testchain = false) ?(cors_origins = []) ?(cors_headers = [])
?rpc_tls ?log_output ?bootstrap_threshold ?history_mode cfg =
let data_dir = Option.unopt ~default:cfg.data_dir data_dir in
Node_data_version.ensure_data_dir data_dir
>>=? fun () ->
let peer_table_size =
Option.map peer_table_size ~f:(fun i -> (i, i / 4 * 3))
in
let unopt_list ~default = function [] -> default | l -> l in
let limits : P2p.limits =
{
cfg.p2p.limits with
min_connections =
Option.unopt ~default:cfg.p2p.limits.min_connections min_connections;
expected_connections =
Option.unopt
~default:cfg.p2p.limits.expected_connections
expected_connections;
max_connections =
Option.unopt ~default:cfg.p2p.limits.max_connections max_connections;
max_download_speed =
Option.first_some max_download_speed cfg.p2p.limits.max_download_speed;
max_upload_speed =
Option.first_some max_upload_speed cfg.p2p.limits.max_upload_speed;
max_known_points =
Option.first_some peer_table_size cfg.p2p.limits.max_known_points;
max_known_peer_ids =
Option.first_some peer_table_size cfg.p2p.limits.max_known_peer_ids;
binary_chunks_size = Option.map ~f:(fun x -> x lsl 10) binary_chunks_size;
}
in
let p2p : p2p =
{
expected_pow = Option.unopt ~default:cfg.p2p.expected_pow expected_pow;
bootstrap_peers =
Option.unopt ~default:cfg.p2p.bootstrap_peers bootstrap_peers;
listen_addr = Option.first_some listen_addr cfg.p2p.listen_addr;
discovery_addr = Option.first_some discovery_addr cfg.p2p.discovery_addr;
private_mode = cfg.p2p.private_mode || private_mode;
limits;
disable_mempool = cfg.p2p.disable_mempool || disable_mempool;
disable_testchain = cfg.p2p.disable_testchain || disable_testchain;
greylisting_config = cfg.p2p.greylisting_config;
}
and rpc : rpc =
{
listen_addrs = unopt_list ~default:cfg.rpc.listen_addrs rpc_listen_addrs;
cors_origins = unopt_list ~default:cfg.rpc.cors_origins cors_origins;
cors_headers = unopt_list ~default:cfg.rpc.cors_headers cors_headers;
tls = Option.first_some rpc_tls cfg.rpc.tls;
}
and log : Lwt_log_sink_unix.cfg =
{cfg.log with output = Option.unopt ~default:cfg.log.output log_output}
and shell : shell =
{
peer_validator_limits = cfg.shell.peer_validator_limits;
block_validator_limits = cfg.shell.block_validator_limits;
prevalidator_limits = cfg.shell.prevalidator_limits;
chain_validator_limits =
Option.unopt_map
~default:cfg.shell.chain_validator_limits
~f:(fun bootstrap_threshold ->
{cfg.shell.chain_validator_limits with bootstrap_threshold})
bootstrap_threshold;
history_mode = Option.first_some history_mode cfg.shell.history_mode;
}
in
let internal_events = cfg.internal_events in
return {data_dir; p2p; rpc; log; internal_events; shell}
let resolve_addr ~default_addr ?default_port ?(passive = false) peer =
let (addr, port) = P2p_point.Id.parse_addr_port peer in
let node = if addr = "" || addr = "_" then default_addr else addr
and service =
match (port, default_port) with
| ("", None) ->
invalid_arg ""
| ("", Some default_port) ->
string_of_int default_port
| (port, _) ->
port
in
Lwt_utils_unix.getaddrinfo ~passive ~node ~service
let resolve_addrs ~default_addr ?default_port ?passive peers =
Lwt_list.fold_left_s
(fun a peer ->
resolve_addr ~default_addr ?default_port ?passive peer
>>= fun points -> Lwt.return (List.rev_append points a))
[]
peers
let resolve_discovery_addrs discovery_addr =
resolve_addr
~default_addr:Ipaddr.V4.(to_string broadcast)
~default_port:default_discovery_port
~passive:true
discovery_addr
>>= fun addrs ->
let rec to_ipv4 acc = function
| [] ->
Lwt.return (List.rev acc)
| (ip, port) :: xs -> (
match Ipaddr.v4_of_v6 ip with
| Some v ->
to_ipv4 ((v, port) :: acc) xs
| None ->
Format.eprintf
"Warning: failed to convert %S to an ipv4 address@."
(Ipaddr.V6.to_string ip) ;
to_ipv4 acc xs )
in
to_ipv4 [] addrs
let resolve_listening_addrs listen_addr =
resolve_addr
~default_addr:"::"
~default_port:default_p2p_port
~passive:true
listen_addr
let resolve_rpc_listening_addrs listen_addr =
resolve_addr
~default_addr:"::"
~default_port:default_rpc_port
~passive:true
listen_addr
let resolve_bootstrap_addrs peers =
resolve_addrs ~default_addr:"::" ~default_port:default_p2p_port peers
let check_listening_addrs config =
match config.p2p.listen_addr with
| None ->
Lwt.return_unit
| Some addr ->
Lwt.catch
(fun () ->
resolve_listening_addrs addr
>>= function
| [] ->
Format.eprintf "Warning: failed to resolve %S\n@." addr ;
Lwt.return_unit
| _ :: _ ->
Lwt.return_unit)
(function
| Invalid_argument msg ->
Format.eprintf "Warning: failed to parse %S: %s\n@." addr msg ;
Lwt.return_unit
| exn ->
Lwt.fail exn)
let check_discovery_addr config =
match config.p2p.discovery_addr with
| None ->
Lwt.return_unit
| Some addr ->
Lwt.catch
(fun () ->
resolve_discovery_addrs addr
>>= function
| [] ->
Format.eprintf "Warning: failed to resolve %S\n@." addr ;
Lwt.return_unit
| _ :: _ ->
Lwt.return_unit)
(function
| Invalid_argument msg ->
Format.eprintf "Warning: failed to parse %S: %s\n@." addr msg ;
Lwt.return_unit
| exn ->
Lwt.fail exn)
let check_rpc_listening_addr config =
Lwt_list.iter_p
(fun addr ->
Lwt.catch
(fun () ->
resolve_rpc_listening_addrs addr
>>= function
| [] ->
Format.eprintf "Warning: failed to resolve %S\n@." addr ;
Lwt.return_unit
| _ :: _ ->
Lwt.return_unit)
(function
| Invalid_argument msg ->
Format.eprintf "Warning: failed to parse %S: %s\n@." addr msg ;
Lwt.return_unit
| exn ->
Lwt.fail exn))
config.rpc.listen_addrs
let check_bootstrap_peer addr =
Lwt.catch
(fun () ->
resolve_bootstrap_addrs [addr]
>>= function
| [] ->
Format.eprintf "Warning: cannot resolve %S\n@." addr ;
Lwt.return_unit
| _ :: _ ->
Lwt.return_unit)
(function
| Invalid_argument msg ->
Format.eprintf "Warning: failed to parse %S: %s\n@." addr msg ;
Lwt.return_unit
| exn ->
Lwt.fail exn)
let check_bootstrap_peers config =
Lwt_list.iter_p check_bootstrap_peer config.p2p.bootstrap_peers
let fail fmt = Format.kasprintf (fun s -> prerr_endline s ; exit 1) fmt
let check_connections config =
if config.p2p.limits.min_connections > config.p2p.limits.expected_connections
then
fail
"Error: The minumum number of connections is greater than the expected \
number of connections"
config.p2p.limits.min_connections
config.p2p.limits.expected_connections ;
if config.p2p.limits.expected_connections > config.p2p.limits.max_connections
then
fail
"Error: The expected number of connections is greater than the maximum \
number of connections"
config.p2p.limits.expected_connections
config.p2p.limits.max_connections ;
( match config.p2p.limits.max_known_peer_ids with
| None ->
()
| Some (max_known_peer_ids, target_known_peer_ids) ->
if target_known_peer_ids > max_known_peer_ids then
fail
"Error: The target number of known peer ids is greater than the \
maximum number of known peer ids."
target_known_peer_ids
max_known_peer_ids ;
if config.p2p.limits.max_connections > target_known_peer_ids then
fail
"Error: The target number of known peer ids is lower than the \
maximum number of connections."
target_known_peer_ids
max_known_peer_ids ) ;
match config.p2p.limits.max_known_points with
| None ->
()
| Some (max_known_points, target_known_points) ->
if target_known_points > max_known_points then
fail
"Error: The target number of known points is greater than the \
maximum number of known points."
target_known_points
max_known_points ;
if config.p2p.limits.max_connections > target_known_points then
fail
"Error: The target number of known points is lower than the maximum \
number of connections."
target_known_points
max_known_points
let check config =
check_listening_addrs config
>>= fun () ->
check_rpc_listening_addr config
>>= fun () ->
check_discovery_addr config
>>= fun () ->
check_bootstrap_peers config
>>= fun () -> check_connections config ; Lwt.return_unit
src/bin_node/node_config_file.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition home : string :=
(* ❌ Try-with are not handled *)
try (Sys.getenv "HOME" % string).
Definition default_data_dir : string := op_divdiv home ".tezos-node" % string.
Definition default_rpc_port : Z := 8732.
Definition default_p2p_port : Z := 9732.
Definition default_discovery_port : Z := 10732.
.
Definition default_p2p_limits : Tezos_p2p.P2p.limits :=
{|
connection_timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 10. is approximated by the integer 10 *)
10;
authentication_timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 5. is approximated by the integer 5 *)
5;
greylist_timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 86400. is approximated by the integer 86400 *)
86400;
maintenance_idle_time :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 120. is approximated by the integer 120 *)
120; min_connections := 10; expected_connections := 50;
max_connections := 100; backlog := 20; max_incoming_connections := 20;
max_download_speed := None; max_upload_speed := None;
read_buffer_size := Z.shiftl 1 14; read_queue_size := None;
write_queue_size := None; incoming_app_message_queue_size := None;
incoming_message_queue_size := None; outgoing_message_queue_size := None;
known_peer_ids_history_size := 500; known_points_history_size := 500;
max_known_peer_ids := Some (400, 300); max_known_points := Some (400, 300);
swap_linger :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 30. is approximated by the integer 30 *)
30; binary_chunks_size := None |}.
Definition default_p2p : p2p :=
{|
expected_pow :=
(* ❌ Float constant 26. is approximated by the integer 26 *)
26; bootstrap_peers := [];
listen_addr :=
Some
(String.append "[::]:" % string
(OCaml.Stdlib.string_of_int default_p2p_port));
discovery_addr := None; private_mode := false; limits := default_p2p_limits;
disable_mempool := false; disable_testchain := false;
greylisting_config := P2p_point_state.Info.default_greylisting_config |}.
Definition default_rpc : rpc :=
{| listen_addrs := []; cors_origins := []; cors_headers := []; tls := None |}.
Definition default_shell : shell :=
{| block_validator_limits := Node.default_block_validator_limits;
prevalidator_limits := Node.default_prevalidator_limits;
peer_validator_limits := Node.default_peer_validator_limits;
chain_validator_limits := Node.default_chain_validator_limits;
history_mode := None |}.
Definition default_config : t :=
{| data_dir := default_data_dir; p2p := default_p2p; rpc := default_rpc;
log := Lwt_log_sink_unix.default_cfg;
internal_events := Internal_event_unix.Configuration.default;
shell := default_shell |}.
Definition limit
: Tezos_base__TzPervasives.Data_encoding.t Tezos_p2p.P2p.limits :=
conv
(fun function_parameter =>
let '{|
P2p.connection_timeout := connection_timeout;
P2p.authentication_timeout := authentication_timeout;
P2p.greylist_timeout := greylist_timeout;
P2p.maintenance_idle_time := maintenance_idle_time;
P2p.min_connections := min_connections;
P2p.expected_connections := expected_connections;
P2p.max_connections := max_connections;
P2p.backlog := backlog;
P2p.max_incoming_connections := max_incoming_connections;
P2p.max_download_speed := max_download_speed;
P2p.max_upload_speed := max_upload_speed;
P2p.read_buffer_size := read_buffer_size;
P2p.read_queue_size := read_queue_size;
P2p.write_queue_size := write_queue_size;
P2p.incoming_app_message_queue_size := incoming_app_message_queue_size;
P2p.incoming_message_queue_size := incoming_message_queue_size;
P2p.outgoing_message_queue_size := outgoing_message_queue_size;
P2p.known_peer_ids_history_size := known_peer_ids_history_size;
P2p.known_points_history_size := known_points_history_size;
P2p.max_known_peer_ids := max_known_peer_ids;
P2p.max_known_points := max_known_points;
P2p.swap_linger := swap_linger;
P2p.binary_chunks_size := binary_chunks_size
|} := function_parameter in
(((connection_timeout, authentication_timeout, min_connections,
expected_connections, max_connections, backlog,
max_incoming_connections, max_download_speed, max_upload_speed,
swap_linger),
(binary_chunks_size, read_buffer_size, read_queue_size,
write_queue_size, incoming_app_message_queue_size,
incoming_message_queue_size, outgoing_message_queue_size,
known_points_history_size, known_peer_ids_history_size,
max_known_points)),
(max_known_peer_ids, greylist_timeout, maintenance_idle_time)))
(fun function_parameter =>
let
'(((connection_timeout, authentication_timeout, min_connections,
expected_connections, max_connections, backlog,
max_incoming_connections, max_download_speed, max_upload_speed,
swap_linger),
(binary_chunks_size, read_buffer_size, read_queue_size,
write_queue_size, incoming_app_message_queue_size,
incoming_message_queue_size, outgoing_message_queue_size,
known_points_history_size, known_peer_ids_history_size,
max_known_points)),
(max_known_peer_ids, greylist_timeout, maintenance_idle_time)) :=
function_parameter in
{| connection_timeout := connection_timeout;
authentication_timeout := authentication_timeout;
greylist_timeout := greylist_timeout;
maintenance_idle_time := maintenance_idle_time;
min_connections := min_connections;
expected_connections := expected_connections;
max_connections := max_connections; backlog := backlog;
max_incoming_connections := max_incoming_connections;
max_download_speed := max_download_speed;
max_upload_speed := max_upload_speed;
read_buffer_size := read_buffer_size;
read_queue_size := read_queue_size;
write_queue_size := write_queue_size;
incoming_app_message_queue_size := incoming_app_message_queue_size;
incoming_message_queue_size := incoming_message_queue_size;
outgoing_message_queue_size := outgoing_message_queue_size;
known_peer_ids_history_size := known_peer_ids_history_size;
known_points_history_size := known_points_history_size;
max_known_peer_ids := max_known_peer_ids;
max_known_points := max_known_points; swap_linger := swap_linger;
binary_chunks_size := binary_chunks_size |}) None
(merge_objs
(merge_objs
(obj10
(dft None
(Some
"Delay acceptable when initiating a connection to a new peer, in seconds."
% string) "connection-timeout" % string
Time.System.Span.encoding
(authentication_timeout default_p2p_limits))
(dft None
(Some
"Delay granted to a peer to perform authentication, in seconds." %
string) "authentication-timeout" % string
Time.System.Span.encoding
(authentication_timeout default_p2p_limits))
(dft None
(Some
"Strict minimum number of connections (triggers an urgent maintenance)."
% string) "min-connections" % string uint16
(min_connections default_p2p_limits))
(dft None
(Some
"Targeted number of connections to reach when bootstrapping / maintaining."
% string) "expected-connections" % string uint16
(expected_connections default_p2p_limits))
(dft None
(Some
"Maximum number of connections (exceeding peers are disconnected)."
% string) "max-connections" % string uint16
(max_connections default_p2p_limits))
(dft None
(Some
"Number above which pending incoming connections are immediately rejected."
% string) "backlog" % string uint8 (backlog default_p2p_limits))
(dft None
(Some
"Number above which pending incoming connections are immediately rejected."
% string) "max-incoming-connections" % string uint8
(max_incoming_connections default_p2p_limits))
(opt None (Some "Max download speeds in KiB/s." % string)
"max-download-speed" % string int31)
(opt None (Some "Max upload speeds in KiB/s." % string)
"max-upload-speed" % string int31)
(dft None None "swap-linger" % string Time.System.Span.encoding
(swap_linger default_p2p_limits)))
(obj10 (opt None None "binary-chunks-size" % string uint8)
(dft None (Some "Size of the buffer passed to read(2)." % string)
"read-buffer-size" % string int31
(read_buffer_size default_p2p_limits))
(opt None None "read-queue-size" % string int31)
(opt None None "write-queue-size" % string int31)
(opt None None "incoming-app-message-queue-size" % string int31)
(opt None None "incoming-message-queue-size" % string int31)
(opt None None "outgoing-message-queue-size" % string int31)
(dft None None "known_points_history_size" % string uint16
(known_points_history_size default_p2p_limits))
(dft None None "known_peer_ids_history_size" % string uint16
(known_points_history_size default_p2p_limits))
(opt None None "max_known_points" % string (tup2 uint16 uint16))))
(obj3 (opt None None "max_known_peer_ids" % string (tup2 uint16 uint16))
(dft None
(Some "GC delay for the greylists tables, in seconds." % string)
"greylist-timeout" % string Time.System.Span.encoding
(greylist_timeout default_p2p_limits))
(dft None
(Some
"How long to wait at most, in seconds, before running a maintenance loop."
% string) "maintenance-idle-time" % string
Time.System.Span.encoding (maintenance_idle_time default_p2p_limits)))).
Definition p2p : Tezos_base__TzPervasives.Data_encoding.encoding p2p :=
conv
(fun function_parameter =>
let '{|
expected_pow := expected_pow;
bootstrap_peers := bootstrap_peers;
listen_addr := listen_addr;
discovery_addr := discovery_addr;
private_mode := private_mode;
limits := limits;
disable_mempool := disable_mempool;
disable_testchain := disable_testchain;
greylisting_config := greylisting_config
|} := function_parameter in
(expected_pow, bootstrap_peers, listen_addr, discovery_addr, private_mode,
limits, disable_mempool, disable_testchain, greylisting_config))
(fun function_parameter =>
let
'(expected_pow, bootstrap_peers, listen_addr, discovery_addr,
private_mode, limits, disable_mempool, disable_testchain,
greylisting_config) := function_parameter in
{| expected_pow := expected_pow; bootstrap_peers := bootstrap_peers;
listen_addr := listen_addr; discovery_addr := discovery_addr;
private_mode := private_mode; limits := limits;
disable_mempool := disable_mempool;
disable_testchain := disable_testchain;
greylisting_config := greylisting_config |}) None
(obj9
(dft None
(Some
"Floating point number between 0 and 256 that represents a difficulty, 24 signifies for example that at least 24 leading zeroes are expected in the hash."
% string) "expected-proof-of-work" % string float
(expected_pow default_p2p))
(dft None
(Some
"List of hosts. Tezos can connect to both IPv6 and IPv4 hosts. If the port is not specified, default port 9732 will be assumed."
% string) "bootstrap-peers" % string (list None string)
(bootstrap_peers default_p2p))
(opt None
(Some
"Host to listen to. If the port is not specified, the default port 8732 will be assumed."
% string) "listen-addr" % string string)
(dft None
(Some
"Host for local peer discovery. If the port is not specified, the default port 10732 will be assumed."
% string) "discovery-addr" % string (option string)
(discovery_addr default_p2p))
(dft None
(Some
"Specify if the node is in private mode or not. A node in private mode rejects incoming connections from untrusted peers and only opens outgoing connections to peers listed in 'bootstrap-peers' or provided with '--peer' option. Moreover, these peers will keep the identity and the address of the private node secret."
% string) "private-mode" % string bool false)
(dft None (Some "Network limits" % string) "limits" % string limit
default_p2p_limits)
(dft None
(Some
"If set to [true], the node will not participate in the propagation of pending operations (mempool). Default value is [false]. It can be used to decrease the memory and computation footprints of the node."
% string) "disable_mempool" % string bool false)
(dft None
(Some
"If set to [true], the node will not spawn a testchain during the protocol's testing voting period. Default value is [false]. It may be used used to decrease the node storage usage and computation by droping the validation of the test network blocks."
% string) "disable_testchain" % string bool false)
(dft None (Some "The greylisting policy." % string)
"greylisting_config" % string greylisting_config_encoding
default_greylisting_config)).
Definition rpc : Tezos_base__TzPervasives.Data_encoding.t rpc :=
conv
(fun function_parameter =>
let '{|
listen_addrs := listen_addrs;
cors_origins := cors_origins;
cors_headers := cors_headers;
tls := tls
|} := function_parameter in
let '(cert, key) :=
match tls with
| None => (None, None)
| Some {| cert := cert; key := key |} => ((Some cert), (Some key))
end in
((Some listen_addrs), None, cors_origins, cors_headers, cert, key))
(fun function_parameter =>
let
'(listen_addrs, legacy_listen_addr, cors_origins, cors_headers, cert,
key) := function_parameter in
let tls :=
match (cert, key) with
| (None, _) | (_, None) => None
| (Some cert, Some key) => Some {| cert := cert; key := key |}
end in
let listen_addrs :=
match (listen_addrs, legacy_listen_addr) with
| (Some addrs, None) => addrs
| (None, Some addr) => cons addr []
| (None, None) => listen_addrs default_rpc
| (Some _, Some _) =>
Pervasives.failwith
"Config file: Use only ""listen-addrs"" and not (legacy) ""listen-addr""."
% string
end in
{| listen_addrs := listen_addrs; cors_origins := cors_origins;
cors_headers := cors_headers; tls := tls |}) None
(obj6
(opt None
(Some
"Hosts to listen to. If the port is not specified, the default port 8732 will be assumed."
% string) "listen-addrs" % string (list None string))
(opt None (Some "Legacy value: Host to listen to" % string)
"listen-addr" % string string)
(dft None
(Some
"Cross Origin Resource Sharing parameters, see https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
% string) "cors-origin" % string (list None string)
(cors_origins default_rpc))
(dft None
(Some
"Cross Origin Resource Sharing parameters, see https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
% string) "cors-headers" % string (list None string)
(cors_headers default_rpc))
(opt None (Some "Certificate file (necessary when TLS is used)." % string)
"crt" % string string)
(opt None (Some "Key file (necessary when TLS is used)." % string)
"key" % string string)).
Definition worker_limits_encoding
(default_size : Z)
(default_level : Tezos_base__TzPervasives.Internal_event.Level.t)
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_shell_services.Worker_types.limits :=
conv
(fun function_parameter =>
let '{|
Worker_types.backlog_size := backlog_size;
Worker_types.backlog_level := backlog_level
|} := function_parameter in
(backlog_size, backlog_level))
(fun function_parameter =>
let '(backlog_size, backlog_level) := function_parameter in
{| backlog_size := backlog_size; backlog_level := backlog_level |}) None
(obj2 (dft None None "worker_backlog_size" % string uint16 default_size)
(dft None None "worker_backlog_level" % string
Internal_event.Level.encoding default_level)).
Definition timeout_encoding
: Tezos_data_encoding.Data_encoding.t
Tezos_base__TzPervasives.Time.System.Span.t := Time.System.Span.encoding.
Definition block_validator_limits_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_shell.Node.block_validator_limits :=
conv
(fun function_parameter =>
let '{|
Node.protocol_timeout := protocol_timeout;
Node.worker_limits := worker_limits
|} := function_parameter in
(protocol_timeout, worker_limits))
(fun function_parameter =>
let '(protocol_timeout, worker_limits) := function_parameter in
{| protocol_timeout := protocol_timeout; worker_limits := worker_limits |})
None
(merge_objs
(obj1
(dft None None "protocol_request_timeout" % string timeout_encoding
(protocol_timeout (block_validator_limits default_shell))))
(worker_limits_encoding
(backlog_size (worker_limits (block_validator_limits default_shell)))
(backlog_level (worker_limits (block_validator_limits default_shell))))).
Definition prevalidator_limits_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_shell.Node.prevalidator_limits :=
conv
(fun function_parameter =>
let '{|
Node.max_refused_operations := max_refused_operations;
Node.operation_timeout := operation_timeout;
Node.worker_limits := worker_limits;
Node.operations_batch_size := operations_batch_size
|} := function_parameter in
((operation_timeout, max_refused_operations, operations_batch_size),
worker_limits))
(fun function_parameter =>
let
'((operation_timeout, max_refused_operations, operations_batch_size),
worker_limits) := function_parameter in
{| max_refused_operations := max_refused_operations;
operation_timeout := operation_timeout; worker_limits := worker_limits;
operations_batch_size := operations_batch_size |}) None
(merge_objs
(obj3
(dft None None "operations_request_timeout" % string timeout_encoding
(operation_timeout (prevalidator_limits default_shell)))
(dft None None "max_refused_operations" % string uint16
(max_refused_operations (prevalidator_limits default_shell)))
(dft None None "operations_batch_size" % string int31
(operations_batch_size (prevalidator_limits default_shell))))
(worker_limits_encoding
(backlog_size (worker_limits (prevalidator_limits default_shell)))
(backlog_level (worker_limits (prevalidator_limits default_shell))))).
Definition peer_validator_limits_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_shell.Node.peer_validator_limits :=
let default_limits := peer_validator_limits default_shell in
conv
(fun function_parameter =>
let '{|
Node.new_head_request_timeout := new_head_request_timeout;
Node.block_header_timeout := block_header_timeout;
Node.block_operations_timeout := block_operations_timeout;
Node.protocol_timeout := protocol_timeout;
Node.worker_limits := worker_limits
|} := function_parameter in
((block_header_timeout, block_operations_timeout, protocol_timeout,
new_head_request_timeout), worker_limits))
(fun function_parameter =>
let
'((block_header_timeout, block_operations_timeout, protocol_timeout,
new_head_request_timeout), worker_limits) := function_parameter in
{| new_head_request_timeout := new_head_request_timeout;
block_header_timeout := block_header_timeout;
block_operations_timeout := block_operations_timeout;
protocol_timeout := protocol_timeout; worker_limits := worker_limits |})
None
(merge_objs
(obj4
(dft None None "block_header_request_timeout" % string timeout_encoding
(block_header_timeout default_limits))
(dft None None "block_operations_request_timeout" % string
timeout_encoding (block_operations_timeout default_limits))
(dft None None "protocol_request_timeout" % string timeout_encoding
(protocol_timeout default_limits))
(dft None None "new_head_request_timeout" % string timeout_encoding
(new_head_request_timeout default_limits)))
(worker_limits_encoding (backlog_size (worker_limits default_limits))
(backlog_level (worker_limits default_limits)))).
Definition chain_validator_limits_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_shell.Node.chain_validator_limits :=
conv
(fun function_parameter =>
let '{|
Node.bootstrap_threshold := bootstrap_threshold;
Node.worker_limits := worker_limits
|} := function_parameter in
(bootstrap_threshold, worker_limits))
(fun function_parameter =>
let '(bootstrap_threshold, worker_limits) := function_parameter in
{| bootstrap_threshold := bootstrap_threshold;
worker_limits := worker_limits |}) None
(merge_objs
(obj1
(dft None
(Some
"Set the number of peers with whom a chain synchronization must be completed to bootstrap the node."
% string) "bootstrap_threshold" % string uint8
(bootstrap_threshold (chain_validator_limits default_shell))))
(worker_limits_encoding
(backlog_size (worker_limits (chain_validator_limits default_shell)))
(backlog_level (worker_limits (chain_validator_limits default_shell))))).
Definition shell : Tezos_base__TzPervasives.Data_encoding.encoding shell :=
conv
(fun function_parameter =>
let '{|
block_validator_limits := block_validator_limits;
prevalidator_limits := prevalidator_limits;
peer_validator_limits := peer_validator_limits;
chain_validator_limits := chain_validator_limits;
history_mode := history_mode
|} := function_parameter in
(peer_validator_limits, block_validator_limits, prevalidator_limits,
chain_validator_limits, history_mode))
(fun function_parameter =>
let
'(peer_validator_limits, block_validator_limits, prevalidator_limits,
chain_validator_limits, history_mode) := function_parameter in
{| block_validator_limits := block_validator_limits;
prevalidator_limits := prevalidator_limits;
peer_validator_limits := peer_validator_limits;
chain_validator_limits := chain_validator_limits;
history_mode := history_mode |}) None
(obj5
(dft None None "peer_validator" % string peer_validator_limits_encoding
(peer_validator_limits default_shell))
(dft None None "block_validator" % string block_validator_limits_encoding
(block_validator_limits default_shell))
(dft None None "prevalidator" % string prevalidator_limits_encoding
(prevalidator_limits default_shell))
(dft None None "chain_validator" % string chain_validator_limits_encoding
(chain_validator_limits default_shell))
(opt None None "history_mode" % string History_mode.encoding)).
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
conv
(fun function_parameter =>
let '{|
data_dir := data_dir;
p2p := p2p;
rpc := rpc;
log := log;
internal_events := internal_events;
shell := shell
|} := function_parameter in
(data_dir, rpc, p2p, log, internal_events, shell))
(fun function_parameter =>
let '(data_dir, rpc, p2p, log, internal_events, shell) :=
function_parameter in
{| data_dir := data_dir; p2p := p2p; rpc := rpc; log := log;
internal_events := internal_events; shell := shell |}) None
(obj6
(dft None (Some "Location of the data dir on disk." % string)
"data-dir" % string string default_data_dir)
(dft None (Some "Configuration of rpc parameters" % string) "rpc" % string
rpc default_rpc)
(req None (Some "Configuration of network parameters" % string)
"p2p" % string p2p)
(dft None
(Some
"Configuration of the Lwt-log sink (part of the logging framework)" %
string) "log" % string Lwt_log_sink_unix.cfg_encoding
Lwt_log_sink_unix.default_cfg)
(dft None
(Some "Configuration of the structured logging framework" % string)
"internal-events" % string Internal_event_unix.Configuration.encoding
Internal_event_unix.Configuration.default)
(dft None (Some "Configuration of network parameters" % string)
"shell" % string shell default_shell)).
Definition read (fp : string) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
if Sys.file_exists fp then
op_gtgteqquestion (Lwt_utils_unix.Json.read_file fp)
(fun json =>
(* ❌ Try-with are not handled *)
try (_return (Data_encoding.Json.destruct encoding json)))
else
_return default_config.
Definition write (fp : string) (cfg : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
(Node_data_version.ensure_data_dir None (Filename.dirname fp))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.Json.write_file fp
(Data_encoding.Json.construct encoding cfg)).
Definition to_string (cfg : t) : string :=
Data_encoding.Json.to_string None None
(Data_encoding.Json.construct encoding cfg).
Definition update
(data_dir : option string) (min_connections : option Z)
(expected_connections : option Z) (max_connections : option Z)
(max_download_speed : option Z) (max_upload_speed : option Z)
(binary_chunks_size : option Z) (peer_table_size : option Z)
(expected_pow : option Z) (bootstrap_peers : option (list string))
(listen_addr : option string) (discovery_addr : option string)
(op_staroptstar : option (list string))
: (option bool) ->
(option bool) ->
(option bool) ->
(option (list string)) ->
(option (list string)) ->
(option tls) ->
(option Tezos_stdlib_unix.Lwt_log_sink_unix.Output.t) ->
(option Z) ->
(option Tezos_shell_services.History_mode.t) ->
t -> Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
let rpc_listen_addrs :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun op_staroptstar =>
let private_mode :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun op_staroptstar =>
let disable_mempool :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun op_staroptstar =>
let disable_testchain :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun op_staroptstar =>
let cors_origins :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun op_staroptstar =>
let cors_headers :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun rpc_tls =>
fun log_output =>
fun bootstrap_threshold =>
fun history_mode =>
fun cfg =>
let data_dir := Option.unopt (data_dir cfg) data_dir in
op_gtgteqquestion
(Node_data_version.ensure_data_dir None data_dir)
(fun function_parameter =>
let 'tt := function_parameter in
let peer_table_size :=
Option.map (fun i => (i, (Z.mul (Z.div i 4) 3)))
peer_table_size in
let unopt_list {A : Type}
(default : list A) (function_parameter : list A)
: list A :=
match function_parameter with
| [] => default
| l => l
end in
let limits :=
(* ❌ Record substitution not handled *)
record_substitution in
let p2p : p2p :=
{|
expected_pow :=
Option.unopt (expected_pow (p2p cfg))
expected_pow;
bootstrap_peers :=
Option.unopt (bootstrap_peers (p2p cfg))
bootstrap_peers;
listen_addr :=
Option.first_some listen_addr
(listen_addr (p2p cfg));
discovery_addr :=
Option.first_some discovery_addr
(discovery_addr (p2p cfg));
private_mode :=
orb (private_mode (p2p cfg)) private_mode;
limits := limits;
disable_mempool :=
orb (disable_mempool (p2p cfg)) disable_mempool;
disable_testchain :=
orb (disable_testchain (p2p cfg))
disable_testchain;
greylisting_config := greylisting_config (p2p cfg)
|}
with rpc : rpc :=
{|
listen_addrs :=
unopt_list (listen_addrs (rpc cfg))
rpc_listen_addrs;
cors_origins :=
unopt_list (cors_origins (rpc cfg)) cors_origins;
cors_headers :=
unopt_list (cors_headers (rpc cfg)) cors_headers;
tls := Option.first_some rpc_tls (tls (rpc cfg))
|}
with log : Tezos_stdlib_unix.Lwt_log_sink_unix.cfg :=
(* ❌ Record substitution not handled *)
record_substitution
with shell : shell :=
{|
block_validator_limits :=
block_validator_limits (shell cfg);
prevalidator_limits :=
prevalidator_limits (shell cfg);
peer_validator_limits :=
peer_validator_limits (shell cfg);
chain_validator_limits :=
Option.unopt_map
(fun bootstrap_threshold =>
(* ❌ Record substitution not handled *)
record_substitution)
(chain_validator_limits (shell cfg))
bootstrap_threshold;
history_mode :=
Option.first_some history_mode
(history_mode (shell cfg)) |} in
let internal_events := internal_events cfg in
_return
{| data_dir := data_dir; p2p := p2p; rpc := rpc;
log := log; internal_events := internal_events;
shell := shell |}).
Definition resolve_addr
(default_addr : string) (default_port : option Z)
(op_staroptstar : option bool) : string -> Lwt.t (list (Ipaddr.V6.t * Z)) :=
let passive :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun peer =>
let '(addr, port) := P2p_point.Id.parse_addr_port peer in
let node : string :=
if orb (equiv_decb addr "" % string) (equiv_decb addr "_" % string) then
default_addr
else
addr
with service : string :=
match (port, default_port) with
| ("" % string, None) => OCaml.Stdlib.invalid_arg "" % string
| ("" % string, Some default_port) =>
OCaml.Stdlib.string_of_int default_port
| (port, _) => port
end in
Lwt_utils_unix.getaddrinfo passive node service.
Definition resolve_addrs
(default_addr : string) (default_port : option Z) (passive : option bool)
(peers : list string) : Lwt.t (list (Ipaddr.V6.t * Z)) :=
Lwt_list.fold_left_s
(fun a =>
fun peer =>
op_gtgteq (resolve_addr default_addr default_port passive peer)
(fun points => Lwt._return (List.rev_append points a))) [] peers.
Definition resolve_discovery_addrs (discovery_addr : string)
: Lwt.t (list (Ipaddr.V4.t * Z)) :=
op_gtgteq
(resolve_addr (to_string broadcast) (Some default_discovery_port)
(Some true) discovery_addr)
(fun addrs =>
let fix to_ipv4 {A : Type}
(acc : list (Ipaddr.V4.t * A)) (function_parameter :
list (Ipaddr.V6.t * A)) : Lwt.t (list (Ipaddr.V4.t * A)) :=
match function_parameter with
| [] => Lwt._return (List.rev acc)
| cons (ip, port) xs =>
match Ipaddr.v4_of_v6 ip with
| Some v => to_ipv4 (cons (v, port) acc) xs
| None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to convert " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" to an ipv4 address" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Warning: failed to convert %S to an ipv4 address@." % string)
(Ipaddr.V6.to_string ip) in
to_ipv4 acc xs
end
end in
to_ipv4 [] addrs).
Definition resolve_listening_addrs (listen_addr : string)
: Lwt.t (list (Ipaddr.V6.t * Z)) :=
resolve_addr "::" % string (Some default_p2p_port) (Some true) listen_addr.
Definition resolve_rpc_listening_addrs (listen_addr : string)
: Lwt.t (list (Ipaddr.V6.t * Z)) :=
resolve_addr "::" % string (Some default_rpc_port) (Some true) listen_addr.
Definition resolve_bootstrap_addrs (peers : list string)
: Lwt.t (list (Ipaddr.V6.t * Z)) :=
resolve_addrs "::" % string (Some default_p2p_port) None peers.
Definition check_listening_addrs (config : t) : Lwt.t unit :=
match listen_addr (p2p config) with
| None => Lwt.return_unit
| Some addr =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (resolve_listening_addrs addr)
(fun function_parameter =>
match function_parameter with
| [] =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to resolve " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Warning: failed to resolve %S
@." % string) addr in
Lwt.return_unit
| cons _ _ => Lwt.return_unit
end))
(fun function_parameter =>
match function_parameter with
| OCaml.Invalid_argument msg =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to parse " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"Warning: failed to parse %S: %s
@." % string) addr msg in
Lwt.return_unit
| exn => Lwt.fail exn
end)
end.
Definition check_discovery_addr (config : t) : Lwt.t unit :=
match discovery_addr (p2p config) with
| None => Lwt.return_unit
| Some addr =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (resolve_discovery_addrs addr)
(fun function_parameter =>
match function_parameter with
| [] =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to resolve " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Warning: failed to resolve %S
@." % string) addr in
Lwt.return_unit
| cons _ _ => Lwt.return_unit
end))
(fun function_parameter =>
match function_parameter with
| OCaml.Invalid_argument msg =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to parse " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"Warning: failed to parse %S: %s
@." % string) addr msg in
Lwt.return_unit
| exn => Lwt.fail exn
end)
end.
Definition check_rpc_listening_addr (config : t) : Lwt.t unit :=
Lwt_list.iter_p
(fun addr =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (resolve_rpc_listening_addrs addr)
(fun function_parameter =>
match function_parameter with
| [] =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to resolve " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Warning: failed to resolve %S
@." % string) addr in
Lwt.return_unit
| cons _ _ => Lwt.return_unit
end))
(fun function_parameter =>
match function_parameter with
| OCaml.Invalid_argument msg =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to parse " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"Warning: failed to parse %S: %s
@." % string) addr msg in
Lwt.return_unit
| exn => Lwt.fail exn
end)) (listen_addrs (rpc config)).
Definition check_bootstrap_peer (addr : string) : Lwt.t unit :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (resolve_bootstrap_addrs (cons addr []))
(fun function_parameter =>
match function_parameter with
| [] =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: cannot resolve " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Warning: cannot resolve %S
@." % string) addr in
Lwt.return_unit
| cons _ _ => Lwt.return_unit
end))
(fun function_parameter =>
match function_parameter with
| OCaml.Invalid_argument msg =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: failed to parse " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"Warning: failed to parse %S: %s
@." % string) addr msg in
Lwt.return_unit
| exn => Lwt.fail exn
end).
Definition check_bootstrap_peers (config : t) : Lwt.t unit :=
Lwt_list.iter_p check_bootstrap_peer (bootstrap_peers (p2p config)).
Definition fail {A B : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
Format.kasprintf
(fun s =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.prerr_endline s in
Stdlib.exit 1) fmt.
Definition check_connections (config : t) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
OCaml.Stdlib.gt (min_connections (limits (p2p config)))
(expected_connections (limits (p2p config))) then
fail
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error: The minumum number of connections is greater than the expected number of connections"
% string CamlinternalFormatBasics.End_of_format)
"Error: The minumum number of connections is greater than the expected number of connections"
% string) (min_connections (limits (p2p config)))
(expected_connections (limits (p2p config)))
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
OCaml.Stdlib.gt (expected_connections (limits (p2p config)))
(max_connections (limits (p2p config))) then
fail
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error: The expected number of connections is greater than the maximum number of connections"
% string CamlinternalFormatBasics.End_of_format)
"Error: The expected number of connections is greater than the maximum number of connections"
% string) (expected_connections (limits (p2p config)))
(max_connections (limits (p2p config)))
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match max_known_peer_ids (limits (p2p config)) with
| None => tt
| Some (max_known_peer_ids, target_known_peer_ids) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt target_known_peer_ids max_known_peer_ids then
fail
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error: The target number of known peer ids is greater than the maximum number of known peer ids."
% string CamlinternalFormatBasics.End_of_format)
"Error: The target number of known peer ids is greater than the maximum number of known peer ids."
% string) target_known_peer_ids max_known_peer_ids
else
tt in
if
OCaml.Stdlib.gt (max_connections (limits (p2p config)))
target_known_peer_ids then
fail
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error: The target number of known peer ids is lower than the maximum number of connections."
% string CamlinternalFormatBasics.End_of_format)
"Error: The target number of known peer ids is lower than the maximum number of connections."
% string) target_known_peer_ids max_known_peer_ids
else
tt
end in
match max_known_points (limits (p2p config)) with
| None => tt
| Some (max_known_points, target_known_points) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt target_known_points max_known_points then
fail
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error: The target number of known points is greater than the maximum number of known points."
% string CamlinternalFormatBasics.End_of_format)
"Error: The target number of known points is greater than the maximum number of known points."
% string) target_known_points max_known_points
else
tt in
if
OCaml.Stdlib.gt (max_connections (limits (p2p config)))
target_known_points then
fail
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error: The target number of known points is lower than the maximum number of connections."
% string CamlinternalFormatBasics.End_of_format)
"Error: The target number of known points is lower than the maximum number of connections."
% string) target_known_points max_known_points
else
tt
end.
Definition check (config : t) : Lwt.t unit :=
op_gtgteq (check_listening_addrs config)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (check_rpc_listening_addr config)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (check_discovery_addr config)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (check_bootstrap_peers config)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := check_connections config in
Lwt.return_unit)))).
src/bin_node/node_data_version.ml 10 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let ( // ) = Filename.concat
type t = string
(* Data_version hitory:
* - 0.0.1 : original storage
* - 0.0.2 : never released
* - 0.0.3 : store upgrade (introducing history mode)
* - 0.0.4 : context upgrade (switching from LMDB to IRMIN v2) *)
let data_version = "0.0.4"
(* List of upgrade functions from each still supported previous
version to the current [data_version] above. If this list grows too
much, an idea would be to have triples (version, version,
converter), and to sequence them dynamically instead of
statically. *)
let upgradable_data_version = []
let store_dir data_dir = data_dir // "store"
let context_dir data_dir = data_dir // "context"
let protocol_dir data_dir = data_dir // "protocol"
let lock_file data_dir = data_dir // "lock"
let default_identity_file_name = "identity.json"
let default_peers_file_name = "peers.json"
let default_config_file_name = "config.json"
let version_file_name = "version.json"
let version_encoding = Data_encoding.(obj1 (req "version" string))
type error += Invalid_data_dir_version of t * t
type error += Invalid_data_dir of string
type error += Could_not_read_data_dir_version of string
type error += Data_dir_needs_upgrade of {expected : t; actual : t}
let () =
register_error_kind
`Permanent
~id:"invalidDataDir"
~title:"Invalid data directory"
~description:"The data directory cannot be accessed or created"
~pp:(fun ppf path ->
Format.fprintf ppf "Invalid data directory '%s'." path)
Data_encoding.(obj1 (req "datadir_path" string))
(function Invalid_data_dir path -> Some path | _ -> None)
(fun path -> Invalid_data_dir path) ;
register_error_kind
`Permanent
~id:"invalidDataDirVersion"
~title:"Invalid data directory version"
~description:"The data directory version was not the one that was expected"
~pp:(fun ppf (exp, got) ->
Format.fprintf
ppf
"Invalid data directory version '%s' (expected '%s')."
got
exp)
Data_encoding.(
obj2 (req "expected_version" string) (req "actual_version" string))
(function
| Invalid_data_dir_version (expected, actual) ->
Some (expected, actual)
| _ ->
None)
(fun (expected, actual) -> Invalid_data_dir_version (expected, actual)) ;
register_error_kind
`Permanent
~id:"couldNotReadDataDirVersion"
~title:"Could not read data directory version file"
~description:"Data directory version file was invalid."
Data_encoding.(obj1 (req "version_path" string))
~pp:(fun ppf path ->
Format.fprintf
ppf
"Tried to read version file at '%s', but the file could not be parsed."
path)
(function Could_not_read_data_dir_version path -> Some path | _ -> None)
(fun path -> Could_not_read_data_dir_version path) ;
register_error_kind
`Permanent
~id:"dataDirNeedsUpgrade"
~title:"The data directory needs to be upgraded"
~description:"The data directory needs to be upgraded"
~pp:(fun ppf (exp, got) ->
Format.fprintf
ppf
"The data directory version is too old.@,\
Found '%s', expected '%s'.@,\
It needs to be upgraded with `tezos-node upgrade_storage`."
got
exp)
Data_encoding.(
obj2 (req "expected_version" string) (req "actual_version" string))
(function
| Data_dir_needs_upgrade {expected; actual} ->
Some (expected, actual)
| _ ->
None)
(fun (expected, actual) -> Data_dir_needs_upgrade {expected; actual})
let version_file data_dir = Filename.concat data_dir version_file_name
let clean_directory files =
let to_delete =
Format.asprintf
"@[<v>%a@]"
(Format.pp_print_list ~pp_sep:Format.pp_print_cut Format.pp_print_string)
files
in
Format.sprintf "Please provide a clean directory by removing:@ %s" to_delete
let write_version data_dir =
Lwt_utils_unix.Json.write_file
(version_file data_dir)
(Data_encoding.Json.construct version_encoding data_version)
let check_data_dir_version files data_dir =
let version_file = version_file data_dir in
Lwt_unix.file_exists version_file
>>= function
| false ->
fail (Invalid_data_dir (clean_directory files))
| true -> (
Lwt_utils_unix.Json.read_file version_file
|> trace (Could_not_read_data_dir_version version_file)
>>=? fun json ->
( try return (Data_encoding.Json.destruct version_encoding json)
with
| Data_encoding.Json.Cannot_destruct _
| Data_encoding.Json.Unexpected _
| Data_encoding.Json.No_case_matched _
| Data_encoding.Json.Bad_array_size _
| Data_encoding.Json.Missing_field _
| Data_encoding.Json.Unexpected_field _
->
fail (Could_not_read_data_dir_version version_file) )
>>=? fun version ->
if String.equal version data_version then return_none
else
match
List.find_opt
(fun (v, _) -> String.equal v version)
upgradable_data_version
with
| Some f ->
return_some f
| None ->
fail (Invalid_data_dir_version (data_version, version)) )
let ensure_data_dir bare data_dir =
let write_version () = write_version data_dir >>=? fun () -> return_none in
Lwt.catch
(fun () ->
Lwt_unix.file_exists data_dir
>>= function
| true -> (
Lwt_stream.to_list (Lwt_unix.files_of_directory data_dir)
>|= List.filter (fun s ->
s <> "." && s <> ".." && s <> version_file_name
&& s <> default_identity_file_name
&& s <> default_config_file_name
&& s <> default_peers_file_name)
>>= function
| [] ->
write_version ()
| files when bare ->
fail (Invalid_data_dir (clean_directory files))
| files ->
check_data_dir_version files data_dir )
| false ->
Lwt_utils_unix.create_dir ~perm:0o700 data_dir
>>= fun () -> write_version ())
(function
| Unix.Unix_error _ ->
fail (Invalid_data_dir data_dir)
| exc ->
raise exc)
let ensure_data_dir ?(bare = false) data_dir =
ensure_data_dir bare data_dir
>>=? function
| None ->
return_unit
| Some (version, _) ->
fail (Data_dir_needs_upgrade {expected = data_version; actual = version})
src/bin_node/node_data_version.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition t := string.
Definition data_version : string := "0.0.4" % string.
Definition upgradable_data_version {A : Type} : list A := [].
Definition store_dir (data_dir : string) : string :=
op_divdiv data_dir "store" % string.
Definition context_dir (data_dir : string) : string :=
op_divdiv data_dir "context" % string.
Definition protocol_dir (data_dir : string) : string :=
op_divdiv data_dir "protocol" % string.
Definition lock_file (data_dir : string) : string :=
op_divdiv data_dir "lock" % string.
Definition default_identity_file_name : string := "identity.json" % string.
Definition default_peers_file_name : string := "peers.json" % string.
Definition default_config_file_name : string := "config.json" % string.
Definition version_file_name : string := "version.json" % string.
Definition version_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding string :=
obj1 (req None None "version" % string string).
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition version_file (data_dir : string) : string :=
Filename.concat data_dir version_file_name.
Definition clean_directory (files : list string) : string :=
let to_delete :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v>" % string
CamlinternalFormatBasics.End_of_format) "<v>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))) "@[<v>%a@]" % string)
(Format.pp_print_list (Some Format.pp_print_cut) Format.pp_print_string)
files in
Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Please provide a clean directory by removing:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"Please provide a clean directory by removing:@ %s" % string) to_delete.
Definition write_version (data_dir : string)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
Lwt_utils_unix.Json.write_file (version_file data_dir)
(Data_encoding.Json.construct version_encoding data_version).
Definition check_data_dir_version {A : Type}
(files : list string) (data_dir : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option (Tezos_base__TzPervasives.String.t * A))) :=
let version_file := version_file data_dir in
op_gtgteq (Lwt_unix.file_exists version_file)
(fun function_parameter =>
match function_parameter with
| false =>
fail (Tezos_base__TzPervasives.Invalid_data_dir (clean_directory files))
| true =>
op_gtgteqquestion
(OCaml.Stdlib.reverse_apply
(Lwt_utils_unix.Json.read_file version_file)
(trace
(Tezos_base__TzPervasives.Could_not_read_data_dir_version
version_file)))
(fun json =>
op_gtgteqquestion
(* ❌ Try-with are not handled *)
(try (_return (Data_encoding.Json.destruct version_encoding json)))
(fun version =>
if String.equal version data_version then
return_none
else
match
List.find_opt
(fun function_parameter =>
let '(v, _) := function_parameter in
String.equal v version) upgradable_data_version with
| Some f => return_some f
| None =>
fail
(Tezos_base__TzPervasives.Invalid_data_dir_version
data_version version)
end))
end).
Definition ensure_data_dir {A : Type} (bare : bool) (data_dir : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option (Tezos_base__TzPervasives.String.t * A))) :=
let write_version {B : Type} (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult (option B)) :=
let 'tt := function_parameter in
op_gtgteqquestion (write_version data_dir)
(fun function_parameter =>
let 'tt := function_parameter in
return_none) in
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_unix.file_exists data_dir)
(fun function_parameter =>
match function_parameter with
| true =>
op_gtgteq
(op_gtpipeeq
(Lwt_stream.to_list (Lwt_unix.files_of_directory data_dir))
(List.filter
(fun s =>
andb (nequiv_decb s "." % string)
(andb (nequiv_decb s ".." % string)
(andb (nequiv_decb s version_file_name)
(andb (nequiv_decb s default_identity_file_name)
(andb (nequiv_decb s default_config_file_name)
(nequiv_decb s default_peers_file_name))))))))
(fun function_parameter =>
match function_parameter with
| [] => write_version tt
| files =>
fail
(Tezos_base__TzPervasives.Invalid_data_dir
(clean_directory files))
| files => check_data_dir_version files data_dir
end)
| false =>
op_gtgteq (Lwt_utils_unix.create_dir (Some 448) data_dir)
(fun function_parameter =>
let 'tt := function_parameter in
write_version tt)
end))
(fun function_parameter =>
match function_parameter with
| Unix_error _ _ _ =>
fail (Tezos_base__TzPervasives.Invalid_data_dir data_dir)
| exc => Stdlib.raise exc
end).
Definition ensure_data_dir (op_staroptstar : option bool)
: string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let bare :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun data_dir =>
op_gtgteqquestion (ensure_data_dir bare data_dir)
(fun function_parameter =>
match function_parameter with
| None => return_unit
| Some (version, _) =>
fail
(Tezos_base__TzPervasives.Data_dir_needs_upgrade
{| expected := data_version; actual := version |})
end).
src/bin_node/node_identity_command.ml 21 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let ( // ) = Filename.concat
(** Commands *)
let identity_file data_dir =
data_dir // Node_data_version.default_identity_file_name
let show {Node_config_file.data_dir; _} =
Node_identity_file.read (identity_file data_dir)
>>=? fun id ->
Format.printf "Peer_id: %a.@." P2p_peer.Id.pp id.peer_id ;
return_unit
let generate_with_animation ppf target =
let duration = 1200 / Animation.number_of_frames in
Animation.make_with_animation
ppf
~make:(fun count ->
try Ok (P2p_identity.generate_with_bound ~max:count target)
with Not_found -> Error count)
~on_retry:(fun time count ->
let ms = int_of_float (Mtime.Span.to_ms time) in
if ms <= 1 then max 10 (count * 10) else count * duration / ms)
10000
let generate {Node_config_file.data_dir; p2p; _} =
let identity_file = identity_file data_dir in
if Sys.file_exists identity_file then
fail (Node_identity_file.Existent_identity_file identity_file)
else
let target = Crypto_box.make_target p2p.expected_pow in
Format.eprintf
"Generating a new identity... (level: %.2f) "
p2p.expected_pow ;
let id = generate_with_animation Format.err_formatter target in
Node_identity_file.write identity_file id
>>=? fun () ->
Format.eprintf
"Stored the new identity (%a) into '%s'.@."
P2p_peer.Id.pp
id.peer_id
identity_file ;
return_unit
let check {Node_config_file.data_dir; p2p = {expected_pow; _}; _} =
Node_identity_file.read ~expected_pow (identity_file data_dir)
>>=? fun id ->
Format.printf
"Peer_id: %a. Proof of work is higher than %.2f.@."
P2p_peer.Id.pp
id.peer_id
expected_pow ;
return_unit
(** Main *)
module Term = struct
type subcommand = Show | Generate | Check
let process subcommand data_dir config_file expected_pow =
let res =
( match (data_dir, config_file) with
| (None, None) ->
let default_config =
Node_config_file.default_data_dir
// Node_data_version.default_config_file_name
in
if Sys.file_exists default_config then
Node_config_file.read default_config
else return Node_config_file.default_config
| (None, Some config_file) ->
Node_config_file.read config_file
| (Some data_dir, None) ->
Node_config_file.read
(data_dir // Node_data_version.default_config_file_name)
>>=? fun cfg -> return {cfg with data_dir}
| (Some data_dir, Some config_file) ->
Node_config_file.read config_file
>>=? fun cfg -> return {cfg with data_dir} )
>>=? fun cfg ->
Node_config_file.update ?expected_pow cfg
>>=? fun cfg ->
match subcommand with
| Show ->
show cfg
| Generate ->
generate cfg
| Check ->
check cfg
in
match Lwt_main.run res with
| Ok () ->
`Ok ()
| Error err ->
`Error (false, Format.asprintf "%a" pp_print_error err)
let subcommand_arg =
let parser = function
| "show" ->
`Ok Show
| "generate" ->
`Ok Generate
| "check" ->
`Ok Check
| s ->
`Error ("invalid argument: " ^ s)
and printer fmt = function
| Show ->
Format.fprintf fmt "show"
| Generate ->
Format.fprintf fmt "generate"
| Check ->
Format.fprintf fmt "check"
in
let doc =
"Operation to perform. Possible values: $(b,show), $(b,generate), \
$(b,check)."
in
let open Cmdliner.Arg in
value & pos 0 (parser, printer) Show & info [] ~docv:"OPERATION" ~doc
let expected_pow =
let open Cmdliner in
let doc =
"Expected amount of proof-of-work for the node identity. The optional \
parameter should be a float between 0 and 256, where\n\
\ 0 disables the proof-of-work mechanism."
in
Arg.(value & pos 1 (some float) None & info [] ~docv:"DIFFICULTY" ~doc)
let term =
Cmdliner.Term.(
ret
( const process $ subcommand_arg $ Node_shared_arg.Term.data_dir
$ Node_shared_arg.Term.config_file $ expected_pow ))
end
module Manpage = struct
let command_description =
"The $(b,identity) command is meant to create and manage node identities. \
An $(i,identity) uniquely identifies a peer on the network and consists \
of a cryptographic key pair as well as a proof-of-work stamp that \
certifies that enough CPU time has been dedicated to produce the \
identity, to avoid sybil attacks. An identity with enough proof-of-work \
is required to participate in the Tezos network, therefore this command \
is necessary to launch Tezos the first time."
let description =
[ `S "DESCRIPTION";
`P (command_description ^ " Several options are possible:");
`P
"$(b,show) reads, parses and displays the current identity of the \
node. Use this command to see what identity will be used by Tezos. \
This is the default operation.";
`P
"$(b,generate [difficulty]) generates an identity whose proof of work \
stamp difficulty is at least equal to $(i,difficulty). The value \
provided must be a floating point number between 0 and 256. It \
roughly reflects the numbers of expected leading zeroes in the hash \
of the identity data-structure. Therefore, a value of 0 means no \
proof-of-work, and the difficulty doubles for each increment of 1 in \
the difficulty value.";
`P
"$(b,check [difficulty]) checks that an identity is valid and that \
its proof of work stamp difficulty is at least equal to \
$(i,difficulty)." ]
let man = description @ (* [ `S misc_docs ] @ *)
Node_shared_arg.Manpage.bugs
let info = Cmdliner.Term.info ~doc:"Manage node identities" ~man "identity"
end
let cmd = (Term.term, Manpage.info)
src/bin_node/node_identity_command.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition identity_file (data_dir : string) : string :=
op_divdiv data_dir Node_data_version.default_identity_file_name.
Definition show (function_parameter : Node_config_file.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{| Node_config_file.data_dir := data_dir |} := function_parameter in
op_gtgteqquestion (Node_identity_file.read None (identity_file data_dir))
(fun id =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Peer_id: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Peer_id: %a.@." % string) P2p_peer.Id.pp (peer_id id) in
return_unit).
Definition generate_with_animation
(ppf : Stdlib.Format.formatter) (target : Tezos_crypto.Crypto_box.target)
: Tezos_base__TzPervasives.P2p_identity.t :=
let duration := Z.div 1200 Animation.number_of_frames in
Animation.make_with_animation ppf
(fun count =>
(* ❌ Try-with are not handled *)
try (Stdlib.Ok (P2p_identity.generate_with_bound (Some count) target)))
(fun time =>
fun count =>
let ms := Stdlib.int_of_float (Mtime.Span.to_ms time) in
if OCaml.Stdlib.le ms 1 then
OCaml.Stdlib.max 10 (Z.mul count 10)
else
Z.div (Z.mul count duration) ms) 10000.
Definition generate (function_parameter : Node_config_file.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{|
Node_config_file.data_dir := data_dir; Node_config_file.p2p := p2p |} :=
function_parameter in
let identity_file := identity_file data_dir in
if Sys.file_exists identity_file then
fail (Tezos_base__TzPervasives.Existent_identity_file identity_file)
else
let target := Crypto_box.make_target (expected_pow p2p) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Generating a new identity... (level: " % string
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal ") " % string
CamlinternalFormatBasics.End_of_format)))
"Generating a new identity... (level: %.2f) " % string)
(expected_pow p2p) in
let id := generate_with_animation Format.err_formatter target in
op_gtgteqquestion (Node_identity_file.write identity_file id)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Stored the new identity (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ") into '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal "'." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"Stored the new identity (%a) into '%s'.@." % string)
P2p_peer.Id.pp (peer_id id) identity_file in
return_unit).
Definition check (function_parameter : Node_config_file.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{|
Node_config_file.data_dir := data_dir;
Node_config_file.p2p := {| expected_pow := expected_pow |}
|} := function_parameter in
op_gtgteqquestion
(Node_identity_file.read (Some expected_pow) (identity_file data_dir))
(fun id =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Peer_id: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
". Proof of work is higher than " % string
(CamlinternalFormatBasics.Float
CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"Peer_id: %a. Proof of work is higher than %.2f.@." % string)
P2p_peer.Id.pp (peer_id id) expected_pow in
return_unit).
Module Term.
Inductive subcommand : Type :=
| Show : subcommand
| Generate : subcommand
| Check : subcommand.
Definition process
(subcommand : subcommand) (data_dir : option string)
(config_file : option string) (expected_pow : option Z) : variant :=
let res :=
op_gtgteqquestion
match (data_dir, config_file) with
| (None, None) =>
let default_config :=
op_divdiv Node_config_file.default_data_dir
Node_data_version.default_config_file_name in
if Sys.file_exists default_config then
Node_config_file.read default_config
else
_return Node_config_file.default_config
| (None, Some config_file) => Node_config_file.read config_file
| (Some data_dir, None) =>
op_gtgteqquestion
(Node_config_file.read
(op_divdiv data_dir Node_data_version.default_config_file_name))
(fun cfg =>
_return
(* ❌ Record substitution not handled *)
record_substitution)
| (Some data_dir, Some config_file) =>
op_gtgteqquestion (Node_config_file.read config_file)
(fun cfg =>
_return
(* ❌ Record substitution not handled *)
record_substitution)
end
(fun cfg =>
op_gtgteqquestion
(Node_config_file.update None None None None None None None None
expected_pow None None None None None None None None None None
None None None cfg)
(fun cfg =>
match subcommand with
| Show => show cfg
| Generate => generate cfg
| Check => check cfg
end)) in
match Lwt_main.run res with
| Stdlib.Ok tt =>
(* ❌ Variants not supported *)
variant
| Stdlib.Error err =>
(* ❌ Variants not supported *)
variant
end.
Definition subcommand_arg : Cmdliner.Term.t subcommand :=
let parser (function_parameter : string) : variant :=
match function_parameter with
| "show" % string =>
(* ❌ Variants not supported *)
variant
| "generate" % string =>
(* ❌ Variants not supported *)
variant
| "check" % string =>
(* ❌ Variants not supported *)
variant
| s =>
(* ❌ Variants not supported *)
variant
end
with printer
(fmt : Stdlib.Format.formatter) (function_parameter : subcommand)
: unit :=
match function_parameter with
| Show =>
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "show" % string
CamlinternalFormatBasics.End_of_format) "show" % string)
| Generate =>
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "generate" % string
CamlinternalFormatBasics.End_of_format) "generate" % string)
| Check =>
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "check" % string
CamlinternalFormatBasics.End_of_format) "check" % string)
end in
let doc :=
"Operation to perform. Possible values: $(b,show), $(b,generate), $(b,check)."
% string in
op_and value
(op_and (pos None 0 (parser, printer) Show)
(info None (Some "OPERATION" % string) (Some doc) None [])).
Definition expected_pow : Cmdliner.Term.t (option Z) :=
let doc :=
"Expected amount of proof-of-work for the node identity. The optional parameter should be a float between 0 and 256, where
0 disables the proof-of-work mechanism."
% string in
op_and value
(op_and (pos None 1 (some None float) None)
(info None (Some "DIFFICULTY" % string) (Some doc) None [])).
Definition term : Cmdliner.Term.t unit :=
ret
(op_dollar
(op_dollar
(op_dollar (op_dollar (const process) subcommand_arg)
Node_shared_arg.Term.data_dir) Node_shared_arg.Term.config_file)
expected_pow).
End Term.
Module Manpage.
Definition command_description : string :=
"The $(b,identity) command is meant to create and manage node identities. An $(i,identity) uniquely identifies a peer on the network and consists of a cryptographic key pair as well as a proof-of-work stamp that certifies that enough CPU time has been dedicated to produce the identity, to avoid sybil attacks. An identity with enough proof-of-work is required to participate in the Tezos network, therefore this command is necessary to launch Tezos the first time."
% string.
Definition description : list variant :=
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant [])))).
Definition man : list Cmdliner.Manpage.block :=
OCaml.Stdlib.app description Node_shared_arg.Manpage.bugs.
Definition info : Cmdliner.Term.info :=
Cmdliner.Term.info None (Some man) None None None None
(Some "Manage node identities" % string) None "identity" % string.
End Manpage.
Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
(Term.term, Manpage.info).
src/bin_node/node_identity_file.ml 15 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type error += No_identity_file of string
type error += Insufficient_proof_of_work of {expected : float}
type error +=
| Identity_mismatch of {
filename : string;
peer_id : Crypto_box.Public_key_hash.t;
}
type error +=
| Identity_keys_mismatch of {
filename : string;
expected_key : Crypto_box.public_key;
}
let () =
register_error_kind
`Permanent
~id:"main.identity.no_file"
~title:"No identity file"
~description:"The node identity file cannot be found"
~pp:(fun ppf file ->
Format.fprintf
ppf
"Cannot read the identity file: `%s`. See `%s identity --help` on how \
to generate an identity."
file
Sys.argv.(0))
Data_encoding.(obj1 (req "file" string))
(function No_identity_file file -> Some file | _ -> None)
(fun file -> No_identity_file file)
let () =
register_error_kind
`Permanent
~id:"main.identity.insufficient_proof_of_work"
~title:"Insufficient proof of work"
~description:
"The proof of work embeded by the current identity is not sufficient"
~pp:(fun ppf expected ->
Format.fprintf
ppf
"The current identity does not embed a sufficient stamp of \
proof-of-work. (expected level: %.2f). See `%s identity --help` on \
how to generate a new identity."
expected
Sys.argv.(0))
Data_encoding.(obj1 (req "expected" float))
(function
| Insufficient_proof_of_work {expected} -> Some expected | _ -> None)
(fun expected -> Insufficient_proof_of_work {expected})
let () =
register_error_kind
`Permanent
~id:"main.identity.identity_mismatch"
~title:"Identity mismatch"
~description:
"The identity (public key hash) does not match the keys provided with it"
~pp:(fun ppf (file, public_key_hash) ->
Format.fprintf
ppf
"The current identity (public key hash) does not match the keys in %s.\n\
\ Expected identity %a."
file
Crypto_box.Public_key_hash.pp
public_key_hash)
Data_encoding.(
obj2
(req "file" string)
(req "public_key_hash" Crypto_box.Public_key_hash.encoding))
(function
| Identity_mismatch {filename; peer_id} ->
Some (filename, peer_id)
| _ ->
None)
(fun (filename, peer_id) -> Identity_mismatch {filename; peer_id})
let () =
register_error_kind
`Permanent
~id:"main.identity.identity_keys_mismatch"
~title:"Identity keys mismatch"
~description:
"The current identity file has non-matching keys (secret key/ public \
key pair is not valid)"
~pp:(fun ppf (file, public_key) ->
Format.fprintf
ppf
"The current identity file %s has non-matching keys (secret key/ \
public key pair is not valid).\n\
\ Expected public key %a."
file
Crypto_box.pp_pk
public_key)
Data_encoding.(
obj2
(req "file" string)
(req "public_key" Crypto_box.public_key_encoding))
(function
| Identity_keys_mismatch {filename; expected_key} ->
Some (filename, expected_key)
| _ ->
None)
(fun (filename, expected_key) ->
Identity_keys_mismatch {filename; expected_key})
let read ?expected_pow filename =
Lwt_unix.file_exists filename
>>= function
| false ->
fail (No_identity_file filename)
| true -> (
Lwt_utils_unix.Json.read_file filename
>>=? fun json ->
let id = Data_encoding.Json.destruct P2p_identity.encoding json in
let pkh = Crypto_box.hash id.public_key in
(* check public_key hash *)
if not (Crypto_box.Public_key_hash.equal pkh id.peer_id) then
fail (Identity_mismatch {filename; peer_id = pkh})
(* check public/private keys correspondance *)
else if not Crypto_box.(equal (neuterize id.secret_key) id.public_key)
then
fail (Identity_keys_mismatch {filename; expected_key = id.public_key})
else
(* check PoW level *)
match expected_pow with
| None ->
return id
| Some expected ->
let target = Crypto_box.make_target expected in
if
not
(Crypto_box.check_proof_of_work
id.public_key
id.proof_of_work_stamp
target)
then fail (Insufficient_proof_of_work {expected})
else return id )
type error += Existent_identity_file of string
let () =
register_error_kind
`Permanent
~id:"main.identity.existent_file"
~title:"Cannot overwrite identity file"
~description:"Cannot implicitely overwrite the current identity file"
~pp:(fun ppf file ->
Format.fprintf
ppf
"Cannot implicitely overwrite the current identity file: '%s'. See \
`%s identity --help` on how to generate a new identity."
file
Sys.argv.(0))
Data_encoding.(obj1 (req "file" string))
(function Existent_identity_file file -> Some file | _ -> None)
(fun file -> Existent_identity_file file)
let write file identity =
if Sys.file_exists file then fail (Existent_identity_file file)
else
Node_data_version.ensure_data_dir (Filename.dirname file)
>>=? fun () ->
Lwt_utils_unix.Json.write_file
file
(Data_encoding.Json.construct P2p_identity.encoding identity)
src/bin_node/node_identity_file.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition read (expected_pow : option Z) (filename : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.P2p_identity.t) :=
op_gtgteq (Lwt_unix.file_exists filename)
(fun function_parameter =>
match function_parameter with
| false => fail (Tezos_base__TzPervasives.No_identity_file filename)
| true =>
op_gtgteqquestion (Lwt_utils_unix.Json.read_file filename)
(fun json =>
let id := Data_encoding.Json.destruct P2p_identity.encoding json in
let pkh := Crypto_box.hash (public_key id) in
if negb (Crypto_box.Public_key_hash.equal pkh (peer_id id)) then
fail
(Tezos_base__TzPervasives.Identity_mismatch
{| filename := filename; peer_id := pkh |})
else
if negb (equal (neuterize (secret_key id)) (public_key id)) then
fail
(Tezos_base__TzPervasives.Identity_keys_mismatch
{| filename := filename; expected_key := public_key id |})
else
match expected_pow with
| None => _return id
| Some expected =>
let target := Crypto_box.make_target expected in
if
negb
(Crypto_box.check_proof_of_work (public_key id)
(proof_of_work_stamp id) target) then
fail
(Tezos_base__TzPervasives.Insufficient_proof_of_work
{| expected := expected |})
else
_return id
end)
end).
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition write
(file : string) (identity : Tezos_base__TzPervasives.P2p_identity.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if Sys.file_exists file then
fail (Tezos_base__TzPervasives.Existent_identity_file file)
else
op_gtgteqquestion
(Node_data_version.ensure_data_dir None (Filename.dirname file))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.Json.write_file file
(Data_encoding.Json.construct P2p_identity.encoding identity)).
src/bin_node/node_logging.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Internal_event.Legacy_logging.Make (struct let name = "node.main" end)
src/bin_node/node_logging.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/bin_node/node_run_command.ml 25 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Node_logging
open Genesis_chain
type error += Non_private_sandbox of P2p_addr.t
type error += RPC_Port_already_in_use of P2p_point.Id.t list
let () =
register_error_kind
`Permanent
~id:"main.run.non_private_sandbox"
~title:"Forbidden public sandbox"
~description:"A sandboxed node should not listen on a public address."
~pp:(fun ppf addr ->
Format.fprintf
ppf
"The node is configured to listen on a public address (%a), while \
only 'private' networks are authorised with `--sandbox`.\n\
\ See `%s run --help` on how to change the listening address."
Ipaddr.V6.pp
addr
Sys.argv.(0))
Data_encoding.(obj1 (req "addr" P2p_addr.encoding))
(function Non_private_sandbox addr -> Some addr | _ -> None)
(fun addr -> Non_private_sandbox addr) ;
register_error_kind
`Permanent
~id:"main.run.port_already_in_use"
~title:"Cannot start node: RPC port already in use"
~description:"Another tezos node is probably running on the same RPC port."
~pp:(fun ppf addrlist ->
Format.fprintf
ppf
"Another tezos node is probably running on one of these addresses \
(%a). Please choose another RPC port."
(Format.pp_print_list P2p_point.Id.pp)
addrlist)
Data_encoding.(obj1 (req "addrlist" (list P2p_point.Id.encoding)))
(function RPC_Port_already_in_use addrlist -> Some addrlist | _ -> None)
(fun addrlist -> RPC_Port_already_in_use addrlist)
let ( // ) = Filename.concat
let init_node ?sandbox ?checkpoint ~singleprocess (config : Node_config_file.t)
=
( match sandbox with
| None ->
Lwt.return_none
| Some sandbox_param -> (
match sandbox_param with
| None ->
Lwt.return_none
| Some file -> (
Lwt_utils_unix.Json.read_file file
>>= function
| Error err ->
lwt_warn "Cannot parse sandbox parameters: %s" file
>>= fun () ->
lwt_debug "%a" pp_print_error err >>= fun () -> Lwt.return_none
| Ok json ->
Lwt.return_some json ) ) )
>>= fun sandbox_param ->
(* TODO "WARN" when pow is below our expectation. *)
( match config.p2p.discovery_addr with
| None ->
lwt_log_notice "No local peer discovery."
>>= fun () -> return (None, None)
| Some addr -> (
Node_config_file.resolve_discovery_addrs addr
>>= function
| [] ->
failwith "Cannot resolve P2P discovery address: %S" addr
| (addr, port) :: _ ->
return (Some addr, Some port) ) )
>>=? fun (discovery_addr, discovery_port) ->
( match config.p2p.listen_addr with
| None ->
lwt_log_notice "Not listening to P2P calls."
>>= fun () -> return (None, None)
| Some addr -> (
Node_config_file.resolve_listening_addrs addr
>>= function
| [] ->
failwith "Cannot resolve P2P listening address: %S" addr
| (addr, port) :: _ ->
return (Some addr, Some port) ) )
>>=? fun (listening_addr, listening_port) ->
( match (listening_addr, sandbox) with
| (Some addr, Some _) when Ipaddr.V6.(compare addr unspecified) = 0 ->
return_none
| (Some addr, Some _) when not (Ipaddr.V6.is_private addr) ->
fail (Non_private_sandbox addr)
| (None, Some _) ->
return_none
| _ ->
Node_config_file.resolve_bootstrap_addrs config.p2p.bootstrap_peers
>>= fun trusted_points ->
Node_identity_file.read
(config.data_dir // Node_data_version.default_identity_file_name)
>>=? fun identity ->
lwt_log_notice "Peer's global id: %a" P2p_peer.Id.pp identity.peer_id
>>= fun () ->
let p2p_config : P2p.config =
{
listening_addr;
listening_port;
discovery_addr;
discovery_port;
trusted_points;
peers_file =
config.data_dir // Node_data_version.default_peers_file_name;
private_mode = config.p2p.private_mode;
greylisting_config = config.p2p.greylisting_config;
identity;
proof_of_work_target = Crypto_box.make_target config.p2p.expected_pow;
disable_mempool = config.p2p.disable_mempool;
trust_discovered_peers = sandbox_param <> None;
disable_testchain = config.p2p.disable_testchain;
}
in
return_some (p2p_config, config.p2p.limits) )
>>=? fun p2p_config ->
let sandbox_parameters = sandbox_param in
let sandbox_param =
Option.map ~f:(fun p -> ("sandbox_parameter", p)) sandbox_param
in
let node_config : Node.config =
{
genesis;
patch_context = Some (Patch_context.patch_context sandbox_param);
store_root = Node_data_version.store_dir config.data_dir;
context_root = Node_data_version.context_dir config.data_dir;
protocol_root = Node_data_version.protocol_dir config.data_dir;
p2p = p2p_config;
checkpoint;
}
in
Node.create
~sandboxed:(sandbox <> None)
?sandbox_parameters
~singleprocess
node_config
config.shell.peer_validator_limits
config.shell.block_validator_limits
config.shell.prevalidator_limits
config.shell.chain_validator_limits
config.shell.history_mode
(* Add default accepted CORS headers *)
let sanitize_cors_headers ~default headers =
List.map String.lowercase_ascii headers
|> String.Set.of_list
|> String.Set.(union (of_list default))
|> String.Set.elements
let launch_rpc_server (rpc_config : Node_config_file.rpc) node (addr, port) =
let host = Ipaddr.V6.to_string addr in
let dir = Node.build_rpc_directory node in
let mode =
match rpc_config.tls with
| None ->
`TCP (`Port port)
| Some {cert; key} ->
`TLS (`Crt_file_path cert, `Key_file_path key, `No_password, `Port port)
in
lwt_log_notice
"Starting a RPC server listening on %s:%d%s."
host
port
(if rpc_config.tls = None then "" else " (TLS enabled)")
>>= fun () ->
let cors_headers =
sanitize_cors_headers ~default:["Content-Type"] rpc_config.cors_headers
in
Lwt.catch
(fun () ->
RPC_server.launch
~host
mode
dir
~media_types:Media_type.all_media_types
~cors:
{
allowed_origins = rpc_config.cors_origins;
allowed_headers = cors_headers;
}
>>= return)
(function
| Unix.Unix_error (Unix.EADDRINUSE, "bind", "") ->
fail (RPC_Port_already_in_use [(addr, port)])
| exn ->
Lwt.return (error_exn exn))
let init_rpc (rpc_config : Node_config_file.rpc) node =
fold_right_s
(fun addr acc ->
Node_config_file.resolve_rpc_listening_addrs addr
>>= function
| [] ->
failwith "Cannot resolve listening address: %S" addr
| addrs ->
fold_right_s
(fun x a ->
launch_rpc_server rpc_config node x >>=? fun o -> return (o :: a))
addrs
acc)
rpc_config.listen_addrs
[]
let run ?verbosity ?sandbox ?checkpoint ~singleprocess
(config : Node_config_file.t) =
Node_data_version.ensure_data_dir config.data_dir
>>=? fun () ->
Lwt_lock_file.create
~unlink_on_exit:true
(Node_data_version.lock_file config.data_dir)
>>=? fun () ->
(* Main loop *)
let log_cfg =
match verbosity with
| None ->
config.log
| Some default_level ->
{config.log with default_level}
in
Internal_event_unix.init
~lwt_log_sink:log_cfg
~configuration:config.internal_events
()
>>= fun () ->
Updater.init (Node_data_version.protocol_dir config.data_dir) ;
lwt_log_notice "Starting the Tezos node..."
>>= fun () ->
init_node ?sandbox ?checkpoint ~singleprocess config
>>= (function
| Ok node ->
return node
| Error
(State.Incorrect_history_mode_switch {previous_mode; next_mode}
:: _) ->
failwith
"@[Cannot switch from history mode '%a' to '%a'. Import a \
context from a corresponding snapshot or re-synchronize a node \
with an empty tezos node directory.@]"
History_mode.pp
previous_mode
History_mode.pp
next_mode
| Error _ as err ->
Lwt.return err)
>>=? fun node ->
init_rpc config.rpc node
>>=? fun rpc ->
lwt_log_notice "The Tezos node is now running!"
>>= fun () ->
Lwt_exit.(
wrap_promise @@ retcode_of_unit_result_lwt @@ Lwt_utils.never_ending ())
>>= fun retcode ->
(* Clean-shutdown code *)
Lwt_exit.termination_thread
>>= fun x ->
lwt_log_notice "Shutting down the Tezos node..."
>>= fun () ->
Node.shutdown node
>>= fun () ->
lwt_log_notice "Shutting down the RPC server..."
>>= fun () ->
Lwt_list.iter_p RPC_server.shutdown rpc
>>= fun () ->
lwt_log_notice "BYE (%d)" x
>>= fun () -> Internal_event_unix.close () >>= fun () -> return retcode
let process sandbox verbosity checkpoint singleprocess args =
let verbosity =
let open Internal_event in
match verbosity with [] -> None | [_] -> Some Info | _ -> Some Debug
in
let run =
Node_shared_arg.read_and_patch_config_file
~ignore_bootstrap_peers:
(match sandbox with Some _ -> true | None -> false)
args
>>=? fun config ->
( match sandbox with
| Some _ ->
if config.data_dir = Node_config_file.default_data_dir then
failwith "Cannot use default data directory while in sandbox mode"
else return_unit
| None ->
return_unit )
>>=? fun () ->
( match checkpoint with
| None ->
return_none
| Some s -> (
match Block_header.of_b58check s with
| Some b ->
return_some b
| None ->
failwith
"Failed to parse the provided checkpoint (Base58Check-encoded)." )
)
>>=? fun checkpoint ->
Lwt_lock_file.is_locked (Node_data_version.lock_file config.data_dir)
>>=? function
| false ->
Lwt.catch
(fun () -> run ?sandbox ?verbosity ?checkpoint ~singleprocess config)
(function
| Unix.Unix_error (Unix.EADDRINUSE, "bind", "") ->
Lwt_list.fold_right_s
(fun addr acc ->
Node_config_file.resolve_rpc_listening_addrs addr
>>= fun x -> Lwt.return (x @ acc))
config.rpc.listen_addrs
[]
>>= fun addrlist -> fail (RPC_Port_already_in_use addrlist)
| exn ->
Lwt.return (error_exn exn))
| true ->
failwith "Data directory is locked by another process"
in
match Lwt_main.run run with
| Ok (0 | 2) ->
(* 2 means that we exit by a signal that was handled *)
`Ok ()
| Ok _ ->
`Error (false, "")
| Error err ->
`Error (false, Format.asprintf "%a" pp_print_error err)
module Term = struct
let verbosity =
let open Cmdliner in
let doc =
"Increase log level. Using $(b,-v) is equivalent to using \
$(b,TEZOS_LOG='*Â ->Â info'), and $(b,-vv) is equivalent to using \
$(b,TEZOS_LOG='*Â ->Â debug')."
in
Arg.(
value & flag_all
& info ~docs:Node_shared_arg.Manpage.misc_section ~doc ["v"])
let sandbox =
let open Cmdliner in
let doc =
"Run the daemon in sandbox mode. P2P to non-localhost addresses are \
disabled, and constants of the economic protocol can be altered with \
an optional JSON file. $(b,IMPORTANT): Using sandbox mode affects the \
node state and subsequent runs of Tezos node must also use sandbox \
mode. In order to run the node in normal mode afterwards, a full reset \
must be performed (by removing the node's data directory)."
in
Arg.(
value
& opt ~vopt:(Some None) (some (some string)) None
& info
~docs:Node_shared_arg.Manpage.misc_section
~doc
~docv:"FILE.json"
["sandbox"])
let checkpoint =
let open Cmdliner in
let doc =
"When asked to take a block hash as a checkpoint, the daemon will only \
accept the chains that contains that block and those that might reach \
it."
in
Arg.(
value
& opt (some string) None
& info
~docs:Node_shared_arg.Manpage.misc_section
~doc
~docv:"<level>,<block_hash>"
["checkpoint"])
let singleprocess =
let open Cmdliner in
let doc =
"When enabled, it deactivates block validation using an external \
process. Thus, the validation procedure is done in the same process as \
the node and might not be responding when doing extensive I/Os."
in
Arg.(
value & flag
& info ~docs:Node_shared_arg.Manpage.misc_section ~doc ["singleprocess"])
let term =
Cmdliner.Term.(
ret
( const process $ sandbox $ verbosity $ checkpoint $ singleprocess
$ Node_shared_arg.Term.args ))
end
module Manpage = struct
let command_description =
"The $(b,run) command is meant to run the Tezos node. Most of its command \
line arguments corresponds to config file entries, and will have \
priority over the latter if used."
let description = [`S "DESCRIPTION"; `P command_description]
let debug =
let log_sections =
String.concat " " (List.rev !Internal_event.Legacy_logging.sections)
in
[ `S "DEBUG";
`P
( "The environment variable $(b,TEZOS_LOG) is used to fine-tune what \
is going to be logged. The syntax is \
$(b,TEZOS_LOG='<section>Â ->Â <level> [ ; ...]') where section is \
one of $(i," ^ log_sections
^ ") and level is one of $(i,fatal), $(i,error), $(i,warn), \
$(i,notice), $(i,info) or $(i,debug). A $(b,*) can be used as a \
wildcard in sections, i.e. $(b, client*Â ->Â debug). The rules are \
matched left to right, therefore the leftmost rule is highest \
priority ." ) ]
let examples =
[ `S "EXAMPLES";
`I
( "$(b,Run in sandbox mode listening to RPC commands at localhost \
port 8732)",
"$(mname) run --sandbox --data-dir /custom/data/dir --rpc-addr \
localhost:8732" );
`I ("$(b,Run a node that accepts network connections)", "$(mname) run")
]
let man =
description @ Node_shared_arg.Manpage.args @ debug @ examples
@ Node_shared_arg.Manpage.bugs
let info = Cmdliner.Term.info ~doc:"Run the Tezos node" ~man "run"
end
let cmd = (Term.term, Manpage.info)
src/bin_node/node_run_command.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Node_logging.
Import Genesis_chain.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition init_node
(sandbox : option (option string))
(checkpoint : option Tezos_base__TzPervasives.Block_header.t)
(singleprocess : bool) (config : Node_config_file.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_shell.Node.t) :=
op_gtgteq
match sandbox with
| None => Lwt.return_none
| Some sandbox_param =>
match sandbox_param with
| None => Lwt.return_none
| Some file =>
op_gtgteq (Lwt_utils_unix.Json.read_file file)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error err =>
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_warn)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot parse sandbox parameters: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Cannot parse sandbox parameters: %s" % string) file)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_debug)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_none))
| Stdlib.Ok json => Lwt.return_some json
end)
end
end
(fun sandbox_param =>
op_gtgteqquestion
match discovery_addr (p2p config) with
| None =>
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No local peer discovery." % string
CamlinternalFormatBasics.End_of_format)
"No local peer discovery." % string))
(fun function_parameter =>
let 'tt := function_parameter in
_return (None, None))
| Some addr =>
op_gtgteq (Node_config_file.resolve_discovery_addrs addr)
(fun function_parameter =>
match function_parameter with
| [] =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot resolve P2P discovery address: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Cannot resolve P2P discovery address: %S" % string) addr
| cons (addr, port) _ => _return ((Some addr), (Some port))
end)
end
(fun function_parameter =>
let '(discovery_addr, discovery_port) := function_parameter in
op_gtgteqquestion
match listen_addr (p2p config) with
| None =>
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Not listening to P2P calls." % string
CamlinternalFormatBasics.End_of_format)
"Not listening to P2P calls." % string))
(fun function_parameter =>
let 'tt := function_parameter in
_return (None, None))
| Some addr =>
op_gtgteq (Node_config_file.resolve_listening_addrs addr)
(fun function_parameter =>
match function_parameter with
| [] =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot resolve P2P listening address: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Cannot resolve P2P listening address: %S" % string)
addr
| cons (addr, port) _ => _return ((Some addr), (Some port))
end)
end
(fun function_parameter =>
let '(listening_addr, listening_port) := function_parameter in
op_gtgteqquestion
match (listening_addr, sandbox) with
| (Some addr, Some _) => return_none
| (Some addr, Some _) =>
fail (Tezos_base__TzPervasives.Non_private_sandbox addr)
| (None, Some _) => return_none
| _ =>
op_gtgteq
(Node_config_file.resolve_bootstrap_addrs
(bootstrap_peers (p2p config)))
(fun trusted_points =>
op_gtgteqquestion
(Node_identity_file.read None
(op_divdiv (data_dir config)
Node_data_version.default_identity_file_name))
(fun identity =>
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Peer's global id: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Peer's global id: %a" % string) P2p_peer.Id.pp
(peer_id identity))
(fun function_parameter =>
let 'tt := function_parameter in
let p2p_config :=
{| listening_port := listening_port;
listening_addr := listening_addr;
discovery_port := discovery_port;
discovery_addr := discovery_addr;
trusted_points := trusted_points;
peers_file :=
op_divdiv (data_dir config)
Node_data_version.default_peers_file_name;
private_mode := private_mode (p2p config);
identity := identity;
proof_of_work_target :=
Crypto_box.make_target
(expected_pow (p2p config));
disable_mempool :=
disable_mempool (p2p config);
trust_discovered_peers :=
nequiv_decb sandbox_param None;
disable_testchain :=
disable_testchain (p2p config);
greylisting_config :=
greylisting_config (p2p config) |} in
return_some (p2p_config, (limits (p2p config))))))
end
(fun p2p_config =>
let sandbox_parameters := sandbox_param in
let sandbox_param :=
Option.map (fun p => ("sandbox_parameter" % string, p))
sandbox_param in
let node_config :=
{| genesis := genesis;
store_root :=
Node_data_version.store_dir (data_dir config);
context_root :=
Node_data_version.context_dir (data_dir config);
protocol_root :=
Node_data_version.protocol_dir (data_dir config);
patch_context :=
Some (Patch_context.patch_context sandbox_param);
p2p := p2p_config; checkpoint := checkpoint |} in
Node.create (Some (nequiv_decb sandbox None))
sandbox_parameters singleprocess node_config
(peer_validator_limits (shell config))
(block_validator_limits (shell config))
(prevalidator_limits (shell config))
(chain_validator_limits (shell config))
(history_mode (shell config)))))).
Definition sanitize_cors_headers
(default : list Tezos_base__TzPervasives.String.Set.elt)
(headers : list string) : list Tezos_base__TzPervasives.String.Set.elt :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply (List.map String.lowercase_ascii headers)
String.Set.of_list) (union (of_list default))) String.Set.elements.
Definition launch_rpc_server
(rpc_config : Node_config_file.rpc) (node : Tezos_shell.Node.t)
(function_parameter : Ipaddr.V6.t * Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_rpc_http_server.RPC_server.server) :=
let '(addr, port) := function_parameter in
let host := Ipaddr.V6.to_string addr in
let dir := Node.build_rpc_directory node in
let mode :=
match tls rpc_config with
| None =>
(* ❌ Variants not supported *)
variant
| Some {| cert := cert; key := key |} =>
(* ❌ Variants not supported *)
variant
end in
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Starting a RPC server listening on " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format))))))
"Starting a RPC server listening on %s:%d%s." % string) host port
(if equiv_decb (tls rpc_config) None then
"" % string
else
" (TLS enabled)" % string))
(fun function_parameter =>
let 'tt := function_parameter in
let cors_headers :=
sanitize_cors_headers (cons "Content-Type" % string [])
(cors_headers rpc_config) in
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(RPC_server.launch (Some host)
(Some
{| allowed_headers := cors_headers;
allowed_origins := cors_origins rpc_config |})
Media_type.all_media_types mode dir) _return)
(fun function_parameter =>
match function_parameter with
| Unix_error Unix.EADDRINUSE "bind" % string "" % string =>
fail
(Tezos_base__TzPervasives.RPC_Port_already_in_use
(cons (addr, port) []))
| exn => Lwt._return (error_exn exn)
end)).
Definition init_rpc
(rpc_config : Node_config_file.rpc) (node : Tezos_shell.Node.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list Tezos_rpc_http_server.RPC_server.server)) :=
fold_right_s
(fun addr =>
fun acc =>
op_gtgteq (Node_config_file.resolve_rpc_listening_addrs addr)
(fun function_parameter =>
match function_parameter with
| [] =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot resolve listening address: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Cannot resolve listening address: %S" % string) addr
| addrs =>
fold_right_s
(fun x =>
fun a =>
op_gtgteqquestion (launch_rpc_server rpc_config node x)
(fun o => _return (cons o a))) addrs acc
end)) (listen_addrs rpc_config) [].
Definition run
(verbosity : option Tezos_event_logging.Internal_event.level)
(sandbox : option (option string))
(checkpoint : option Tezos_base__TzPervasives.Block_header.t)
(singleprocess : bool) (config : Node_config_file.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Z) :=
op_gtgteqquestion (Node_data_version.ensure_data_dir None (data_dir config))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt_lock_file.create None (Some true)
(Node_data_version.lock_file (data_dir config)))
(fun function_parameter =>
let 'tt := function_parameter in
let log_cfg :=
match verbosity with
| None => log config
| Some default_level =>
(* ❌ Record substitution not handled *)
record_substitution
end in
op_gtgteq
(Internal_event_unix.init (Some log_cfg)
(Some (internal_events config)) tt)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Updater.init (Node_data_version.protocol_dir (data_dir config))
in
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Starting the Tezos node..." % string
CamlinternalFormatBasics.End_of_format)
"Starting the Tezos node..." % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_gtgteq
(init_node sandbox checkpoint singleprocess config)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok node => _return node
|
Stdlib.Error
(cons
(Tezos_base__TzPervasives.Incorrect_history_mode_switch
{|
previous_mode := previous_mode;
next_mode := next_mode
|}) _) =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.String_literal
"Cannot switch from history mode '" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"' to '" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"'. Import a context from a corresponding snapshot or re-synchronize a node with an empty tezos node directory."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[Cannot switch from history mode '%a' to '%a'. Import a context from a corresponding snapshot or re-synchronize a node with an empty tezos node directory.@]"
% string) History_mode.pp previous_mode
History_mode.pp next_mode
| (Stdlib.Error _) as err => Lwt._return err
end))
(fun node =>
op_gtgteqquestion (init_rpc (rpc config) node)
(fun rpc =>
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The Tezos node is now running!" % string
CamlinternalFormatBasics.End_of_format)
"The Tezos node is now running!" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(apply wrap_promise
(apply retcode_of_unit_result_lwt
(Lwt_utils.never_ending tt)))
(fun retcode =>
op_gtgteq Lwt_exit.termination_thread
(fun x =>
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down the Tezos node..."
% string
CamlinternalFormatBasics.End_of_format)
"Shutting down the Tezos node..." %
string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Node.shutdown node)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down the RPC server..."
% string
CamlinternalFormatBasics.End_of_format)
"Shutting down the RPC server..."
% string))
(fun function_parameter =>
let 'tt := function_parameter
in
op_gtgteq
(Lwt_list.iter_p
RPC_server.shutdown rpc)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteq
(Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"BYE (" % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))
"BYE (%d)" % string)
x)
(fun function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(Internal_event_unix.close
tt)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
_return retcode))))))))))))))).
Definition process {A : Type}
(sandbox : option (option string)) (verbosity : list A)
(checkpoint : option string) (singleprocess : bool) (args : Node_shared_arg.t)
: variant :=
let verbosity :=
match verbosity with
| [] => None
| cons _ [] => Some Tezos_base__TzPervasives.Internal_event.Info
| _ => Some Tezos_base__TzPervasives.Internal_event.Debug
end in
let run :=
op_gtgteqquestion
(Node_shared_arg.read_and_patch_config_file
(Some
match sandbox with
| Some _ => true
| None => false
end) args)
(fun config =>
op_gtgteqquestion
match sandbox with
| Some _ =>
if equiv_decb (data_dir config) Node_config_file.default_data_dir
then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot use default data directory while in sandbox mode" %
string CamlinternalFormatBasics.End_of_format)
"Cannot use default data directory while in sandbox mode" %
string)
else
return_unit
| None => return_unit
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
match checkpoint with
| None => return_none
| Some s =>
match Block_header.of_b58check s with
| Some b => return_some b
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to parse the provided checkpoint (Base58Check-encoded)."
% string CamlinternalFormatBasics.End_of_format)
"Failed to parse the provided checkpoint (Base58Check-encoded)."
% string)
end
end
(fun checkpoint =>
op_gtgteqquestion
(Lwt_lock_file.is_locked
(Node_data_version.lock_file (data_dir config)))
(fun function_parameter =>
match function_parameter with
| false =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
run verbosity sandbox checkpoint singleprocess config)
(fun function_parameter =>
match function_parameter with
|
Unix_error Unix.EADDRINUSE "bind" % string
"" % string =>
op_gtgteq
(Lwt_list.fold_right_s
(fun addr =>
fun acc =>
op_gtgteq
(Node_config_file.resolve_rpc_listening_addrs
addr)
(fun x =>
Lwt._return (OCaml.Stdlib.app x acc)))
(listen_addrs (rpc config)) [])
(fun addrlist =>
fail
(Tezos_base__TzPervasives.RPC_Port_already_in_use
addrlist))
| exn => Lwt._return (error_exn exn)
end)
| true =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Data directory is locked by another process" %
string CamlinternalFormatBasics.End_of_format)
"Data directory is locked by another process" % string)
end)))) in
match Lwt_main.run run with
| Stdlib.Ok (0 | 2) =>
(* ❌ Variants not supported *)
variant
| Stdlib.Ok _ =>
(* ❌ Variants not supported *)
variant
| Stdlib.Error err =>
(* ❌ Variants not supported *)
variant
end.
Module Term.
Definition verbosity : Cmdliner.Term.t (list bool) :=
let doc :=
"Increase log level. Using $(b,-v) is equivalent to using $(b,TEZOS_LOG='* -> info'), and $(b,-vv) is equivalent to using $(b,TEZOS_LOG='* -> debug')."
% string in
op_and value
(op_and flag_all
(info (Some Node_shared_arg.Manpage.misc_section) None (Some doc) None
(cons "v" % string []))).
Definition sandbox : Cmdliner.Term.t (option (option string)) :=
let doc :=
"Run the daemon in sandbox mode. P2P to non-localhost addresses are disabled, and constants of the economic protocol can be altered with an optional JSON file. $(b,IMPORTANT): Using sandbox mode affects the node state and subsequent runs of Tezos node must also use sandbox mode. In order to run the node in normal mode afterwards, a full reset must be performed (by removing the node's data directory)."
% string in
op_and value
(op_and (opt (Some (Some None)) (some None (some None string)) None)
(info (Some Node_shared_arg.Manpage.misc_section)
(Some "FILE.json" % string) (Some doc) None
(cons "sandbox" % string []))).
Definition checkpoint : Cmdliner.Term.t (option string) :=
let doc :=
"When asked to take a block hash as a checkpoint, the daemon will only accept the chains that contains that block and those that might reach it."
% string in
op_and value
(op_and (opt None (some None string) None)
(info (Some Node_shared_arg.Manpage.misc_section)
(Some "<level>,<block_hash>" % string) (Some doc) None
(cons "checkpoint" % string []))).
Definition singleprocess : Cmdliner.Term.t bool :=
let doc :=
"When enabled, it deactivates block validation using an external process. Thus, the validation procedure is done in the same process as the node and might not be responding when doing extensive I/Os."
% string in
op_and value
(op_and flag
(info (Some Node_shared_arg.Manpage.misc_section) None (Some doc) None
(cons "singleprocess" % string []))).
Definition term : Cmdliner.Term.t unit :=
ret
(op_dollar
(op_dollar
(op_dollar (op_dollar (op_dollar (const process) sandbox) verbosity)
checkpoint) singleprocess) Node_shared_arg.Term.args).
End Term.
Module Manpage.
Definition command_description : string :=
"The $(b,run) command is meant to run the Tezos node. Most of its command line arguments corresponds to config file entries, and will have priority over the latter if used."
% string.
Definition description : list variant :=
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant []).
Definition debug : list variant :=
let log_sections :=
String.concat " " % string
(List.rev (Stdlib.op_exclamation Internal_event.Legacy_logging.sections))
in
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant []).
Definition examples : list variant :=
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant [])).
Definition man : list Cmdliner.Manpage.block :=
OCaml.Stdlib.app description
(OCaml.Stdlib.app Node_shared_arg.Manpage.args
(OCaml.Stdlib.app debug
(OCaml.Stdlib.app examples Node_shared_arg.Manpage.bugs))).
Definition info : Cmdliner.Term.info :=
Cmdliner.Term.info None (Some man) None None None None
(Some "Run the Tezos node" % string) None "run" % string.
End Manpage.
Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
(Term.term, Manpage.info).
src/bin_node/node_snapshot_command.ml 18 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Node_logging
let ( // ) = Filename.concat
let context_dir data_dir = data_dir // "context"
let store_dir data_dir = data_dir // "store"
(** Main *)
module Term = struct
type subcommand = Export | Import
let dir_cleaner data_dir =
lwt_log_notice "Cleaning directory %s because of failure" data_dir
>>= fun () ->
Lwt_utils_unix.remove_dir @@ store_dir data_dir
>>= fun () -> Lwt_utils_unix.remove_dir @@ context_dir data_dir
let process subcommand args snapshot_file block export_rolling =
let run =
Internal_event_unix.init ()
>>= fun () ->
Node_shared_arg.read_data_dir args
>>=? fun data_dir ->
let genesis = Genesis_chain.genesis in
match subcommand with
| Export ->
Node_data_version.ensure_data_dir data_dir
>>=? fun () ->
let context_root = context_dir data_dir in
let store_root = store_dir data_dir in
Store.init store_root
>>=? fun store ->
Context.init ~readonly:true context_root
>>= fun context_index ->
Snapshots.export
~export_rolling
~context_index
~store
~genesis:genesis.block
snapshot_file
block
>>=? fun () -> Store.close store |> return
| Import ->
Node_data_version.ensure_data_dir ~bare:true data_dir
>>=? fun () ->
Lwt_lock_file.create
~unlink_on_exit:true
(Node_data_version.lock_file data_dir)
>>=? fun () ->
Snapshots.import
~data_dir
~dir_cleaner
~genesis
~patch_context:Patch_context.patch_context
snapshot_file
block
in
match Lwt_main.run run with
| Ok () ->
`Ok ()
| Error err ->
`Error (false, Format.asprintf "%a" pp_print_error err)
let subcommand_arg =
let parser = function
| "export" ->
`Ok Export
| "import" ->
`Ok Import
| s ->
`Error ("invalid argument: " ^ s)
and printer ppf = function
| Export ->
Format.fprintf ppf "export"
| Import ->
Format.fprintf ppf "import"
in
let open Cmdliner.Arg in
let doc =
"Operation to perform. Possible values: $(b,export), $(b,import)."
in
required
& pos 0 (some (parser, printer)) None
& info [] ~docv:"OPERATION" ~doc
let file_arg =
let open Cmdliner.Arg in
required & pos 1 (some string) None & info [] ~docv:"FILE"
let blocks =
let open Cmdliner.Arg in
let doc = "Block hash of the block to export/import." in
value & opt (some string) None & info ~docv:"<block_hash>" ~doc ["block"]
let export_rolling =
let open Cmdliner in
let doc =
"Force export command to dump a minimal snapshot based on the rolling \
mode."
in
Arg.(
value & flag
& info ~docs:Node_shared_arg.Manpage.misc_section ~doc ["rolling"])
let term =
let open Cmdliner.Term in
ret
( const process $ subcommand_arg $ Node_shared_arg.Term.args $ file_arg
$ blocks $ export_rolling )
end
module Manpage = struct
let command_description =
"The $(b,snapshot) command is meant to export and import snapshots files."
let description =
[ `S "DESCRIPTION";
`P (command_description ^ " Several operations are possible: ");
`P
"$(b,export) allows to export a snapshot of the current node state \
into a file.";
`P "$(b,import) allows to import a snapshot from a given file." ]
let options = [`S "OPTIONS"]
let examples =
[ `S "EXAMPLES";
`I
( "$(b,Export a snapshot using the rolling mode)",
"$(mname) snapshot export latest.rolling --rolling" );
`I
( "$(b,Import a snapshot located in file.full)",
"$(mname) snapshot import file.full" ) ]
let man = description @ options @ examples @ Node_shared_arg.Manpage.bugs
let info = Cmdliner.Term.info ~doc:"Manage snapshots" ~man "snapshot"
end
let cmd = (Term.term, Manpage.info)
src/bin_node/node_snapshot_command.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Node_logging.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition context_dir (data_dir : string) : string :=
op_divdiv data_dir "context" % string.
Definition store_dir (data_dir : string) : string :=
op_divdiv data_dir "store" % string.
Module Term.
Inductive subcommand : Type :=
| Export : subcommand
| Import : subcommand.
Definition dir_cleaner (data_dir : string) : Lwt.t unit :=
op_gtgteq
(lwt_log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cleaning directory " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" because of failure" % string
CamlinternalFormatBasics.End_of_format)))
"Cleaning directory %s because of failure" % string) data_dir)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (apply Lwt_utils_unix.remove_dir (store_dir data_dir))
(fun function_parameter =>
let 'tt := function_parameter in
apply Lwt_utils_unix.remove_dir (context_dir data_dir))).
Definition process
(subcommand : subcommand) (args : Node_shared_arg.t)
(snapshot_file : string) (block : option string) (export_rolling : bool)
: variant :=
let run :=
op_gtgteq (Internal_event_unix.init None None tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Node_shared_arg.read_data_dir args)
(fun data_dir =>
let genesis := Genesis_chain.genesis in
match subcommand with
| Export =>
op_gtgteqquestion
(Node_data_version.ensure_data_dir None data_dir)
(fun function_parameter =>
let 'tt := function_parameter in
let context_root := context_dir data_dir in
let store_root := store_dir data_dir in
op_gtgteqquestion (Store.init None None store_root)
(fun store =>
op_gtgteq
(Context.init None None (Some true) context_root)
(fun context_index =>
op_gtgteqquestion
(Snapshots.export (Some export_rolling)
context_index store (block genesis)
snapshot_file block)
(fun function_parameter =>
let 'tt := function_parameter in
OCaml.Stdlib.reverse_apply (Store.close store)
_return))))
| Import =>
op_gtgteqquestion
(Node_data_version.ensure_data_dir (Some true) data_dir)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt_lock_file.create None (Some true)
(Node_data_version.lock_file data_dir))
(fun function_parameter =>
let 'tt := function_parameter in
Snapshots.import data_dir dir_cleaner
Patch_context.patch_context genesis snapshot_file
block))
end)) in
match Lwt_main.run run with
| Stdlib.Ok tt =>
(* ❌ Variants not supported *)
variant
| Stdlib.Error err =>
(* ❌ Variants not supported *)
variant
end.
Definition subcommand_arg : Cmdliner.Term.t subcommand :=
let parser (function_parameter : string) : variant :=
match function_parameter with
| "export" % string =>
(* ❌ Variants not supported *)
variant
| "import" % string =>
(* ❌ Variants not supported *)
variant
| s =>
(* ❌ Variants not supported *)
variant
end
with printer
(ppf : Stdlib.Format.formatter) (function_parameter : subcommand)
: unit :=
match function_parameter with
| Export =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "export" % string
CamlinternalFormatBasics.End_of_format) "export" % string)
| Import =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "import" % string
CamlinternalFormatBasics.End_of_format) "import" % string)
end in
let doc :=
"Operation to perform. Possible values: $(b,export), $(b,import)." %
string in
op_and required
(op_and (pos None 0 (some None (parser, printer)) None)
(info None (Some "OPERATION" % string) (Some doc) None [])).
Definition file_arg : Cmdliner.Term.t string :=
op_and required
(op_and (pos None 1 (some None string) None)
(info None (Some "FILE" % string) None None [])).
Definition blocks : Cmdliner.Term.t (option string) :=
let doc := "Block hash of the block to export/import." % string in
op_and value
(op_and (opt None (some None string) None)
(info None (Some "<block_hash>" % string) (Some doc) None
(cons "block" % string []))).
Definition export_rolling : Cmdliner.Term.t bool :=
let doc :=
"Force export command to dump a minimal snapshot based on the rolling mode."
% string in
op_and value
(op_and flag
(info (Some Node_shared_arg.Manpage.misc_section) None (Some doc) None
(cons "rolling" % string []))).
Definition term : Cmdliner.Term.t unit :=
ret
(op_dollar
(op_dollar
(op_dollar
(op_dollar (op_dollar (const process) subcommand_arg)
Node_shared_arg.Term.args) file_arg) blocks) export_rolling).
End Term.
Module Manpage.
Definition command_description : string :=
"The $(b,snapshot) command is meant to export and import snapshots files." %
string.
Definition description : list variant :=
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant []))).
Definition options : list variant :=
cons
(* ❌ Variants not supported *)
variant [].
Definition examples : list variant :=
cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant [])).
Definition man : list Cmdliner.Manpage.block :=
OCaml.Stdlib.app description
(OCaml.Stdlib.app options
(OCaml.Stdlib.app examples Node_shared_arg.Manpage.bugs)).
Definition info : Cmdliner.Term.info :=
Cmdliner.Term.info None (Some man) None None None None
(Some "Manage snapshots" % string) None "snapshot" % string.
End Manpage.
Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
(Term.term, Manpage.info).
src/bin_node/patch_context.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Genesis_chain
let patch_context key_json ctxt =
( match key_json with
| None ->
Lwt.return ctxt
| Some (key, json) ->
Tezos_storage.Context.set
ctxt
[key]
(Data_encoding.Binary.to_bytes_exn Data_encoding.json json) )
>>= fun ctxt ->
(* TODO: this code seems to be shared with validator.ml, function run:
can we share it? *)
match Registered_protocol.get genesis.protocol with
| None ->
assert false (* FIXME error *)
| Some proto -> (
let module Proto = (val proto) in
let ctxt = Shell_context.wrap_disk_context ctxt in
Proto.init
ctxt
{
level = 0l;
proto_level = 0;
predecessor = genesis.block;
timestamp = genesis.time;
validation_passes = 0;
operations_hash = Operation_list_list_hash.empty;
fitness = [];
context = Context_hash.zero;
}
>>= function
| Error _ ->
assert false (* FIXME error *)
| Ok {context; _} ->
let context = Shell_context.unwrap_disk_context context in
Lwt.return context )
src/bin_node/patch_context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Genesis_chain.
Definition patch_context
(key_json : option (string * Tezos_base__TzPervasives.Data_encoding.json))
(ctxt : Tezos_storage.Context.context) : Lwt.t Tezos_storage.Context.t :=
op_gtgteq
match key_json with
| None => Lwt._return ctxt
| Some (key, json) =>
Tezos_storage.Context.set ctxt (cons key [])
(Data_encoding.Binary.to_bytes_exn Data_encoding.json json)
end
(fun ctxt =>
match Registered_protocol.get (protocol genesis) with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some proto =>
let Proto := projT2 proto in
let ctxt := Shell_context.wrap_disk_context ctxt in
op_gtgteq
(Proto.(Tezos_protocol_updater__Registered_protocol.T.init) ctxt
{|
level :=
(* ❌ Constant of type int32 is converted to int *)
0; proto_level := 0; predecessor := block genesis;
timestamp := time genesis; validation_passes := 0;
operations_hash := Operation_list_list_hash.empty; fitness := [];
context := Context_hash.zero |})
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| Stdlib.Ok {| context := context |} =>
let context := Shell_context.unwrap_disk_context context in
Lwt._return context
end)
end).
src/bin_sandbox/command_accusations.ml 419 errors
open Flextesa
open Internal_pervasives
open Console
let default_attempts = 35
let little_mesh_with_bakers ?base_port ?generate_kiln_config state ~protocol
~starting_level ~node_exec ~client_exec ~bakers () =
Helpers.clear_root state
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.[af "Ready to start"; af "Root path deleted."]
>>= fun () ->
let block_interval = 1 in
let (protocol, baker_list) =
let d = protocol in
let open Tezos_protocol in
let bakers = List.take d.bootstrap_accounts bakers in
( {
d with
time_between_blocks = [block_interval; 0];
bootstrap_accounts =
List.map d.bootstrap_accounts ~f:(fun (n, v) ->
if List.exists bakers ~f:(fun baker -> n = fst baker) then (n, v)
else (n, 1_000L));
},
bakers )
in
let net_size = 3 in
let topology = Test_scenario.Topology.(mesh "Simple" net_size) in
let all_nodes =
Test_scenario.Topology.build ~protocol ~exec:node_exec topology ?base_port
in
Helpers.dump_connections state all_nodes
>>= fun () ->
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.(
all_defaults state ~nodes:all_nodes
@ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]) ;
Test_scenario.Network.(start_up state ~client_exec (make all_nodes))
>>= fun () ->
let baker nth_node =
let nth_baker = nth_node mod List.length baker_list in
let key_name = sprintf "b%d" nth_baker in
let node = List.nth_exn all_nodes nth_node in
let client = Tezos_client.of_node node ~exec:client_exec in
let baker_account = List.nth_exn baker_list nth_baker in
let bak =
Tezos_client.Keyed.make
client
~key_name
~secret_key:(Tezos_protocol.Account.private_key (fst baker_account))
in
Tezos_client.Keyed.initialize state bak >>= fun _ -> return (client, bak)
in
baker 0
>>= fun (client_0, baker_0) ->
baker 1
>>= fun (client_1, baker_1) ->
baker 2
>>= fun (client_2, baker_2) ->
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.(
arbitrary_commands_for_each_and_all_clients
state
~clients:[client_0; client_1; client_2]) ;
Asynchronous_result.map_option generate_kiln_config ~f:(fun kiln_config ->
Tezos_client.rpc
state
~client:client_0
`Get
~path:"/chains/main/chain_id"
>>= fun chain_id_json ->
let network_id =
match chain_id_json with `String s -> s | _ -> assert false
in
Kiln.Configuration_directory.generate
state
kiln_config
~peers:
(List.map all_nodes ~f:(fun {Tezos_node.p2p_port; _} -> p2p_port))
~sandbox_json:(Tezos_protocol.sandbox_path ~config:state protocol)
~nodes:
(List.map all_nodes ~f:(fun {Tezos_node.rpc_port; _} ->
sprintf "http://localhost:%d" rpc_port))
~bakers:
(List.map
protocol.Tezos_protocol.bootstrap_accounts
~f:(fun (account, _) ->
Tezos_protocol.Account.(name account, pubkey_hash account)))
~network_string:network_id
~node_exec
~client_exec
>>= fun () ->
return EF.(wf "Kiln was configured at `%s`" kiln_config.path))
>>= fun _ ->
let bake msg baker = Tezos_client.Keyed.bake state baker msg in
List.fold
(List.init (starting_level - 1) ~f:(fun n -> n))
~init:(return ()) (* We are already at level 1, we bake 7 times: *)
~f:(fun pm n ->
pm
>>= fun () ->
bake
(sprintf "first bakes: [%d/%d]" (n + 1) (starting_level - 1))
baker_0)
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
all_nodes
(`Equal_to starting_level)
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.
[ af "Clients ready";
af "Node 0 baked %d times." (starting_level - 1);
af "All nodes should be at level %d." starting_level ]
>>= fun () ->
return (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2)
let wait_for_operation_in_mempools state ~nodes:all_nodes ~kind ~client_exec
how =
let (init, combine) =
match how with `At_least_one -> (false, ( || )) | `All -> (true, ( && ))
in
Helpers.wait_for state ~attempts:default_attempts ~seconds:8. (fun _ ->
List.fold ~init:(return init) all_nodes ~f:(fun prev_m node ->
prev_m
>>= fun prev ->
let client = Tezos_client.of_node node ~exec:client_exec in
Tezos_client.mempool_has_operation state ~client ~kind
>>= fun client_result -> return (combine client_result prev))
>>= function
| true ->
return (`Done ())
| false ->
return
(`Not_done
(sprintf "Waiting for %S to show up in the mempool" kind)))
let simple_double_baking ~starting_level ?generate_kiln_config ~state ~protocol
~base_port node_exec client_exec () =
little_mesh_with_bakers
~bakers:1
~protocol
state
~node_exec
~client_exec
()
~base_port
~starting_level
?generate_kiln_config
>>= fun (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) ->
let kill_nth nth = List.nth_exn all_nodes nth |> Helpers.kill_node state in
let restart_nth nth =
List.nth_exn all_nodes nth |> Helpers.restart_node ~client_exec state
in
let number_of_lonely_bakes = 1 in
kill_nth 1
>>= fun () ->
kill_nth 2
>>= fun () ->
Loop.n_times (number_of_lonely_bakes - 1) (fun _ ->
Tezos_client.Keyed.bake state baker_0 "Bake-on-0")
>>= fun () ->
(* Bake one block less and inject an operation to generate a different
block's hash *)
Tezos_client.Keyed.endorse state baker_0 "endorsing lonely bake-on-0"
>>= fun () ->
Tezos_client.Keyed.bake state baker_0 "Bake-on-0"
>>= fun () ->
Tezos_client.get_block_header state ~client:client_0 `Head
>>= fun baking_0_header ->
(* This baking will have better fitness so other nodes will have to fetch it. *)
Tezos_client.Keyed.endorse state baker_0 "endorsing lonely bake-on-0"
>>= fun () ->
System.sleep 1.
>>= fun () ->
kill_nth 0
>>= fun () ->
restart_nth 1
>>= fun () ->
restart_nth 2
>>= fun () ->
Loop.n_times number_of_lonely_bakes (fun _ ->
Tezos_client.Keyed.bake state baker_1 "Bake-on-1")
>>= fun () ->
Tezos_client.get_block_header state ~client:client_1 `Head
>>= fun baking_1_header ->
restart_nth 0
>>= fun () ->
Tezos_client.Keyed.bake state baker_0 "Bake-on-0"
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
all_nodes
(`At_least (starting_level + number_of_lonely_bakes + 1))
>>= fun () ->
Tezos_client.rpc
state
~client:client_1
`Get
~path:"/chains/main/blocks/head/hash"
>>= fun head_hash_json ->
Interactive_test.Pauser.generic
state
EF.
[ af "About to forge";
ef_json "Baking 0" baking_0_header;
ef_json "Baking 1" baking_1_header;
ef_json "Head hash" head_hash_json ]
>>= fun () ->
Tezos_client.Keyed.forge_and_inject
state
baker_1
~json:
(let clean header =
let open Jqo in
remove_field header ~name:"hash"
|> remove_field ~name:"chain_id"
|> remove_field ~name:"protocol"
in
`O
[ ("branch", head_hash_json);
( "contents",
`A
[ `O
[ ("kind", `String "double_baking_evidence");
("bh1", clean baking_0_header);
("bh2", clean baking_1_header) ] ] ) ])
>>= fun result ->
Interactive_test.Pauser.generic
state
EF.
[ af "Waiting for accuser to notice double baking";
ef_json "Result of injection" result;
af
"All nodes reaching level %d"
(starting_level + number_of_lonely_bakes + 1) ]
>>= fun () ->
wait_for_operation_in_mempools
state
~nodes:all_nodes
~kind:"double_baking_evidence"
~client_exec
`All
>>= fun () ->
Tezos_client.Keyed.bake
state
baker_2
(sprintf "all at lvl %d" (starting_level + number_of_lonely_bakes + 1))
>>= fun () ->
let last_level = starting_level + number_of_lonely_bakes + 2 in
Interactive_test.Pauser.generic
state
EF.[af "Just baked what's the level? Vs %d" last_level]
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
all_nodes
(`Equal_to last_level)
>>= fun () ->
Helpers.wait_for state ~attempts:10 ~seconds:4. (fun _ ->
Tezos_client.block_has_operation
state
~client:client_2
~level:last_level
~kind:"double_baking_evidence"
>>= function
| true ->
return (`Done ())
| false ->
return
(`Not_done
(sprintf
"Waiting for accusation to show up in block %d"
last_level)))
>>= fun () -> say state EF.(af "Test done.")
let find_endorsement_in_mempool state ~client =
Helpers.wait_for state ~attempts:4 ~seconds:2. (fun _ ->
Tezos_client.find_applied_in_mempool state ~client ~f:(fun o ->
Jqo.field o ~k:"contents"
|> Jqo.list_exists ~f:(fun op ->
(* Dbg.e EF.(ef_json "op" op) ; *)
Jqo.field op ~k:"kind" = `String "endorsement"))
>>= function
| None ->
return (`Not_done (sprintf "No endorsement so far"))
| Some e ->
return (`Done e))
let simple_double_endorsement ~starting_level ?generate_kiln_config ~state
~protocol ~base_port node_exec client_exec () =
little_mesh_with_bakers
~bakers:2
~protocol
state
~node_exec
~client_exec
()
~starting_level
~base_port
?generate_kiln_config
>>= fun (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) ->
(* 2 bakers â baker_0 and baker_2 are for the same key on â nodes *)
assert (
Tezos_client.Keyed.(
baker_0.key_name = baker_2.key_name
&& baker_0.secret_key = baker_2.secret_key) ) ;
let node_0 = List.nth_exn all_nodes 0 in
let node_1 = List.nth_exn all_nodes 1 in
let node_2 = List.nth_exn all_nodes 2 in
let baker_1_n0 =
let open Tezos_client.Keyed in
let {key_name; secret_key; _} = baker_1 in
make client_0 ~key_name ~secret_key
in
Tezos_client.Keyed.initialize state baker_1_n0
>>= fun _ ->
Helpers.kill_node state node_1
>>= fun () ->
Helpers.kill_node state node_2
>>= fun () ->
(* Inject an operation to generate a different block's hash *)
Tezos_client.Keyed.endorse state baker_0 "endorsing lonely bake-on-0"
>>= fun () ->
Tezos_client.Keyed.bake state baker_0 "baker-0 baking with node 0"
>>= fun () ->
Tezos_client.Keyed.endorse state baker_0 "baker-0 endorsing with node 0"
>>= fun () ->
find_endorsement_in_mempool state ~client:client_0
>>= fun endorsement_0 ->
Tezos_client.Keyed.endorse state baker_1_n0 "baker-1 endorsing with node 0"
>>= fun () ->
Helpers.kill_node state node_0
>>= fun () ->
Helpers.restart_node state node_2 ~client_exec
>>= fun () ->
Tezos_client.Keyed.bake state baker_2 "baker-0 baking with node 2"
>>= fun () ->
Tezos_client.Keyed.endorse state baker_2 "baker-0 endorsing with node 2"
>>= fun () ->
find_endorsement_in_mempool state ~client:client_2
>>= fun endorsement_1 ->
say
state
EF.(
list
[ ef_json "Endorsement 0:" endorsement_0;
ef_json "Endorsement 1:" endorsement_1 ])
>>= fun () ->
Helpers.restart_node state node_1 ~client_exec
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
[node_1; node_2]
(`Equal_to (starting_level + 1))
>>= fun () ->
Helpers.restart_node state node_0 ~client_exec
>>= fun () ->
(* TODO: understand why this kick in the butt is necessary for node
2 (seems like the node was not getting to level starting+2 without
this). *)
Helpers.kill_node state node_2
>>= fun () ->
Helpers.restart_node state node_2 ~client_exec
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
all_nodes
(`Equal_to (starting_level + 1))
>>= fun () ->
Tezos_client.rpc
state
~client:client_1
`Get
~path:"/chains/main/blocks/head/hash"
>>= fun head_hash_json ->
let double_endorsement =
let transform_endorsement endorsement =
let branch = Jqo.field ~k:"branch" endorsement in
let signature = Jqo.field ~k:"signature" endorsement in
let contents =
match Jqo.field ~k:"contents" endorsement with
| `A [one] ->
one
| _ ->
assert false
in
`O
[("branch", branch); ("operations", contents); ("signature", signature)]
in
let inlined_endorsement_1 = transform_endorsement endorsement_0 in
let inlined_endorsement_2 = transform_endorsement endorsement_1 in
`O
[ ("branch", head_hash_json);
( "contents",
`A
[ `O
[ ("kind", `String "double_endorsement_evidence");
("op1", inlined_endorsement_1);
("op2", inlined_endorsement_2) ] ] ) ]
in
Interactive_test.Pauser.generic
state
EF.[ef_json "About to forge" double_endorsement]
>>= fun () ->
Tezos_client.Keyed.forge_and_inject state baker_1 ~json:double_endorsement
>>= fun result ->
Interactive_test.Pauser.generic
state
EF.[ef_json "Result of injection" result]
>>= fun () ->
wait_for_operation_in_mempools
state
~nodes:[node_1]
~kind:"double_endorsement_evidence"
~client_exec
`All
>>= fun () ->
let last_level = starting_level + 2 in
Tezos_client.Keyed.bake state baker_1 (sprintf "level %d" last_level)
>>= fun () ->
Tezos_client.Keyed.endorse
state
baker_1
(sprintf "endorse level %d" last_level)
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
all_nodes
(`Equal_to last_level)
>>= fun () ->
Helpers.wait_for state ~attempts:10 ~seconds:4. (fun _ ->
(* We check that client-2 sees the evidence from baker-1 *)
Tezos_client.block_has_operation
state
~client:client_2
~level:last_level
~kind:"double_endorsement_evidence"
>>= function
| true ->
return (`Done ())
| false ->
return
(`Not_done
(sprintf
"Waiting for accusation to show up in block %d"
last_level)))
>>= fun () -> say state EF.(af "Test done.")
let with_accusers ~state ~protocol ~base_port node_exec accuser_exec
client_exec () =
Helpers.clear_root state
>>= fun () ->
let block_interval = 2 in
let (protocol, baker_0_account) =
let d = protocol in
let open Tezos_protocol in
let baker = List.hd_exn d.bootstrap_accounts in
( {
d with
time_between_blocks = [block_interval; block_interval * 2];
bootstrap_accounts =
List.map d.bootstrap_accounts ~f:(fun (n, v) ->
if n = fst baker then (n, v) else (n, 1_000L));
},
baker )
in
let topology =
Test_scenario.Topology.(
net_in_the_middle "AT-" (mesh "Mid" 3) (mesh "Main" 4) (mesh "Acc" 4))
in
let (mesh_nodes, intermediary_nodes, accuser_nodes) =
Test_scenario.Topology.build ~protocol ~exec:node_exec topology ~base_port
in
let all_nodes = mesh_nodes @ intermediary_nodes @ accuser_nodes in
Helpers.dump_connections state all_nodes
>>= fun () ->
Test_scenario.Network.(start_up state ~client_exec (make all_nodes))
>>= fun () ->
let start_accuser nod =
let client = Tezos_client.of_node nod ~exec:client_exec in
let acc = Tezos_daemon.accuser_of_node ~exec:accuser_exec ~client nod in
Running_processes.start state (Tezos_daemon.process acc ~state)
>>= fun _ -> return ()
in
List_sequential.iter accuser_nodes ~f:start_accuser
>>= fun () ->
let key_name = "b0" in
let baker nth =
let node = List.nth_exn all_nodes nth in
let client = Tezos_client.of_node node ~exec:client_exec in
let bak =
Tezos_client.Keyed.make
client
~key_name
~secret_key:(Tezos_protocol.Account.private_key (fst baker_0_account))
in
Tezos_client.Keyed.initialize state bak >>= fun _ -> return (client, bak)
in
baker 0
>>= fun (client_0, baker_0) ->
baker 1
>>= fun (client_1, baker_1) ->
baker 2
>>= fun (client_2, baker_2) ->
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.(
all_defaults state ~nodes:all_nodes
@ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
@ arbitrary_commands_for_each_and_all_clients
state
~clients:[client_0; client_1; client_2]) ;
let pause ?force msgs = Interactive_test.Pauser.generic state ?force msgs in
let starting_level = 10 in
List.fold
(List.init (starting_level - 1) ~f:(fun n -> n))
~init:(return ()) (* We are already at level 1, we bake 7 times: *)
~f:(fun pm n ->
pm
>>= fun () ->
Tezos_client.Keyed.bake
state
baker_0
(sprintf "first bakes: [%d/%d]" (n + 1) (starting_level - 1)))
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
all_nodes
(`Equal_to starting_level)
>>= fun () ->
pause
EF.
[ af "Two clients ready";
af "Node 0 baked %d times." (starting_level - 1);
af "All nodes should be at level %d." starting_level ]
>>= fun () ->
let transfer _msg client =
let dest =
List.random_element_exn protocol.Tezos_protocol.bootstrap_accounts
|> fst |> Tezos_protocol.Account.pubkey_hash
in
Tezos_client.successful_client_cmd
state
~client
[ "--wait";
"none";
"transfer";
"1";
"from";
key_name;
"to";
dest;
"--fee";
"0.05" ]
>>= fun res ->
say
state
EF.(
desc
(af "Successful transfer (%s):" client.Tezos_client.id)
(ocaml_string_list res#out))
in
List_sequential.iter intermediary_nodes ~f:(fun x ->
Helpers.kill_node state x)
>>= fun () ->
let kill_all_but nodes iths =
List_sequential.iteri nodes ~f:(fun ith n ->
if List.mem iths ith ~equal:Int.equal then return ()
else Helpers.kill_node state n)
in
let kill_nth_node nodes nth =
Helpers.kill_node
state
(Option.value_exn ~message:"kill_nth_node" (List.nth nodes nth))
in
let restart_nth_node nodes nth =
Helpers.restart_node
state
~client_exec
(Option.value_exn ~message:"restart_nth_node" (List.nth nodes nth))
in
let get_block_header ~client block =
let path =
sprintf
"/chains/main/blocks/%s/header"
(match block with `Head -> "head" | `Level i -> Int.to_string i)
in
Tezos_client.rpc state ~client `Get ~path
in
kill_all_but mesh_nodes [0]
>>= fun () ->
let number_of_lonely_bakes = 1 in
pause EF.[af "Node 0 is the only one alive"]
>>= fun () ->
transfer "node0 only alive" client_0
>>= fun () ->
Loop.n_times number_of_lonely_bakes (fun n ->
Tezos_client.Keyed.bake state baker_0 (sprintf "n0 only alive: %d" n))
>>= fun () ->
get_block_header ~client:client_0 `Head
>>= fun _baking_0_header ->
Tezos_client.Keyed.endorse state baker_0 "self-endorsing"
>>= fun () ->
Tezos_client.Keyed.bake state baker_0 "baking self-endorsement"
>>= fun () ->
kill_nth_node mesh_nodes 0
>>= fun () ->
restart_nth_node mesh_nodes 1
>>= fun () ->
transfer "node1 only one alive" client_1
>>= fun () ->
Loop.n_times number_of_lonely_bakes (fun _ ->
Tezos_client.Keyed.bake state baker_1 "after transfer")
>>= fun () ->
get_block_header ~client:client_1 `Head
>>= fun _baking_1_header ->
kill_nth_node mesh_nodes 1
>>= fun () ->
pause
EF.
[ af "Node 0 was killed";
af "Node 1 was restarted";
af "Node 1 transfered";
af "Node 1 baked";
af "Node 1 was killed" ]
>>= fun () ->
List.fold ~init:(return ()) intermediary_nodes ~f:(fun prev x ->
prev >>= fun () -> Helpers.restart_node state ~client_exec x)
>>= fun () ->
let node_0 = List.nth_exn mesh_nodes 0 in
let except_0 l = List.filter l ~f:Tezos_node.(fun n -> n.id <> node_0.id) in
List_sequential.iter
(except_0 mesh_nodes)
~f:(Helpers.restart_node state ~client_exec)
>>= fun () ->
pause EF.[af "All nodes restarted Except 0"]
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
(except_0 all_nodes)
(`At_least (starting_level + number_of_lonely_bakes))
>>= fun () ->
Helpers.restart_node state ~client_exec node_0
>>= fun () ->
pause EF.[af "Restarted 0"]
>>= fun () ->
Helpers.wait_for state ~attempts:default_attempts ~seconds:8. (fun _ ->
List.fold ~init:(return false) accuser_nodes ~f:(fun prev_m node ->
prev_m
>>= fun prev ->
let client = Tezos_client.of_node node ~exec:client_exec in
Tezos_client.mempool_has_operation
state
~client
~kind:"double_baking_evidence"
>>= fun client_result -> return (client_result || prev))
>>= function
| true ->
return (`Done ())
| false ->
return
(`Not_done
(sprintf "Waiting for accusation to show up in the mempool")))
>>= fun () ->
Tezos_client.Keyed.bake
state
baker_2
(sprintf "all at lvl %d" (starting_level + number_of_lonely_bakes + 1))
>>= fun () ->
Helpers.wait_for state ~attempts:10 ~seconds:4. (fun _ ->
let level = starting_level + number_of_lonely_bakes + 2 in
Tezos_client.block_has_operation
state
~client:client_2
~level
~kind:"double_baking_evidence"
>>= function
| true ->
return (`Done ())
| false ->
return
(`Not_done
(sprintf "Waiting for accusation to show up in block %d" level)))
>>= fun () ->
pause
EF.
[ af "One more baking (level should include accusation)";
af
"All nodes reaching level %d"
(starting_level + number_of_lonely_bakes + 2) ]
>>= fun () ->
Tezos_client.Keyed.bake state baker_1 "a couple more"
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
all_nodes
(`At_least (starting_level + number_of_lonely_bakes + 1))
let cmd ~pp_error () =
let open Cmdliner in
let open Term in
let pf fmt = ksprintf (fun s -> `P s) fmt in
let tests =
let test variant name title man = (variant, name, title, man) in
[ test
`With_accusers
"with-accusers"
"Network With Accusers"
(pf
"This test builds a network with 3 interconnected meshes: Main, \
Intermediate, and Accuser.");
test
`Simple_double_baking
"simple-double-baking"
"Simple Network With Manual Double Baking Accusation"
(pf
"This test builds a very simple 3-piece network, makes a baker \
double bake and $(i,manually) inserts a double-baking accusation.");
test
`Simple_double_endorsing
"simple-double-endorsing"
"Simple Network With Manual Double Endorsing Accusation"
(pf
"This test builds a very simple 3-piece network, makes a baker \
double endorse and $(i,manually) inserts a double-baking \
accusation.") ]
in
Test_command_line.Run_command.make
~pp_error
( pure
(fun test
base_port
(`Starting_level starting_level)
bnod
bcli
accex
generate_kiln_config
protocol
state
->
let checks () =
let acc = if test = `With_accusers then [accex] else [] in
Helpers.System_dependencies.precheck
state
`Or_fail
~executables:(acc @ [bnod; bcli])
in
let actual_test () =
match test with
| `With_accusers ->
checks ()
>>= fun () ->
with_accusers ~state bnod accex bcli ~base_port () ~protocol
| `Simple_double_baking ->
checks ()
>>= fun () ->
simple_double_baking
~state
bnod
bcli
~base_port
?generate_kiln_config
~starting_level
~protocol
()
| `Simple_double_endorsing ->
checks ()
>>= fun () ->
simple_double_endorsement
~state
bnod
bcli
~base_port
?generate_kiln_config
~starting_level
~protocol
()
in
(state, Interactive_test.Pauser.run_test ~pp_error state actual_test))
$ Arg.(
required
(pos
0
(some (enum (List.map tests ~f:(fun (v, n, _, _) -> (n, v)))))
None
(info [] ~docv:"TEST-NAME" ~doc:"Choose which test to run.")))
$ Arg.(
value & opt int 30_000
& info ["base-port"] ~doc:"Base port number to build upon.")
$ Arg.(
pure (fun l -> `Starting_level l)
$ value
(opt
int
5
(info
["starting-level"]
~doc:
"Initial block-level to reach before actually starting \
the test.")))
$ Tezos_executable.cli_term `Node "tezos"
$ Tezos_executable.cli_term `Client "tezos"
$ Tezos_executable.cli_term `Accuser "tezos"
$ Kiln.Configuration_directory.cli_term ()
$ Tezos_protocol.cli_term ()
$ Test_command_line.cli_state ~name:"accusing" () )
(let doc = "Sandbox networks which record double-bakings." in
let man : Manpage.block list =
[ `S "ACCUSATION TESTS";
pf
"This command provides %d tests which use network sandboxes to \
make double-bakings and double-endorsements happen."
(List.length tests);
`Blocks
(List.map tests ~f:(fun (_, n, tit, m) ->
`Blocks [pf "* $(b,`%s`): $(i,%s)." n tit; `Noblank; m])) ]
in
info ~man ~doc "accusations")
src/bin_sandbox/command_accusations.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition default_attempts : Z := 35.
Definition little_mesh_with_bakers {A B C D E F G H : Type}
(base_port : option A) (generate_kiln_config : option B) (state : C)
(protocol : D) (starting_level : Z) (node_exec : E) (client_exec : F)
(bakers : G) (function_parameter : unit) : H :=
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let block_interval := 1 in
let '(protocol, baker_list) :=
let d := protocol in
op_startypeminuserrorstar in
let net_size := 3 in
let topology := op_startypeminuserrorstar in
let all_nodes :=
op_startypeminuserrorstar protocol node_exec topology base_port in
op_startypeminuserrorstar (op_startypeminuserrorstar state all_nodes)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar state op_startypeminuserrorstar
in
op_startypeminuserrorstar op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
let baker {I : Type} (nth_node : Z) : I :=
let nth_baker :=
Z.modulo nth_node (OCaml.List.length baker_list) in
let key_name :=
op_startypeminuserrorstar "b%d" % string nth_baker in
let node := op_startypeminuserrorstar all_nodes nth_node in
let client := op_startypeminuserrorstar node client_exec in
let baker_account :=
op_startypeminuserrorstar baker_list nth_baker in
let bak :=
op_startypeminuserrorstar client key_name
(op_startypeminuserrorstar (fst baker_account)) in
op_startypeminuserrorstar
(op_startypeminuserrorstar state bak)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar (client, bak)) in
op_startypeminuserrorstar (baker 0)
(fun function_parameter =>
let '(client_0, baker_0) := function_parameter in
op_startypeminuserrorstar (baker 1)
(fun function_parameter =>
let '(client_1, baker_1) := function_parameter in
op_startypeminuserrorstar (baker 2)
(fun function_parameter =>
let '(client_2, baker_2) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state
op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar generate_kiln_config
(fun kiln_config =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state client_0
(* ❌ Variants not supported *)
variant "/chains/main/chain_id" % string)
(fun chain_id_json =>
let network_id :=
match chain_id_json with
| String s => s
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
kiln_config
(List.map all_nodes
(* ❌ expected an argument *)
expected_argument
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar))
(op_startypeminuserrorstar state
protocol)
(List.map all_nodes
(* ❌ expected an argument *)
expected_argument
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
"http://localhost:%d" % string
op_startypeminuserrorstar))
(List.map
(Tezos_protocol.bootstrap_accounts
protocol)
(* ❌ expected an argument *)
expected_argument
(fun function_parameter =>
let '(account, _) :=
function_parameter in
op_startypeminuserrorstar))
network_id node_exec client_exec)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
op_startypeminuserrorstar))))
(fun function_parameter =>
let '_ := function_parameter in
let bake {I J K : Type} (msg : I) (baker : J)
: K :=
op_startypeminuserrorstar state baker msg in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(Stdlib.List.init (Z.sub starting_level 1)
(* ❌ expected an argument *)
expected_argument (fun n => n))
(op_startypeminuserrorstar tt)
(fun pm =>
fun n =>
op_startypeminuserrorstar pm
(fun function_parameter =>
let 'tt := function_parameter in
bake
(op_startypeminuserrorstar
"first bakes: [%d/%d]" %
string (Z.add n 1)
(Z.sub starting_level 1))
baker_0)))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8 all_nodes
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(all_nodes, client_0, baker_0,
client_1, baker_1, client_2,
baker_2)))))))))))).
Definition wait_for_operation_in_mempools {A B C D E : Type}
(state : A) (all_nodes : B) (kind : C) (client_exec : D) (how : variant)
: E :=
let '(init, combine) :=
match how with
| At_least_one => (false, orb)
| All => (true, andb)
end in
op_startypeminuserrorstar state default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar (op_startypeminuserrorstar init) all_nodes
(fun prev_m =>
fun node =>
op_startypeminuserrorstar prev_m
(fun prev =>
let client := op_startypeminuserrorstar node client_exec in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client kind)
(fun client_result =>
op_startypeminuserrorstar (combine client_result prev)))))
(fun function_parameter =>
match function_parameter with
| true =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
| false =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end)).
Definition simple_double_baking {A B C D E F G : Type}
(starting_level : Z) (generate_kiln_config : option A) (state : B)
(protocol : C) (base_port : D) (node_exec : E) (client_exec : F)
(function_parameter : unit) : G :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(little_mesh_with_bakers (Some base_port) generate_kiln_config state
protocol starting_level node_exec client_exec 1 tt)
(fun function_parameter =>
let
'(all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) :=
function_parameter in
let kill_nth {H I : Type} (nth : H) : I :=
OCaml.Stdlib.reverse_apply (op_startypeminuserrorstar all_nodes nth)
(op_startypeminuserrorstar state) in
let restart_nth {H I : Type} (nth : H) : I :=
OCaml.Stdlib.reverse_apply (op_startypeminuserrorstar all_nodes nth)
(op_startypeminuserrorstar client_exec state) in
let number_of_lonely_bakes := 1 in
op_startypeminuserrorstar (kill_nth 1)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (kill_nth 2)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar (Z.sub number_of_lonely_bakes 1)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar state baker_0 "Bake-on-0" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0
"endorsing lonely bake-on-0" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0
"Bake-on-0" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client_0
(* ❌ Variants not supported *)
variant)
(fun baking_0_header =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0
"endorsing lonely bake-on-0" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(* ❌ Float constant 1. is approximated by the integer 1 *)
1)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (kill_nth 0)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(restart_nth 1)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(restart_nth 2)
(fun function_parameter =>
let 'tt := function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
number_of_lonely_bakes
(fun function_parameter =>
let '_ :=
function_parameter in
op_startypeminuserrorstar
state baker_1
"Bake-on-1" % string))
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state client_1
(* ❌ Variants not supported *)
variant)
(fun baking_1_header =>
op_startypeminuserrorstar
(restart_nth 0)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state baker_0
"Bake-on-0" %
string)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
all_nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_1
(* ❌ Variants not supported *)
variant
"/chains/main/blocks/head/hash"
%
string)
(fun
head_hash_json
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_1
(let
clean
{H
I
:
Type}
(header
:
H)
: I :=
op_startypeminuserrorstar
in
(* ❌ Variants not supported *)
variant))
(fun
result
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(wait_for_operation_in_mempools
state
all_nodes
"double_baking_evidence"
%
string
client_exec
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_2
(op_startypeminuserrorstar
"all at lvl %d"
%
string
(Z.add
(Z.add
starting_level
number_of_lonely_bakes)
1)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
let
last_level :=
Z.add
(Z.add
starting_level
number_of_lonely_bakes)
2
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
all_nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
10
(* ❌ Float constant 4. is approximated by the integer 4 *)
4
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_2
last_level
"double_baking_evidence"
%
string)
(fun
function_parameter
=>
match
function_parameter
with
|
true
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
|
false
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar)))))))))))))))))))))))))).
Definition find_endorsement_in_mempool {A B C : Type} (state : A) (client : B)
: C :=
op_startypeminuserrorstar state 4
(* ❌ Float constant 2. is approximated by the integer 2 *)
2
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(fun o =>
OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar o "contents" % string)
(op_startypeminuserrorstar
(fun op =>
equiv_decb (op_startypeminuserrorstar op "kind" % string)
(* ❌ Variants not supported *)
variant))))
(fun function_parameter =>
match function_parameter with
| None =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
| Some e =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end)).
Definition simple_double_endorsement {A B C D E F G : Type}
(starting_level : Z) (generate_kiln_config : option A) (state : B)
(protocol : C) (base_port : D) (node_exec : E) (client_exec : F)
(function_parameter : unit) : G :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(little_mesh_with_bakers (Some base_port) generate_kiln_config state
protocol starting_level node_exec client_exec 2 tt)
(fun function_parameter =>
let
'(all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) :=
function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert op_startypeminuserrorstar in
let node_0 := op_startypeminuserrorstar all_nodes 0 in
let node_1 := op_startypeminuserrorstar all_nodes 1 in
let node_2 := op_startypeminuserrorstar all_nodes 2 in
let baker_1_n0 := op_startypeminuserrorstar in
op_startypeminuserrorstar (op_startypeminuserrorstar state baker_1_n0)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state node_1)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state node_2)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0
"endorsing lonely bake-on-0" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0
"baker-0 baking with node 0" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0
"baker-0 endorsing with node 0" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(find_endorsement_in_mempool state client_0)
(fun endorsement_0 =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_1_n0
"baker-1 endorsing with node 0" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state node_0)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
node_2 client_exec)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
baker_2
"baker-0 baking with node 2" %
string)
(fun function_parameter =>
let 'tt := function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state baker_2
"baker-0 endorsing with node 2"
% string)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(find_endorsement_in_mempool
state client_2)
(fun endorsement_1 =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state node_1
client_exec)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
(cons
node_1
(cons
node_2
[]))
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
node_0
client_exec)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
node_2)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
node_2
client_exec)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
all_nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_1
(* ❌ Variants not supported *)
variant
"/chains/main/blocks/head/hash"
%
string)
(fun
head_hash_json
=>
let
double_endorsement :=
let
transform_endorsement
{H
:
Type}
(endorsement
:
H)
: variant :=
let
branch :=
op_startypeminuserrorstar
"branch"
%
string
endorsement
in
let
signature :=
op_startypeminuserrorstar
"signature"
%
string
endorsement
in
let
contents :=
match
op_startypeminuserrorstar
"contents"
%
string
endorsement
with
|
A
(cons
one
[])
=>
one
|
_
=>
(* ❌ Assert instruction is not handled. *)
assert
false
end
in
(* ❌ Variants not supported *)
variant
in
let
inlined_endorsement_1 :=
transform_endorsement
endorsement_0
in
let
inlined_endorsement_2 :=
transform_endorsement
endorsement_1
in
(* ❌ Variants not supported *)
variant
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_1
double_endorsement)
(fun
result
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(wait_for_operation_in_mempools
state
(cons
node_1
[])
"double_endorsement_evidence"
%
string
client_exec
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
let
last_level :=
Z.add
starting_level
2
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_1
(op_startypeminuserrorstar
"level %d"
%
string
last_level))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_1
(op_startypeminuserrorstar
"endorse level %d"
%
string
last_level))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
all_nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
10
(* ❌ Float constant 4. is approximated by the integer 4 *)
4
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_2
last_level
"double_endorsement_evidence"
%
string)
(fun
function_parameter
=>
match
function_parameter
with
|
true
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
|
false
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar)))))))))))))))))))))))))))))).
Definition with_accusers {A B C D E F G : Type}
(state : A) (protocol : B) (base_port : C) (node_exec : D) (accuser_exec : E)
(client_exec : F) (function_parameter : unit) : G :=
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state)
(fun function_parameter =>
let 'tt := function_parameter in
let block_interval := 2 in
let '(protocol, baker_0_account) :=
let d := protocol in
op_startypeminuserrorstar in
let topology := op_startypeminuserrorstar in
let '(mesh_nodes, intermediary_nodes, accuser_nodes) :=
op_startypeminuserrorstar protocol node_exec topology base_port in
let all_nodes :=
OCaml.Stdlib.app mesh_nodes
(OCaml.Stdlib.app intermediary_nodes accuser_nodes) in
op_startypeminuserrorstar (op_startypeminuserrorstar state all_nodes)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
let start_accuser {H I : Type} (nod : H) : I :=
let client := op_startypeminuserrorstar nod client_exec in
let acc := op_startypeminuserrorstar accuser_exec client nod in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
(op_startypeminuserrorstar acc state))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar tt) in
op_startypeminuserrorstar
(op_startypeminuserrorstar accuser_nodes start_accuser)
(fun function_parameter =>
let 'tt := function_parameter in
let key_name := "b0" % string in
let baker {H I : Type} (nth : H) : I :=
let node := op_startypeminuserrorstar all_nodes nth in
let client := op_startypeminuserrorstar node client_exec in
let bak :=
op_startypeminuserrorstar client key_name
(op_startypeminuserrorstar (fst baker_0_account)) in
op_startypeminuserrorstar
(op_startypeminuserrorstar state bak)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar (client, bak)) in
op_startypeminuserrorstar (baker 0)
(fun function_parameter =>
let '(client_0, baker_0) := function_parameter in
op_startypeminuserrorstar (baker 1)
(fun function_parameter =>
let '(client_1, baker_1) := function_parameter in
op_startypeminuserrorstar (baker 2)
(fun function_parameter =>
let '(client_2, baker_2) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state
op_startypeminuserrorstar in
let pause {H I J : Type}
(force : option H) (msgs : I) : J :=
op_startypeminuserrorstar state force msgs in
let starting_level := 10 in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(Stdlib.List.init (Z.sub starting_level 1)
(* ❌ expected an argument *)
expected_argument (fun n => n))
(op_startypeminuserrorstar tt)
(fun pm =>
fun n =>
op_startypeminuserrorstar pm
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state
baker_0
(op_startypeminuserrorstar
"first bakes: [%d/%d]" % string
(Z.add n 1)
(Z.sub starting_level 1)))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8 all_nodes
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(pause None op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let transfer {H I J : Type}
(_msg : H) (client : I) : J :=
let dest :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar
(Tezos_protocol.bootstrap_accounts
protocol)) fst)
op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
client
(cons "--wait" % string
(cons "none" % string
(cons "transfer" % string
(cons "1" % string
(cons "from" % string
(cons key_name
(cons "to" % string
(cons dest
(cons
"--fee" %
string
(cons
"0.05" %
string [])))))))))))
(fun res =>
op_startypeminuserrorstar state
op_startypeminuserrorstar) in
op_startypeminuserrorstar
(op_startypeminuserrorstar
intermediary_nodes
(fun x =>
op_startypeminuserrorstar state
x))
(fun function_parameter =>
let 'tt := function_parameter in
let kill_all_but {H I J : Type}
(nodes : H) (iths : I) : J :=
op_startypeminuserrorstar nodes
(fun ith =>
fun n =>
if
Stdlib.List.mem iths ith
op_startypeminuserrorstar
then
op_startypeminuserrorstar
tt
else
op_startypeminuserrorstar
state n) in
let kill_nth_node {H I : Type}
(nodes : list H) (nth : Z)
: I :=
op_startypeminuserrorstar state
(op_startypeminuserrorstar
"kill_nth_node" % string
(Stdlib.List.nth nodes nth))
in
let restart_nth_node {H I : Type}
(nodes : list H) (nth : Z)
: I :=
op_startypeminuserrorstar state
client_exec
(op_startypeminuserrorstar
"restart_nth_node" % string
(Stdlib.List.nth nodes nth))
in
let get_block_header {H I : Type}
(client : H) (block : variant)
: I :=
let path :=
op_startypeminuserrorstar
"/chains/main/blocks/%s/header"
% string
match block with
| Head => "head" % string
| Level i =>
op_startypeminuserrorstar
i
end in
op_startypeminuserrorstar state
client
(* ❌ Variants not supported *)
variant path in
op_startypeminuserrorstar
(kill_all_but mesh_nodes
(cons 0 []))
(fun function_parameter =>
let 'tt := function_parameter
in
let number_of_lonely_bakes :=
1 in
op_startypeminuserrorstar
(pause None
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(transfer
"node0 only alive" %
string client_0)
(fun function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
number_of_lonely_bakes
(fun n =>
op_startypeminuserrorstar
state baker_0
(op_startypeminuserrorstar
"n0 only alive: %d"
% string n)))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(get_block_header
client_0
(* ❌ Variants not supported *)
variant)
(fun
_baking_0_header
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_0
"self-endorsing"
% string)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_0
"baking self-endorsement"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(kill_nth_node
mesh_nodes
0)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(restart_nth_node
mesh_nodes
1)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(transfer
"node1 only one alive"
%
string
client_1)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
number_of_lonely_bakes
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
state
baker_1
"after transfer"
%
string))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(get_block_header
client_1
(* ❌ Variants not supported *)
variant)
(fun
_baking_1_header
=>
op_startypeminuserrorstar
(kill_nth_node
mesh_nodes
1)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(pause
None
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
tt)
intermediary_nodes
(fun
prev
=>
fun
x
=>
op_startypeminuserrorstar
prev
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
state
client_exec
x)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
let
node_0 :=
op_startypeminuserrorstar
mesh_nodes
0
in
let
except_0
{H
:
Type}
(l
:
H
->
bool)
: (list
H)
->
list
H :=
Stdlib.List.filter
l
(* ❌ expected an argument *)
expected_argument
op_startypeminuserrorstar
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(except_0
mesh_nodes)
(op_startypeminuserrorstar
state
client_exec))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(pause
None
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_exec
node_0)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(pause
None
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
false)
accuser_nodes
(fun
prev_m
=>
fun
node
=>
op_startypeminuserrorstar
prev_m
(fun
prev
=>
let
client :=
op_startypeminuserrorstar
node
client_exec
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client
"double_baking_evidence"
%
string)
(fun
client_result
=>
op_startypeminuserrorstar
(orb
client_result
prev)))))
(fun
function_parameter
=>
match
function_parameter
with
|
true
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
|
false
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_2
(op_startypeminuserrorstar
"all at lvl %d"
%
string
(Z.add
(Z.add
starting_level
number_of_lonely_bakes)
1)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
10
(* ❌ Float constant 4. is approximated by the integer 4 *)
4
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
let
level :=
Z.add
(Z.add
starting_level
number_of_lonely_bakes)
2
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_2
level
"double_baking_evidence"
%
string)
(fun
function_parameter
=>
match
function_parameter
with
|
true
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
|
false
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(pause
None
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_1
"a couple more"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
all_nodes
(* ❌ Variants not supported *)
variant)))))))))))))))))))))))))))))))))))).
Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
src/bin_sandbox/command_daemons_protocol_change.ml 230 errors
open Flextesa
open Internal_pervasives
open Console
let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt
let wait_for_voting_period ?level_within_period state ~client ~attempts period
=
let period_name = Tezos_protocol.Voting_period.to_string period in
let message =
sprintf
"Waiting for voting period: `%s`%s"
period_name
(Option.value_map
level_within_period
~default:""
~f:(sprintf " (and level-within-period ⥠%d)"))
in
Console.say state EF.(wf "%s" message)
>>= fun () ->
Helpers.wait_for state ~attempts ~seconds:10. (fun nth ->
Asynchronous_result.map_option level_within_period ~f:(fun lvl ->
Tezos_client.rpc
state
~client
`Get
~path:"/chains/main/blocks/head/metadata"
>>= fun json ->
try
let voting_period_position =
Jqo.field ~k:"level" json
|> Jqo.field ~k:"voting_period_position"
|> Jqo.get_int
in
return (voting_period_position >= lvl)
with e ->
failf
"Cannot get level.voting_period_position: %s"
(Printexc.to_string e))
>>= fun lvl_ok ->
Tezos_client.rpc
state
~client
`Get
~path:"/chains/main/blocks/head/votes/current_period_kind"
>>= function
| `String p when p = period_name && (lvl_ok = None || lvl_ok = Some true)
->
return (`Done (nth - 1))
| _ ->
Tezos_client.successful_client_cmd
state
~client
["show"; "voting"; "period"]
>>= fun res ->
Console.say
state
EF.(
desc_list
(wf "Voting period:")
[markdown_verbatim (String.concat ~sep:"\n" res#out)])
>>= fun () -> return (`Not_done message))
let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports
?generate_kiln_config ~node_exec ~client_exec ~first_baker_exec
~first_endorser_exec ~first_accuser_exec ~second_baker_exec
~second_endorser_exec ~second_accuser_exec ~admin_exec ~new_protocol_path
~extra_dummy_proposals_batch_size ~extra_dummy_proposals_batch_levels
~waiting_attempts test_variant () =
Helpers.System_dependencies.precheck
state
`Or_fail
~protocol_paths:[new_protocol_path]
~executables:
[ node_exec;
client_exec;
first_baker_exec;
first_endorser_exec;
first_accuser_exec;
second_baker_exec;
second_endorser_exec;
second_accuser_exec ]
>>= fun () ->
Test_scenario.network_with_protocol
?external_peer_ports
~protocol
~size
~base_port
state
~node_exec
~client_exec
>>= fun (nodes, protocol) ->
Tezos_client.rpc
state
~client:(Tezos_client.of_node (List.hd_exn nodes) ~exec:client_exec)
`Get
~path:"/chains/main/chain_id"
>>= fun chain_id_json ->
let network_id =
match chain_id_json with `String s -> s | _ -> assert false
in
let accusers =
List.concat_map nodes ~f:(fun node ->
let client = Tezos_client.of_node node ~exec:client_exec in
[ Tezos_daemon.accuser_of_node
~exec:first_accuser_exec
~client
node
~name_tag:"first";
Tezos_daemon.accuser_of_node
~exec:second_accuser_exec
~client
node
~name_tag:"second" ])
in
List_sequential.iter accusers ~f:(fun acc ->
Running_processes.start state (Tezos_daemon.process acc ~state)
>>= fun _ -> return ())
>>= fun () ->
let keys_and_daemons =
let pick_a_node_and_client idx =
match List.nth nodes ((1 + idx) mod List.length nodes) with
| Some node ->
(node, Tezos_client.of_node node ~exec:client_exec)
| None ->
assert false
in
Tezos_protocol.bootstrap_accounts protocol
|> List.filter_mapi ~f:(fun idx acc ->
let (node, client) = pick_a_node_and_client idx in
let key = Tezos_protocol.Account.name acc in
if List.mem ~equal:String.equal no_daemons_for key then None
else
Some
( acc,
client,
[ Tezos_daemon.baker_of_node
~exec:first_baker_exec
~client
node
~key
~name_tag:"first";
Tezos_daemon.baker_of_node
~exec:second_baker_exec
~client
~name_tag:"second"
node
~key;
Tezos_daemon.endorser_of_node
~exec:first_endorser_exec
~name_tag:"first"
~client
node
~key;
Tezos_daemon.endorser_of_node
~exec:second_endorser_exec
~name_tag:"second"
~client
node
~key ] ))
in
List_sequential.iter keys_and_daemons ~f:(fun (acc, client, daemons) ->
Tezos_client.bootstrapped ~state client
>>= fun () ->
let (key, priv) = Tezos_protocol.Account.(name acc, private_key acc) in
Tezos_client.import_secret_key ~state client key priv
>>= fun () ->
say
state
EF.(
desc_list
(haf "Registration-as-delegate:")
[ desc (af "Client:") (af "%S" client.Tezos_client.id);
desc (af "Key:") (af "%S" key) ])
>>= fun () ->
Tezos_client.register_as_delegate ~state client key
>>= fun () ->
say
state
EF.(
desc_list
(haf "Starting daemons:")
[ desc (af "Client:") (af "%S" client.Tezos_client.id);
desc (af "Key:") (af "%S" key) ])
>>= fun () ->
List_sequential.iter daemons ~f:(fun daemon ->
Running_processes.start state (Tezos_daemon.process daemon ~state)
>>= fun _ -> return ()))
>>= fun () ->
let client_0 =
Tezos_client.of_node (List.nth_exn nodes 0) ~exec:client_exec
in
let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.(
all_defaults state ~nodes
@ [secret_keys state ~protocol]
@ arbitrary_commands_for_each_and_all_clients
state
~make_admin
~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
(*
For each node we try to see if the node knows about the protocol,
if it does we're good, if not we inject it.
This is because `inject` fails when the node already knows a protocol.
*)
List.fold ~init:(return None) nodes ~f:(fun prevm nod ->
prevm
>>= fun _ ->
System.read_file state (new_protocol_path // "TEZOS_PROTOCOL")
>>= fun protocol ->
( try return Jqo.(of_string protocol |> field ~k:"hash" |> get_string)
with e ->
failf
"Cannot parse %s/TEZOS_PROTOCOL: %s"
new_protocol_path
(Printexc.to_string e) )
>>= fun hash ->
let client = Tezos_client.of_node ~exec:client_exec nod in
Tezos_client.rpc state ~client `Get ~path:"/protocols"
>>= fun protocols ->
match protocols with
| `A l
when List.exists l ~f:(function `String h -> h = hash | _ -> false) ->
Console.say
state
EF.(
wf
"Node `%s` already knows protocol `%s`."
nod.Tezos_node.id
hash)
>>= fun () -> return (Some hash)
| _ ->
let admin = make_admin client in
Tezos_admin_client.inject_protocol
admin
state
~path:new_protocol_path
>>= fun (_, new_protocol_hash) ->
( if new_protocol_hash = hash then
Console.say
state
EF.(
wf
"Injected protocol `%s` in `%s`"
new_protocol_hash
nod.Tezos_node.id)
else
failf
"Injecting protocol %s failed (â %s)"
new_protocol_hash
hash )
>>= fun () -> return (Some hash))
>>= fun prot_opt ->
( match prot_opt with
| Some s ->
return s
| None ->
failf "protocol injection problem?" )
>>= fun new_protocol_hash ->
Asynchronous_result.map_option generate_kiln_config ~f:(fun kiln_config ->
Kiln.Configuration_directory.generate
state
kiln_config
~peers:(List.map nodes ~f:(fun {Tezos_node.p2p_port; _} -> p2p_port))
~sandbox_json:(Tezos_protocol.sandbox_path ~config:state protocol)
~nodes:
(List.map nodes ~f:(fun {Tezos_node.rpc_port; _} ->
sprintf "http://localhost:%d" rpc_port))
~bakers:
(List.map
protocol.Tezos_protocol.bootstrap_accounts
~f:(fun (account, _) ->
Tezos_protocol.Account.(name account, pubkey_hash account)))
~network_string:network_id
~node_exec
~client_exec
~protocol_execs:
[ ( protocol.Tezos_protocol.hash,
first_baker_exec,
first_endorser_exec );
(new_protocol_hash, second_baker_exec, second_endorser_exec) ]
>>= fun () ->
let msg =
EF.(
desc
(shout "Kiln-Configuration DONE")
(wf "Kiln was configured at `%s`" kiln_config.path))
in
Console.say state msg >>= fun () -> return msg)
>>= fun kiln_info_opt ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:waiting_attempts
~seconds:10.
nodes
(* TODO: wait for /chains/main/blocks/head/votes/listings to be
non-empty instead of counting blocks *)
(`At_least protocol.Tezos_protocol.blocks_per_voting_period)
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.
[ wf "Test becomes interactive.";
Option.value kiln_info_opt ~default:(wf "");
wf "Please type `q` to start a voting/protocol-change period." ]
~force:true
>>= fun () ->
wait_for_voting_period
state
~client:client_0
~attempts:waiting_attempts
`Proposal
~level_within_period:3
>>= fun _ ->
let submit_prop acc client hash =
Tezos_client.successful_client_cmd
state
~client
[ "submit";
"proposals";
"for";
Tezos_protocol.Account.name acc;
hash;
"--force" ]
>>= fun _ ->
Console.sayf
state
Fmt.(
fun ppf () ->
pf ppf "%s voted for %s" (Tezos_protocol.Account.name acc) hash)
in
List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) ->
submit_prop acc client new_protocol_hash)
>>= fun () ->
let make_dummy_protocol_hashes t tag =
List.map
(List.init extra_dummy_proposals_batch_size ~f:(fun s ->
sprintf "proto-%s-%d" tag s))
~f:(fun s ->
(t, Tezos_crypto.Protocol_hash.(hash_string [s] |> to_b58check)))
in
let extra_dummy_protocols =
List.bind extra_dummy_proposals_batch_levels ~f:(fun l ->
make_dummy_protocol_hashes l (sprintf "%d" l))
in
Console.say
state
EF.(
wf
"Going to also vote for %s"
(String.concat ~sep:", " (List.map extra_dummy_protocols ~f:snd)))
>>= fun () ->
List_sequential.iteri
extra_dummy_protocols
~f:(fun nth (level, proto_hash) ->
match List.nth keys_and_daemons (nth / 19) with
| None ->
failf "Too many dummy protocols Vs available voting power (%d)" nth
| Some (acc, client, _) ->
wait_for_voting_period
state
~client:client_0
~attempts:waiting_attempts
`Proposal
~level_within_period:level
>>= fun _ -> submit_prop acc client proto_hash)
>>= fun () ->
wait_for_voting_period
state
~client:client_0
~attempts:waiting_attempts
`Testing_vote
>>= fun _ ->
List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) ->
Tezos_client.successful_client_cmd
state
~client
[ "submit";
"ballot";
"for";
Tezos_protocol.Account.name acc;
new_protocol_hash;
"yea" ]
>>= fun _ ->
Console.sayf
state
Fmt.(
fun ppf () ->
pf
ppf
"%s voted Yea to test %s"
(Tezos_protocol.Account.name acc)
new_protocol_hash))
>>= fun () ->
wait_for_voting_period
state
~client:client_0
~attempts:waiting_attempts
`Promotion_vote
>>= fun _ ->
let protocol_switch_will_happen =
match test_variant with
| `Full_upgrade ->
true
| `Nay_for_promotion ->
false
in
List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) ->
Tezos_client.successful_client_cmd
state
~client
[ "submit";
"ballot";
"for";
Tezos_protocol.Account.name acc;
new_protocol_hash;
(if protocol_switch_will_happen then "yea" else "nay") ]
>>= fun _ ->
Console.sayf
state
Fmt.(
fun ppf () ->
pf
ppf
"%s voted Yea to promote %s"
(Tezos_protocol.Account.name acc)
new_protocol_hash))
>>= fun () ->
wait_for_voting_period
state
~client:client_0
~attempts:waiting_attempts
`Proposal
>>= fun _ ->
Tezos_client.successful_client_cmd
state
~client:client_0
["show"; "voting"; "period"]
>>= fun res ->
let protocol_to_wait_for =
if protocol_switch_will_happen then new_protocol_hash
else protocol.Tezos_protocol.hash
in
Helpers.wait_for state ~attempts:waiting_attempts ~seconds:4. (fun _ ->
Console.say state EF.(wf "Checking actual protocol transition")
>>= fun () ->
Tezos_client.rpc
state
~client:client_0
`Get
~path:"/chains/main/blocks/head/metadata"
>>= fun json ->
( try Jqo.field ~k:"protocol" json |> Jqo.get_string |> return
with e -> failf "Cannot parse metadata: %s" (Printexc.to_string e) )
>>= fun proto_hash ->
if proto_hash <> protocol_to_wait_for then
return
(`Not_done
(sprintf
"Protocol not done: %s Vs %s"
proto_hash
protocol_to_wait_for))
else return (`Done ()))
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.
[ wf
"Test finished, protocol is now %s, things should keep baking."
protocol_to_wait_for;
markdown_verbatim (String.concat ~sep:"\n" res#out) ]
~force:true
let cmd ~pp_error () =
let open Cmdliner in
let open Term in
let variants =
[ ( "full-upgrade",
`Full_upgrade,
"Go through the whole voting process and do the protocol change." );
( "nay-for-promotion",
`Nay_for_promotion,
"Go through the whole voting process but vote Nay at the last period \
and hence stay on the same protocol." ) ]
in
Test_command_line.Run_command.make
~pp_error
( pure
(fun size
base_port
(`Attempts waiting_attempts)
(`External_peers external_peer_ports)
(`No_daemons_for no_daemons_for)
protocol
node_exec
client_exec
admin_exec
first_baker_exec
first_endorser_exec
first_accuser_exec
second_baker_exec
second_endorser_exec
second_accuser_exec
(`Protocol_path new_protocol_path)
(`Extra_dummy_proposals_batch_size
extra_dummy_proposals_batch_size)
(`Extra_dummy_proposals_batch_levels
extra_dummy_proposals_batch_levels)
generate_kiln_config
test_variant
state
->
let actual_test =
run
state
~size
~base_port
~protocol
~node_exec
~client_exec
~first_baker_exec
~first_endorser_exec
~first_accuser_exec
~second_baker_exec
~second_endorser_exec
~second_accuser_exec
~admin_exec
?generate_kiln_config
~external_peer_ports
~no_daemons_for
~new_protocol_path
test_variant
~waiting_attempts
~extra_dummy_proposals_batch_size
~extra_dummy_proposals_batch_levels
in
(state, Interactive_test.Pauser.run_test ~pp_error state actual_test))
$ Arg.(
value & opt int 5
& info ["size"; "S"] ~doc:"Set the size of the network.")
$ Arg.(
value & opt int 20_000
& info ["base-port"; "P"] ~doc:"Base port number to build upon.")
$ Arg.(
pure (fun n -> `Attempts n)
$ value
(opt
int
60
(info
["waiting-attempts"]
~doc:
"Number of attempts done while waiting for voting periods")))
$ Arg.(
pure (fun l -> `External_peers l)
$ value
(opt_all
int
[]
(info
["add-external-peer-port"]
~docv:"PORT-NUMBER"
~doc:"Add $(docv) to the peers of the network nodes.")))
$ Arg.(
pure (fun l -> `No_daemons_for l)
$ value
(opt_all
string
[]
(info
["no-daemons-for"]
~docv:"ACCOUNT-NAME"
~doc:"Do not start daemons for $(docv).")))
$ Tezos_protocol.cli_term ()
$ Tezos_executable.cli_term `Node "tezos"
$ Tezos_executable.cli_term `Client "tezos"
$ Tezos_executable.cli_term `Admin "tezos"
$ Tezos_executable.cli_term `Baker "first"
$ Tezos_executable.cli_term `Endorser "first"
$ Tezos_executable.cli_term `Accuser "first"
$ Tezos_executable.cli_term `Baker "second"
$ Tezos_executable.cli_term `Endorser "second"
$ Tezos_executable.cli_term `Accuser "second"
$ Arg.(
pure (fun p -> `Protocol_path p)
$ required
(pos
0
(some string)
None
(info
[]
~doc:"The protocol to inject and vote on."
~docv:"PROTOCOL-PATH")))
$ Arg.(
pure (fun l -> `Extra_dummy_proposals_batch_size l)
$ value
(opt
int
0
(info
["extra-dummy-proposals-batch-size"]
~docv:"NUMBER"
~doc:"Submit $(docv) extra proposals per batch.")))
$ Arg.(
pure (fun x -> `Extra_dummy_proposals_batch_levels x)
$ value
(opt
(list ~sep:',' int)
[]
(info
["extra-dummy-proposals-batch-levels"]
~docv:"NUMBER"
~doc:
"Set the levels within the proposal period where batches \
of extra proposals appear, e.g. `3,5,7`.")))
$ Kiln.Configuration_directory.cli_term ()
$ Arg.(
let doc =
sprintf
"Which variant of the test to run (one of {%s})"
( List.map ~f:(fun (n, _, _) -> n) variants
|> String.concat ~sep:", " )
in
value
(opt
(enum (List.map variants ~f:(fun (n, v, _) -> (n, v))))
`Full_upgrade
(info ["test-variant"] ~doc)))
$ Test_command_line.cli_state ~name:"daemons-upgrade" () )
(let doc =
"Vote and Protocol-upgrade with bakers, endorsers, and accusers."
in
let man : Manpage.block list =
[ `S "DAEMONS-UPGRADE TEST";
`P
"This test builds and runs a sandbox network to do a full voting \
round followed by a protocol change while all the daemons.";
`P
(sprintf
"There are for now %d variants (see option `--test-variant`):"
(List.length variants));
`Blocks
(List.concat_map variants ~f:(fun (n, _, desc) ->
[`Noblank; `P (sprintf "* `%s`: %s" n desc)]));
`P "The test is interactive-only:";
`Blocks
(List.concat_mapi
~f:(fun i s -> [`Noblank; `P (sprintf "%d) %s" (i + 1) s)])
[ "It starts a sandbox assuming the protocol of the `--first-*` \
executables (use the `--protocol-hash` option to make sure \
it matches).";
"An interactive pause is done to let the user play with the \
`first` protocol.";
"Once the user quits the prompt (`q` or `quit` command), a \
full voting round happens with a single proposal: the one at \
`PROTOCOL-PATH` (which should be the one understood by the \
`--second-*` executables).";
"Once the potential protocol switch has happened (and been \
verified), the test re-enters an interactive prompt to let \
the user play with the protocol (the first or second one, \
depending on the `--test-variant` option)." ]) ]
in
info "daemons-upgrade" ~man ~doc)
src/bin_sandbox/command_daemons_protocol_change.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition failf {A B : Type} (fmt : A) : B :=
op_startypeminuserrorstar
(fun s =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant) fmt.
Definition wait_for_voting_period {A B C D E F : Type}
(level_within_period : option A) (state : B) (client : C) (attempts : D)
(period : E) : F :=
let period_name := op_startypeminuserrorstar period in
let message :=
op_startypeminuserrorstar "Waiting for voting period: `%s`%s" % string
period_name
(op_startypeminuserrorstar level_within_period "" % string
(op_startypeminuserrorstar " (and level-within-period ≥ %d)" % string))
in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state attempts
(* ❌ Float constant 10. is approximated by the integer 10 *)
10
(fun nth =>
op_startypeminuserrorstar
(op_startypeminuserrorstar level_within_period
(fun lvl =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(* ❌ Variants not supported *)
variant "/chains/main/blocks/head/metadata" % string)
(fun json =>
(* ❌ Try-with are not handled *)
try
(let voting_period_position :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar "level" % string json)
(op_startypeminuserrorstar
"voting_period_position" % string))
op_startypeminuserrorstar in
op_startypeminuserrorstar
(OCaml.Stdlib.ge voting_period_position lvl)))))
(fun lvl_ok =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(* ❌ Variants not supported *)
variant
"/chains/main/blocks/head/votes/current_period_kind" % string)
(fun function_parameter =>
match function_parameter with
| String p =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
| _ =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(cons "show" % string
(cons "voting" % string (cons "period" % string []))))
(fun res =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant))
end)))).
Definition run {A B C D E F G H I J K L M : Type}
(state : A) (protocol : B) (size : C) (base_port : D) (no_daemons_for : E)
(external_peer_ports : option F) (generate_kiln_config : option G)
(node_exec : H) (client_exec : H) (first_baker_exec : H)
(first_endorser_exec : H) (first_accuser_exec : H) (second_baker_exec : H)
(second_endorser_exec : H) (second_accuser_exec : H) (admin_exec : I)
(new_protocol_path : J) (extra_dummy_proposals_batch_size : Z)
(extra_dummy_proposals_batch_levels : K) (waiting_attempts : L)
(test_variant : variant) (function_parameter : unit) : M :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
(* ❌ Variants not supported *)
variant (cons new_protocol_path [])
(cons node_exec
(cons client_exec
(cons first_baker_exec
(cons first_endorser_exec
(cons first_accuser_exec
(cons second_baker_exec
(cons second_endorser_exec (cons second_accuser_exec [])))))))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar external_peer_ports protocol size base_port
state node_exec client_exec)
(fun function_parameter =>
let '(nodes, protocol) := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
(op_startypeminuserrorstar (op_startypeminuserrorstar nodes)
client_exec)
(* ❌ Variants not supported *)
variant "/chains/main/chain_id" % string)
(fun chain_id_json =>
let network_id :=
match chain_id_json with
| String s => s
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
let accusers :=
op_startypeminuserrorstar nodes
(fun node =>
let client := op_startypeminuserrorstar node client_exec in
cons
(op_startypeminuserrorstar first_accuser_exec client node
"first" % string)
(cons
(op_startypeminuserrorstar second_accuser_exec client
node "second" % string) [])) in
op_startypeminuserrorstar
(op_startypeminuserrorstar accusers
(fun acc =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
(op_startypeminuserrorstar acc state))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar tt)))
(fun function_parameter =>
let 'tt := function_parameter in
let keys_and_daemons :=
let pick_a_node_and_client {N O : Type} (idx : Z) : N * O :=
match
Stdlib.List.nth nodes
(Z.modulo (Z.add 1 idx) (OCaml.List.length nodes))
with
| Some node =>
(node, (op_startypeminuserrorstar node client_exec))
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar protocol)
(op_startypeminuserrorstar
(fun idx =>
fun acc =>
let '(node, client) := pick_a_node_and_client idx in
let key := op_startypeminuserrorstar acc in
if
Stdlib.List.mem no_daemons_for key
Stdlib.String.equal then
None
else
Some
(acc, client,
(cons
(op_startypeminuserrorstar first_baker_exec
client node key "first" % string)
(cons
(op_startypeminuserrorstar
second_baker_exec client
"second" % string node key)
(cons
(op_startypeminuserrorstar
first_endorser_exec "first" % string
client node key)
(cons
(op_startypeminuserrorstar
second_endorser_exec
"second" % string client node key)
[]))))))) in
op_startypeminuserrorstar
(op_startypeminuserrorstar keys_and_daemons
(fun function_parameter =>
let '(acc, client, daemons) := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client)
(fun function_parameter =>
let 'tt := function_parameter in
let '(key, priv) := op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client key priv)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
key)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar daemons
(fun daemon =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(op_startypeminuserrorstar
daemon state))
(fun function_parameter =>
let '_ := function_parameter
in
op_startypeminuserrorstar tt)))))))))
(fun function_parameter =>
let 'tt := function_parameter in
let client_0 :=
op_startypeminuserrorstar
(op_startypeminuserrorstar nodes 0) client_exec in
let make_admin := op_startypeminuserrorstar admin_exec in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state
op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar None) nodes
(fun prevm =>
fun nod =>
op_startypeminuserrorstar prevm
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
(op_startypeminuserrorstar
new_protocol_path
"TEZOS_PROTOCOL" % string))
(fun protocol =>
op_startypeminuserrorstar
(* ❌ Try-with are not handled *)
(try
(op_startypeminuserrorstar
op_startypeminuserrorstar))
(fun hash =>
let client :=
op_startypeminuserrorstar
client_exec nod in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
client
(* ❌ Variants not supported *)
variant "/protocols" % string)
(fun protocols =>
match protocols with
| A l =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(Some hash))
| _ =>
let admin := make_admin client
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
admin state
new_protocol_path)
(fun function_parameter =>
let
'(_, new_protocol_hash) :=
function_parameter in
op_startypeminuserrorstar
(if
equiv_decb
new_protocol_hash hash
then
op_startypeminuserrorstar
state
op_startypeminuserrorstar
else
failf
"Injecting protocol %s failed (≠ %s)"
% string
new_protocol_hash hash)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(Some hash)))
end))))))
(fun prot_opt =>
op_startypeminuserrorstar
match prot_opt with
| Some s => op_startypeminuserrorstar s
| None =>
failf "protocol injection problem?" % string
end
(fun new_protocol_hash =>
op_startypeminuserrorstar
(op_startypeminuserrorstar generate_kiln_config
(fun kiln_config =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
kiln_config op_startypeminuserrorstar
(op_startypeminuserrorstar state
protocol) op_startypeminuserrorstar
(List.map
(Tezos_protocol.bootstrap_accounts
protocol)
(* ❌ expected an argument *)
expected_argument
(fun function_parameter =>
let '(account, _) :=
function_parameter in
op_startypeminuserrorstar))
network_id node_exec client_exec
(cons
((Tezos_protocol.hash protocol),
first_baker_exec,
first_endorser_exec)
(cons
(new_protocol_hash,
second_baker_exec,
second_endorser_exec) [])))
(fun function_parameter =>
let 'tt := function_parameter in
let msg := op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar state msg)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar msg))))
(fun kiln_info_opt =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
waiting_attempts
(* ❌ Float constant 10. is approximated by the integer 10 *)
10 nodes
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar true)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(wait_for_voting_period (Some 3)
state client_0 waiting_attempts
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let '_ := function_parameter in
let submit_prop {N O P : Type}
(acc : N) (client : O) (hash :
string) : P :=
op_startypeminuserrorstar
(op_startypeminuserrorstar
state client
(cons "submit" % string
(cons "proposals" % string
(cons "for" % string
(cons
(op_startypeminuserrorstar
acc)
(cons hash
(cons
"--force" %
string [])))))))
(fun function_parameter =>
let '_ := function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar)
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
keys_and_daemons
(fun function_parameter =>
let '(acc, client, _) :=
function_parameter in
submit_prop acc client
new_protocol_hash))
(fun function_parameter =>
let 'tt := function_parameter
in
let make_dummy_protocol_hashes
{N O P : Type}
(t : N) (tag : O)
: (list (Z -> P)) ->
list (list P) :=
List.map
(Stdlib.List.init
extra_dummy_proposals_batch_size
(* ❌ expected an argument *)
expected_argument
(fun s =>
op_startypeminuserrorstar
"proto-%s-%d" %
string tag s))
(* ❌ expected an argument *)
expected_argument
(fun s =>
(t,
op_startypeminuserrorstar))
in
let extra_dummy_protocols :=
op_startypeminuserrorstar
extra_dummy_proposals_batch_levels
(fun l =>
make_dummy_protocol_hashes
l
(op_startypeminuserrorstar
"%d" % string l)) in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
extra_dummy_protocols
(fun nth =>
fun
function_parameter
=>
let
'(level,
proto_hash) :=
function_parameter
in
match
Stdlib.List.nth
keys_and_daemons
(Z.div nth 19)
with
| None =>
failf
"Too many dummy protocols Vs available voting power (%d)"
% string nth
|
Some
(acc, client,
_) =>
op_startypeminuserrorstar
(wait_for_voting_period
(Some level)
state
client_0
waiting_attempts
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let '_ :=
function_parameter
in
submit_prop
acc client
proto_hash)
end))
(fun function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(wait_for_voting_period
None state
client_0
waiting_attempts
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let '_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
keys_and_daemons
(fun
function_parameter
=>
let
'(acc,
client,
_) :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client
(cons
"submit"
%
string
(cons
"ballot"
%
string
(cons
"for"
%
string
(cons
(op_startypeminuserrorstar
acc)
(cons
new_protocol_hash
(cons
"yea"
%
string
[])))))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar)))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(wait_for_voting_period
None state
client_0
waiting_attempts
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let '_ :=
function_parameter
in
let
protocol_switch_will_happen :=
match
test_variant
with
|
Full_upgrade
=>
true
|
Nay_for_promotion
=>
false
end in
op_startypeminuserrorstar
(op_startypeminuserrorstar
keys_and_daemons
(fun
function_parameter
=>
let
'(acc,
client,
_) :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client
(cons
"submit"
%
string
(cons
"ballot"
%
string
(cons
"for"
%
string
(cons
(op_startypeminuserrorstar
acc)
(cons
new_protocol_hash
(cons
(if
protocol_switch_will_happen
then
"yea"
%
string
else
"nay"
%
string)
[])))))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(wait_for_voting_period
None
state
client_0
waiting_attempts
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_0
(cons
"show"
%
string
(cons
"voting"
%
string
(cons
"period"
%
string
[]))))
(fun
res
=>
let
protocol_to_wait_for :=
if
protocol_switch_will_happen
then
new_protocol_hash
else
Tezos_protocol.hash
protocol
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
waiting_attempts
(* ❌ Float constant 4. is approximated by the integer 4 *)
4
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
client_0
(* ❌ Variants not supported *)
variant
"/chains/main/blocks/head/metadata"
%
string)
(fun
json
=>
op_startypeminuserrorstar
(* ❌ Try-with are not handled *)
(try
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar
"protocol"
%
string
json)
op_startypeminuserrorstar)
op_startypeminuserrorstar))
(fun
proto_hash
=>
if
nequiv_decb
proto_hash
protocol_to_wait_for
then
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
else
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant)))))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar
true))))))))))))))))))))).
Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
src/bin_sandbox/command_ledger_baking.ml 255 errors
open Flextesa
open Internal_pervasives
let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt
let ledger_prompt_notice state ~ef ?(button = `Checkmark) () =
let button_str =
match button with
| `Checkmark ->
"â"
| `X ->
"â"
| `Both ->
"â and â at the same time"
in
Console.say
state
EF.(
desc
(shout "Ledger-prompt")
(list [ef; wf "Press %s on the ledger." button_str]))
let assert_failure state msg f () =
Console.say state EF.(wf "Asserting %s" msg)
>>= fun () ->
Asynchronous_result.bind_on_error
(f () >>= fun _ -> return `Worked)
~f:(fun ~result:_ _ -> return `Didn'tWork)
>>= function `Worked -> failf "%s" msg | `Didn'tWork -> return ()
let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt
let assert_ a = if a then return () else failf "Assertion failed"
let assert_eq to_string ~expected ~actual =
if expected = actual then return ()
else
failf
"Assertion failed: expected %s but got %s"
(to_string expected)
(to_string actual)
let rec ask state ef =
Console.say state EF.(list [ef; wf " (y/n)?"])
>>= fun () ->
System_error.catch Lwt_io.read_char Lwt_io.stdin
>>= function
| 'y' | 'Y' -> return true | 'n' | 'N' -> return false | _ -> ask state ef
let ask_assert state ef () = ask state ef >>= fun b -> assert_ b
let with_ledger_prompt state message expectation ~f =
ledger_prompt_notice
state
()
~button:(match expectation with `Succeeds -> `Checkmark | `Fails -> `X)
~ef:
EF.(
list
[ message;
wf "\n\n";
wf
( match expectation with
| `Succeeds ->
">> ACCEPT THIS <<"
| `Fails ->
">> REJECT THIS <<" ) ])
>>= fun () ->
match expectation with
| `Succeeds ->
f () >>= fun _ -> Console.say state EF.(wf "> Got response: ACCEPTED")
| `Fails ->
assert_failure state "expected failure" f ()
>>= fun () -> Console.say state EF.(wf "> Got response: REJECTED")
let with_ledger_test_reject_and_succeed state ef f =
with_ledger_prompt state ef `Fails ~f
>>= fun () -> with_ledger_prompt state ef `Succeeds ~f
let assert_hwms state ~client ~uri ~main ~test =
Console.say
state
EF.(wf "Asserting main HWM = %d and test HWM = %d" main test)
>>= fun () ->
Tezos_client.Ledger.get_hwm state ~client ~uri
>>= fun {main = main_actual; test = test_actual; _} ->
assert_eq string_of_int ~actual:main_actual ~expected:main
>>= fun () -> assert_eq string_of_int ~actual:test_actual ~expected:test
let get_chain_id state ~client =
Tezos_client.rpc state ~client `Get ~path:"/chains/main/chain_id"
>>= (function
| `String x ->
return x
| _ ->
failf "Failed to parse chain_id JSON from node")
>>= fun chain_id_string ->
return (Tezos_crypto.Chain_id.of_b58check_exn chain_id_string)
let get_head_block_hash state ~client () =
Tezos_client.rpc state ~client `Get ~path:"/chains/main/blocks/head/hash"
>>= function
| `String x ->
return x
| _ ->
failf "Failed to parse block hash JSON from node"
let forge_endorsement state ~client ~chain_id ~level () =
get_head_block_hash state ~client ()
>>= fun branch ->
let json =
`O
[ ("branch", `String branch);
( "contents",
`A
[ `O
[ ("kind", `String "endorsement");
("level", `Float (float_of_int level)) ] ] ) ]
in
Tezos_client.rpc
state
~client
~path:"/chains/main/blocks/head/helpers/forge/operations"
(`Post (Ezjsonm.to_string json))
>>= function
| `String operation_bytes ->
let endorsement_magic_byte = "02" in
return
( endorsement_magic_byte
^ (chain_id |> Tezos_crypto.Chain_id.to_hex |> Hex.show)
^ operation_bytes )
| _ ->
failf "Failed to forge operation or parse result"
let forge_delegation state ~client ~src ~dest ?(fee = 0.00126) () =
get_head_block_hash state ~client ()
>>= fun branch ->
let json =
`O
[ ("branch", `String branch);
( "contents",
`A
[ `O
[ ("kind", `String "delegation");
("source", `String src);
( "fee",
`String (string_of_int (int_of_float (fee *. 1000000.))) );
("counter", `String (string_of_int 30713));
("gas_limit", `String (string_of_int 10100));
("delegate", `String dest);
("storage_limit", `String (string_of_int 277)) ] ] ) ]
in
Tezos_client.rpc
state
~client
~path:"/chains/main/blocks/head/helpers/forge/operations"
(`Post (Ezjsonm.to_string json))
>>= function
| `String operation_bytes ->
let magic_byte = "03" in
return (magic_byte ^ operation_bytes)
| _ ->
failf "Failed to forge operation or parse result"
let sign state ~client ~bytes () =
Tezos_client.successful_client_cmd
state
~client:client.Tezos_client.Keyed.client
["sign"; "bytes"; "0x" ^ bytes; "for"; client.Tezos_client.Keyed.key_name]
>>= fun _ -> return ()
let originate_account_from state ~client ~account =
let orig_account_name =
Tezos_protocol.Account.name account ^ "-originated-account"
in
Tezos_client.successful_client_cmd
state
~client
[ "originate";
"account";
orig_account_name;
"for";
Tezos_protocol.Account.name account;
"transferring";
string_of_int 1000;
"from";
Tezos_protocol.Account.name account;
"--burn-cap";
string_of_float 0.257 ]
>>= fun _ -> return orig_account_name
let setup_baking_ledger state uri ~client ~protocol =
Console.say state EF.(wf "Setting up the ledger device %S" uri)
>>= fun () ->
let key_name = "ledgered" in
let baker = Tezos_client.Keyed.make client ~key_name ~secret_key:uri in
let assert_baking_key x () =
let to_string = function Some x -> x | None -> "<none>" in
Console.say
state
EF.(wf "Asserting that the authorized key is %s" (to_string x))
>>= fun () ->
Tezos_client.Ledger.get_authorized_key state ~client ~uri
>>= fun auth_key -> assert_eq to_string ~expected:x ~actual:auth_key
in
Tezos_client.Ledger.deauthorize_baking state ~client ~uri
(* TODO: The following assertion doesn't confirm anything if the ledger was already not authorized to bake. *)
>>= assert_baking_key None
>>= fun () ->
Tezos_client.Ledger.show_ledger state ~client ~uri
>>= fun account ->
with_ledger_test_reject_and_succeed
state
EF.(
wf
"Importing %S in client `%s`. The ledger should be prompting for \
acknowledgment to provide the public key of %s"
uri
client.Tezos_client.id
(Tezos_protocol.Account.pubkey_hash account))
(fun () ->
Tezos_client.Keyed.initialize state baker >>= fun _ -> return ())
>>= assert_failure state "baking before setup should fail" (fun () ->
Tezos_client.Keyed.bake state baker "Baked by ledger")
>>= assert_failure state "endorsing before setup should fail" (fun () ->
Tezos_client.Keyed.endorse state baker "Endorsed by ledger")
>>= fun () ->
let test_invalid_delegations () =
let ledger_pkh = Tezos_protocol.Account.pubkey_hash account in
let other_pkh =
Tezos_protocol.Account.pubkey_hash
(fst (List.last_exn protocol.Tezos_protocol.bootstrap_accounts))
in
let cases =
[ (ledger_pkh, other_pkh, "ledger to another account");
(other_pkh, ledger_pkh, "another account to ledger");
(other_pkh, other_pkh, "another account to another account") ]
in
List_sequential.iter cases ~f:(fun (src, dest, msg) ->
forge_delegation state ~client ~src ~dest ()
>>= fun forged_delegation_bytes ->
assert_failure
state
(sprintf
"signing a delegation from %s (%s to %s) should fail"
msg
src
dest)
(sign state ~client:baker ~bytes:forged_delegation_bytes)
())
in
test_invalid_delegations ()
>>= fun () ->
with_ledger_test_reject_and_succeed
state
EF.(
wf
"Setting up %S for baking.\n\
Address: %S\n\
Chain: mainnet\n\
Main Chain HWM: 0\n\
Test Chain HWM: 0"
uri
(Tezos_protocol.Account.pubkey_hash account))
(fun () ->
Tezos_client.successful_client_cmd
state
~client
[ "setup";
"ledger";
"to";
"bake";
"for";
key_name;
"--main-hwm";
"0";
"--test-hwm";
"0" ])
>>= assert_failure
state
"signing a 'Withdraw delegate' operation in Baking App should fail"
(fun () ->
Tezos_client.successful_client_cmd
state
~client
[ "--wait";
"none";
"withdraw";
"delegate";
"from";
Tezos_protocol.Account.pubkey_hash account ])
>>= assert_baking_key (Some uri)
>>= test_invalid_delegations
>>= fun () -> return (baker, account)
let run state ~protocol ~node_exec ~client_exec ~admin_exec ~size ~base_port
~uri ~enable_deterministic_nonce_tests () =
Helpers.clear_root state
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.[af "Ready to start"; af "Root path deleted."]
>>= fun () ->
let ledger_client = Tezos_client.no_node_client ~exec:client_exec in
Tezos_client.Ledger.show_ledger state ~client:ledger_client ~uri
>>= fun ledger_account ->
let protocol =
let open Tezos_protocol in
{
protocol with
time_between_blocks = [1; 2];
bootstrap_accounts =
(ledger_account, 1_000_000_000_000L) :: protocol.bootstrap_accounts;
}
in
let other_baker_account =
fst (List.nth_exn protocol.Tezos_protocol.bootstrap_accounts 1)
in
Test_scenario.network_with_protocol
~protocol
~size
~base_port
state
~node_exec
~client_exec
>>= fun (nodes, protocol) ->
let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.(
all_defaults state ~nodes
@ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
@ arbitrary_commands_for_each_and_all_clients
state
~make_admin
~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
Interactive_test.Pauser.generic state EF.[af "About to really start playing"]
>>= fun () ->
let client n =
Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n)
in
Tezos_client.successful_client_cmd
state
~client:(client 0)
Tezos_protocol.Account.
[ "import";
"secret";
"key";
name other_baker_account;
private_key other_baker_account ]
>>= fun _ ->
Tezos_client.successful_client_cmd
state
~client:(client 0)
Tezos_protocol.Account.["bake"; "for"; name other_baker_account]
>>= fun _ ->
let assert_hwms_ ~main ~test () =
assert_hwms state ~client:(client 0) ~uri ~main ~test
in
let set_hwm_ level () =
with_ledger_prompt
state
EF.(wf "Setting HWM to %d" level)
`Succeeds
~f:(fun () ->
Tezos_client.Ledger.set_hwm state ~client:(client 0) ~uri ~level)
in
get_chain_id state ~client:(client 0)
>>= fun chain_id ->
setup_baking_ledger state uri ~client:(client 0) ~protocol
>>= fun (baker, ledger_account) ->
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.
[ arbitrary_command_on_all_clients
state
~command_names:["baker"]
~make_admin
~clients:[baker.Tezos_client.Keyed.client] ] ;
let bake () = Tezos_client.Keyed.bake state baker "Baked by ledger" in
let endorse () =
Tezos_client.Keyed.endorse state baker "Endorsed by ledger"
in
let ask_hwm ~main ~test () =
assert_hwms_ ~main ~test ()
>>= ask_assert
state
EF.(wf "Is 'Chain' = %S and 'Last Block Level' = %d" "mainnet" main)
in
( if enable_deterministic_nonce_tests then
(* Test determinism of nonces *)
Tezos_client.Keyed.generate_nonce state baker "this"
>>= fun thisNonce1 ->
Tezos_client.Keyed.generate_nonce state baker "that"
>>= fun thatNonce1 ->
Tezos_client.Keyed.generate_nonce state baker "this"
>>= fun thisNonce2 ->
Tezos_client.Keyed.generate_nonce state baker "that"
>>= fun thatNonce2 ->
assert_eq (fun x -> x) ~expected:thisNonce1 ~actual:thisNonce2
>>= fun () ->
assert_eq (fun x -> x) ~expected:thatNonce1 ~actual:thatNonce2
>>= fun () -> assert_ (thisNonce1 <> thatNonce1)
else return () )
>>= fun () ->
assert_failure
state
"originating an account from the Tezos Baking app should fail"
(fun () ->
originate_account_from state ~client:(client 0) ~account:ledger_account
>>= fun _ -> return ())
()
>>= fun () ->
let fee = 0.00126 in
let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
forge_delegation
state
~client:(client 0)
()
~src:ledger_pkh
~dest:ledger_pkh
~fee
>>= fun forged_delegation_bytes ->
with_ledger_test_reject_and_succeed
state
EF.(wf "Self delegating address %s with fee %f" ledger_pkh fee)
(sign state ~client:baker ~bytes:forged_delegation_bytes)
>>= bake >>= ask_hwm ~main:3 ~test:0
>>= fun () ->
(let level = 1 in
with_ledger_test_reject_and_succeed
state
EF.(wf "Setting HWM to %d" level)
(fun () ->
Tezos_client.Ledger.set_hwm state ~client:(client 0) ~uri ~level))
>>= assert_hwms_ ~main:1 ~test:1
>>= bake
>>= assert_hwms_ ~main:4 ~test:1
>>= set_hwm_ 5
>>= assert_hwms_ ~main:5 ~test:5
>>= assert_failure state "endorsing a level beneath HWM should fail" endorse
>>= assert_failure state "baking a level beneath HWM should fail" bake
>>= set_hwm_ 4 >>= bake
>>= assert_hwms_ ~main:5 ~test:4
>>= endorse (* does not increase level since we just baked *)
>>= assert_failure state "endorsing same block twice should not work" endorse
>>= assert_hwms_ ~main:5 ~test:4
>>= bake
>>= assert_hwms_ ~main:6 ~test:4
>>= forge_endorsement state ~client:baker.client ~chain_id ~level:1
>>= fun endorsement_at_low_level_bytes ->
assert_failure
state
"endorsing-after-baking a level beneath HWM should fail"
(sign state ~client:baker ~bytes:endorsement_at_low_level_bytes)
()
>>= assert_hwms_ ~main:6 ~test:4
(* HWM has not changed *)
>>= endorse
(* HWM still has not changed *)
>>= assert_hwms_ ~main:6 ~test:4
(* Forge an endorsement on a different chain *)
>>= fun () ->
let other_chain_id = "NetXSzLHKwSumh7" in
Console.say
state
EF.(
wf "Signing a forged endorsement on a different chain: %s" other_chain_id)
>>= forge_endorsement
state
~client:baker.client
~chain_id:(Tezos_crypto.Chain_id.of_b58check_exn other_chain_id)
~level:5
>>= fun endorsement_on_different_chain_bytes ->
sign state ~client:baker ~bytes:endorsement_on_different_chain_bytes ()
(* Only the test HWM has changed *)
>>= assert_hwms_ ~main:6 ~test:5
>>= fun () ->
Loop.n_times 5 (fun _ -> bake ())
>>= ask_hwm ~main:11 ~test:5
>>= fun () ->
Tezos_client.Ledger.deauthorize_baking state ~client:(client 0) ~uri
>>= assert_failure state "baking after deauthorization should fail" bake
>>= assert_failure
state
"endorsing after deauthorization should fail"
endorse
let cmd ~pp_error () =
let open Cmdliner in
let open Term in
Test_command_line.Run_command.make
~pp_error
( pure
(fun uri
node_exec
client_exec
admin_exec
size
(`Base_port base_port)
no_deterministic_nonce_tests
protocol
state
->
( state,
Interactive_test.Pauser.run_test
~pp_error
state
(run
state
~protocol
~node_exec
~size
~admin_exec
~base_port
~client_exec
~enable_deterministic_nonce_tests:
(not no_deterministic_nonce_tests)
~uri) ))
$ Arg.(
required
(pos
0
(some string)
None
(info [] ~docv:"LEDGER-URI" ~doc:"ledger:// URI")))
$ Tezos_executable.cli_term `Node "tezos"
$ Tezos_executable.cli_term `Client "tezos"
$ Tezos_executable.cli_term `Admin "tezos"
$ Arg.(value (opt int 5 (info ["size"; "S"] ~doc:"Size of the Network")))
$ Arg.(
pure (fun p -> `Base_port p)
$ value
(opt
int
46_000
(info ["base-port"; "P"] ~doc:"Base port number to build upon")))
$ Arg.(
value
(flag
(info
["no-deterministic-nonce-tests"]
~doc:"Disable tests for deterministic nonces")))
$ Tezos_protocol.cli_term ()
$ Test_command_line.cli_state ~name:"ledger-baking" () )
(let doc = "Interactive test exercising the Ledger Baking app features" in
info ~doc "ledger-baking")
src/bin_sandbox/command_ledger_baking.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition failf {A B : Type} (fmt : A) : B :=
op_startypeminuserrorstar
(fun s =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant) fmt.
Definition ledger_prompt_notice {A B C : Type}
(state : A) (ef : B) (op_staroptstar : option variant) : unit -> C :=
let button :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun function_parameter =>
let 'tt := function_parameter in
let button_str :=
match button with
| Checkmark => "✔" % string
| X => "❌" % string
| Both => "❌ and ✔ at the same time" % string
end in
op_startypeminuserrorstar state op_startypeminuserrorstar.
Definition assert_failure {A B C D : Type}
(state : A) (msg : B) (f : unit -> C) (function_parameter : unit) : D :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar (f tt)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant))
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant))
(fun function_parameter =>
match function_parameter with
| Worked => failf "%s" % string msg
| Didn'tWork => op_startypeminuserrorstar tt
end)).
Definition failf {A B : Type} (fmt : A) : B :=
op_startypeminuserrorstar
(fun s =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant) fmt.
Definition assert_ {A : Type} (a : bool) : A :=
if a then
op_startypeminuserrorstar tt
else
failf "Assertion failed" % string.
Definition assert_eq {A B C : Type}
(to_string : A -> B) (expected : A) (actual : A) : C :=
if equiv_decb expected actual then
op_startypeminuserrorstar tt
else
failf "Assertion failed: expected %s but got %s" % string
(to_string expected) (to_string actual).
Fixpoint ask {A B C : Type} (state : A) (ef : B) : C :=
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| "y" % char | "Y" % char => op_startypeminuserrorstar true
| "n" % char | "N" % char => op_startypeminuserrorstar false
| _ => ask state ef
end)).
Definition ask_assert {A B C : Type}
(state : A) (ef : B) (function_parameter : unit) : C :=
let 'tt := function_parameter in
op_startypeminuserrorstar (ask state ef) (fun b => assert_ b).
Definition with_ledger_prompt {A B C D : Type}
(state : A) (message : B) (expectation : variant) (f : unit -> C) : D :=
op_startypeminuserrorstar
(ledger_prompt_notice state op_startypeminuserrorstar
(Some
match expectation with
| Succeeds =>
(* ❌ Variants not supported *)
variant
| Fails =>
(* ❌ Variants not supported *)
variant
end) tt)
(fun function_parameter =>
let 'tt := function_parameter in
match expectation with
| Succeeds =>
op_startypeminuserrorstar (f tt)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar state op_startypeminuserrorstar)
| Fails =>
op_startypeminuserrorstar
(assert_failure state "expected failure" % string f tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state op_startypeminuserrorstar)
end).
Definition with_ledger_test_reject_and_succeed {A B C D : Type}
(state : A) (ef : B) (f : unit -> C) : D :=
op_startypeminuserrorstar
(with_ledger_prompt state ef
(* ❌ Variants not supported *)
variant f)
(fun function_parameter =>
let 'tt := function_parameter in
with_ledger_prompt state ef
(* ❌ Variants not supported *)
variant f).
Definition assert_hwms {A B C D : Type}
(state : A) (client : B) (uri : C) (main : Z) (test : Z) : D :=
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state client uri)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(assert_eq OCaml.Stdlib.string_of_int main op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
assert_eq OCaml.Stdlib.string_of_int test
op_startypeminuserrorstar))).
Definition get_chain_id {A B C : Type} (state : A) (client : B) : C :=
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(* ❌ Variants not supported *)
variant "/chains/main/chain_id" % string)
(fun function_parameter =>
match function_parameter with
| String x => op_startypeminuserrorstar x
| _ => failf "Failed to parse chain_id JSON from node" % string
end))
(fun chain_id_string =>
op_startypeminuserrorstar (op_startypeminuserrorstar chain_id_string)).
Definition get_head_block_hash {A B C : Type}
(state : A) (client : B) (function_parameter : unit) : C :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(* ❌ Variants not supported *)
variant "/chains/main/blocks/head/hash" % string)
(fun function_parameter =>
match function_parameter with
| String x => op_startypeminuserrorstar x
| _ => failf "Failed to parse block hash JSON from node" % string
end).
Definition forge_endorsement {A B C D : Type}
(state : A) (client : B) (chain_id : C) (level : Z)
(function_parameter : unit) : D :=
let 'tt := function_parameter in
op_startypeminuserrorstar (get_head_block_hash state client tt)
(fun branch =>
let json :=
(* ❌ Variants not supported *)
variant in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
"/chains/main/blocks/head/helpers/forge/operations" % string
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
match function_parameter with
| String operation_bytes =>
let endorsement_magic_byte := "02" % string in
op_startypeminuserrorstar
(String.append endorsement_magic_byte
(String.append
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply chain_id
op_startypeminuserrorstar) op_startypeminuserrorstar)
operation_bytes))
| _ => failf "Failed to forge operation or parse result" % string
end)).
Definition forge_delegation {A B C : Type}
(state : A) (client : B) (src : string) (dest : string)
(op_staroptstar : option Z) : unit -> C :=
let fee :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Float constant 0.00126 is approximated by the integer 0 *)
0
end in
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (get_head_block_hash state client tt)
(fun branch =>
let json :=
(* ❌ Variants not supported *)
variant in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
"/chains/main/blocks/head/helpers/forge/operations" % string
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
match function_parameter with
| String operation_bytes =>
let magic_byte := "03" % string in
op_startypeminuserrorstar
(String.append magic_byte operation_bytes)
| _ => failf "Failed to forge operation or parse result" % string
end)).
Definition sign {A B C : Type}
(state : A) (client : B) (bytes : string) (function_parameter : unit) : C :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state (Tezos_client.Keyed.client client)
(cons "sign" % string
(cons "bytes" % string
(cons (String.append "0x" % string string)
(cons "for" % string (cons (Tezos_client.Keyed.key_name client) []))))))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar tt).
Definition originate_account_from {A B C D : Type}
(state : A) (client : B) (account : C) : D :=
let orig_account_name :=
String.append (op_startypeminuserrorstar account)
"-originated-account" % string in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(cons "originate" % string
(cons "account" % string
(cons orig_account_name
(cons "for" % string
(cons (op_startypeminuserrorstar account)
(cons "transferring" % string
(cons (OCaml.Stdlib.string_of_int 1000)
(cons "from" % string
(cons (op_startypeminuserrorstar account)
(cons "--burn-cap" % string
(cons
(Stdlib.string_of_float
(* ❌ Float constant 0.257 is approximated by the integer 0 *)
0) []))))))))))))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar orig_account_name).
Definition setup_baking_ledger {A B C D : Type}
(state : A) (uri : string) (client : B) (protocol : C) : D :=
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let key_name := "ledgered" % string in
let baker := op_startypeminuserrorstar client key_name uri in
let assert_baking_key {E : Type}
(x : option string) (function_parameter : unit) : E :=
let 'tt := function_parameter in
let to_string (function_parameter : option string) : string :=
match function_parameter with
| Some x => x
| None => "<none>" % string
end in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client uri)
(fun auth_key => assert_eq to_string x auth_key)) in
op_startypeminuserrorstar
(op_startypeminuserrorstar (op_startypeminuserrorstar state client uri)
(assert_baking_key None))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state client uri)
(fun account =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(with_ledger_test_reject_and_succeed state
op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar tt)))
(assert_failure state
"baking before setup should fail" % string
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state baker
"Baked by ledger" % string)))
(assert_failure state
"endorsing before setup should fail" % string
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state baker
"Endorsed by ledger" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
let test_invalid_delegations {E : Type}
(function_parameter : unit) : E :=
let 'tt := function_parameter in
let ledger_pkh := op_startypeminuserrorstar account in
let other_pkh :=
op_startypeminuserrorstar
(fst
(op_startypeminuserrorstar
(Tezos_protocol.bootstrap_accounts protocol))) in
let cases :=
cons
(ledger_pkh, other_pkh,
"ledger to another account" % string)
(cons
(other_pkh, ledger_pkh,
"another account to ledger" % string)
(cons
(other_pkh, other_pkh,
"another account to another account" % string) []))
in
op_startypeminuserrorstar cases
(fun function_parameter =>
let '(src, dest, msg) := function_parameter in
op_startypeminuserrorstar
(forge_delegation state client src dest None tt)
(fun forged_delegation_bytes =>
assert_failure state
(op_startypeminuserrorstar
"signing a delegation from %s (%s to %s) should fail"
% string msg src dest)
(sign state baker forged_delegation_bytes) tt)) in
op_startypeminuserrorstar (test_invalid_delegations tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(with_ledger_test_reject_and_succeed state
op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state client
(cons "setup" % string
(cons "ledger" % string
(cons "to" % string
(cons "bake" % string
(cons "for" % string
(cons key_name
(cons "--main-hwm" % string
(cons "0" % string
(cons "--test-hwm" % string
(cons "0" % string []))))))))))))
(assert_failure state
"signing a 'Withdraw delegate' operation in Baking App should fail"
% string
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state client
(cons "--wait" % string
(cons "none" % string
(cons "withdraw" % string
(cons "delegate" % string
(cons "from" % string
(cons
(op_startypeminuserrorstar
account) [])))))))))
(assert_baking_key (Some uri)))
test_invalid_delegations)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (baker, account))))))).
Definition run {A B C D E F G H : Type}
(state : A) (protocol : B) (node_exec : C) (client_exec : D) (admin_exec : E)
(size : F) (base_port : G) (uri : string)
(enable_deterministic_nonce_tests : bool) (function_parameter : unit) : H :=
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let ledger_client := op_startypeminuserrorstar client_exec in
op_startypeminuserrorstar
(op_startypeminuserrorstar state ledger_client uri)
(fun ledger_account =>
let protocol := op_startypeminuserrorstar in
let other_baker_account :=
fst
(op_startypeminuserrorstar
(Tezos_protocol.bootstrap_accounts protocol) 1) in
op_startypeminuserrorstar
(op_startypeminuserrorstar protocol size base_port state
node_exec client_exec)
(fun function_parameter =>
let '(nodes, protocol) := function_parameter in
let make_admin := op_startypeminuserrorstar admin_exec in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let client {I J : Type} (n : I) : J :=
op_startypeminuserrorstar client_exec
(op_startypeminuserrorstar nodes n) in
op_startypeminuserrorstar
(op_startypeminuserrorstar state (client 0)
op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state (client 0)
op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
let assert_hwms_ {I : Type}
(main : Z) (test : Z) (function_parameter :
unit) : I :=
let 'tt := function_parameter in
assert_hwms state (client 0) uri main test in
let set_hwm_ {I J : Type}
(level : I) (function_parameter : unit) : J :=
let 'tt := function_parameter in
with_ledger_prompt state
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state (client 0)
uri level) in
op_startypeminuserrorstar
(get_chain_id state (client 0))
(fun chain_id =>
op_startypeminuserrorstar
(setup_baking_ledger state uri (client 0)
protocol)
(fun function_parameter =>
let '(baker, ledger_account) :=
function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state
op_startypeminuserrorstar in
let bake {I : Type}
(function_parameter : unit) : I :=
let 'tt := function_parameter in
op_startypeminuserrorstar state baker
"Baked by ledger" % string in
let endorse {I : Type}
(function_parameter : unit) : I :=
let 'tt := function_parameter in
op_startypeminuserrorstar state baker
"Endorsed by ledger" % string in
let ask_hwm {I : Type}
(main : Z) (test : Z)
(function_parameter : unit) : I :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_hwms_ main test tt)
(ask_assert state
op_startypeminuserrorstar) in
op_startypeminuserrorstar
(if enable_deterministic_nonce_tests
then
op_startypeminuserrorstar
(op_startypeminuserrorstar state
baker "this" % string)
(fun thisNonce1 =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
baker "that" % string)
(fun thatNonce1 =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state baker
"this" % string)
(fun thisNonce2 =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state baker
"that" % string)
(fun thatNonce2 =>
op_startypeminuserrorstar
(assert_eq
(fun x => x)
thisNonce1
thisNonce2)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_eq
(fun x => x)
thatNonce1
thatNonce2)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
assert_
(nequiv_decb
thisNonce1
thatNonce1)))))))
else
op_startypeminuserrorstar tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_failure state
"originating an account from the Tezos Baking app should fail"
% string
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(originate_account_from state
(client 0) ledger_account)
(fun function_parameter =>
let '_ := function_parameter
in
op_startypeminuserrorstar tt))
tt)
(fun function_parameter =>
let 'tt := function_parameter in
let fee :=
(* ❌ Float constant 0.00126 is approximated by the integer 0 *)
0 in
let ledger_pkh :=
op_startypeminuserrorstar
ledger_account in
op_startypeminuserrorstar
(forge_delegation state
(client 0) ledger_pkh
ledger_pkh (Some fee) tt)
(fun forged_delegation_bytes =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(with_ledger_test_reject_and_succeed
state
op_startypeminuserrorstar
(sign state baker
forged_delegation_bytes))
bake) (ask_hwm 3 0))
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(let
level :=
1
in
with_ledger_test_reject_and_succeed
state
op_startypeminuserrorstar
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
state
(client
0)
uri
level))
(assert_hwms_
1
1))
bake)
(assert_hwms_
4
1))
(set_hwm_
5))
(assert_hwms_
5
5))
(assert_failure
state
"endorsing a level beneath HWM should fail"
%
string
endorse))
(assert_failure
state
"baking a level beneath HWM should fail"
%
string
bake))
(set_hwm_
4))
bake)
(assert_hwms_
5 4))
endorse)
(assert_failure
state
"endorsing same block twice should not work"
% string
endorse))
(assert_hwms_ 5
4)) bake)
(assert_hwms_ 6 4))
(forge_endorsement
state (client baker)
chain_id 1))
(fun
endorsement_at_low_level_bytes
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(assert_failure
state
"endorsing-after-baking a level beneath HWM should fail"
% string
(sign state
baker
endorsement_at_low_level_bytes)
tt)
(assert_hwms_
6 4))
endorse)
(assert_hwms_ 6 4))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
let
other_chain_id :=
"NetXSzLHKwSumh7"
% string in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(forge_endorsement
state
(client
baker)
(op_startypeminuserrorstar
other_chain_id)
5))
(fun
endorsement_on_different_chain_bytes
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
(sign
state
baker
endorsement_on_different_chain_bytes
tt)
(assert_hwms_
6 5))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
5
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
bake
tt))
(ask_hwm
11 5))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
0)
uri)
(assert_failure
state
"baking after deauthorization should fail"
%
string
bake))
(assert_failure
state
"endorsing after deauthorization should fail"
%
string
endorse))))))))))))))))))).
Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
src/bin_sandbox/command_ledger_wallet.ml 527 errors
open Flextesa
open Internal_pervasives
let client_async_cmd state ~client args ~f =
Running_processes.Async.run_cmdf
~id_base:"client_async_cmd"
state
~f
"sh -c %s"
( Tezos_client.client_command client ~state args
|> Genspio.Compile.to_one_liner |> Filename.quote )
>>= fun (status, res) ->
return
( object
method out = fst res
method err = snd res
method status = status
end
: Process_result.t )
let ledger_hash_re =
lazy
Re.(
compile
(seq
[ str "* Blake 2B Hash (ledger-style, with operation watermark):";
rep1 (alt [space; eol]);
group (rep1 alnum);
rep1 (alt [space; eol]) ]))
(* Searches a stream for an expected ledger hash from `tezos-client --verbose-signing`*)
let find_and_print_signature_hash ?(display_expectation = true) state process =
let re = Lazy.force ledger_hash_re in
let check lines =
Re.(
match exec_opt re lines with
| None ->
None
| Some matches ->
Some (Group.get matches 1))
in
(* Dbg.e EF.(wf "find_and_print_signature_hash") ; *)
Running_processes.Async.fold_process
process
~init:("", "", not display_expectation)
~f:(fun (all_output_prev, all_error_prev, showed_message_prev) out err ->
(* Dbg.e EF.(wf "find_and_print_signature_hash.fold_process %S %S" out err) ; *)
let all_output = all_output_prev ^ out in
let all_error = all_error_prev ^ err in
( if not showed_message_prev then
match check all_output with
| None ->
return false
| Some x ->
Console.say state EF.(wf "Displayed hash should be: `%s`" x)
>>= fun () -> return true
else return true )
>>= fun showed_message ->
return (`Continue (all_output, all_error, showed_message)))
>>= fun (output, error, _) ->
return (String.split ~on:'\n' output, String.split ~on:'\n' error)
module MFmt = Experiments.More_fmt
let failf ?attach fmt =
ksprintf (fun s -> fail ?attach (`Scenario_error s)) fmt
let process_should_fail msg f =
Asynchronous_result.bind_on_error
( f ()
>>= fun (proc : Process_result.t) ->
match proc#status with
| Unix.WEXITED 0 ->
failf
"Process should have failed: %s"
msg
~attach:
[("stdout", `Verbatim proc#out); ("stderr", `Verbatim proc#err)]
| _ ->
return () )
~f:(fun ~result:_ _ -> return ())
let ledger_prompt_notice state ~msgs ?(button = `Checkmark) () =
let button_str =
match button with
| `Checkmark ->
"â"
| `X ->
"â"
| `Both ->
"â and â at the same time"
in
Console.sayf
state
MFmt.(
fun ppf () ->
vertical_box ~indent:4 ppf (fun ppf ->
shout ppf (fun ppf -> const string "Ledger-prompt:" ppf ()) ;
cut ppf () ;
List.iter msgs ~f:(fun f -> f ppf () ; cut ppf ()) ;
wf ppf "â Press %s on the ledger." button_str))
let ledger_prompt_notice_expectation state ~messages ~user_answer =
ledger_prompt_notice
state
()
~button:(match user_answer with `Accept -> `Checkmark | `Reject -> `X)
~msgs:
( messages
@ MFmt.
[ cut;
(fun ppf () ->
match user_answer with
| `Accept ->
shout ppf (fun ppf -> pf ppf ">> ACCEPT THIS <<")
| `Reject ->
shout ppf (fun ppf -> pf ppf ">> REJECT THIS <<")) ] )
let with_ledger_test_reject_and_accept ?(only_success = false) state ~messages
f =
let with_ledger_prompt state ~messages ~user_answer ~f =
ledger_prompt_notice_expectation state ~messages ~user_answer
>>= fun () -> f ~user_answer
in
( if only_success then return ()
else with_ledger_prompt state ~messages ~user_answer:`Reject ~f )
>>= fun () -> with_ledger_prompt state ~messages ~user_answer:`Accept ~f
let get_chain_id state ~client =
Tezos_client.rpc state ~client `Get ~path:"/chains/main/chain_id"
>>= (function
| `String x ->
return x
| _ ->
failf "Failed to parse chain_id JSON from node")
>>= fun chain_id_string ->
return (Tezos_crypto.Chain_id.of_b58check_exn chain_id_string)
let get_head_block_hash state ~client () =
Tezos_client.rpc state ~client `Get ~path:"/chains/main/blocks/head/hash"
>>= function
| `String x ->
return x
| _ ->
failf "Failed to parse block hash JSON from node"
let please_check_the_hash ppf () =
let open MFmt in
tag "prompt" ppf (fun ppf ->
wf ppf "The ledger cannot parse this operation, please verify the hash.")
let forge_batch_transactions state ~client ~src ~dest:_ ~n ?(fee = 0.00126) ()
=
get_head_block_hash state ~client ()
>>= fun branch ->
let json =
`O
[ ("branch", `String branch);
( "contents",
`A
(List.map (List.range 0 n) ~f:(fun i ->
`O
[ ("kind", `String "transaction");
("source", `String src);
( "destination",
`String "tz2KZPgf2rshxNUBXFcTaCemik1LH1v9qz3F" );
("amount", `String (string_of_int 100));
( "fee",
`String (string_of_int (int_of_float (fee *. 1000000.)))
);
("counter", `String (string_of_int i));
("gas_limit", `String (string_of_int 127));
("storage_limit", `String (string_of_int 277)) ])) ) ]
in
Tezos_client.rpc
state
~client
~path:"/chains/main/blocks/head/helpers/forge/operations"
(`Post (Ezjsonm.to_string json))
>>= function
| `String operation_bytes ->
let magic_byte = "03" in
return (magic_byte ^ operation_bytes)
| _ ->
failf "Failed to forge operation or parse result"
let expect_from_output ~expectation ~message (proc_res : Process_result.t) =
(* let expect_rejection msg (success, (stdout, stderr)) = *)
let exp =
match expectation with
| `Ledger_reject_or_timeout ->
"rejection"
| `Not_a_delegate ->
"not-delegate-error"
| `Success ->
"success"
| `Origination_failed ->
"origination-failure"
in
let nope s =
failf
~attach:
[("stdout", `Verbatim proc_res#out); ("stderr", `Verbatim proc_res#err)]
"%s, expected %s: %s."
message
exp
s
in
let success = proc_res#status = Unix.WEXITED 0 in
match expectation with
| `Success when success ->
return ()
| `Success ->
nope "did not succeed"
| (`Ledger_reject_or_timeout | `Not_a_delegate | `Origination_failed) as e
-> (
let pattern =
match e with
| `Ledger_reject_or_timeout ->
"Conditions of use not satisfied"
| `Not_a_delegate ->
"not registered as valid delegate key"
| `Origination_failed ->
"origination simulation failed"
in
let all_output = String.concat ~sep:"\n" (proc_res#out @ proc_res#err) in
match (success, String.substr_index all_output ~pattern) with
| (false, Some _) ->
return ()
| (false, None) ->
nope "cannot find the right error message"
| (true, _) ->
nope "command succeeded??" )
let voting_tests state ~client ~src ~with_rejections ~protocol_kind
~ledger_account ~tested_proposal ~go_to_next_period () =
let expect_success message v =
expect_from_output ~expectation:`Not_a_delegate ~message v
in
let expect_rejection message v =
expect_from_output ~expectation:`Ledger_reject_or_timeout ~message v
in
let test_reject_and_accept name ~messages action =
( if with_rejections then
ledger_prompt_notice_expectation state ~messages ~user_answer:`Reject
>>= fun () -> action () >>= fun res -> expect_rejection name res
else return () )
>>= fun () ->
ledger_prompt_notice_expectation state ~messages ~user_answer:`Accept
>>= fun () -> action () >>= fun res -> expect_success name res
in
let source_display = Tezos_protocol.Account.pubkey_hash ledger_account in
let submit_proposals ~display_expectation proposals () =
client_async_cmd
state
~client:(client 0)
~f:(fun _ proc ->
find_and_print_signature_hash ~display_expectation state proc)
( ["submit"; "proposals"; "for"; src]
@ proposals
@ ["--force"; "--verbose-signing"] )
in
test_reject_and_accept
"single-proposal"
~messages:
MFmt.
[ (fun ppf () -> wf ppf "Submitting single proposal %s" tested_proposal);
(fun ppf () ->
match protocol_kind with
| `Athens ->
()
| `Babylon ->
wf
ppf
"On Babylon, You will first be asked to provide the public \
key." ;
cut ppf () ;
wf
ppf
"Accept this prompt, regardless of below, then continue.");
(fun ppf () ->
vertical_box ppf ~indent:4 (fun ppf ->
wf
ppf
"Protocol is %a, the ledger should be able to display \
voting parameters:"
Tezos_protocol.Protocol_kind.pp
protocol_kind ;
cut ppf () ;
wf ppf "* Source: `%s`" source_display ;
cut ppf () ;
wf ppf "* Period: `0`" ;
cut ppf () ;
wf ppf "* Protocol: `%s`" tested_proposal)) ]
(submit_proposals ~display_expectation:false [tested_proposal])
>>= fun () ->
test_reject_and_accept
"multiple-proposal"
~messages:
MFmt.
[ (fun ppf () -> wf ppf "Submitting 2 proposals together");
please_check_the_hash ]
(submit_proposals
~display_expectation:true
[tested_proposal; "Psd1ynUBhMZAeajwcZJAeq5NrxorM6UCU4GJqxZ7Bx2e9vUWB6z"])
>>= fun () ->
go_to_next_period ()
>>= fun () ->
List_sequential.iteri ["yea"; "nay"] ~f:(fun n vote ->
test_reject_and_accept
(Fmt.strf "vote-%s" vote)
~messages:
MFmt.
[ (fun ppf () ->
match protocol_kind with
| `Athens ->
()
| `Babylon ->
wf
ppf
"On Babylon, You will first be asked to provide the \
public key." ;
cut ppf () ;
wf
ppf
"Accept this prompt, regardless of below, then continue.");
(fun ppf () -> wf ppf "Voting %s for %s" vote tested_proposal);
(fun ppf () -> wf ppf "Source: `%s`" source_display);
(fun ppf () -> wf ppf "Period: `%i`" (n + 1));
(fun ppf () -> wf ppf "Protocol: `%s`" tested_proposal) ]
(fun () ->
Tezos_client.client_cmd
state
~client:(client 0)
["submit"; "ballot"; "for"; src; tested_proposal; vote]
>>= fun (_, proc) -> return proc))
let ledger_should_display ppf l =
let open MFmt in
vertical_box ~indent:4 ppf (fun ppf ->
wf ppf "Ledger should display:" ;
List.iter l ~f:(fun (s, f) -> cut ppf () ; pf ppf "* %s: %a." s f ()))
let show_command_message command =
MFmt.(
fun ppf () ->
wrapping_box ~indent:2 ppf (fun ppf ->
wf ppf "Command:" ;
sp ppf () ;
const
(list ~sep:sp string)
("<tezos-client>" :: command |> List.map ~f:Filename.quote)
ppf
()))
let sign state ~client ~bytes =
Tezos_client.client_cmd
state
~client:client.Tezos_client.Keyed.client
["sign"; "bytes"; "0x" ^ bytes; "for"; client.Tezos_client.Keyed.key_name]
let delegation_tests state ~client ~src ~with_rejections ~protocol_kind
~ledger_account ~delegate ~bake () =
let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
let only_success = not with_rejections in
let self_delegation () =
(* Which is equivalent to registration as delegate. *)
let command =
[ "--wait";
"none";
"set";
"delegate";
"for";
src;
"to";
src;
"--verbose-signing" ]
in
with_ledger_test_reject_and_accept
state
~only_success
~messages:
MFmt.
[ (fun ppf () -> wf ppf "Self-delegating account `%s`" ledger_pkh);
show_command_message command;
(fun ppf () ->
wf
ppf
"Note that X is a placeholder for some value that will vary \
between runs");
(fun ppf () ->
ledger_should_display
ppf
[ ("Fee", const string "0.00XXX");
("Source", const string ledger_pkh);
("Delegate", const string ledger_pkh);
("Storage", const int 0) ]) ]
(fun ~user_answer ->
client_async_cmd
state
~client
~f:(fun _ proc ->
find_and_print_signature_hash
~display_expectation:(protocol_kind = `Babylon)
state
proc)
command
>>= fun res ->
expect_from_output
~message:"self-delegation"
res
~expectation:
( match user_answer with
| `Reject ->
`Ledger_reject_or_timeout
| `Accept ->
`Success ))
>>= fun _ -> ksprintf bake "setting self-delegate of %s" src
(* Self-delegate deletion is forbidden for both Athens and Babylon *)
in
let tz_account_delegation () =
let command =
[ "--wait";
"none";
"set";
"delegate";
"for";
src;
"to";
delegate;
"--verbose-signing" ]
in
with_ledger_test_reject_and_accept
state
~only_success
~messages:
MFmt.
[ (fun ppf () ->
wf ppf "Delegating account `%s` to `%s`" ledger_pkh delegate);
show_command_message command;
(fun ppf () ->
wf
ppf
"Note that X is a placeholder for some value that will vary \
between runs");
(fun ppf () ->
ledger_should_display
ppf
[ ("Fee", const string "0.00XXX");
("Source", const string ledger_pkh);
("Delegate", const string delegate);
("Storage", const int 0) ]) ]
(fun ~user_answer ->
client_async_cmd
state
~client
~f:(fun _ proc ->
find_and_print_signature_hash
~display_expectation:(protocol_kind = `Babylon)
state
proc)
command
>>= fun res ->
expect_from_output
~message:"tz123-delegation"
res
~expectation:
( match user_answer with
| `Reject ->
`Ledger_reject_or_timeout
| `Accept ->
`Success ))
>>= fun _ -> ksprintf bake "setting delegate of %s" src
(* Self-delegate deletion is forbidden for both Athens and Babylon *)
in
let run_command_and_check state ~client ~command ~message ~user_answer =
Tezos_client.client_cmd state ~client command
>>= fun (_, res) ->
expect_from_output
~message
res
~expectation:
( match user_answer with
| `Reject ->
`Ledger_reject_or_timeout
| `Accept ->
`Success )
in
let delegate_with_scriptless_account () =
let originated_account_name = "ledginated" in
let amount = "200" in
let burn_cap = "0.257" in
let command =
[ "--wait";
"none";
"originate";
"account";
originated_account_name;
"for";
src;
"transferring";
"200";
"from";
src;
"--delegatable";
"--burn-cap";
burn_cap;
"--force" ]
in
with_ledger_test_reject_and_accept
state
~only_success
~messages:
MFmt.
[ (fun ppf () ->
wf ppf "Originating account `%s`" originated_account_name);
(fun ppf () ->
ledger_should_display
ppf
[ ("Amount", const string amount);
("Fee", const string (strf "⤠%S" burn_cap));
("Source", const string ledger_pkh);
("Manager", const string ledger_pkh);
("Delegation", const string "Any");
("Storage", const int 277) ]) ]
(fun ~user_answer ->
run_command_and_check
state
~client
~command
~message:"account origination"
~user_answer)
>>= fun _ ->
ksprintf bake "origination of %s" originated_account_name
>>= fun () ->
Tezos_client.client_cmd
state
~client
["show"; "known"; "contract"; originated_account_name]
>>= fun (_, proc_result) ->
let contract_address = proc_result#out |> String.concat ~sep:"" in
Tezos_client.client_cmd state ~client ["show"; "address"; delegate]
>>= fun (_, proc_result) ->
let delegate_address =
List.hd_exn proc_result#out
|> String.split ~on:' ' |> List.last
|> Option.value ~default:delegate
in
let command =
[ "--wait";
"none";
"set";
"delegate";
"for";
originated_account_name;
"to";
delegate ]
in
with_ledger_test_reject_and_accept
state
~only_success
~messages:
MFmt.
[ (fun ppf () ->
wf
ppf
"Setting `%s` as delegate for `%s`"
delegate
originated_account_name);
(fun ppf () ->
ledger_should_display
ppf
[ ("Source", const string contract_address);
("Fee", const string "⤠0.001");
("Delegate", const string delegate_address);
("Storage", const int 0) ]) ]
(fun ~user_answer ->
run_command_and_check
state
~client
~command
~message:"setting delegate of KT1"
~user_answer)
>>= fun () ->
ksprintf bake "setting delegate of %s" originated_account_name
>>= fun () ->
let withdraw_command =
[ "--wait";
"none";
"withdraw";
"delegate";
"from";
originated_account_name ]
in
with_ledger_test_reject_and_accept
state
~only_success
~messages:
MFmt.
[ (fun ppf () ->
wf ppf "Withdrawing delegate from `%s`" originated_account_name);
show_command_message withdraw_command;
(fun ppf () ->
ledger_should_display
ppf
[ ("Source", const string contract_address);
("Fee", const string "⤠0.001");
("Delegate", const string "None");
("Storage", const int 0) ]) ]
(fun ~user_answer ->
run_command_and_check
state
~client
~command:withdraw_command
~message:"withdrawing delegate from originated account"
~user_answer)
>>= fun () ->
ksprintf bake "withdrawing delegate of %s" originated_account_name
in
match protocol_kind with
| `Athens ->
self_delegation () >>= fun () -> delegate_with_scriptless_account ()
| `Babylon ->
tz_account_delegation () >>= fun () -> self_delegation ()
let transaction_tests state ~client ~src ~with_rejections ~protocol_kind
~pair_string_nat_kt1_account ~ledger_account ~unit_kt1_account ~bake () =
let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
let only_success = not with_rejections in
let test_transaction ?(storage = 0) ?arguments ~name ~dst_name ~dst_pkh () =
let amount = "15" in
let command =
["--wait"; "none"; "transfer"; amount; "from"; src; "to"; dst_name]
@ Option.value_map ~default:[] arguments ~f:(fun a -> ["--arg"; a])
@ ["--burn-cap"; "100"; "--verbose-signing"]
in
with_ledger_test_reject_and_accept
state
~only_success
~messages:
MFmt.
[ (fun ppf () -> wf ppf "%s with account `%s`" name ledger_pkh);
show_command_message command;
(fun ppf () ->
wf
ppf
"Note that X is a placeholder for some value that will vary \
between runs");
(fun ppf () ->
match arguments with
| None ->
ledger_should_display
ppf
[ ("Amount", const string amount);
("Fee", const string "0.00XXX");
("Source", const string ledger_pkh);
("Destination", const string dst_pkh);
("Storage", const int storage) ]
| _ (* some arguments *) ->
please_check_the_hash ppf ()) ]
(fun ~user_answer ->
client_async_cmd
state
~client
~f:(fun _ proc ->
find_and_print_signature_hash
~display_expectation:
(protocol_kind = `Babylon || arguments <> None)
state
proc)
command
>>= fun res ->
expect_from_output
~message:name
res
~expectation:
( match user_answer with
| `Reject ->
`Ledger_reject_or_timeout
| `Accept ->
`Success ))
>>= fun _ -> ksprintf bake "%s with %s" name src
in
test_transaction
~name:"Self-transaction"
~dst_pkh:ledger_pkh
~dst_name:src
()
>>= fun () ->
let module Acc = Tezos_protocol.Account in
let random_account = Acc.of_name "random-account-for-transaction-test" in
test_transaction
~name:"transaction-to-random-tz1"
~dst_pkh:(Acc.pubkey_hash random_account)
~dst_name:(Acc.pubkey_hash random_account)
~storage:277
(* First time: there is a reveal *) ()
>>= fun () ->
test_transaction
~name:"transaction-to-random-tz1-again"
~dst_pkh:(Acc.pubkey_hash random_account)
~dst_name:(Acc.pubkey_hash random_account)
~storage:0
(* no moa reveal *) ()
>>= fun () ->
test_transaction
~name:"parameterless-transaction-to-kt1"
~dst_pkh:"KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
~dst_name:unit_kt1_account
()
>>= fun () ->
test_transaction
~name:"parameterfull-transaction-to-kt1"
~dst_pkh:"KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
~arguments:"Pair \"hello from the ledger\" 51"
~dst_name:pair_string_nat_kt1_account
()
let prepare_origination_of_id_script ?(spendable = false)
?(delegatable = false) ?delegate ?(push_drops = 0) ?(amount = "2") state
~client:_ ~name ~from ~protocol_kind ~parameter ~init_storage =
let id_script parameter =
Fmt.strf
"parameter %s;\n\
storage %s;\n\
code\n\
\ {\n\
\ %s\n\
\ { CAR; NIL operation; PAIR }\n\
\ };\n"
parameter
parameter
( match push_drops with
| 0 ->
"# No push-drops"
| n ->
Fmt.strf
"# %d push-drop%s\n %s"
n
(if n > 1 then "s" else "")
( List.init push_drops ~f:(fun ith ->
Fmt.strf
"{ PUSH string %S ; DROP } ;"
(Fmt.strf
"push-dropping %d adds stupid bytes to the contract"
ith))
|> String.concat ~sep:"\n " ) )
in
let tmp = Filename.temp_file "little-id-script" ".tz" in
System.write_file state tmp ~content:(id_script parameter)
>>= fun () ->
Dbg.e EF.(wf "id_script %s: %s" parameter tmp) ;
let origination =
let opt = Option.value_map ~default:[] in
["--wait"; "none"; "originate"; "contract"; name]
@ (match protocol_kind with `Athens -> ["for"; from] | `Babylon -> [])
@ [ "transferring";
amount;
"from";
from;
"running";
tmp;
"--init";
init_storage;
"--force";
"--burn-cap";
"300000000000";
(* ; "--fee-cap" ; "20000000000000" *)
"--gas-limit";
"1000000000000000";
"--storage-limit";
"20000000000000";
"--verbose-signing" ]
@ opt delegate ~f:(fun s -> (* Baby & Aths *) ["--delegate"; s])
@ (if delegatable then [(* Aths *) "--delegatable"] else [])
@ if spendable then [(* Aths *) "--spendable"] else []
in
return origination
let originate_id_script ?push_drops state ~client ~name ~from ~bake
~protocol_kind ~parameter ~init_storage =
prepare_origination_of_id_script
state
~client
~name
~from
~protocol_kind
?push_drops
~parameter
~init_storage
>>= fun origination ->
Tezos_client.successful_client_cmd state ~client origination
>>= fun _ -> Fmt.kstrf bake "baking `%s` in" name
let pp_warning_ledger_takes_a_while ~adjective =
let open MFmt in
fun ppf () ->
cut ppf () ;
let prompt = "WARNING: " in
let warning1 = "The ledger will take a few seconds to show" in
let warning2 = strf "the hash for such a %s operation." adjective in
let wl = String.length prompt + String.length warning1 in
tag "shout" ppf (fun ppf -> string ppf ("/" ^ String.make wl '=' ^ "\\")) ;
cut ppf () ;
tag "shout" ppf (fun ppf -> pf ppf "|%s" prompt) ;
string ppf warning1 ;
tag "shout" ppf (fun ppf -> string ppf "|") ;
cut ppf () ;
tag "shout" ppf (fun ppf -> pf ppf "|") ;
string ppf String.(make (length prompt) ' ') ;
string ppf warning2 ;
string ppf String.(make (length warning1 - length warning2) ' ') ;
tag "shout" ppf (fun ppf -> string ppf "|") ;
cut ppf () ;
tag "shout" ppf (fun ppf -> string ppf ("\\" ^ String.make wl '=' ^ "/"))
let basic_contract_operations_tests state ~client ~src ~with_rejections
~protocol_kind ~ledger_account ~bake ~delegate () =
let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
let only_success = not with_rejections in
let test_origination ?delegate ?delegatable ?spendable ?push_drops ~name
~amount ~parameter ~init_storage () =
prepare_origination_of_id_script
~amount
?push_drops
state
~client
~name
~from:src
?delegate
?delegatable
?spendable
~protocol_kind
~parameter
~init_storage
>>= fun origination ->
with_ledger_test_reject_and_accept
state
~only_success
~messages:
MFmt.
[ (fun ppf () ->
wf ppf "Origination: %s (ledger: %s)" name ledger_pkh);
show_command_message origination;
please_check_the_hash;
( if push_drops <> None then
pp_warning_ledger_takes_a_while ~adjective:"huge"
else const string "" ) ]
(fun ~user_answer ->
client_async_cmd
state
~client
~f:(fun _ proc ->
find_and_print_signature_hash ~display_expectation:true state proc)
origination
>>= fun res ->
expect_from_output
~message:name
res
~expectation:
( match user_answer with
| `Reject ->
`Ledger_reject_or_timeout
| `Accept ->
`Success ))
>>= fun _ -> ksprintf bake "%s with %s" name src
in
test_origination
~name:"ID-unit"
~amount:"0"
~parameter:"unit"
~init_storage:"Unit"
()
>>= fun () ->
test_origination
~name:"ID-string"
~amount:"10"
~parameter:"string"
~init_storage:"\"some string\""
()
>>= fun () ->
test_origination
~name:"ID-string-nat-mutez"
~amount:"10"
~parameter:"(pair string (pair nat mutez))"
~init_storage:"Pair \"hello\" (Pair 12 1)"
()
>>= fun () ->
test_origination
~name:"ID-address+delegate"
~amount:"1"
~parameter:"address"
~delegate
~init_storage:"\"tz1YPSCGWXwBdTncK2aCctSZAXWvGsGwVJqU\""
()
>>= fun () ->
( match protocol_kind with
| `Athens ->
test_origination
~name:"ID-string+delegatable"
~amount:"0"
~parameter:"string"
~delegate
~init_storage:"\"delegatable contract\""
~delegatable:true
()
| `Babylon ->
return () )
>>= fun () ->
let push_drops =
(* Found by dichotomic trial-and-error :)
240 works, 250 fails at 16870 bytes, ⦠*)
242
in
test_origination
~push_drops
~name:"giant-contract"
~amount:"10"
~parameter:"(pair string nat)"
~init_storage:"Pair \"the answer is: \" 42"
()
module Wallet_scenario = struct
type root =
[ `All
| `Voting
| `Batch_transactions
| `Delegation
| `Transactions
| `Contracts
| `None ]
type t = [root | `Without_rejections of root]
let with_rejections : t -> bool = function
| `Without_rejections _ ->
false
| _ ->
true
let enum_assoc : (string * root) list =
[ ("everything", `All);
("voting", `Voting);
("none", `None);
("delegation", `Delegation);
("transactions", `Transactions);
("contracts", `Contracts);
("batch-transactions", `Batch_transactions) ]
let root (ws : t) =
match ws with `Without_rejections r -> r | #root as r -> r
let run_if v t ~yes ~no =
let with_rejections = with_rejections t in
match root t with
| `All ->
yes ~with_rejections
| other when other = v ->
yes ~with_rejections
| _other ->
no
(List.find_map_exn enum_assoc ~f:(function
| (k, this) when v = this ->
Some k
| _ ->
None))
let if_voting t = run_if `Voting t
let if_batch_transactions t = run_if `Batch_transactions t
let if_delegation t = run_if `Delegation t
let if_transactions t = run_if `Transactions t
let if_contracts t = run_if `Contracts t
let cli_term () =
let make no_rejections v =
if no_rejections then `Without_rejections v else (v :> t)
in
let open Cmdliner in
let open Term in
pure make
$ Arg.(
value
(flag (info ["no-rejections"] ~doc:"Do not test ledger rejections.")))
$ Arg.(
value
(opt
(enum ([("all", `All)] @ enum_assoc))
`All
(info
["only-test"]
~doc:
(Fmt.strf
"Limit to a family of tests (one of: %s)."
( List.map enum_assoc ~f:(fun (n, _) -> sprintf "`%s`" n)
|> String.concat ~sep:", " )))))
end
let run state ~pp_error ~protocol ~protocol_kind ~node_exec ~client_exec
~admin_exec ~wallet_scenario ~size ~base_port ~uri () =
Helpers.clear_root state
>>= fun () ->
Helpers.System_dependencies.precheck
state
`Or_fail
~executables:[node_exec; client_exec; admin_exec]
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.[af "Ready to start"; af "Root path deleted."]
>>= fun () ->
let ledger_client = Tezos_client.no_node_client ~exec:client_exec in
Tezos_client.Ledger.show_ledger state ~client:ledger_client ~uri
>>= fun _ledger_account ->
let (protocol, baker_0_account, _baker_0_balance) =
let open Tezos_protocol in
let d = protocol in
let baker = List.nth_exn d.bootstrap_accounts 0 in
( {
d with
kind = protocol_kind;
time_between_blocks = [1; 0];
bootstrap_accounts =
List.map d.bootstrap_accounts ~f:(fun (n, v) ->
if fst baker = n then (n, v) else (n, 1_000L));
},
fst baker,
snd baker )
in
Test_scenario.network_with_protocol
~protocol
~size
~base_port
state
~node_exec
~client_exec
>>= fun (nodes, protocol) ->
let client n =
Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n)
in
let client_0 = client 0 in
let baker_0 =
Tezos_client.Keyed.make
client_0
~key_name:"baker-0"
~secret_key:(Tezos_protocol.Account.private_key baker_0_account)
in
Tezos_client.Keyed.initialize state baker_0
>>= fun _ ->
let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.(
all_defaults state ~nodes
@ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
@ arbitrary_commands_for_each_and_all_clients
state
~make_admin
~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
let first_bakes = 3 in
Loop.n_times first_bakes (fun nth ->
ksprintf (Tezos_client.Keyed.bake state baker_0) "initial-bake %d" nth)
>>= fun () ->
Interactive_test.Pauser.generic state EF.[af "About to really start playing"]
>>= fun () ->
let signer =
Tezos_client.Keyed.make (client 0) ~key_name:"ledgered" ~secret_key:uri
in
Tezos_client.Ledger.show_ledger state ~client:client_0 ~uri
>>= fun ledger_account ->
Tezos_client.successful_client_cmd
state
~client:client_0
[ "--wait";
"none";
"transfer";
"20000";
"from";
baker_0.Tezos_client.Keyed.key_name;
"to" (* *);
Tezos_protocol.Account.pubkey_hash ledger_account;
"--burn-cap";
"100" ]
>>= fun _ ->
let bake msg = Tezos_client.Keyed.bake state baker_0 msg in
bake "After transferring tez to the ledger account"
>>= fun () ->
with_ledger_test_reject_and_accept
~only_success:(Wallet_scenario.with_rejections wallet_scenario |> not)
state
~messages:
MFmt.
[ (fun ppf () ->
wf ppf "Importing %S in client `%s`." uri client_0.Tezos_client.id);
(fun ppf () ->
wf
ppf
"The ledger should be prompting for acknowledgment to provide \
the public key of `%s`."
(Tezos_protocol.Account.pubkey_hash ledger_account)) ]
(fun ~user_answer ->
Tezos_client.client_cmd
state
~client:client_0
[ "import";
"secret";
"key";
signer.key_name;
signer.secret_key;
"--force" ]
>>= fun (_, proc) ->
expect_from_output
~message:"importing key"
proc
~expectation:
( match user_answer with
| `Accept ->
`Success
| `Reject ->
`Ledger_reject_or_timeout ))
>>= fun () ->
let skipping s = Console.say state EF.(haf "Skipping %s tests" s) in
let voting_test ~with_rejections =
let tested_proposal =
"Pt24m4xiPbLDhVgVfABUjirbmda3yohdN82Sp9FeuAXJ4eV9otd"
in
voting_tests
state
~client
~ledger_account
~src:signer.key_name
()
~with_rejections
~protocol_kind
~tested_proposal
~go_to_next_period:(fun () ->
Tezos_client.successful_client_cmd
state
~client:client_0
[ "--wait";
"none";
"submit";
"proposals";
"for";
baker_0.Tezos_client.Keyed.key_name;
tested_proposal;
"--force" ]
>>= fun _ ->
let blocks = protocol.Tezos_protocol.blocks_per_voting_period in
Loop.n_times blocks (fun nth ->
ksprintf
(Tezos_client.Keyed.bake state baker_0)
"going to testing-vote period %d/%d"
(nth + 1)
blocks)
>>= fun () -> return ())
in
let batch_test ~with_rejections =
let n = 50 in
forge_batch_transactions
state
~client:(client 0)
~src:(Tezos_protocol.Account.pubkey_hash ledger_account)
~dest:"tz2KZPgf2rshxNUBXFcTaCemik1LH1v9qz3F"
~n
()
>>= fun batch_transaction_bytes ->
let bytes_hash =
Tezos_crypto.(
`Hex batch_transaction_bytes |> Hex.to_bytes
|> (fun x -> [x])
|> Blake2B.hash_bytes |> Blake2B.to_string |> Base58.raw_encode)
in
with_ledger_test_reject_and_accept
state
~only_success:(not with_rejections)
~messages:
MFmt.
[ (fun ppf () -> wf ppf "Signing batch of %d transactions" n);
(fun ppf () ->
wf
ppf
"Ledger should display âSign Hashâ â `%s`"
bytes_hash);
pp_warning_ledger_takes_a_while ~adjective:"big" ]
(fun ~user_answer ->
sign state ~client:signer ~bytes:batch_transaction_bytes
>>= fun (_, proc) ->
expect_from_output
~message:"Signing batch operation"
proc
~expectation:
( match user_answer with
| `Accept ->
`Success
| `Reject ->
`Ledger_reject_or_timeout ))
in
let delegation_tests ~with_rejections =
delegation_tests
state
~client:client_0
~ledger_account
~delegate:baker_0.Tezos_client.Keyed.key_name
~src:signer.key_name
()
~bake
~with_rejections
~protocol_kind
in
let unit_kt1_account = "unit-kt1-of-the-baker" in
originate_id_script
state
~client:client_0
~name:unit_kt1_account
~from:baker_0.Tezos_client.Keyed.key_name
~bake
~protocol_kind
~parameter:"unit"
~init_storage:"Unit"
>>= fun () ->
let pair_string_nat_kt1_account = "pair-string-nat-kt1-of-the-baker" in
originate_id_script
state
~client:client_0
~name:pair_string_nat_kt1_account
~push_drops:10
~from:baker_0.Tezos_client.Keyed.key_name
~bake
~protocol_kind
~parameter:"(pair string nat)"
~init_storage:"Pair \"the answer is: \" 42"
>>= fun () ->
let transactions_test ~with_rejections =
transaction_tests
state
~client:client_0
~ledger_account
~unit_kt1_account
~pair_string_nat_kt1_account
~src:signer.key_name
()
~bake
~with_rejections
~protocol_kind
in
let contracts_test ~with_rejections =
basic_contract_operations_tests
state
~client:client_0
~ledger_account
~delegate:baker_0.Tezos_client.Keyed.key_name
~src:signer.key_name
()
~bake
~with_rejections
~protocol_kind
in
let bake_command =
Console.Prompt.unit_and_loop
EF.(wf "Bake a block with the default baker.")
["bake"]
(fun _sexps ->
Asynchronous_result.transform_error
~f:(fun e ->
Format.kasprintf
(fun s -> `Command_line s)
"run-test-error: %a"
pp_error
e)
(bake "Interactive"))
in
let run_test_command =
Console.Prompt.unit_and_loop
EF.(
wf
"Run a test (%s)."
(List.map Wallet_scenario.enum_assoc ~f:fst |> String.concat ~sep:"|"))
["rt"; "run-test"]
(fun sexps ->
Asynchronous_result.transform_error
~f:(fun e ->
Format.kasprintf
(fun s -> `Command_line s)
"run-test-error: %a"
pp_error
e)
( match sexps with
| [Atom a] -> (
let run f = f ~with_rejections:true in
match
List.Assoc.find
~equal:String.equal
Wallet_scenario.enum_assoc
a
with
| Some `None ->
return ()
| Some `Delegation ->
run delegation_tests
| Some `All ->
run delegation_tests
>>= fun () -> run batch_test >>= fun () -> run voting_test
| Some `Batch_transactions ->
run batch_test
| Some `Transactions ->
run transactions_test
| Some `Voting ->
run voting_test
| Some `Contracts ->
run contracts_test
| None ->
failf "Don't know this test: %S" a )
| _ ->
failf "Cannot understand command line" ))
in
Interactive_test.Pauser.add_commands state [run_test_command; bake_command] ;
Wallet_scenario.if_voting wallet_scenario ~yes:voting_test ~no:skipping
>>= fun () ->
Wallet_scenario.if_batch_transactions
wallet_scenario
~yes:batch_test
~no:skipping
>>= fun () ->
Wallet_scenario.if_transactions
wallet_scenario
~yes:transactions_test
~no:skipping
>>= fun () ->
Wallet_scenario.if_contracts wallet_scenario ~yes:contracts_test ~no:skipping
>>= fun () ->
Wallet_scenario.if_delegation
wallet_scenario
~yes:delegation_tests
~no:skipping
>>= fun () -> Interactive_test.Pauser.generic state EF.[af "Tests done."]
let cmd ~pp_error () =
let open Cmdliner in
let open Term in
Test_command_line.Run_command.make
~pp_error
( pure
(fun uri
node_exec
client_exec
admin_exec
size
(`Base_port base_port)
protocol
wallet_scenario
state
->
( state,
Interactive_test.Pauser.run_test
~pp_error
state
(run
state
~protocol_kind:protocol.kind
~node_exec
~size
~admin_exec
~base_port
~pp_error
~wallet_scenario
~protocol
~client_exec
~uri) ))
$ Arg.(
required
(pos
0
(some string)
None
(info [] ~docv:"LEDGER-URI" ~doc:"ledger:// URI")))
$ Tezos_executable.cli_term `Node "tezos"
$ Tezos_executable.cli_term `Client "tezos"
$ Tezos_executable.cli_term `Admin "tezos"
$ Arg.(value (opt int 2 (info ["size"; "S"] ~doc:"Size of the Network")))
$ Arg.(
pure (fun p -> `Base_port p)
$ value
(opt
int
32_000
(info ["base-port"; "P"] ~doc:"Base port number to build upon")))
$ Tezos_protocol.cli_term ()
$ Wallet_scenario.cli_term ()
$ Test_command_line.cli_state ~name:"ledger-wallet" () )
(let doc = "Interactive test exercising the Ledger Wallet app features" in
info ~doc "ledger-wallet")
src/bin_sandbox/command_ledger_wallet.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition client_async_cmd {A B C D E F : Type}
(state : A) (client : B) (args : list string) (f : C -> D -> E) : F :=
op_startypeminuserrorstar
(op_startypeminuserrorstar "client_async_cmd" % string state f
"sh -c %s" % string
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar client state args)
op_startypeminuserrorstar) Filename.quote))
(fun function_parameter =>
let '(status, res) := function_parameter in
op_startypeminuserrorstar op_startypeminuserrorstar).
Definition ledger_hash_re {A : Type} : lazy_t A :=
(* ❌ Lazy expressions are not handled *)
lazy op_startypeminuserrorstar.
Definition find_and_print_signature_hash {A B C : Type}
(op_staroptstar : option bool) : A -> B -> C :=
let display_expectation :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun state =>
fun process =>
let re := Lazy.force ledger_hash_re in
let check {D E : Type} (lines : D) : E :=
op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar process
("" % string, "" % string, (negb display_expectation))
(fun function_parameter =>
let '(all_output_prev, all_error_prev, showed_message_prev) :=
function_parameter in
fun out =>
fun err =>
let all_output := String.append all_output_prev out in
let all_error := String.append all_error_prev err in
op_startypeminuserrorstar
(if negb showed_message_prev then
match check all_output with
| None => op_startypeminuserrorstar false
| Some x =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar true)
end
else
op_startypeminuserrorstar true)
(fun showed_message =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant)))
(fun function_parameter =>
let '(output, error, _) := function_parameter in
op_startypeminuserrorstar
((op_startypeminuserrorstar "010" % char output),
(op_startypeminuserrorstar "010" % char error))).
Module MFmt.
End MFmt.
Definition failf {A B C : Type} (attach : option A) (fmt : B) : C :=
op_startypeminuserrorstar
(fun s =>
op_startypeminuserrorstar attach
(* ❌ Variants not supported *)
variant) fmt.
Definition process_should_fail {A B C : Type} (msg : A) (f : unit -> B) : C :=
op_startypeminuserrorstar
(op_startypeminuserrorstar (f tt)
(fun function_parameter =>
let '_ := function_parameter in
match
(* ❌ Sending method message is not handled *)
send with
| Unix.WEXITED 0 =>
failf
(Some
(cons
("stdout" % string,
(* ❌ Variants not supported *)
variant)
(cons
("stderr" % string,
(* ❌ Variants not supported *)
variant) []))) "Process should have failed: %s" % string msg
| _ => op_startypeminuserrorstar tt
end))
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar tt).
Definition ledger_prompt_notice {A B C : Type}
(state : A) (msgs : B -> unit) (op_staroptstar : option variant)
: unit -> C :=
let button :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun function_parameter =>
let 'tt := function_parameter in
let button_str :=
match button with
| Checkmark => "✔" % string
| X => "❌" % string
| Both => "❌ and ✔ at the same time" % string
end in
op_startypeminuserrorstar state
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar 4 ppf
(fun ppf =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf
(fun ppf =>
op_startypeminuserrorstar op_startypeminuserrorstar
"Ledger-prompt:" % string ppf tt) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.List.iter msgs
(* ❌ expected an argument *)
expected_argument
(fun f =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := f ppf tt in
op_startypeminuserrorstar ppf tt) in
op_startypeminuserrorstar ppf
"→ Press %s on the ledger." % string button_str)).
Definition ledger_prompt_notice_expectation {A B C : Type}
(state : A) (messages : list (B -> unit -> unit)) (user_answer : variant)
: C := op_startypeminuserrorstar.
Definition with_ledger_test_reject_and_accept {A B C D : Type}
(op_staroptstar : option bool)
: A -> (list (B -> unit -> unit)) -> (variant -> C) -> D :=
let only_success :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun state =>
fun messages =>
fun f =>
let with_ledger_prompt {E F : Type}
(state : A) (messages : list (B -> unit -> unit)) (user_answer :
variant) (f : variant -> E) : F :=
op_startypeminuserrorstar
(ledger_prompt_notice_expectation state messages user_answer)
(fun function_parameter =>
let 'tt := function_parameter in
f user_answer) in
op_startypeminuserrorstar
(if only_success then
op_startypeminuserrorstar tt
else
with_ledger_prompt state messages
(* ❌ Variants not supported *)
variant f)
(fun function_parameter =>
let 'tt := function_parameter in
with_ledger_prompt state messages
(* ❌ Variants not supported *)
variant f).
Definition get_chain_id {A B C : Type} (state : A) (client : B) : C :=
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(* ❌ Variants not supported *)
variant "/chains/main/chain_id" % string)
(fun function_parameter =>
match function_parameter with
| String x => op_startypeminuserrorstar x
| _ => failf None "Failed to parse chain_id JSON from node" % string
end))
(fun chain_id_string =>
op_startypeminuserrorstar (op_startypeminuserrorstar chain_id_string)).
Definition get_head_block_hash {A B C : Type}
(state : A) (client : B) (function_parameter : unit) : C :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(* ❌ Variants not supported *)
variant "/chains/main/blocks/head/hash" % string)
(fun function_parameter =>
match function_parameter with
| String x => op_startypeminuserrorstar x
| _ => failf None "Failed to parse block hash JSON from node" % string
end).
Definition please_check_the_hash {A B : Type}
(ppf : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar "prompt" % string ppf
(fun ppf =>
op_startypeminuserrorstar ppf
"The ledger cannot parse this operation, please verify the hash." %
string).
Definition forge_batch_transactions {A B C D E : Type}
(state : A) (client : B) (src : string) (function_parameter : C)
: D -> (option Z) -> unit -> E :=
let '_ := function_parameter in
fun n =>
fun op_staroptstar =>
let fee :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Float constant 0.00126 is approximated by the integer 0 *)
0
end in
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (get_head_block_hash state client tt)
(fun branch =>
let json :=
(* ❌ Variants not supported *)
variant in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
"/chains/main/blocks/head/helpers/forge/operations" % string
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
match function_parameter with
| String operation_bytes =>
let magic_byte := "03" % string in
op_startypeminuserrorstar
(String.append magic_byte operation_bytes)
| _ =>
failf None
"Failed to forge operation or parse result" % string
end)).
Definition expect_from_output {A B : Type}
(expectation : variant) (message : string) (function_parameter : A) : B :=
let '_ := function_parameter in
let exp :=
match expectation with
| Ledger_reject_or_timeout => "rejection" % string
| Not_a_delegate => "not-delegate-error" % string
| Success => "success" % string
| Origination_failed => "origination-failure" % string
end in
let nope {C D : Type} (s : C) : D :=
failf
(Some
(cons
("stdout" % string,
(* ❌ Variants not supported *)
variant)
(cons
("stderr" % string,
(* ❌ Variants not supported *)
variant) []))) "%s, expected %s: %s." % string message exp s in
let success :=
equiv_decb
(* ❌ Sending method message is not handled *)
send (Unix.WEXITED 0) in
match expectation with
| Success => op_startypeminuserrorstar tt
| Success => nope "did not succeed" % string
| (Ledger_reject_or_timeout | Not_a_delegate | Origination_failed) as e =>
let pattern :=
match e with
| Ledger_reject_or_timeout => "Conditions of use not satisfied" % string
| Not_a_delegate => "not registered as valid delegate key" % string
| Origination_failed => "origination simulation failed" % string
end in
let all_output :=
Stdlib.String.concat op_startypeminuserrorstar
(* ❌ expected an argument *)
expected_argument "
" % string in
match (success, (op_startypeminuserrorstar all_output pattern)) with
| (false, Some _) => op_startypeminuserrorstar tt
| (false, None) => nope "cannot find the right error message" % string
| (true, _) => nope "command succeeded??" % string
end
end.
Definition voting_tests {A B C D E : Type}
(state : A) (client : Z -> B) (src : string) (with_rejections : bool)
(protocol_kind : variant) (ledger_account : C) (tested_proposal : string)
(go_to_next_period : unit -> D) (function_parameter : unit) : E :=
let 'tt := function_parameter in
let expect_success {F G : Type} (message : string) (v : F) : G :=
expect_from_output
(* ❌ Variants not supported *)
variant message v in
let expect_rejection {F G : Type} (message : string) (v : F) : G :=
expect_from_output
(* ❌ Variants not supported *)
variant message v in
let test_reject_and_accept {F G H : Type}
(name : string) (messages : list (F -> unit -> unit)) (action : unit -> G)
: H :=
op_startypeminuserrorstar
(if with_rejections then
op_startypeminuserrorstar
(ledger_prompt_notice_expectation state messages
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (action tt)
(fun res => expect_rejection name res))
else
op_startypeminuserrorstar tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(ledger_prompt_notice_expectation state messages
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (action tt)
(fun res => expect_success name res))) in
let source_display := op_startypeminuserrorstar ledger_account in
let submit_proposals {F : Type}
(display_expectation : bool) (proposals : list string) (function_parameter :
unit) : F :=
let 'tt := function_parameter in
client_async_cmd state (client 0)
(OCaml.Stdlib.app
(cons "submit" % string
(cons "proposals" % string (cons "for" % string (cons src []))))
(OCaml.Stdlib.app proposals
(cons "--force" % string (cons "--verbose-signing" % string []))))
(fun function_parameter =>
let '_ := function_parameter in
fun proc =>
find_and_print_signature_hash (Some display_expectation) state proc)
in
op_startypeminuserrorstar
(test_reject_and_accept "single-proposal" % string
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Submitting single proposal %s" % string tested_proposal)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
match protocol_kind with
| Athens => tt
| Babylon =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf
"On Babylon, You will first be asked to provide the public key."
% string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
op_startypeminuserrorstar ppf
"Accept this prompt, regardless of below, then continue." %
string
end)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf 4
(fun ppf =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf
"Protocol is %a, the ledger should be able to display voting parameters:"
% string op_startypeminuserrorstar protocol_kind in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf "* Source: `%s`" % string
source_display in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf "* Period: `0`" % string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
op_startypeminuserrorstar ppf "* Protocol: `%s`" % string
tested_proposal)) [])))
(submit_proposals false (cons tested_proposal [])))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(test_reject_and_accept "multiple-proposal" % string
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Submitting 2 proposals together" % string)
(cons please_check_the_hash []))
(submit_proposals true
(cons tested_proposal
(cons
"Psd1ynUBhMZAeajwcZJAeq5NrxorM6UCU4GJqxZ7Bx2e9vUWB6z" % string
[]))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (go_to_next_period tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(cons "yea" % string (cons "nay" % string []))
(fun n =>
fun vote =>
test_reject_and_accept
(op_startypeminuserrorstar "vote-%s" % string vote)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
match protocol_kind with
| Athens => tt
| Babylon =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf
"On Babylon, You will first be asked to provide the public key."
% string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
op_startypeminuserrorstar ppf
"Accept this prompt, regardless of below, then continue."
% string
end)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Voting %s for %s" % string vote tested_proposal)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Source: `%s`" % string source_display)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Period: `%i`" % string (Z.add n 1))
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Protocol: `%s`" % string tested_proposal)
[])))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state (client 0)
(cons "submit" % string
(cons "ballot" % string
(cons "for" % string
(cons src
(cons tested_proposal (cons vote [])))))))
(fun function_parameter =>
let '(_, proc) := function_parameter in
op_startypeminuserrorstar proc)))))).
Definition ledger_should_display {A B C : Type} (ppf : A) (l : B -> unit) : C :=
op_startypeminuserrorstar 4 ppf
(fun ppf =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf "Ledger should display:" % string
in
Stdlib.List.iter l
(* ❌ expected an argument *)
expected_argument
(fun function_parameter =>
let '(s, f) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
op_startypeminuserrorstar ppf "* %s: %a." % string s f tt)).
Definition show_command_message {A : Type}
(command : list string) (ppf : A) (function_parameter : unit) : unit :=
let 'tt := function_parameter in
op_startypeminuserrorstar 2 ppf
(fun ppf =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf "Command:" % string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
op_startypeminuserrorstar
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar) op_startypeminuserrorstar ppf tt).
Definition sign {A B C : Type} (state : A) (client : B) (bytes : string) : C :=
op_startypeminuserrorstar state (Tezos_client.Keyed.client client)
(cons "sign" % string
(cons "bytes" % string
(cons (String.append "0x" % string string)
(cons "for" % string (cons (Tezos_client.Keyed.key_name client) []))))).
Definition delegation_tests {A B C D E : Type}
(state : A) (client : B) (src : string) (with_rejections : bool)
(protocol_kind : variant) (ledger_account : C) (delegate : string) (bake : D)
(function_parameter : unit) : E :=
let 'tt := function_parameter in
let ledger_pkh := op_startypeminuserrorstar ledger_account in
let only_success := negb with_rejections in
let self_delegation {F : Type} (function_parameter : unit) : F :=
let 'tt := function_parameter in
let command :=
cons "--wait" % string
(cons "none" % string
(cons "set" % string
(cons "delegate" % string
(cons "for" % string
(cons src
(cons "to" % string
(cons src (cons "--verbose-signing" % string [])))))))) in
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept (Some only_success) state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Self-delegating account `%s`" % string ledger_pkh)
(cons (show_command_message command)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Note that X is a placeholder for some value that will vary between runs"
% string)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
ledger_should_display ppf op_startypeminuserrorstar) []))))
(fun user_answer =>
op_startypeminuserrorstar
(client_async_cmd state client command
(fun function_parameter =>
let '_ := function_parameter in
fun proc =>
find_and_print_signature_hash
(Some
(equiv_decb protocol_kind
(* ❌ Variants not supported *)
variant)) state proc))
(fun res =>
expect_from_output
match user_answer with
| Reject =>
(* ❌ Variants not supported *)
variant
| Accept =>
(* ❌ Variants not supported *)
variant
end "self-delegation" % string res)))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar bake "setting self-delegate of %s" % string
src) in
let tz_account_delegation {F : Type} (function_parameter : unit) : F :=
let 'tt := function_parameter in
let command :=
cons "--wait" % string
(cons "none" % string
(cons "set" % string
(cons "delegate" % string
(cons "for" % string
(cons src
(cons "to" % string
(cons delegate (cons "--verbose-signing" % string []))))))))
in
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept (Some only_success) state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Delegating account `%s` to `%s`" % string ledger_pkh delegate)
(cons (show_command_message command)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Note that X is a placeholder for some value that will vary between runs"
% string)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
ledger_should_display ppf op_startypeminuserrorstar) []))))
(fun user_answer =>
op_startypeminuserrorstar
(client_async_cmd state client command
(fun function_parameter =>
let '_ := function_parameter in
fun proc =>
find_and_print_signature_hash
(Some
(equiv_decb protocol_kind
(* ❌ Variants not supported *)
variant)) state proc))
(fun res =>
expect_from_output
match user_answer with
| Reject =>
(* ❌ Variants not supported *)
variant
| Accept =>
(* ❌ Variants not supported *)
variant
end "tz123-delegation" % string res)))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar bake "setting delegate of %s" % string src) in
let run_command_and_check {F G H I : Type}
(state : F) (client : G) (command : H) (message : string) (user_answer :
variant) : I :=
op_startypeminuserrorstar (op_startypeminuserrorstar state client command)
(fun function_parameter =>
let '(_, res) := function_parameter in
expect_from_output
match user_answer with
| Reject =>
(* ❌ Variants not supported *)
variant
| Accept =>
(* ❌ Variants not supported *)
variant
end message res) in
let delegate_with_scriptless_account {F : Type} (function_parameter : unit)
: F :=
let 'tt := function_parameter in
let originated_account_name := "ledginated" % string in
let amount := "200" % string in
let burn_cap := "0.257" % string in
let command :=
cons "--wait" % string
(cons "none" % string
(cons "originate" % string
(cons "account" % string
(cons originated_account_name
(cons "for" % string
(cons src
(cons "transferring" % string
(cons "200" % string
(cons "from" % string
(cons src
(cons "--delegatable" % string
(cons "--burn-cap" % string
(cons burn_cap (cons "--force" % string []))))))))))))))
in
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept (Some only_success) state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf "Originating account `%s`" % string
originated_account_name)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
ledger_should_display ppf op_startypeminuserrorstar) []))
(fun user_answer =>
run_command_and_check state client command
"account origination" % string user_answer))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar bake "origination of %s" % string
originated_account_name)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(cons "show" % string
(cons "known" % string
(cons "contract" % string (cons originated_account_name [])))))
(fun function_parameter =>
let '(_, proc_result) := function_parameter in
let contract_address :=
OCaml.Stdlib.reverse_apply
(* ❌ Sending method message is not handled *)
send
(Stdlib.String.concat
(* ❌ expected an argument *)
expected_argument
(* ❌ expected an argument *)
expected_argument "" % string) in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(cons "show" % string
(cons "address" % string (cons delegate []))))
(fun function_parameter =>
let '(_, proc_result) := function_parameter in
let delegate_address :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar
(* ❌ Sending method message is not handled *)
send) (op_startypeminuserrorstar " " % char))
op_startypeminuserrorstar)
(op_startypeminuserrorstar delegate) in
let command :=
cons "--wait" % string
(cons "none" % string
(cons "set" % string
(cons "delegate" % string
(cons "for" % string
(cons originated_account_name
(cons "to" % string (cons delegate [])))))))
in
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept (Some only_success)
state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Setting `%s` as delegate for `%s`" % string
delegate originated_account_name)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
ledger_should_display ppf
op_startypeminuserrorstar) []))
(fun user_answer =>
run_command_and_check state client command
"setting delegate of KT1" % string user_answer))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar bake
"setting delegate of %s" % string
originated_account_name)
(fun function_parameter =>
let 'tt := function_parameter in
let withdraw_command :=
cons "--wait" % string
(cons "none" % string
(cons "withdraw" % string
(cons "delegate" % string
(cons "from" % string
(cons originated_account_name []))))) in
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept
(Some only_success) state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Withdrawing delegate from `%s`" %
string originated_account_name)
(cons (show_command_message withdraw_command)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
ledger_should_display ppf
op_startypeminuserrorstar) [])))
(fun user_answer =>
run_command_and_check state client
withdraw_command
"withdrawing delegate from originated account"
% string user_answer))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar bake
"withdrawing delegate of %s" % string
originated_account_name))))))) in
match protocol_kind with
| Athens =>
op_startypeminuserrorstar (self_delegation tt)
(fun function_parameter =>
let 'tt := function_parameter in
delegate_with_scriptless_account tt)
| Babylon =>
op_startypeminuserrorstar (tz_account_delegation tt)
(fun function_parameter =>
let 'tt := function_parameter in
self_delegation tt)
end.
Definition transaction_tests {A B C D E : Type}
(state : A) (client : B) (src : string) (with_rejections : bool)
(protocol_kind : variant) (pair_string_nat_kt1_account : string)
(ledger_account : C) (unit_kt1_account : string) (bake : D)
(function_parameter : unit) : E :=
let 'tt := function_parameter in
let ledger_pkh := op_startypeminuserrorstar ledger_account in
let only_success := negb with_rejections in
let test_transaction {F G H : Type} (op_staroptstar : option Z)
: (option F) -> string -> string -> G -> unit -> H :=
let storage :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 0
end in
fun arguments =>
fun name =>
fun dst_name =>
fun dst_pkh =>
fun function_parameter =>
let 'tt := function_parameter in
let amount := "15" % string in
let command :=
OCaml.Stdlib.app
(cons "--wait" % string
(cons "none" % string
(cons "transfer" % string
(cons amount
(cons "from" % string
(cons src (cons "to" % string (cons dst_name []))))))))
(OCaml.Stdlib.app
(op_startypeminuserrorstar [] arguments
(fun a => cons "--arg" % string (cons a [])))
(cons "--burn-cap" % string
(cons "100" % string
(cons "--verbose-signing" % string [])))) in
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept (Some only_success) state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"%s with account `%s`" % string name ledger_pkh)
(cons (show_command_message command)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Note that X is a placeholder for some value that will vary between runs"
% string)
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
match arguments with
| None =>
ledger_should_display ppf
op_startypeminuserrorstar
| _ => please_check_the_hash ppf tt
end) []))))
(fun user_answer =>
op_startypeminuserrorstar
(client_async_cmd state client command
(fun function_parameter =>
let '_ := function_parameter in
fun proc =>
find_and_print_signature_hash
(Some
(orb
(equiv_decb protocol_kind
(* ❌ Variants not supported *)
variant) (nequiv_decb arguments None)))
state proc))
(fun res =>
expect_from_output
match user_answer with
| Reject =>
(* ❌ Variants not supported *)
variant
| Accept =>
(* ❌ Variants not supported *)
variant
end name res)))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar bake "%s with %s" % string name src)
in
op_startypeminuserrorstar
(test_transaction None None "Self-transaction" % string src ledger_pkh tt)
(fun function_parameter =>
let 'tt := function_parameter in
let Acc :=
(* ❌ The signature name of this module could not be found *)
existT _ _
{|
|} in
let random_account :=
op_startypeminuserrorstar "random-account-for-transaction-test" % string
in
op_startypeminuserrorstar
(test_transaction (Some 277) None "transaction-to-random-tz1" % string
(op_startypeminuserrorstar random_account)
(op_startypeminuserrorstar random_account) tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(test_transaction (Some 0) None
"transaction-to-random-tz1-again" % string
(op_startypeminuserrorstar random_account)
(op_startypeminuserrorstar random_account) tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(test_transaction None None
"parameterless-transaction-to-kt1" % string unit_kt1_account
"KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" % string tt)
(fun function_parameter =>
let 'tt := function_parameter in
test_transaction None
(Some "Pair ""hello from the ledger"" 51" % string)
"parameterfull-transaction-to-kt1" % string
pair_string_nat_kt1_account
"KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" % string tt)))).
Definition prepare_origination_of_id_script {A B C D : Type}
(op_staroptstar : option bool)
: (option bool) ->
(option A) ->
(option Z) ->
(option string) ->
B -> C -> string -> string -> variant -> string -> string -> D :=
let spendable :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun op_staroptstar =>
let delegatable :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun delegate =>
fun op_staroptstar =>
let push_drops :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 0
end in
fun op_staroptstar =>
let amount :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "2" % string
end in
fun state =>
fun function_parameter =>
let '_ := function_parameter in
fun name =>
fun from =>
fun protocol_kind =>
fun parameter =>
fun init_storage =>
let id_script {E : Type} (parameter : string) : E :=
op_startypeminuserrorstar
"parameter %s;
storage %s;
code
{
%s
{ CAR; NIL operation; PAIR }
};
"
% string parameter parameter
match push_drops with
| 0 => "# No push-drops" % string
| n =>
op_startypeminuserrorstar
"# %d push-drop%s
%s" % string n
(if OCaml.Stdlib.gt n 1 then
"s" % string
else
"" % string) op_startypeminuserrorstar
end in
let tmp :=
Filename.temp_file None "little-id-script" % string
".tz" % string in
op_startypeminuserrorstar
(op_startypeminuserrorstar state tmp
(id_script parameter))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
op_startypeminuserrorstar in
let origination :=
let opt := op_startypeminuserrorstar [] in
OCaml.Stdlib.app
(cons "--wait" % string
(cons "none" % string
(cons "originate" % string
(cons "contract" % string (cons name [])))))
(OCaml.Stdlib.app
match protocol_kind with
| Athens => cons "for" % string (cons from [])
| Babylon => []
end
(OCaml.Stdlib.app
(cons "transferring" % string
(cons amount
(cons "from" % string
(cons from
(cons "running" % string
(cons tmp
(cons "--init" % string
(cons init_storage
(cons "--force" % string
(cons
"--burn-cap" % string
(cons
"300000000000" %
string
(cons
"--gas-limit" %
string
(cons
"1000000000000000"
% string
(cons
"--storage-limit"
% string
(cons
"20000000000000"
% string
(cons
"--verbose-signing"
% string
[]))))))))))))))))
(OCaml.Stdlib.app
(opt delegate
(fun s =>
cons "--delegate" % string (cons s [])))
(OCaml.Stdlib.app
(if delegatable then
cons "--delegatable" % string []
else
[])
(if spendable then
cons "--spendable" % string []
else
[]))))) in
op_startypeminuserrorstar origination).
Definition originate_id_script {A B C D : Type}
(push_drops : option Z) (state : A) (client : B) (name : string)
(from : string) (bake : C) (protocol_kind : variant) (parameter : string)
(init_storage : string) : D :=
op_startypeminuserrorstar
(prepare_origination_of_id_script None None None push_drops None state
client name from protocol_kind parameter init_storage)
(fun origination =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state client origination)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar bake "baking `%s` in" % string name)).
Definition pp_warning_ledger_takes_a_while {A B C : Type}
(adjective : A) (ppf : B) (function_parameter : unit) : C :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
let prompt := "WARNING: " % string in
let warning1 := "The ledger will take a few seconds to show" % string in
let warning2 :=
op_startypeminuserrorstar "the hash for such a %s operation." % string
adjective in
let wl := Z.add (OCaml.String.length prompt) (OCaml.String.length warning1) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar "shout" % string ppf
(fun ppf =>
op_startypeminuserrorstar ppf
(String.append "/" % string
(String.append (Stdlib.String.make wl "=" % char) "\" % string))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar "shout" % string ppf
(fun ppf => op_startypeminuserrorstar ppf "|%s" % string prompt) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf warning1 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar "shout" % string ppf
(fun ppf => op_startypeminuserrorstar ppf "|" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar "shout" % string ppf
(fun ppf => op_startypeminuserrorstar ppf "|" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf
(Stdlib.String.make (OCaml.String.length prompt) " " % char) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf warning2 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar ppf
(Stdlib.String.make
(Z.sub (OCaml.String.length warning1) (OCaml.String.length warning2))
" " % char) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar "shout" % string ppf
(fun ppf => op_startypeminuserrorstar ppf "|" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar ppf tt in
op_startypeminuserrorstar "shout" % string ppf
(fun ppf =>
op_startypeminuserrorstar ppf
(String.append "\" % string
(String.append (Stdlib.String.make wl "=" % char) "/" % string))).
Definition basic_contract_operations_tests {A B C D E F : Type}
(state : A) (client : B) (src : string) (with_rejections : bool)
(protocol_kind : variant) (ledger_account : C) (bake : D) (delegate : E)
(function_parameter : unit) : F :=
let 'tt := function_parameter in
let ledger_pkh := op_startypeminuserrorstar ledger_account in
let only_success := negb with_rejections in
let test_origination {G : Type}
(delegate : option E) (delegatable : option bool) (spendable : option bool)
(push_drops : option Z) (name : string) (amount : string) (parameter :
string) (init_storage : string) (function_parameter : unit) : G :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(prepare_origination_of_id_script spendable delegatable delegate
push_drops (Some amount) state client name src protocol_kind parameter
init_storage)
(fun origination =>
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept (Some only_success) state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar ppf
"Origination: %s (ledger: %s)" % string name ledger_pkh)
(cons (show_command_message origination)
(cons please_check_the_hash
(cons
(if nequiv_decb push_drops None then
pp_warning_ledger_takes_a_while "huge" % string
else
op_startypeminuserrorstar op_startypeminuserrorstar
"" % string) []))))
(fun user_answer =>
op_startypeminuserrorstar
(client_async_cmd state client origination
(fun function_parameter =>
let '_ := function_parameter in
fun proc =>
find_and_print_signature_hash (Some true) state proc))
(fun res =>
expect_from_output
match user_answer with
| Reject =>
(* ❌ Variants not supported *)
variant
| Accept =>
(* ❌ Variants not supported *)
variant
end name res)))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar bake "%s with %s" % string name src)) in
op_startypeminuserrorstar
(test_origination None None None None "ID-unit" % string "0" % string
"unit" % string "Unit" % string tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(test_origination None None None None "ID-string" % string "10" % string
"string" % string """some string""" % string tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(test_origination None None None None "ID-string-nat-mutez" % string
"10" % string "(pair string (pair nat mutez))" % string
"Pair ""hello"" (Pair 12 1)" % string tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(test_origination (Some delegate) None None None
"ID-address+delegate" % string "1" % string "address" % string
"""tz1YPSCGWXwBdTncK2aCctSZAXWvGsGwVJqU""" % string tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
match protocol_kind with
| Athens =>
test_origination (Some delegate) (Some true) None None
"ID-string+delegatable" % string "0" % string
"string" % string """delegatable contract""" % string tt
| Babylon => op_startypeminuserrorstar tt
end
(fun function_parameter =>
let 'tt := function_parameter in
let push_drops := 242 in
test_origination None None None (Some push_drops)
"giant-contract" % string "10" % string
"(pair string nat)" % string
"Pair ""the answer is: "" 42" % string tt))))).
Module Wallet_scenario.
Definition root := variant.
Definition t := variant.
Definition with_rejections (function_parameter : t) : bool :=
match function_parameter with
| Without_rejections _ => false
| _ => true
end.
Definition enum_assoc : list (string * root) :=
cons
("everything" % string,
(* ❌ Variants not supported *)
variant)
(cons
("voting" % string,
(* ❌ Variants not supported *)
variant)
(cons
("none" % string,
(* ❌ Variants not supported *)
variant)
(cons
("delegation" % string,
(* ❌ Variants not supported *)
variant)
(cons
("transactions" % string,
(* ❌ Variants not supported *)
variant)
(cons
("contracts" % string,
(* ❌ Variants not supported *)
variant)
(cons
("batch-transactions" % string,
(* ❌ Variants not supported *)
variant) [])))))).
Definition root (ws : t) : root :=
match ws with
| Without_rejections r => r
|
(Transactions |
Delegation | Contracts | All | Batch_transactions | None | Voting) as r
=> r
end.
Definition run_if {A B : Type}
(v : root) (t : t) (yes : bool -> A) (no : B -> A) : A :=
let with_rejections := with_rejections t in
match root t with
| All => yes with_rejections
| other => yes with_rejections
| _other =>
no
(op_startypeminuserrorstar enum_assoc
(fun function_parameter =>
match function_parameter with
| (k, this) => Some k
| _ => None
end))
end.
Definition if_voting {A B : Type} (t : t) : (bool -> A) -> (B -> A) -> A :=
run_if
(* ❌ Variants not supported *)
variant t.
Definition if_batch_transactions {A B : Type} (t : t)
: (bool -> A) -> (B -> A) -> A :=
run_if
(* ❌ Variants not supported *)
variant t.
Definition if_delegation {A B : Type} (t : t)
: (bool -> A) -> (B -> A) -> A :=
run_if
(* ❌ Variants not supported *)
variant t.
Definition if_transactions {A B : Type} (t : t)
: (bool -> A) -> (B -> A) -> A :=
run_if
(* ❌ Variants not supported *)
variant t.
Definition if_contracts {A B : Type} (t : t) : (bool -> A) -> (B -> A) -> A :=
run_if
(* ❌ Variants not supported *)
variant t.
Definition cli_term {A : Type} (function_parameter : unit) : A :=
let 'tt := function_parameter in
let make (no_rejections : bool) (v : root) : t :=
if no_rejections then
(* ❌ Variants not supported *)
variant
else
v in
op_startypeminuserrorstar.
End Wallet_scenario.
Definition run {A B C D E F G H : Type}
(state : A) (pp_error : Stdlib.Format.formatter -> B -> unit) (protocol : C)
(protocol_kind : variant) (node_exec : D) (client_exec : D) (admin_exec : D)
(wallet_scenario : Wallet_scenario.t) (size : E) (base_port : F) (uri : G)
(function_parameter : unit) : H :=
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
(* ❌ Variants not supported *)
variant (cons node_exec (cons client_exec (cons admin_exec []))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let ledger_client := op_startypeminuserrorstar client_exec in
op_startypeminuserrorstar
(op_startypeminuserrorstar state ledger_client uri)
(fun _ledger_account =>
let '(protocol, baker_0_account, _baker_0_balance) :=
op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar protocol size base_port state
node_exec client_exec)
(fun function_parameter =>
let '(nodes, protocol) := function_parameter in
let client {I J : Type} (n : I) : J :=
op_startypeminuserrorstar client_exec
(op_startypeminuserrorstar nodes n) in
let client_0 := client 0 in
let baker_0 :=
op_startypeminuserrorstar client_0 "baker-0" % string
(op_startypeminuserrorstar baker_0_account) in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0)
(fun function_parameter =>
let '_ := function_parameter in
let make_admin := op_startypeminuserrorstar admin_exec
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state
op_startypeminuserrorstar in
let first_bakes := 3 in
op_startypeminuserrorstar
(op_startypeminuserrorstar first_bakes
(fun nth =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0)
"initial-bake %d" % string nth))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let signer :=
op_startypeminuserrorstar (client 0)
"ledgered" % string uri in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client_0
uri)
(fun ledger_account =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
client_0
(cons "--wait" % string
(cons "none" % string
(cons "transfer" % string
(cons "20000" % string
(cons "from" % string
(cons
(Tezos_client.Keyed.key_name
baker_0)
(cons "to" % string
(cons
(op_startypeminuserrorstar
ledger_account)
(cons
"--burn-cap" %
string
(cons "100" % string
[])))))))))))
(fun function_parameter =>
let '_ := function_parameter in
let bake {I J : Type} (msg : I) : J :=
op_startypeminuserrorstar state
baker_0 msg in
op_startypeminuserrorstar
(bake
"After transferring tez to the ledger account"
% string)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(with_ledger_test_reject_and_accept
(Some
(OCaml.Stdlib.reverse_apply
(Wallet_scenario.with_rejections
wallet_scenario) negb))
state
(cons
(fun ppf =>
fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
ppf
"Importing %S in client `%s`."
% string uri
(Tezos_client.id
client_0))
(cons
(fun ppf =>
fun function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
ppf
"The ledger should be prompting for acknowledgment to provide the public key of `%s`."
% string
(op_startypeminuserrorstar
ledger_account))
[]))
(fun user_answer =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state client_0
(cons "import" % string
(cons
"secret" % string
(cons "key" % string
(cons
(key_name signer)
(cons
(secret_key
signer)
(cons
"--force" %
string [])))))))
(fun function_parameter =>
let '(_, proc) :=
function_parameter in
expect_from_output
match user_answer with
| Accept =>
(* ❌ Variants not supported *)
variant
| Reject =>
(* ❌ Variants not supported *)
variant
end
"importing key" %
string proc)))
(fun function_parameter =>
let 'tt := function_parameter
in
let skipping {I J : Type}
(s : I) : J :=
op_startypeminuserrorstar
state
op_startypeminuserrorstar
in
let voting_test {I : Type}
(with_rejections : bool)
: I :=
let tested_proposal :=
"Pt24m4xiPbLDhVgVfABUjirbmda3yohdN82Sp9FeuAXJ4eV9otd"
% string in
voting_tests state client
(key_name signer)
with_rejections
protocol_kind
ledger_account
tested_proposal
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state client_0
(cons
"--wait" % string
(cons
"none" % string
(cons
"submit" %
string
(cons
"proposals"
% string
(cons
"for" %
string
(cons
(Tezos_client.Keyed.key_name
baker_0)
(cons
tested_proposal
(cons
"--force"
%
string
[])))))))))
(fun
function_parameter
=>
let '_ :=
function_parameter
in
let blocks :=
Tezos_protocol.blocks_per_voting_period
protocol in
op_startypeminuserrorstar
(op_startypeminuserrorstar
blocks
(fun nth =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_0)
"going to testing-vote period %d/%d"
% string
(Z.add nth 1)
blocks))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
tt))) tt in
let batch_test {I : Type}
(with_rejections : bool)
: I :=
let n := 50 in
op_startypeminuserrorstar
(forge_batch_transactions
state (client 0)
(op_startypeminuserrorstar
ledger_account)
"tz2KZPgf2rshxNUBXFcTaCemik1LH1v9qz3F"
% string n None tt)
(fun
batch_transaction_bytes
=>
let bytes_hash :=
op_startypeminuserrorstar
in
with_ledger_test_reject_and_accept
(Some
(negb
with_rejections))
state
(cons
(fun ppf =>
fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
ppf
"Signing batch of %d transactions"
% string n)
(cons
(fun ppf =>
fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
ppf
"Ledger should display “Sign Hash” → `%s`"
% string
bytes_hash)
(cons
(pp_warning_ledger_takes_a_while
"big" % string)
[])))
(fun user_answer =>
op_startypeminuserrorstar
(sign state signer
batch_transaction_bytes)
(fun
function_parameter
=>
let
'(_, proc) :=
function_parameter
in
expect_from_output
match
user_answer
with
| Accept =>
(* ❌ Variants not supported *)
variant
| Reject =>
(* ❌ Variants not supported *)
variant
end
"Signing batch operation"
% string
proc))) in
let delegation_tests
{I : Type}
(with_rejections : bool)
: I :=
delegation_tests state
client_0 (key_name signer)
with_rejections
protocol_kind
ledger_account
(Tezos_client.Keyed.key_name
baker_0) bake tt in
let unit_kt1_account :=
"unit-kt1-of-the-baker" %
string in
op_startypeminuserrorstar
(originate_id_script None
state client_0
unit_kt1_account
(Tezos_client.Keyed.key_name
baker_0) bake
protocol_kind
"unit" % string
"Unit" % string)
(fun function_parameter =>
let 'tt :=
function_parameter in
let
pair_string_nat_kt1_account :=
"pair-string-nat-kt1-of-the-baker"
% string in
op_startypeminuserrorstar
(originate_id_script
(Some 10) state
client_0
pair_string_nat_kt1_account
(Tezos_client.Keyed.key_name
baker_0) bake
protocol_kind
"(pair string nat)" %
string
"Pair ""the answer is: "" 42"
% string)
(fun function_parameter
=>
let 'tt :=
function_parameter
in
let transactions_test
{I : Type}
(with_rejections :
bool) : I :=
transaction_tests
state client_0
(key_name signer)
with_rejections
protocol_kind
pair_string_nat_kt1_account
ledger_account
unit_kt1_account
bake tt in
let contracts_test
{I : Type}
(with_rejections :
bool) : I :=
basic_contract_operations_tests
state client_0
(key_name signer)
with_rejections
protocol_kind
ledger_account
bake
(Tezos_client.Keyed.key_name
baker_0) tt in
let bake_command :=
op_startypeminuserrorstar
op_startypeminuserrorstar
(cons
"bake" % string
[])
(fun _sexps =>
op_startypeminuserrorstar
(fun e =>
Format.kasprintf
(fun s =>
(* ❌ Variants not supported *)
variant)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"run-test-error: "
%
string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"run-test-error: %a"
%
string)
pp_error e)
(bake
"Interactive"
% string))
in
let
run_test_command :=
op_startypeminuserrorstar
op_startypeminuserrorstar
(cons
"rt" % string
(cons
"run-test" %
string []))
(fun sexps =>
op_startypeminuserrorstar
(fun e =>
Format.kasprintf
(fun s =>
(* ❌ Variants not supported *)
variant)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"run-test-error: "
%
string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"run-test-error: %a"
%
string)
pp_error e)
match sexps
with
| _ =>
let run
{I : Type}
(f :
bool -> I)
: I :=
f true in
match
op_startypeminuserrorstar
Stdlib.String.equal
Wallet_scenario.enum_assoc
op_startypeminuserrorstar
with
| Some None
=>
op_startypeminuserrorstar
tt
|
Some
Delegation
=>
run
delegation_tests
| Some All
=>
op_startypeminuserrorstar
(run
delegation_tests)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(run
batch_test)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
run
voting_test))
|
Some
Batch_transactions
=>
run
batch_test
|
Some
Transactions
=>
run
transactions_test
|
Some
Voting
=>
run
voting_test
|
Some
Contracts
=>
run
contracts_test
| None =>
failf None
"Don't know this test: %S"
%
string
op_startypeminuserrorstar
end
| _ =>
failf None
"Cannot understand command line"
% string
end) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
state
(cons
run_test_command
(cons
bake_command
[])) in
op_startypeminuserrorstar
(Wallet_scenario.if_voting
wallet_scenario
voting_test
skipping)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(Wallet_scenario.if_batch_transactions
wallet_scenario
batch_test
skipping)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(Wallet_scenario.if_transactions
wallet_scenario
transactions_test
skipping)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(Wallet_scenario.if_contracts
wallet_scenario
contracts_test
skipping)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(Wallet_scenario.if_delegation
wallet_scenario
delegation_tests
skipping)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar))))))))))))))))))).
Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
src/bin_sandbox/command_prevalidation.ml 17 errors
open Flextesa
open Internal_pervasives
open Console
let run state node_exec client_exec () =
Test_scenario.network_with_protocol ~size:2 state ~node_exec ~client_exec
>>= fun (nodes, _protocol) ->
match nodes with
| [] | [_] | _ :: _ :: _ :: _ ->
assert false
| [n1; n2] ->
let c1 = Tezos_client.of_node ~exec:client_exec n1 in
let c2 = Tezos_client.of_node ~exec:client_exec n2 in
(* TODO: helpers for
- injecting an op
- displaying the mempool
- setting filter plugin config
TODO: non-interactive test for propagation
TODO: commands for interactivea use *)
Pervasives.ignore c1 ;
Pervasives.ignore c2 ;
return ()
>>= fun () ->
let commands = Interactive_test.Commands.all_defaults state ~nodes in
Prompt.command state ~commands
>>= fun () -> Running_processes.wait_all state
let cmd ~pp_error () =
let open Cmdliner in
let open Term in
Test_command_line.Run_command.make
~pp_error
( pure (fun bnod bcli state -> (state, run state bnod bcli))
$ Tezos_executable.cli_term `Node "tezos"
$ Tezos_executable.cli_term `Client "tezos"
$ Test_command_line.cli_state ~name:"prevalidation" () )
(info ~doc:"Work-in-progress." "prevalidation")
src/bin_sandbox/command_prevalidation.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition run {A B C D : Type}
(state : A) (node_exec : B) (client_exec : C) (function_parameter : unit)
: D :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar 2 state node_exec client_exec)
(fun function_parameter =>
let '(nodes, _protocol) := function_parameter in
match nodes with
| [] | cons _ [] | cons _ (cons _ (cons _ _)) =>
(* ❌ Assert instruction is not handled. *)
assert false
| cons n1 (cons n2 []) =>
let c1 := op_startypeminuserrorstar client_exec n1 in
let c2 := op_startypeminuserrorstar client_exec n2 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Pervasives.ignore c1 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Pervasives.ignore c2 in
op_startypeminuserrorstar (op_startypeminuserrorstar tt)
(fun function_parameter =>
let 'tt := function_parameter in
let commands := op_startypeminuserrorstar state nodes in
op_startypeminuserrorstar (op_startypeminuserrorstar state commands)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar state))
end).
Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
src/bin_sandbox/command_voting.ml 423 errors
(* Semi-interactive test for voting *)
open Flextesa
open Internal_pervasives
module Counter_log = Helpers.Counter_log
let ledger_prompt_notice state ef =
Console.say
state
EF.(
desc
(shout "Ledger-prompt")
(list [ef; wf "Please hit âââ on the ledger."]))
let setup_baking_ledger state uri ~client =
Interactive_test.Pauser.generic
state
EF.
[ wf "Setting up the ledger device %S" uri;
haf
"Please make sure the ledger is on the Baking app and quit (`q`) \
this prompt to continue." ]
~force:true
>>= fun () ->
let key_name = "ledgered" in
let baker = Tezos_client.Keyed.make client ~key_name ~secret_key:uri in
ledger_prompt_notice
state
EF.(
wf
"Importing %S in client `%s`. The ledger should be prompting for \
acknowledgment to provide the public key."
uri
client.Tezos_client.id)
>>= fun () ->
Tezos_client.Keyed.initialize state baker
>>= fun _ ->
ledger_prompt_notice
state
EF.(
wf
"Setting up %S for baking. The ledger should be showing the setup \
parameters (Address, Main chain, HWMs)."
uri)
>>= fun () ->
Tezos_client.successful_client_cmd
state
~client
[ "setup";
"ledger";
"to";
"bake";
"for";
key_name;
"--main-hwm";
"0";
"--test-hwm";
"0" ]
>>= fun _ -> return baker
let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt
let transfer state ~client ~src ~dst ~amount =
Tezos_client.successful_client_cmd
state
~client
[ "--wait";
"none";
"transfer";
sprintf "%Ld" amount;
"from";
src;
"to";
dst;
"--fee";
"0.05";
"--burn-cap";
"0.3" ]
let register state ~client ~dst =
Tezos_client.successful_client_cmd
state
~client
[ "--wait";
"none";
"register";
"key";
dst;
"as";
"delegate";
"--fee";
"0.05" ]
let bake_until_voting_period ?keep_alive_delegate state ~baker ~attempts period
=
let client = baker.Tezos_client.Keyed.client in
let period_name = Tezos_protocol.Voting_period.to_string period in
Helpers.wait_for state ~attempts ~seconds:0.5 (fun nth ->
Tezos_client.rpc
state
~client
`Get
~path:"/chains/main/blocks/head/votes/current_period_kind"
>>= function
| `String p when p = period_name ->
return (`Done (nth - 1))
| _ ->
Asynchronous_result.map_option keep_alive_delegate ~f:(fun dst ->
register state ~client ~dst)
>>= fun _ ->
ksprintf
(Tezos_client.Keyed.bake state baker)
"Baker %s bakes %d/%d waiting for %S voting period"
client.id
nth
attempts
period_name
>>= fun () ->
return (`Not_done (sprintf "Waiting for %S period" period_name)))
let check_understood_protocols state ~chain ~client ~protocol_hash
~expect_clueless_client =
Asynchronous_result.bind_on_result
(Tezos_client.successful_client_cmd
state
~client
["--chain"; chain; "list"; "understood"; "protocols"])
~f:(function
| Ok client_protocols_result -> (
match
List.find client_protocols_result#out ~f:(fun prefix ->
String.is_prefix protocol_hash ~prefix)
with
| Some _ ->
return `Proper_understanding
| None when expect_clueless_client ->
return `Expected_misunderstanding
| None ->
return `Failure_to_understand )
| Error (`Client_command_error _) when expect_clueless_client ->
return `Expected_misunderstanding
| Error e ->
fail e)
let run state ~winner_path ~demo_path ~protocol ~node_exec ~client_exec
~clueless_winner ~admin_exec ~winner_client_exec ~size ~base_port
~serialize_proposals ?with_ledger () =
let default_attempts = 50 in
Helpers.clear_root state
>>= fun () ->
Helpers.System_dependencies.precheck
state
`Or_fail
~executables:[node_exec; client_exec; admin_exec; winner_client_exec]
~protocol_paths:[winner_path; demo_path]
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.[af "Ready to start"; af "Root path deleted."]
>>= fun () ->
let (protocol, baker_0_account, baker_0_balance) =
let open Tezos_protocol in
let baker = List.nth_exn protocol.bootstrap_accounts 0 in
( {
protocol with
time_between_blocks = [1; 0];
bootstrap_accounts =
List.map protocol.bootstrap_accounts ~f:(fun (n, v) ->
if fst baker = n then (n, v) else (n, 1_000L));
},
fst baker,
snd baker )
in
Test_scenario.network_with_protocol
~protocol
~size
~base_port
state
~node_exec
~client_exec
>>= fun (nodes, protocol) ->
let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.(
all_defaults state ~nodes
@ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
@ arbitrary_commands_for_each_and_all_clients
state
~make_admin
~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
Interactive_test.Pauser.generic state EF.[af "About to really start playing"]
>>= fun () ->
let client n =
Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n)
in
let baker_0 =
Tezos_client.Keyed.make
(client 0)
~key_name:"baker-0"
~secret_key:(Tezos_protocol.Account.private_key baker_0_account)
in
Tezos_client.Keyed.initialize state baker_0
>>= fun _ ->
let level_counter = Counter_log.create () in
let first_bakes = 5 in
Loop.n_times first_bakes (fun nth ->
ksprintf (Tezos_client.Keyed.bake state baker_0) "initial-bake %d" nth)
>>= fun () ->
let initial_level = first_bakes + 1 in
Counter_log.add level_counter "initial_level" initial_level ;
( match with_ledger with
| None ->
Console.say state EF.(wf "No ledger.")
>>= fun () ->
let account = Tezos_protocol.Account.of_name "special-baker" in
let baker =
Tezos_client.Keyed.make
(client 0)
~key_name:(Tezos_protocol.Account.name account)
~secret_key:(Tezos_protocol.Account.private_key account)
in
Tezos_client.Keyed.initialize state baker >>= fun _ -> return baker
| Some uri ->
setup_baking_ledger state ~client:(client 0) uri )
>>= fun special_baker ->
let winner_client = {baker_0.client with exec = winner_client_exec} in
let winner_baker_0 =
let open Tezos_client.Keyed in
{baker_0 with client = winner_client}
in
let winner_special_baker =
let open Tezos_client.Keyed in
{special_baker with client = winner_client}
in
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.
[ arbitrary_command_on_all_clients
state
~command_names:["wc"; "winner-client"]
?make_admin:None
~clients:[winner_client] ] ;
Interactive_test.Pauser.generic
state
EF.[wf "You can now try the new-client"]
>>= fun () ->
Interactive_test.Pauser.add_commands
state
Interactive_test.Commands.
[ arbitrary_command_on_all_clients
state
~command_names:["baker"]
~make_admin
~clients:[special_baker.Tezos_client.Keyed.client] ] ;
transfer
state (* Tezos_client.successful_client_cmd state *)
~client:(client 0)
~amount:(Int64.div baker_0_balance 2_000_000L)
~src:"baker-0"
~dst:special_baker.Tezos_client.Keyed.key_name
>>= fun res ->
Console.say
state
EF.(
desc
(wf "Successful transfer baker-0 -> special:")
(ocaml_string_list res#out))
>>= fun () ->
let after_transfer_bakes = 2 in
Loop.n_times after_transfer_bakes (fun nth ->
ksprintf
(Tezos_client.Keyed.bake state baker_0)
"after-transfer-bake %d"
nth)
>>= fun () ->
Counter_log.add level_counter "after-transfer-bakes" after_transfer_bakes ;
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
nodes
(`At_least (Counter_log.sum level_counter))
>>= fun () ->
Asynchronous_result.map_option with_ledger ~f:(fun _ ->
ledger_prompt_notice state EF.(wf "Registering as delegate."))
>>= fun (_ : unit option) ->
Tezos_client.successful_client_cmd
state
~client:(client 0)
[ "--wait";
"none";
"register";
"key";
special_baker.Tezos_client.Keyed.key_name;
"as";
"delegate";
"--fee";
"0.5" ]
>>= fun _ ->
let activation_bakes =
let open Tezos_protocol in
protocol.blocks_per_cycle * (protocol.preserved_cycles + 2)
in
Loop.n_times activation_bakes (fun nth ->
ksprintf
(Tezos_client.Keyed.bake state baker_0)
"Baking after new delegate registered: %d/%d"
nth
activation_bakes
>>= fun () ->
Tezos_client.successful_client_cmd
state
~client:(client 0)
["rpc"; "get"; "/chains/main/blocks/head/helpers/baking_rights"]
>>= fun res ->
Console.say
state
EF.(
desc
(haf "Baking rights")
(markdown_verbatim (String.concat ~sep:"\n" res#out))))
>>= fun () ->
Counter_log.add level_counter "activation-bakes" activation_bakes ;
Tezos_client.Keyed.bake state special_baker "Baked by Special Bakerâ¢"
>>= fun () ->
Counter_log.incr level_counter "special-baker-first-bake" ;
let attempts =
Tezos_protocol.(
(* If we are right after the proposal period, we need to get to
the next one *)
3 * protocol.blocks_per_voting_period)
in
bake_until_voting_period
state
~baker:special_baker
~attempts
`Proposal
~keep_alive_delegate:baker_0.key_name
>>= fun extra_bakes_waiting_for_proposal_period ->
Counter_log.add
level_counter
"wait-for-proposal-period"
extra_bakes_waiting_for_proposal_period ;
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
nodes
(`At_least (Counter_log.sum level_counter))
>>= fun () ->
let admin_0 = Tezos_admin_client.of_client ~exec:admin_exec (client 0) in
Tezos_admin_client.successful_command admin_0 state ["list"; "protocols"]
>>= fun res ->
let default_protocols = res#out in
let make_and_inject_protocol ?(make_different = false) name path =
let tmpdir = Paths.root state // sprintf "protocol-%s" name in
Console.say state EF.(wf "Injecting protocol from %s" tmpdir)
>>= fun () ->
Running_processes.run_successful_cmdf
state
"cp -L -R %s %s"
(Filename.quote path)
(Filename.quote tmpdir)
>>= fun _ ->
( if make_different then
Running_processes.run_successful_cmdf
state
"echo '(* Protocol %s *)' >> %s/main.mli"
name
(Filename.quote tmpdir)
>>= fun _ -> return ()
else return () )
>>= fun () ->
Tezos_admin_client.inject_protocol admin_0 state ~path:tmpdir
>>= fun (res, hash) ->
Interactive_test.Pauser.generic
state
EF.
[ af "Just injected %s (%s): %s" name path hash;
markdown_verbatim (String.concat ~sep:"\n" res#out) ]
>>= fun () -> return hash
in
make_and_inject_protocol "winner" winner_path
>>= fun winner_hash ->
make_and_inject_protocol
~make_different:(winner_path = demo_path)
"demo"
demo_path
>>= fun demo_hash ->
Tezos_admin_client.successful_command admin_0 state ["list"; "protocols"]
>>= fun res ->
let after_injections_protocols = res#out in
Interactive_test.Pauser.generic
state
EF.
[ af "Network up";
desc (haf "Protcols")
@@ list
(List.map after_injections_protocols ~f:(fun p ->
af
"`%s` (%s)"
p
( if List.mem default_protocols p ~equal:String.equal then
"previously known"
else
match p with
| _ when p = winner_hash ->
"injected winner"
| _ when p = demo_hash ->
"injected demo"
| _ ->
"injected unknown" ))) ]
>>= fun () ->
Asynchronous_result.map_option with_ledger ~f:(fun _ ->
Interactive_test.Pauser.generic
state
EF.
[ af "About to VOTE";
haf "Please switch to the Wallet app and quit (`q`) this prompt."
]
~force:true)
>>= fun (_ : unit option) ->
let submit_proposals baker props =
Asynchronous_result.map_option with_ledger ~f:(fun _ ->
ledger_prompt_notice
state
EF.(
wf
"Submitting proposal%s: %s"
(if List.length props = 1 then "" else "s")
(String.concat ~sep:", " props)))
>>= fun _ ->
Tezos_client.successful_client_cmd
state
~client:baker.Tezos_client.Keyed.client
(["submit"; "proposals"; "for"; baker.key_name] @ props)
>>= fun _ -> return ()
in
let to_submit_first = [winner_hash; demo_hash] in
( match serialize_proposals with
| false ->
submit_proposals special_baker to_submit_first
| true ->
List_sequential.iter to_submit_first ~f:(fun one ->
submit_proposals special_baker [one]) )
>>= fun () ->
Tezos_client.successful_client_cmd
state
~client:baker_0.client
["submit"; "proposals"; "for"; baker_0.key_name; winner_hash]
>>= fun _ ->
bake_until_voting_period
state
~baker:baker_0
~attempts:protocol.blocks_per_voting_period
`Testing_vote
~keep_alive_delegate:special_baker.key_name
>>= fun extra_bakes_waiting_for_testing_vote_period ->
Counter_log.add
level_counter
"wait-for-testing-vote-period"
extra_bakes_waiting_for_testing_vote_period ;
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
nodes
(`At_least (Counter_log.sum level_counter))
>>= fun () ->
Helpers.wait_for state ~attempts:default_attempts ~seconds:2. (fun _ ->
Tezos_client.rpc
state
~client:(client 1)
`Get
~path:"/chains/main/blocks/head/votes/current_proposal"
>>= fun current_proposal_json ->
if current_proposal_json <> `String winner_hash then
return
(`Not_done
(sprintf
"Waiting for current_proposal_json to be %s (%s)"
winner_hash
Ezjsonm.(to_string (wrap current_proposal_json))))
else return (`Done ()))
>>= fun () ->
Tezos_client.successful_client_cmd
state
~client:baker_0.client
["submit"; "ballot"; "for"; baker_0.key_name; winner_hash; "yay"]
>>= fun _ ->
Asynchronous_result.map_option with_ledger ~f:(fun _ ->
ledger_prompt_notice
state
EF.(wf "Submitting âYesâ ballot for %S" winner_hash))
>>= fun (_ : unit option) ->
Tezos_client.successful_client_cmd
state
~client:special_baker.client
["submit"; "ballot"; "for"; special_baker.key_name; winner_hash; "yay"]
>>= fun _ ->
Interactive_test.Pauser.generic
state
EF.[af "Ballots are in (not baked though)"]
>>= fun () ->
bake_until_voting_period
state
~baker:baker_0
~attempts:(1 + protocol.blocks_per_voting_period)
~keep_alive_delegate:special_baker.key_name
`Testing
>>= fun extra_bakes_waiting_for_testing_period ->
Counter_log.add
level_counter
"wait-for-testing-period"
extra_bakes_waiting_for_testing_period ;
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
nodes
(`At_least (Counter_log.sum level_counter))
>>= fun () ->
check_understood_protocols
state
~client:winner_client
~chain:"main"
~protocol_hash:winner_hash
~expect_clueless_client:clueless_winner
>>= (function
| `Proper_understanding ->
let chain = "test" in
Asynchronous_result.map_option with_ledger ~f:(fun _ ->
Interactive_test.Pauser.generic
state
EF.
[ af "About to bake on the test chain.";
haf
"Please switch back to the Baking app and quit (`q`) \
this prompt." ]
~force:true)
>>= fun (_ : unit option) ->
let testing_bakes = 5 in
Loop.n_times testing_bakes (fun ith ->
let baker =
if ith mod 2 = 0 then winner_baker_0
else winner_special_baker
in
Tezos_client.Keyed.bake
~chain
state
baker
(sprintf
"Baking on the test chain [%d/%d]"
(ith + 1)
testing_bakes))
>>= fun () ->
Test_scenario.Queries.wait_for_all_levels_to_be
state
~chain
~attempts:default_attempts
~seconds:8.
nodes
(`At_least (Counter_log.sum level_counter + testing_bakes))
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.[wf "Testing period, with proper winner-client, have fun."]
>>= fun () -> return ()
| `Expected_misunderstanding ->
Console.say
state
EF.(wf "Winner-Client cannot bake on test chain (expected)")
| `Failure_to_understand ->
failf "Winner-Client cannot bake on test chain!")
>>= fun () ->
Helpers.wait_for state ~attempts:default_attempts ~seconds:0.3 (fun _ ->
Tezos_client.rpc
state
~client:(client 1)
`Get
~path:"/chains/main/blocks/head/metadata"
>>= fun metadata_json ->
try
match
Jqo.field metadata_json ~k:"test_chain_status"
|> Jqo.field ~k:"protocol"
with
| `String s when s = winner_hash ->
return (`Done ())
| other ->
return
(`Not_done
(sprintf "Wrong protocol: %s" Ezjsonm.(to_string (wrap other))))
with e ->
return
(`Not_done
(sprintf
"Cannot get test-chain protocol: %s â %s"
(Exn.to_string e)
Ezjsonm.(to_string (wrap metadata_json)))))
>>= fun () ->
bake_until_voting_period
state
~baker:baker_0
~attempts:(1 + protocol.blocks_per_voting_period)
~keep_alive_delegate:special_baker.key_name
`Promotion_vote
>>= fun extra_bakes_waiting_for_promotion_period ->
Counter_log.add
level_counter
"wait-for-promotion-period"
extra_bakes_waiting_for_promotion_period ;
Test_scenario.Queries.wait_for_all_levels_to_be
state
~attempts:default_attempts
~seconds:8.
nodes
(`At_least (Counter_log.sum level_counter))
>>= fun () ->
Interactive_test.Pauser.generic state EF.[haf "Before ballots"]
>>= fun () ->
Tezos_client.successful_client_cmd
state
~client:baker_0.client
["submit"; "ballot"; "for"; baker_0.key_name; winner_hash; "yay"]
>>= fun _ ->
Asynchronous_result.map_option with_ledger ~f:(fun _ ->
Interactive_test.Pauser.generic
state
EF.
[ af "About to cast approval ballot.";
haf
"Please switch back to the Wallet app and quit (`q`) this prompt."
]
~force:true
>>= fun () ->
ledger_prompt_notice
state
EF.(wf "Submitting âYesâ ballot for %S" winner_hash))
>>= fun (_ : unit option) ->
Tezos_client.successful_client_cmd
state
~client:special_baker.client
["submit"; "ballot"; "for"; special_baker.key_name; winner_hash; "yay"]
>>= fun _ ->
Interactive_test.Pauser.generic
state
EF.[af "Final ballot(s) are in (not baked though)"]
>>= fun () ->
let ballot_bakes = 1 in
Loop.n_times ballot_bakes (fun _ ->
Tezos_client.Keyed.bake state baker_0 "Baking the promotion vote ballots")
>>= fun () ->
Counter_log.add level_counter "bake-the-ballots" ballot_bakes ;
Tezos_client.successful_client_cmd
state
~client:(client 0)
["list"; "understood"; "protocols"]
>>= fun client_protocols_result ->
Interactive_test.Pauser.generic
state
EF.
[ af "Final ballot(s) are baked in.";
af
"The client `%s` understands the following protocols: %s"
Tezos_executable.(
Option.value
~default:(default_binary client_exec)
client_exec.binary)
(String.concat ~sep:", " client_protocols_result#out) ]
>>= fun () ->
Helpers.wait_for
state
~seconds:0.5
~attempts:(1 + protocol.blocks_per_voting_period)
(fun nth ->
let client = baker_0.client in
Running_processes.run_successful_cmdf
state
"curl http://localhost:%d/chains/main/blocks/head/metadata"
client.port
>>= fun curl_res ->
let json_string = curl_res#out |> String.concat ~sep:"\n" in
let json_metadata = Ezjsonm.from_string json_string in
match Jqo.field json_metadata ~k:"next_protocol" with
| `String p when p = winner_hash ->
return (`Done (nth - 1))
| other ->
transfer
state
~client
~amount:1L
~src:baker_0.Tezos_client.Keyed.key_name
~dst:special_baker.Tezos_client.Keyed.key_name
>>= fun _ ->
ksprintf
(Tezos_client.Keyed.bake state baker_0)
"Baker %s bakes %d/%d waiting for next protocol: %S"
client.id
nth
attempts
winner_hash
>>= fun () ->
return
(`Not_done
(sprintf
"Waiting for next_protocol: %S (â %s)"
winner_hash
Ezjsonm.(to_string (wrap other)))))
>>= fun extra_bakes_waiting_for_next_protocol ->
Counter_log.add
level_counter
"wait-for-next-protocol"
extra_bakes_waiting_for_next_protocol ;
check_understood_protocols
state
~client:winner_client
~chain:"main"
~protocol_hash:winner_hash
~expect_clueless_client:clueless_winner
>>= (function
| `Expected_misunderstanding ->
Console.say
state
EF.(
wf "As expected, the client does not know about %s" winner_hash)
| `Failure_to_understand ->
failf "The winner-client does not know about `%s`" winner_hash
| `Proper_understanding -> (
Console.say state EF.(wf "The client knows about %s" winner_hash)
>>= fun () ->
(* This actually depends on the protocol upgrade. *)
Asynchronous_result.bind_on_result
(Tezos_client.successful_client_cmd
state
~client:winner_client
["upgrade"; "baking"; "state"])
~f:(function
| Ok _ ->
return ()
| Error _ ->
Console.say
state
EF.(
desc
(shout "Warning")
(wf
"Command `upgrade baking state` failed, but we \
keep going with the baking.")))
>>= fun () ->
Asynchronous_result.map_option with_ledger ~f:(fun _ ->
Interactive_test.Pauser.generic
state
EF.
[ af "About to bake on the new winning protocol.";
haf
"Please switch to the Baking app and quit (`q`) this \
prompt." ]
~force:true
>>= fun () ->
Console.say state EF.(wf "Sleeping for a couple of secondsâ¦")
>>= fun () -> System.sleep 4.
(* USB thing is often slower than humans hitting `q` *))
>>= fun (_ : unit option) ->
Tezos_client.Keyed.bake
state
winner_baker_0
"First bake on new protocol !!"
>>= fun () ->
Counter_log.incr level_counter "baker-0-bakes-on-new-protocol" ;
Tezos_client.Keyed.bake
state
winner_special_baker
"Second bake on new protocol !!"
>>= fun () ->
Counter_log.incr
level_counter
"special-baker-bakes-on-new-protocol" ;
Tezos_client.rpc
state
~client:winner_client
`Get
~path:"/chains/main/blocks/head/metadata"
>>= fun json_metadata ->
match Jqo.field json_metadata ~k:"protocol" with
| `String p when p = winner_hash ->
return ()
| other ->
failf
"Protocol is not `%s` but `%s`"
winner_hash
Ezjsonm.(to_string (wrap other)) ))
>>= fun () ->
Interactive_test.Pauser.generic
state
EF.
[ haf "End of the Voting test: SUCCESS \\o/";
desc
(af "Estimated level: %d" (Counter_log.sum level_counter))
(markdown_verbatim (Counter_log.to_table_string level_counter)) ]
>>= fun () -> return ()
let cmd ~pp_error () =
let open Cmdliner in
let open Term in
Test_command_line.Run_command.make
~pp_error
( pure
(fun winner_path
demo_path
node_exec
client_exec
admin_exec
winner_client_exec
size
(`Clueless_winner clueless_winner)
(`Base_port base_port)
(`With_ledger with_ledger)
(`Serialize_proposals serialize_proposals)
protocol
state
->
( state,
Interactive_test.Pauser.run_test
state
~pp_error
(run
state
~serialize_proposals
~winner_path
~clueless_winner
~demo_path
~node_exec
~size
~admin_exec
~base_port
~client_exec
~winner_client_exec
~protocol
?with_ledger) ))
$ Arg.(
pure Filename.dirname
$ required
(pos
0
(some string)
None
(info
[]
~docv:"WINNER-PROTOCOL-PATH"
~doc:
"The protocol to inject and make win the election, e.g. \
`src/proto_004_Pt24m4xi/lib_protocol/src/TEZOS_PROTOCOL`.")))
$ Arg.(
pure Filename.dirname
$ required
(pos
1
(some string)
None
(info
[]
~docv:"LOSER-PROTOCOL-PATH"
~doc:
"The protocol to inject and down-vote, e.g. \
`./src/bin_client/test/proto_test_injection/TEZOS_PROTOCOL` \
(if same as `WINNER-PROTOCOL-PATH` the scenario will \
make them automatically & artificially different).")))
$ Tezos_executable.cli_term `Node "current"
$ Tezos_executable.cli_term `Client "current"
$ Tezos_executable.cli_term `Admin "current"
$ Tezos_executable.cli_term `Client "winner"
$ Arg.(value (opt int 5 (info ["size"; "S"] ~doc:"Size of the Network.")))
$ Arg.(
pure (fun b -> `Clueless_winner b)
$ value
(flag
(info
["winning-client-is-clueless"]
~doc:
"Do not fail if the client does not know about ânextâ \
protocol.")))
(*
$ Arg.(
pure (fun p -> `Hash p)
$ value
(opt
(some string)
None
(info
["current-hash"]
~doc:"The hash to advertise as the current protocol.")))
*)
$ Arg.(
pure (fun p -> `Base_port p)
$ value
(opt
int
46_000
(info ["base-port"] ~doc:"Base port number to build upon.")))
$ Arg.(
pure (fun x -> `With_ledger x)
$ value
(opt
(some string)
None
(info
["with-ledger"]
~docv:"ledger://..."
~doc:
"Do the test with a Ledger Nano device as one of the \
bakers/voters.")))
$ Arg.(
pure (fun x -> `Serialize_proposals x)
$ value
(flag
(info
["serialize-proposals"]
~doc:
"Run the proposals one-by-one instead of all together \
(preferred by the Ledger).")))
$ Tezos_protocol.cli_term ()
$ Test_command_line.cli_state ~name:"voting" () )
(let doc = "Sandbox network with a full round of voting." in
let man : Manpage.block list =
[ `S "VOTING TEST";
`P
"This command provides a test which uses a network sandbox to \
perform a full round of protocol vote and upgrade, including \
voting and baking on the test chain with or without a Ledger Nano \
device.";
`P "There are two main test behaviors:";
`P
"* $(b,SIMPLE:) The simple one does as much as possible with any \
dummy protocol candidates and a Tezos code-base which doesn't \
handle them: it tests all the voting periods until baking the \
last block of the currently understood protocol.";
`Noblank;
`P
"To allow the test to succeed in this case, the option \
`--winning-client-is-clueless` is required; it is meant to signal \
that the âwinnerâ `tezos-client` executable (from the \
`--winner-client-binary` option) is expected to not understand \
the winning protocol.";
`Noblank;
`P
"This is the version running in Gitlab-CI, see `bin_flextesa/dune`.";
`P
"* $(b,FULL:) Without the `--winning-client-is-clueless` option, \
the test will try to bake on the test chain as well as after the \
protocol switch (with the winner-client). This requires the \
winning protocol to be a working one and, of course, the \
winning-client to understand it.";
`P
"The test can run fully automated unless one uses the \
`\"--with-ledger=ledger://...\"` option in which case some steps \
have to be interactive. In this case, the option \
`--serialize-proposals` is recommended, because if it is not \
provided, the proposal vote will be a âSign Unverfiedâ \
operation." ]
in
info ~doc ~man "voting")
src/bin_sandbox/command_voting.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Counter_log.
End Counter_log.
Definition ledger_prompt_notice {A B C : Type} (state : A) (ef : B) : C :=
op_startypeminuserrorstar state op_startypeminuserrorstar.
Definition setup_baking_ledger {A B C D : Type}
(state : A) (uri : B) (client : C) : D :=
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar true)
(fun function_parameter =>
let 'tt := function_parameter in
let key_name := "ledgered" % string in
let baker := op_startypeminuserrorstar client key_name uri in
op_startypeminuserrorstar
(ledger_prompt_notice state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar state baker)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(ledger_prompt_notice state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(cons "setup" % string
(cons "ledger" % string
(cons "to" % string
(cons "bake" % string
(cons "for" % string
(cons key_name
(cons "--main-hwm" % string
(cons "0" % string
(cons "--test-hwm" % string
(cons "0" % string [])))))))))))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar baker))))).
Definition failf {A B : Type} (fmt : A) : B :=
op_startypeminuserrorstar
(fun s =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant) fmt.
Definition transfer {A B C D : Type}
(state : A) (client : B) (src : string) (dst : string) (amount : C) : D :=
op_startypeminuserrorstar state client
(cons "--wait" % string
(cons "none" % string
(cons "transfer" % string
(cons (op_startypeminuserrorstar "%Ld" % string amount)
(cons "from" % string
(cons src
(cons "to" % string
(cons dst
(cons "--fee" % string
(cons "0.05" % string
(cons "--burn-cap" % string (cons "0.3" % string [])))))))))))).
Definition register {A B C : Type} (state : A) (client : B) (dst : string)
: C :=
op_startypeminuserrorstar state client
(cons "--wait" % string
(cons "none" % string
(cons "register" % string
(cons "key" % string
(cons dst
(cons "as" % string
(cons "delegate" % string
(cons "--fee" % string (cons "0.05" % string []))))))))).
Definition bake_until_voting_period {A B C D E F : Type}
(keep_alive_delegate : option A) (state : B) (baker : C) (attempts : D)
(period : E) : F :=
let client := Tezos_client.Keyed.client baker in
let period_name := op_startypeminuserrorstar period in
op_startypeminuserrorstar state attempts
(* ❌ Float constant 0.5 is approximated by the integer 0 *)
0
(fun nth =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(* ❌ Variants not supported *)
variant "/chains/main/blocks/head/votes/current_period_kind" % string)
(fun function_parameter =>
match function_parameter with
| String p =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
| _ =>
op_startypeminuserrorstar
(op_startypeminuserrorstar keep_alive_delegate
(fun dst => register state client dst))
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar state baker)
"Baker %s bakes %d/%d waiting for %S voting period" % string
(id client) nth attempts period_name)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant))
end)).
Definition check_understood_protocols {A B C D : Type}
(state : A) (chain : string) (client : B) (protocol_hash : C)
(expect_clueless_client : bool) : D :=
op_startypeminuserrorstar
(op_startypeminuserrorstar state client
(cons "--chain" % string
(cons chain
(cons "list" % string
(cons "understood" % string (cons "protocols" % string []))))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok client_protocols_result =>
match
Stdlib.List.find
(* ❌ Sending method message is not handled *)
send
(* ❌ expected an argument *)
expected_argument
(fun prefix => op_startypeminuserrorstar protocol_hash prefix) with
| _ =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
| _ =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
| _ =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end
| Stdlib.Error (Client_command_error _) =>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
| Stdlib.Error e => op_startypeminuserrorstar e
end).
Definition run {A B C D E F G : Type}
(state : A) (winner_path : string) (demo_path : string) (protocol : B)
(node_exec : C) (client_exec : C) (clueless_winner : bool) (admin_exec : C)
(winner_client_exec : C) (size : D) (base_port : E)
(serialize_proposals : bool) (with_ledger : option F)
(function_parameter : unit) : G :=
let 'tt := function_parameter in
let default_attempts := 50 in
op_startypeminuserrorstar (op_startypeminuserrorstar state)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
(* ❌ Variants not supported *)
variant
(cons node_exec
(cons client_exec (cons admin_exec (cons winner_client_exec []))))
(cons winner_path (cons demo_path [])))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let '(protocol, baker_0_account, baker_0_balance) :=
op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar protocol size base_port state
node_exec client_exec)
(fun function_parameter =>
let '(nodes, protocol) := function_parameter in
let make_admin := op_startypeminuserrorstar admin_exec in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar state op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let client {H I : Type} (n : H) : I :=
op_startypeminuserrorstar client_exec
(op_startypeminuserrorstar nodes n) in
let baker_0 :=
op_startypeminuserrorstar (client 0) "baker-0" % string
(op_startypeminuserrorstar baker_0_account) in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0)
(fun function_parameter =>
let '_ := function_parameter in
let level_counter := op_startypeminuserrorstar tt in
let first_bakes := 5 in
op_startypeminuserrorstar
(op_startypeminuserrorstar first_bakes
(fun nth =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker_0)
"initial-bake %d" % string nth))
(fun function_parameter =>
let 'tt := function_parameter in
let initial_level := Z.add first_bakes 1 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar level_counter
"initial_level" % string initial_level in
op_startypeminuserrorstar
match with_ledger with
| None =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let account :=
op_startypeminuserrorstar
"special-baker" % string in
let baker :=
op_startypeminuserrorstar (client 0)
(op_startypeminuserrorstar account)
(op_startypeminuserrorstar account) in
op_startypeminuserrorstar
(op_startypeminuserrorstar state baker)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar baker))
| Some uri =>
setup_baking_ledger state uri (client 0)
end
(fun special_baker =>
let winner_client := op_startypeminuserrorstar
in
let winner_baker_0 :=
op_startypeminuserrorstar in
let winner_special_baker :=
op_startypeminuserrorstar in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state
op_startypeminuserrorstar in
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar state
op_startypeminuserrorstar in
op_startypeminuserrorstar
(transfer state (client 0)
"baker-0" % string
(Tezos_client.Keyed.key_name
special_baker)
(Int64.div baker_0_balance
(* ❌ Constant of type int64 is converted to int *)
2000000))
(fun res =>
op_startypeminuserrorstar
(op_startypeminuserrorstar state
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
let after_transfer_bakes := 2 in
op_startypeminuserrorstar
(op_startypeminuserrorstar
after_transfer_bakes
(fun nth =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state baker_0)
"after-transfer-bake %d" %
string nth))
(fun function_parameter =>
let 'tt := function_parameter
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
level_counter
"after-transfer-bakes" %
string
after_transfer_bakes in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8 nodes
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar
with_ledger
(fun
function_parameter
=>
let '_ :=
function_parameter
in
ledger_prompt_notice
state
op_startypeminuserrorstar))
(fun function_parameter
=>
let '_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state (client 0)
(cons
"--wait" %
string
(cons
"none" %
string
(cons
"register" %
string
(cons
"key" %
string
(cons
(Tezos_client.Keyed.key_name
special_baker)
(cons
"as" %
string
(cons
"delegate"
%
string
(cons
"--fee"
%
string
(cons
"0.5"
%
string
[]))))))))))
(fun
function_parameter
=>
let '_ :=
function_parameter
in
let
activation_bakes :=
op_startypeminuserrorstar
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
activation_bakes
(fun nth =>
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_0)
"Baking after new delegate registered: %d/%d"
%
string
nth
activation_bakes)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
0)
(cons
"rpc"
%
string
(cons
"get"
%
string
(cons
"/chains/main/blocks/head/helpers/baking_rights"
%
string
[]))))
(fun
res
=>
op_startypeminuserrorstar
state
op_startypeminuserrorstar))))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
level_counter
"activation-bakes"
% string
activation_bakes
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
special_baker
"Baked by Special Baker™"
% string)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
level_counter
"special-baker-first-bake"
%
string
in
let
attempts :=
op_startypeminuserrorstar
in
op_startypeminuserrorstar
(bake_until_voting_period
(Some
(key_name
baker_0))
state
special_baker
attempts
(* ❌ Variants not supported *)
variant)
(fun
extra_bakes_waiting_for_proposal_period
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _
:=
op_startypeminuserrorstar
level_counter
"wait-for-proposal-period"
%
string
extra_bakes_waiting_for_proposal_period
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
let
admin_0 :=
op_startypeminuserrorstar
admin_exec
(client
0)
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
admin_0
state
(cons
"list"
%
string
(cons
"protocols"
%
string
[])))
(fun
res
=>
let
default_protocols :=
(* ❌ Sending method message is not handled *)
send
in
let
make_and_inject_protocol
{H
I
:
Type}
(op_staroptstar
:
option
bool)
: H
->
string
->
I :=
let
make_different :=
match
op_staroptstar
with
|
Some
op_starsthstar
=>
op_starsthstar
|
None
=>
false
end
in
fun
name
=>
fun
path
=>
let
tmpdir :=
op_startypeminuserrorstar
(op_startypeminuserrorstar
state)
(op_startypeminuserrorstar
"protocol-%s"
%
string
name)
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
"cp -L -R %s %s"
%
string
(Filename.quote
path)
(Filename.quote
tmpdir))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(if
make_different
then
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
"echo '(* Protocol %s *)' >> %s/main.mli"
%
string
name
(Filename.quote
tmpdir))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
tt)
else
op_startypeminuserrorstar
tt)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
admin_0
state
tmpdir)
(fun
function_parameter
=>
let
'(res,
hash) :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
hash)))))
in
op_startypeminuserrorstar
(make_and_inject_protocol
None
"winner"
%
string
winner_path)
(fun
winner_hash
=>
op_startypeminuserrorstar
(make_and_inject_protocol
(Some
(equiv_decb
winner_path
demo_path))
"demo"
%
string
demo_path)
(fun
demo_hash
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
admin_0
state
(cons
"list"
%
string
(cons
"protocols"
%
string
[])))
(fun
res
=>
let
after_injections_protocols :=
(* ❌ Sending method message is not handled *)
send
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
with_ledger
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar
true))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
let
submit_proposals
{H
I
:
Type}
(baker
:
H)
(props
:
list
string)
: I :=
op_startypeminuserrorstar
(op_startypeminuserrorstar
with_ledger
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
ledger_prompt_notice
state
op_startypeminuserrorstar))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(Tezos_client.Keyed.client
baker)
(OCaml.Stdlib.app
(cons
"submit"
%
string
(cons
"proposals"
%
string
(cons
"for"
%
string
(cons
(key_name
baker)
[]))))
props))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
tt))
in
let
to_submit_first :=
cons
winner_hash
(cons
demo_hash
[])
in
op_startypeminuserrorstar
match
serialize_proposals
with
|
false
=>
submit_proposals
special_baker
to_submit_first
|
true
=>
op_startypeminuserrorstar
to_submit_first
(fun
one
=>
submit_proposals
special_baker
(cons
one
[]))
end
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
baker_0)
(cons
"submit"
%
string
(cons
"proposals"
%
string
(cons
"for"
%
string
(cons
(key_name
baker_0)
(cons
winner_hash
[]))))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(bake_until_voting_period
(Some
(key_name
special_baker))
state
baker_0
(blocks_per_voting_period
protocol)
(* ❌ Variants not supported *)
variant)
(fun
extra_bakes_waiting_for_testing_vote_period
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
level_counter
"wait-for-testing-vote-period"
%
string
extra_bakes_waiting_for_testing_vote_period
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 2. is approximated by the integer 2 *)
2
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
1)
(* ❌ Variants not supported *)
variant
"/chains/main/blocks/head/votes/current_proposal"
%
string)
(fun
current_proposal_json
=>
if
nequiv_decb
current_proposal_json
(* ❌ Variants not supported *)
variant
then
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
else
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
baker_0)
(cons
"submit"
%
string
(cons
"ballot"
%
string
(cons
"for"
%
string
(cons
(key_name
baker_0)
(cons
winner_hash
(cons
"yay"
%
string
[])))))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
with_ledger
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
ledger_prompt_notice
state
op_startypeminuserrorstar))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
special_baker)
(cons
"submit"
%
string
(cons
"ballot"
%
string
(cons
"for"
%
string
(cons
(key_name
special_baker)
(cons
winner_hash
(cons
"yay"
%
string
[])))))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(bake_until_voting_period
(Some
(key_name
special_baker))
state
baker_0
(Z.add
1
(blocks_per_voting_period
protocol))
(* ❌ Variants not supported *)
variant)
(fun
extra_bakes_waiting_for_testing_period
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
level_counter
"wait-for-testing-period"
%
string
extra_bakes_waiting_for_testing_period
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(check_understood_protocols
state
"main"
%
string
winner_client
winner_hash
clueless_winner)
(fun
function_parameter
=>
match
function_parameter
with
|
Proper_understanding
=>
let
chain :=
"test"
%
string
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
with_ledger
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
state
op_startypeminuserrorstar
true))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
let
testing_bakes :=
5
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
testing_bakes
(fun
ith
=>
let
baker :=
if
equiv_decb
(Z.modulo
ith
2)
0
then
winner_baker_0
else
winner_special_baker
in
op_startypeminuserrorstar
chain
state
baker
(op_startypeminuserrorstar
"Baking on the test chain [%d/%d]"
%
string
(Z.add
ith
1)
testing_bakes)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
chain
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
tt))))
|
Expected_misunderstanding
=>
op_startypeminuserrorstar
state
op_startypeminuserrorstar
|
Failure_to_understand
=>
failf
"Winner-Client cannot bake on test chain!"
%
string
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 0.3 is approximated by the integer 0 *)
0
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
1)
(* ❌ Variants not supported *)
variant
"/chains/main/blocks/head/metadata"
%
string)
(fun
metadata_json
=>
(* ❌ Try-with are not handled *)
try
match
OCaml.Stdlib.reverse_apply
(op_startypeminuserrorstar
metadata_json
"test_chain_status"
%
string)
(op_startypeminuserrorstar
"protocol"
%
string)
with
|
String
s
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
|
other
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
end)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(bake_until_voting_period
(Some
(key_name
special_baker))
state
baker_0
(Z.add
1
(blocks_per_voting_period
protocol))
(* ❌ Variants not supported *)
variant)
(fun
extra_bakes_waiting_for_promotion_period
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
level_counter
"wait-for-promotion-period"
%
string
extra_bakes_waiting_for_promotion_period
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
default_attempts
(* ❌ Float constant 8. is approximated by the integer 8 *)
8
nodes
(* ❌ Variants not supported *)
variant)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
baker_0)
(cons
"submit"
%
string
(cons
"ballot"
%
string
(cons
"for"
%
string
(cons
(key_name
baker_0)
(cons
winner_hash
(cons
"yay"
%
string
[])))))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
with_ledger
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar
true)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
ledger_prompt_notice
state
op_startypeminuserrorstar)))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
special_baker)
(cons
"submit"
%
string
(cons
"ballot"
%
string
(cons
"for"
%
string
(cons
(key_name
special_baker)
(cons
winner_hash
(cons
"yay"
%
string
[])))))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
let
ballot_bakes :=
1
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
ballot_bakes
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
state
baker_0
"Baking the promotion vote ballots"
%
string))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
level_counter
"bake-the-ballots"
%
string
ballot_bakes
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(client
0)
(cons
"list"
%
string
(cons
"understood"
%
string
(cons
"protocols"
%
string
[]))))
(fun
client_protocols_result
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
(* ❌ Float constant 0.5 is approximated by the integer 0 *)
0
(Z.add
1
(blocks_per_voting_period
protocol))
(fun
nth
=>
let
client :=
client
baker_0
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
"curl http://localhost:%d/chains/main/blocks/head/metadata"
%
string
(port
client))
(fun
curl_res
=>
let
json_string :=
OCaml.Stdlib.reverse_apply
(* ❌ Sending method message is not handled *)
send
(Stdlib.String.concat
(* ❌ expected an argument *)
expected_argument
(* ❌ expected an argument *)
expected_argument
"
"
%
string)
in
let
json_metadata :=
op_startypeminuserrorstar
json_string
in
match
op_startypeminuserrorstar
json_metadata
"next_protocol"
%
string
with
|
String
p
=>
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant
|
other
=>
op_startypeminuserrorstar
(transfer
state
client
(Tezos_client.Keyed.key_name
baker_0)
(Tezos_client.Keyed.key_name
special_baker)
(* ❌ Constant of type int64 is converted to int *)
1)
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
state
baker_0)
"Baker %s bakes %d/%d waiting for next protocol: %S"
%
string
(id
client)
nth
attempts
winner_hash)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(* ❌ Variants not supported *)
variant))
end)))
(fun
extra_bakes_waiting_for_next_protocol
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
level_counter
"wait-for-next-protocol"
%
string
extra_bakes_waiting_for_next_protocol
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(check_understood_protocols
state
"main"
%
string
winner_client
winner_hash
clueless_winner)
(fun
function_parameter
=>
match
function_parameter
with
|
Expected_misunderstanding
=>
op_startypeminuserrorstar
state
op_startypeminuserrorstar
|
Failure_to_understand
=>
failf
"The winner-client does not know about `%s`"
%
string
winner_hash
|
Proper_understanding
=>
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
state
winner_client
(cons
"upgrade"
%
string
(cons
"baking"
%
string
(cons
"state"
%
string
[]))))
(fun
function_parameter
=>
match
function_parameter
with
|
Stdlib.Ok
_
=>
op_startypeminuserrorstar
tt
|
Stdlib.Error
_
=>
op_startypeminuserrorstar
state
op_startypeminuserrorstar
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
with_ledger
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar
true)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(* ❌ Float constant 4. is approximated by the integer 4 *)
4))))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
winner_baker_0
"First bake on new protocol !!"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
level_counter
"baker-0-bakes-on-new-protocol"
%
string
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
winner_special_baker
"Second bake on new protocol !!"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
level_counter
"special-baker-bakes-on-new-protocol"
%
string
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
winner_client
(* ❌ Variants not supported *)
variant
"/chains/main/blocks/head/metadata"
%
string)
(fun
json_metadata
=>
match
op_startypeminuserrorstar
json_metadata
"protocol"
%
string
with
|
String
p
=>
op_startypeminuserrorstar
tt
|
other
=>
failf
"Protocol is not `%s` but `%s`"
%
string
winner_hash
op_startypeminuserrorstar
end))))))
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(op_startypeminuserrorstar
state
op_startypeminuserrorstar)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
tt))))))))))))))))))))))))))))))))))))))))))))))))))).
Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
src/bin_sandbox/main.ml 6 errors
open Flextesa
open Internal_pervasives
module Small_utilities = struct
let key_of_name_command () =
let open Cmdliner in
let open Term in
( ( pure (fun n ->
let open Tezos_protocol.Account in
let account = of_name n in
Printf.printf
"%s,%s,%s,%s\n%!"
(name account)
(pubkey account)
(pubkey_hash account)
(private_key account))
$ Arg.(
required
(pos
0
(some string)
None
(info [] ~docv:"NAME" ~doc:"String to generate the data from.")))
),
info
"key-of-name"
~doc:"Make an unencrypted key-pair deterministically from a string."
~man:
[ `P
"`flextesa key-of-name hello-world` generates a key-pair of the \
`unencrypted:..` kind and outputs it as a 4 values separated \
by commas: `name,pub-key,pub-key-hash,private-uri` (hence \
compatible with the `--add-bootstrap-account` option of some \
of the test scenarios)." ] )
let netstat_ports ~pp_error () =
let open Cmdliner in
let open Term in
Test_command_line.Run_command.make
~pp_error
( pure (fun state ->
( state,
fun () ->
Test_scenario.Network.netstat_listening_ports state
>>= fun ports ->
let to_display =
List.map ports ~f:(fun (p, _) -> p)
|> List.sort ~compare:Int.compare
in
Console.sayf
state
Fmt.(
hvbox ~indent:2 (fun ppf () ->
box words ppf "Netstat listening ports:" ;
sp ppf () ;
box
(list
~sep:(fun ppf () -> string ppf "," ; sp ppf ())
(fun ppf p -> fmt "%d" ppf p))
ppf
to_display)) ))
$ Test_command_line.cli_state
~disable_interactivity:true
~name:"netstat-ports"
() )
(info
"netstat-listening-ports"
~doc:"Like `netstat -nut | awk something-something` but glorified.")
let all ~pp_error () = [key_of_name_command (); netstat_ports ~pp_error ()]
end
let () =
let open Cmdliner in
let help = Term.(ret (pure (`Help (`Auto, None))), info "help") in
let pp_error fmt = function
| `Scenario_error s ->
Format.fprintf fmt "%s" s
| #Test_scenario.Inconsistency_error.t as e ->
Format.fprintf fmt "%a" Test_scenario.Inconsistency_error.pp e
| #Process_result.Error.t as e ->
Format.fprintf fmt "%a" Process_result.Error.pp e
| #System_error.t as e ->
Format.fprintf fmt "%a" System_error.pp e
| `Client_command_error _ as e ->
Tezos_client.Command_error.pp fmt e
| `Admin_command_error _ as e ->
Tezos_admin_client.Command_error.pp fmt e
| `Waiting_for (msg, `Time_out) ->
Format.fprintf fmt "WAITING-FOR â%sâ: Time-out" msg
| `Precheck_failure _ as p ->
Helpers.System_dependencies.Error.pp fmt p
| `Die _ ->
()
in
Term.exit
@@ Term.eval_choice
(help : unit Term.t * _)
( Small_utilities.all ~pp_error ()
@ [ Command_daemons_protocol_change.cmd () ~pp_error;
Command_voting.cmd () ~pp_error;
Command_accusations.cmd () ~pp_error;
Command_prevalidation.cmd () ~pp_error;
Command_ledger_baking.cmd () ~pp_error;
Command_ledger_wallet.cmd () ~pp_error;
Flextesa.Interactive_mini_network.cmd ~pp_error () ] )
src/bin_sandbox/main.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Small_utilities.
Definition key_of_name_command {A : Type} (function_parameter : unit) : A :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
Definition netstat_ports {A B : Type}
(pp_error : A) (function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
Definition all {A B : Type} (pp_error : A) (function_parameter : unit)
: list B :=
let 'tt := function_parameter in
cons (key_of_name_command tt) (cons (netstat_ports pp_error tt) []).
End Small_utilities.
src/bin_signer/handler.ml 163 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Signer_logging
let log = lwt_log_notice
module High_watermark = struct
let encoding =
let open Data_encoding in
let raw_hash = conv Blake2B.to_bytes Blake2B.of_bytes_exn bytes in
conv
(List.map (fun (chain_id, marks) ->
(Chain_id.to_b58check chain_id, marks)))
(List.map (fun (chain_id, marks) ->
(Chain_id.of_b58check_exn chain_id, marks)))
@@ assoc
@@ conv
(List.map (fun (pkh, mark) ->
(Signature.Public_key_hash.to_b58check pkh, mark)))
(List.map (fun (pkh, mark) ->
(Signature.Public_key_hash.of_b58check_exn pkh, mark)))
@@ assoc
@@ obj3
(req "level" int32)
(req "hash" raw_hash)
(opt "signature" Signature.encoding)
let mark_if_block_or_endorsement (cctxt : #Client_context.wallet) pkh bytes
sign =
let mark art name get_level =
let file = name ^ "_high_watermark" in
cctxt#with_lock
@@ fun () ->
cctxt#load file ~default:[] encoding
>>=? fun all ->
if Bytes.length bytes < 9 then
failwith "byte sequence too short to be %s %s" art name
else
let hash = Blake2B.hash_bytes [bytes] in
let chain_id = Chain_id.of_bytes_exn (Bytes.sub bytes 1 4) in
let level = get_level () in
( match List.assoc_opt chain_id all with
| None ->
return_none
| Some marks -> (
match List.assoc_opt pkh marks with
| None ->
return_none
| Some (previous_level, _, None) ->
if previous_level >= level then
failwith
"%s level %ld not above high watermark %ld"
name
level
previous_level
else return_none
| Some (previous_level, previous_hash, Some signature) ->
if previous_level > level then
failwith
"%s level %ld below high watermark %ld"
name
level
previous_level
else if previous_level = level then
if previous_hash <> hash then
failwith
"%s level %ld already signed with different data"
name
level
else return_some signature
else return_none ) )
>>=? function
| Some signature ->
return signature
| None ->
sign bytes
>>=? fun signature ->
let rec update = function
| [] ->
[(chain_id, [(pkh, (level, hash, Some signature))])]
| (e_chain_id, marks) :: rest ->
if chain_id = e_chain_id then
let marks =
(pkh, (level, hash, Some signature))
:: List.filter (fun (pkh', _) -> pkh <> pkh') marks
in
(e_chain_id, marks) :: rest
else (e_chain_id, marks) :: update rest
in
cctxt#write file (update all) encoding
>>=? fun () -> return signature
in
if Bytes.length bytes > 0 && TzEndian.get_uint8 bytes 0 = 0x01 then
mark "a" "block" (fun () -> TzEndian.get_int32 bytes 5)
else if Bytes.length bytes > 0 && TzEndian.get_uint8 bytes 0 = 0x02 then
mark "an" "endorsement" (fun () ->
TzEndian.get_int32 bytes (Bytes.length bytes - 4))
else sign bytes
end
module Authorized_key = Client_aliases.Alias (struct
include Signature.Public_key
let name = "authorized_key"
let to_source s = return (to_b58check s)
let of_source t = Lwt.return (of_b58check t)
end)
let check_magic_byte magic_bytes data =
match magic_bytes with
| None ->
return_unit
| Some magic_bytes ->
let byte = TzEndian.get_uint8 data 0 in
if Bytes.length data > 1 && List.mem byte magic_bytes then return_unit
else failwith "magic byte 0x%02X not allowed" byte
let check_authorization cctxt pkh data require_auth signature =
match (require_auth, signature) with
| (false, _) ->
return_unit
| (true, None) ->
failwith "missing authentication signature field"
| (true, Some signature) ->
let to_sign = Signer_messages.Sign.Request.to_sign ~pkh ~data in
Authorized_key.load cctxt
>>=? fun keys ->
if
List.fold_left
(fun acc (_, key) -> acc || Signature.check key signature to_sign)
false
keys
then return_unit
else failwith "invalid authentication signature"
let sign (cctxt : #Client_context.wallet)
Signer_messages.Sign.Request.{pkh; data; signature} ?magic_bytes
~check_high_watermark ~require_auth =
log
Tag.DSL.(
fun f ->
f "Request for signing %d bytes of data for key %a, magic byte = %02X"
-% t event "request_for_signing"
-% s num_bytes (Bytes.length data)
-% a Signature.Public_key_hash.Logging.tag pkh
-% s magic_byte (TzEndian.get_uint8 data 0))
>>= fun () ->
check_magic_byte magic_bytes data
>>=? fun () ->
check_authorization cctxt pkh data require_auth signature
>>=? fun () ->
Client_keys.get_key cctxt pkh
>>=? fun (name, _pkh, sk_uri) ->
log
Tag.DSL.(
fun f ->
f "Signing data for key %s"
-% t event "signing_data"
-% s Client_keys.Logging.tag name)
>>= fun () ->
let sign = Client_keys.sign cctxt sk_uri in
if check_high_watermark then
High_watermark.mark_if_block_or_endorsement cctxt pkh data sign
else sign data
let deterministic_nonce (cctxt : #Client_context.wallet)
Signer_messages.Deterministic_nonce.Request.{pkh; data; signature}
~require_auth =
log
Tag.DSL.(
fun f ->
f "Request for creating a nonce from %d input bytes for key %a"
-% t event "request_for_deterministic_nonce"
-% s num_bytes (Bytes.length data)
-% a Signature.Public_key_hash.Logging.tag pkh)
>>= fun () ->
check_authorization cctxt pkh data require_auth signature
>>=? fun () ->
Client_keys.get_key cctxt pkh
>>=? fun (name, _pkh, sk_uri) ->
log
Tag.DSL.(
fun f ->
f "Creating nonce for key %s"
-% t event "creating_nonce"
-% s Client_keys.Logging.tag name)
>>= fun () -> Client_keys.deterministic_nonce sk_uri data
let deterministic_nonce_hash (cctxt : #Client_context.wallet)
Signer_messages.Deterministic_nonce_hash.Request.{pkh; data; signature}
~require_auth =
log
Tag.DSL.(
fun f ->
f "Request for creating a nonce hash from %d input bytes for key %a"
-% t event "request_for_deterministic_nonce_hash"
-% s num_bytes (Bytes.length data)
-% a Signature.Public_key_hash.Logging.tag pkh)
>>= fun () ->
check_authorization cctxt pkh data require_auth signature
>>=? fun () ->
Client_keys.get_key cctxt pkh
>>=? fun (name, _pkh, sk_uri) ->
log
Tag.DSL.(
fun f ->
f "Creating nonce hash for key %s"
-% t event "creating_nonce_hash"
-% s Client_keys.Logging.tag name)
>>= fun () -> Client_keys.deterministic_nonce_hash sk_uri data
let supports_deterministic_nonces (cctxt : #Client_context.wallet) pkh =
log
Tag.DSL.(
fun f ->
f
"Request for checking whether the signer supports deterministic \
nonces for key %a"
-% t event "request_for_supports_deterministic_nonces"
-% a Signature.Public_key_hash.Logging.tag pkh)
>>= fun () ->
Client_keys.get_key cctxt pkh
>>=? fun (name, _pkh, sk_uri) ->
log
Tag.DSL.(
fun f ->
f
"Returns true if and only if signer can generate determinstic \
nonces for key %s"
-% t event "supports_deterministic_nonces"
-% s Client_keys.Logging.tag name)
>>= fun () -> Client_keys.supports_deterministic_nonces sk_uri
let public_key (cctxt : #Client_context.wallet) pkh =
log
Tag.DSL.(
fun f ->
f "Request for public key %a"
-% t event "request_for_public_key"
-% a Signature.Public_key_hash.Logging.tag pkh)
>>= fun () ->
Client_keys.list_keys cctxt
>>=? fun all_keys ->
match
List.find_opt
(fun (_, h, _, _) -> Signature.Public_key_hash.equal h pkh)
all_keys
with
| None ->
log
Tag.DSL.(
fun f ->
f "No public key found for hash %a"
-% t event "not_found_public_key"
-% a Signature.Public_key_hash.Logging.tag pkh)
>>= fun () -> Lwt.fail Not_found
| Some (_, _, None, _) ->
log
Tag.DSL.(
fun f ->
f "No public key found for hash %a"
-% t event "not_found_public_key"
-% a Signature.Public_key_hash.Logging.tag pkh)
>>= fun () -> Lwt.fail Not_found
| Some (name, _, Some pk, _) ->
log
Tag.DSL.(
fun f ->
f "Found public key for hash %a (name: %s)"
-% t event "found_public_key"
-% a Signature.Public_key_hash.Logging.tag pkh
-% s Client_keys.Logging.tag name)
>>= fun () -> return pk
src/bin_signer/handler.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Signer_logging.
Definition log {A : Type}
: Tezos_base__TzPervasives.Internal_event.Legacy_logging.log A (Lwt.t unit) :=
lwt_log_notice.
Module High_watermark.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
(list
(Tezos_base__TzPervasives.Chain_id.t *
(list
(Tezos_base__TzPervasives.Signature.Public_key_hash.t *
(int32 * Tezos_base__TzPervasives.Blake2B.t *
(option Tezos_base__TzPervasives.Signature.t)))))) :=
let raw_hash := conv Blake2B.to_bytes Blake2B.of_bytes_exn None bytes in
apply
(let arg :=
conv
(List.map
(fun function_parameter =>
let '(chain_id, marks) := function_parameter in
((Chain_id.to_b58check chain_id), marks)))
(List.map
(fun function_parameter =>
let '(chain_id, marks) := function_parameter in
((Chain_id.of_b58check_exn chain_id), marks))) in
fun eta => arg None eta)
(apply assoc
(apply
(let arg :=
conv
(List.map
(fun function_parameter =>
let '(pkh, mark) := function_parameter in
((Signature.Public_key_hash.to_b58check pkh), mark)))
(List.map
(fun function_parameter =>
let '(pkh, mark) := function_parameter in
((Signature.Public_key_hash.of_b58check_exn pkh), mark))) in
fun eta => arg None eta)
(apply assoc
(obj3 (req None None "level" % string int32)
(req None None "hash" % string raw_hash)
(opt None None "signature" % string Signature.encoding))))).
Definition mark_if_block_or_endorsement {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(bytes : Stdlib.Bytes.t)
(sign :
Stdlib.Bytes.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.t))
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
let mark (art : string) (name : string) (get_level : unit -> int32)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
let file := String.append name "_high_watermark" % string in
apply
(* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send file [] encoding)
(fun all =>
if OCaml.Stdlib.lt (String.length string) 9 then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"byte sequence too short to be " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"byte sequence too short to be %s %s" % string) art name
else
let hash := Blake2B.hash_bytes None (cons string []) in
let chain_id := Chain_id.of_bytes_exn (String.sub string 1 4) in
let level := get_level tt in
op_gtgteqquestion
match List.assoc_opt chain_id all with
| None => return_none
| Some marks =>
match List.assoc_opt pkh marks with
| None => return_none
| Some (previous_level, _, None) =>
if OCaml.Stdlib.ge previous_level level then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" level " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" not above high watermark " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)))))
"%s level %ld not above high watermark %ld" % string)
name level previous_level
else
return_none
| Some (previous_level, previous_hash, Some signature) =>
if OCaml.Stdlib.gt previous_level level then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" level " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" below high watermark " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)))))
"%s level %ld below high watermark %ld" % string)
name level previous_level
else
if equiv_decb previous_level level then
if nequiv_decb previous_hash hash then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" level " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" already signed with different data" %
string
CamlinternalFormatBasics.End_of_format))))
"%s level %ld already signed with different data"
% string) name level
else
return_some signature
else
return_none
end
end
(fun function_parameter =>
match function_parameter with
| Some signature => _return signature
| None =>
op_gtgteqquestion (sign string)
(fun signature =>
let fix update
(function_parameter :
list
(Tezos_base__TzPervasives.Chain_id.t *
(list
(Tezos_base__TzPervasives.Signature.Public_key_hash.t
*
(int32 * Tezos_base__TzPervasives.Blake2B.t
*
(option
Tezos_base__TzPervasives.Signature.t))))))
: list
(Tezos_base__TzPervasives.Chain_id.t *
(list
(Tezos_base__TzPervasives.Signature.Public_key_hash.t
*
(int32 * Tezos_base__TzPervasives.Blake2B.t
*
(option
Tezos_base__TzPervasives.Signature.t))))) :=
match function_parameter with
| [] =>
cons
(chain_id,
(cons (pkh, (level, hash, (Some signature)))
[])) []
| cons (e_chain_id, marks) rest =>
if equiv_decb chain_id e_chain_id then
let marks :=
cons (pkh, (level, hash, (Some signature)))
(List.filter
(fun function_parameter =>
let '(pkh', _) := function_parameter in
nequiv_decb pkh pkh') marks) in
cons (e_chain_id, marks) rest
else
cons (e_chain_id, marks) (update rest)
end in
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send file (update all) encoding)
(fun function_parameter =>
let 'tt := function_parameter in
_return signature))
end))) in
if
andb (OCaml.Stdlib.gt (String.length string) 0)
(equiv_decb (TzEndian.get_uint8 string 0) 1) then
mark "a" % string "block" % string
(fun function_parameter =>
let 'tt := function_parameter in
TzEndian.get_int32 string 5)
else
if
andb (OCaml.Stdlib.gt (String.length string) 0)
(equiv_decb (TzEndian.get_uint8 string 0) 2) then
mark "an" % string "endorsement" % string
(fun function_parameter =>
let 'tt := function_parameter in
TzEndian.get_int32 string (Z.sub (String.length string) 4))
else
sign string.
End High_watermark.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition check_magic_byte (magic_bytes : option (list Z)) (data : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match magic_bytes with
| None => return_unit
| Some magic_bytes =>
let byte := TzEndian.get_uint8 data 0 in
if andb (OCaml.Stdlib.gt (String.length data) 1) (List.mem byte magic_bytes)
then
return_unit
else
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "magic byte 0x" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_X
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " not allowed" % string
CamlinternalFormatBasics.End_of_format)))
"magic byte 0x%02X not allowed" % string) byte
end.
Definition check_authorization {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(data : Stdlib.Bytes.t) (require_auth : bool)
(signature : option Tezos_base__TzPervasives.Signature.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match (require_auth, signature) with
| (false, _) => return_unit
| (true, None) =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"missing authentication signature field" % string
CamlinternalFormatBasics.End_of_format)
"missing authentication signature field" % string)
| (true, Some signature) =>
let to_sign := Signer_messages.Sign.Request.to_sign pkh data in
op_gtgteqquestion (Authorized_key.load cctxt)
(fun keys =>
if
List.fold_left
(fun acc =>
fun function_parameter =>
let '(_, key) := function_parameter in
orb acc (Signature.check None key signature to_sign)) false keys
then
return_unit
else
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"invalid authentication signature" % string
CamlinternalFormatBasics.End_of_format)
"invalid authentication signature" % string))
end.
Definition sign {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B)
(function_parameter : Tezos_signer_services.Signer_messages.Sign.Request.t)
: (option (list Z)) ->
bool ->
bool ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.t) :=
let '{| pkh := pkh; data := data; signature := signature |} :=
function_parameter in
fun magic_bytes =>
fun check_high_watermark =>
fun require_auth =>
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Request for signing " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" bytes of data for key " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", magic byte = " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_X
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))))))
"Request for signing %d bytes of data for key %a, magic byte = %02X"
% string)) (t event "request_for_signing" % string))
(s num_bytes (String.length data)))
(a Signature.Public_key_hash.Logging.tag pkh))
(s magic_byte (TzEndian.get_uint8 data 0))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (check_magic_byte magic_bytes data)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(check_authorization cctxt pkh data require_auth signature)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Client_keys.get_key cctxt pkh)
(fun function_parameter =>
let '(name, _pkh, sk_uri) := function_parameter in
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Signing data for key " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Signing data for key %s" % string))
(t event "signing_data" % string))
(s Client_keys.Logging.tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
let sign := Client_keys.sign cctxt None sk_uri in
if check_high_watermark then
High_watermark.mark_if_block_or_endorsement cctxt
pkh data sign
else
sign data))))).
Definition deterministic_nonce {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B)
(function_parameter :
Tezos_signer_services.Signer_messages.Deterministic_nonce.Request.t)
: bool -> Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
let '{| pkh := pkh; data := data; signature := signature |} :=
function_parameter in
fun require_auth =>
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Request for creating a nonce from " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" input bytes for key " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Request for creating a nonce from %d input bytes for key %a"
% string))
(t event "request_for_deterministic_nonce" % string))
(s num_bytes (String.length data)))
(a Signature.Public_key_hash.Logging.tag pkh)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(check_authorization cctxt pkh data require_auth signature)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Client_keys.get_key cctxt pkh)
(fun function_parameter =>
let '(name, _pkh, sk_uri) := function_parameter in
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Creating nonce for key " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Creating nonce for key %s" % string))
(t event "creating_nonce" % string))
(s Client_keys.Logging.tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
Client_keys.deterministic_nonce sk_uri data)))).
Definition deterministic_nonce_hash {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B)
(function_parameter :
Tezos_signer_services.Signer_messages.Deterministic_nonce_hash.Request.t)
: bool -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
let '{| pkh := pkh; data := data; signature := signature |} :=
function_parameter in
fun require_auth =>
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Request for creating a nonce hash from " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" input bytes for key " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Request for creating a nonce hash from %d input bytes for key %a"
% string))
(t event "request_for_deterministic_nonce_hash" % string))
(s num_bytes (String.length data)))
(a Signature.Public_key_hash.Logging.tag pkh)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(check_authorization cctxt pkh data require_auth signature)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Client_keys.get_key cctxt pkh)
(fun function_parameter =>
let '(name, _pkh, sk_uri) := function_parameter in
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Creating nonce hash for key " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Creating nonce hash for key %s" % string))
(t event "creating_nonce_hash" % string))
(s Client_keys.Logging.tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
Client_keys.deterministic_nonce_hash sk_uri data)))).
Definition supports_deterministic_nonces {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (pkh : Tezos_crypto__Signature.Public_key_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Request for checking whether the signer supports deterministic nonces for key "
% string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Request for checking whether the signer supports deterministic nonces for key %a"
% string))
(t event "request_for_supports_deterministic_nonces" % string))
(a Signature.Public_key_hash.Logging.tag pkh)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Client_keys.get_key cctxt pkh)
(fun function_parameter =>
let '(name, _pkh, sk_uri) := function_parameter in
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Returns true if and only if signer can generate determinstic nonces for key "
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Returns true if and only if signer can generate determinstic nonces for key %s"
% string))
(t event "supports_deterministic_nonces" % string))
(s Client_keys.Logging.tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
Client_keys.supports_deterministic_nonces sk_uri))).
Definition public_key {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (pkh : Tezos_crypto__Signature.Public_key_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.public_key) :=
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Request for public key " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Request for public key %a" % string))
(t event "request_for_public_key" % string))
(a Signature.Public_key_hash.Logging.tag pkh)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Client_keys.list_keys cctxt)
(fun all_keys =>
match
List.find_opt
(fun function_parameter =>
let '(_, h, _, _) := function_parameter in
Signature.Public_key_hash.equal h pkh) all_keys with
| None =>
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No public key found for hash " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"No public key found for hash %a" % string))
(t event "not_found_public_key" % string))
(a Signature.Public_key_hash.Logging.tag pkh)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.fail OCaml.Not_found)
| Some (_, _, None, _) =>
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No public key found for hash " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"No public key found for hash %a" % string))
(t event "not_found_public_key" % string))
(a Signature.Public_key_hash.Logging.tag pkh)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.fail OCaml.Not_found)
| Some (name, _, Some pk, _) =>
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Found public key for hash " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (name: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))))
"Found public key for hash %a (name: %s)" % string))
(t event "found_public_key" % string))
(a Signature.Public_key_hash.Logging.tag pkh))
(s Client_keys.Logging.tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
_return pk)
end)).
src/bin_signer/http_daemon.ml 43 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let log = Signer_logging.lwt_log_notice
open Signer_logging
let run (cctxt : #Client_context.wallet) ~hosts ?magic_bytes
~check_high_watermark ~require_auth mode =
let dir = RPC_directory.empty in
let dir =
RPC_directory.register1 dir Signer_services.sign (fun pkh signature data ->
Handler.sign
cctxt
{pkh; data; signature}
?magic_bytes
~check_high_watermark
~require_auth)
in
let dir =
RPC_directory.register1 dir Signer_services.public_key (fun pkh () () ->
Handler.public_key cctxt pkh)
in
let dir =
RPC_directory.register0 dir Signer_services.authorized_keys (fun () () ->
if require_auth then
Handler.Authorized_key.load cctxt
>>=? fun keys ->
return_some
(keys |> List.split |> snd |> List.map Signature.Public_key.hash)
else return_none)
in
Lwt.catch
(fun () ->
List.map
(fun host ->
let host = Ipaddr.V6.to_string host in
log
Tag.DSL.(
fun f ->
f "Listening on address %s"
-% t event "signer_listening" -% s host_name host)
>>= fun () ->
RPC_server.launch
~host
mode
dir
~media_types:Media_type.all_media_types
>>= fun _server -> fst (Lwt.wait ()))
hosts
|> Lwt.choose)
(function
| Unix.Unix_error (Unix.EADDRINUSE, "bind", "") ->
failwith "Port already in use."
| exn ->
Lwt.return (error_exn exn))
let run_https (cctxt : #Client_context.wallet) ~host ~port ~cert ~key
?magic_bytes ~check_high_watermark ~require_auth =
Lwt_utils_unix.getaddrinfo
~passive:true
~node:host
~service:(string_of_int port)
>>= function
| [] ->
failwith "Cannot resolve listening address: %S" host
| points ->
let hosts = fst (List.split points) in
log
Tag.DSL.(
fun f ->
f "Accepting HTTPS requests on port %d"
-% t event "accepting_https_requests"
-% s port_number port)
>>= fun () ->
let mode : Conduit_lwt_unix.server =
`TLS (`Crt_file_path cert, `Key_file_path key, `No_password, `Port port)
in
run
(cctxt : #Client_context.wallet)
~hosts
?magic_bytes
~check_high_watermark
~require_auth
mode
let run_http (cctxt : #Client_context.wallet) ~host ~port ?magic_bytes
~check_high_watermark ~require_auth =
Lwt_utils_unix.getaddrinfo
~passive:true
~node:host
~service:(string_of_int port)
>>= function
| [] ->
failwith "Cannot resolve listening address: %S" host
| points ->
let hosts = fst (List.split points) in
log
Tag.DSL.(
fun f ->
f "Accepting HTTP requests on port %d"
-% t event "accepting_http_requests"
-% s port_number port)
>>= fun () ->
let mode : Conduit_lwt_unix.server = `TCP (`Port port) in
run
(cctxt : #Client_context.wallet)
~hosts
?magic_bytes
~check_high_watermark
~require_auth
mode
src/bin_signer/http_daemon.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition log {A : Type}
: Tezos_base__TzPervasives.Internal_event.Legacy_logging.log A (Lwt.t unit) :=
Signer_logging.lwt_log_notice.
Import Signer_logging.
Definition run {B C a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (hosts : list Ipaddr.V6.t) (magic_bytes : option (list Z))
(check_high_watermark : bool) (require_auth : bool)
(mode : Conduit_lwt_unix.server)
: Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
let dir := RPC_directory.empty in
let dir :=
RPC_directory.register1 dir Signer_services.sign
(fun pkh =>
fun signature =>
fun data =>
Handler.sign cctxt
{| pkh := pkh; data := data; signature := signature |} magic_bytes
check_high_watermark require_auth) in
let dir :=
RPC_directory.register1 dir Signer_services.public_key
(fun pkh =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Handler.public_key cctxt pkh) in
let dir :=
RPC_directory.register0 dir Signer_services.authorized_keys
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
if require_auth then
op_gtgteqquestion (Handler.Authorized_key.load cctxt)
(fun keys =>
return_some
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply keys List.split) snd)
(List.map Signature.Public_key.hash)))
else
return_none) in
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
OCaml.Stdlib.reverse_apply
(List.map
(fun host =>
let host := Ipaddr.V6.to_string host in
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Listening on address " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Listening on address %s" % string))
(t event "signer_listening" % string)) (s host_name host)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(RPC_server.launch (Some host) None Media_type.all_media_types
mode dir) (fun _server => fst (Lwt.wait tt)))) hosts)
Lwt.choose)
(fun function_parameter =>
match function_parameter with
| Unix_error Unix.EADDRINUSE "bind" % string "" % string =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Port already in use." % string
CamlinternalFormatBasics.End_of_format)
"Port already in use." % string)
| exn => Lwt._return (error_exn exn)
end).
Definition run_https {B C a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (host : string) (port : Z) (cert : string) (key : string)
(magic_bytes : option (list Z)) (check_high_watermark : bool)
(require_auth : bool) : Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
op_gtgteq
(Lwt_utils_unix.getaddrinfo true host (OCaml.Stdlib.string_of_int port))
(fun function_parameter =>
match function_parameter with
| [] =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot resolve listening address: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Cannot resolve listening address: %S" % string) host
| points =>
let hosts := fst (List.split points) in
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Accepting HTTPS requests on port " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"Accepting HTTPS requests on port %d" % string))
(t event "accepting_https_requests" % string))
(s port_number port)))
(fun function_parameter =>
let 'tt := function_parameter in
let mode :=
(* ❌ Variants not supported *)
variant in
run cctxt hosts magic_bytes check_high_watermark require_auth mode)
end).
Definition run_http {B C a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (host : string) (port : Z) (magic_bytes : option (list Z))
(check_high_watermark : bool) (require_auth : bool)
: Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
op_gtgteq
(Lwt_utils_unix.getaddrinfo true host (OCaml.Stdlib.string_of_int port))
(fun function_parameter =>
match function_parameter with
| [] =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot resolve listening address: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Cannot resolve listening address: %S" % string) host
| points =>
let hosts := fst (List.split points) in
op_gtgteq
(log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Accepting HTTP requests on port " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"Accepting HTTP requests on port %d" % string))
(t event "accepting_http_requests" % string))
(s port_number port)))
(fun function_parameter =>
let 'tt := function_parameter in
let mode :=
(* ❌ Variants not supported *)
variant in
run cctxt hosts magic_bytes check_high_watermark require_auth mode)
end).
src/bin_signer/main_signer.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Log = Internal_event.Legacy_logging.Make (struct
let name = "signer.main"
end)
let default_tcp_host =
match Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST" with
| None ->
"localhost"
| Some host ->
host
let default_tcp_port =
match Sys.getenv_opt "TEZOS_SIGNER_TCP_PORT" with
| None ->
"7732"
| Some port ->
port
let default_https_host =
match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" with
| None ->
"localhost"
| Some host ->
host
let default_https_port =
match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_PORT" with
| None ->
"443"
| Some port ->
port
let default_http_host =
match Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST" with
| None ->
"localhost"
| Some host ->
host
let default_http_port =
match Sys.getenv_opt "TEZOS_SIGNER_HTTP_PORT" with
| None ->
"6732"
| Some port ->
port
open Clic
let group =
{Clic.name = "signer"; title = "Commands specific to the signing daemon"}
let magic_bytes_arg =
Clic.arg
~doc:"values allowed for the magic bytes, defaults to any"
~short:'M'
~long:"magic-bytes"
~placeholder:"0xHH,0xHH,..."
(Clic.parameter (fun _ s ->
try
return
(List.map
(fun s ->
let b = int_of_string s in
if b < 0 || b > 255 then raise Exit else b)
(String.split ',' s))
with _ ->
failwith
"Bad format for magic bytes, a series of numbers is expected, \
separated by commas."))
let high_watermark_switch =
Clic.switch
~doc:
"high watermark restriction\n\
Stores the highest level signed for blocks and endorsements for each \
address, and forbids to sign a level that is inferior or equal \
afterwards, except for the exact same input data."
~short:'W'
~long:"check-high-watermark"
()
let pidfile_arg =
arg
~doc:"write process id in file"
~short:'P'
~long:"pidfile"
~placeholder:"filename"
(parameter (fun _ s -> return s))
let may_setup_pidfile = function
| None ->
return_unit
| Some pidfile ->
trace (failure "Failed to create the pidfile: %s" pidfile)
@@ Lwt_lock_file.create ~unlink_on_exit:true pidfile
let commands base_dir require_auth : Client_context.full command list =
Tezos_signer_backends_unix.Ledger.commands ()
@ Client_keys_commands.commands None
@ [ command
~group
~desc:"Launch a signer daemon over a TCP socket."
(args5
pidfile_arg
magic_bytes_arg
high_watermark_switch
(default_arg
~doc:"listening address or host name"
~short:'a'
~long:"address"
~placeholder:"host|address"
~default:default_tcp_host
(parameter (fun _ s -> return s)))
(default_arg
~doc:"listening TCP port or service name"
~short:'p'
~long:"port"
~placeholder:"port number"
~default:default_tcp_port
(parameter (fun _ s -> return s))))
(prefixes ["launch"; "socket"; "signer"] @@ stop)
(fun (pidfile, magic_bytes, check_high_watermark, host, port) cctxt ->
may_setup_pidfile pidfile
>>=? fun () ->
Tezos_signer_backends.Encrypted.decrypt_all cctxt
>>=? fun () ->
Socket_daemon.run
cctxt
(Tcp (host, port, [AI_SOCKTYPE SOCK_STREAM]))
?magic_bytes
~check_high_watermark
~require_auth
>>=? fun _ -> return_unit);
command
~group
~desc:"Launch a signer daemon over a local Unix socket."
(args4
pidfile_arg
magic_bytes_arg
high_watermark_switch
(default_arg
~doc:"path to the local socket file"
~short:'s'
~long:"socket"
~placeholder:"path"
~default:(Filename.concat base_dir "socket")
(parameter (fun _ s -> return s))))
(prefixes ["launch"; "local"; "signer"] @@ stop)
(fun (pidfile, magic_bytes, check_high_watermark, path) cctxt ->
may_setup_pidfile pidfile
>>=? fun () ->
Tezos_signer_backends.Encrypted.decrypt_all cctxt
>>=? fun () ->
Socket_daemon.run
cctxt
(Unix path)
?magic_bytes
~check_high_watermark
~require_auth
>>=? fun _ -> return_unit);
command
~group
~desc:"Launch a signer daemon over HTTP."
(args5
pidfile_arg
magic_bytes_arg
high_watermark_switch
(default_arg
~doc:"listening address or host name"
~short:'a'
~long:"address"
~placeholder:"host|address"
~default:default_http_host
(parameter (fun _ s -> return s)))
(default_arg
~doc:"listening HTTP port"
~short:'p'
~long:"port"
~placeholder:"port number"
~default:default_http_port
(parameter (fun _ x ->
try return (int_of_string x)
with Failure _ -> failwith "Invalid port %s" x))))
(prefixes ["launch"; "http"; "signer"] @@ stop)
(fun (pidfile, magic_bytes, check_high_watermark, host, port) cctxt ->
may_setup_pidfile pidfile
>>=? fun () ->
Tezos_signer_backends.Encrypted.decrypt_all cctxt
>>=? fun () ->
Http_daemon.run_http
cctxt
~host
~port
?magic_bytes
~check_high_watermark
~require_auth);
command
~group
~desc:"Launch a signer daemon over HTTPS."
(args5
pidfile_arg
magic_bytes_arg
high_watermark_switch
(default_arg
~doc:"listening address or host name"
~short:'a'
~long:"address"
~placeholder:"host|address"
~default:default_https_host
(parameter (fun _ s -> return s)))
(default_arg
~doc:"listening HTTPS port"
~short:'p'
~long:"port"
~placeholder:"port number"
~default:default_https_port
(parameter (fun _ x ->
try return (int_of_string x)
with Failure _ -> failwith "Invalid port %s" x))))
( prefixes ["launch"; "https"; "signer"]
@@ param
~name:"cert"
~desc:"path to the TLS certificate"
(parameter (fun _ s ->
if not (Sys.file_exists s) then
failwith "No such TLS certificate file %s" s
else return s))
@@ param
~name:"key"
~desc:"path to the TLS key"
(parameter (fun _ s ->
if not (Sys.file_exists s) then
failwith "No such TLS key file %s" s
else return s))
@@ stop )
(fun (pidfile, magic_bytes, check_high_watermark, host, port)
cert
key
cctxt ->
may_setup_pidfile pidfile
>>=? fun () ->
Tezos_signer_backends.Encrypted.decrypt_all cctxt
>>=? fun () ->
Http_daemon.run_https
cctxt
~host
~port
~cert
~key
?magic_bytes
~check_high_watermark
~require_auth);
command
~group
~desc:"Authorize a given public key to perform signing requests."
(args1
(arg
~doc:"an optional name for the key (defaults to the hash)"
~short:'N'
~long:"name"
~placeholder:"name"
(parameter (fun _ s -> return s))))
( prefixes ["add"; "authorized"; "key"]
@@ param
~name:"pk"
~desc:"full public key (Base58 encoded)"
(parameter (fun _ s ->
Lwt.return (Signature.Public_key.of_b58check s)))
@@ stop )
(fun name key cctxt ->
let pkh = Signature.Public_key.hash key in
let name =
match name with
| Some name ->
name
| None ->
Signature.Public_key_hash.to_b58check pkh
in
Handler.Authorized_key.add ~force:false cctxt name key) ]
let home = try Sys.getenv "HOME" with Not_found -> "/root"
let default_base_dir = Filename.concat home ".tezos-signer"
let string_parameter () : (string, _) parameter =
parameter (fun _ x -> return x)
let base_dir_arg () =
arg
~long:"base-dir"
~short:'d'
~placeholder:"path"
~doc:
( "signer data directory\n\
The directory where the Tezos client will store all its data.\n\
By default: '" ^ default_base_dir ^ "'." )
(string_parameter ())
let require_auth_arg () =
switch
~long:"require-authentication"
~short:'A'
~doc:"Require a signature from the caller to sign."
()
let password_filename_arg () =
arg
~long:"password-file"
~short:'f'
~placeholder:"filename"
~doc:"Absolute path of the password file"
(string_parameter ())
let global_options () =
args3 (base_dir_arg ()) (require_auth_arg ()) (password_filename_arg ())
module C = struct
type t = string option * bool * string option
let global_options = global_options
let parse_config_args ctx argv =
Clic.parse_global_options (global_options ()) ctx argv
>>=? fun ((base_dir, require_auth, password_filename), remaining) ->
return
( {
Client_config.default_parsed_config_args with
base_dir;
require_auth;
password_filename;
},
remaining )
let default_chain = Client_config.default_chain
let default_block = Client_config.default_block
let default_base_dir = default_base_dir
let other_registrations = None
let clic_commands ~base_dir ~config_commands:_ ~builtin_commands:_
~other_commands ~require_auth =
commands base_dir require_auth @ other_commands
let logger = Some (RPC_client_unix.full_logger Format.err_formatter)
end
let () =
Client_main_run.run
~log:(Log.fatal_error "%s")
(module C)
~select_commands:(fun _ _ -> return_nil)
src/bin_signer/main_signer.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition default_tcp_host : string :=
match Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST" % string with
| None => "localhost" % string
| Some host => host
end.
Definition default_tcp_port : string :=
match Sys.getenv_opt "TEZOS_SIGNER_TCP_PORT" % string with
| None => "7732" % string
| Some port => port
end.
Definition default_https_host : string :=
match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" % string with
| None => "localhost" % string
| Some host => host
end.
Definition default_https_port : string :=
match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_PORT" % string with
| None => "443" % string
| Some port => port
end.
Definition default_http_host : string :=
match Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST" % string with
| None => "localhost" % string
| Some host => host
end.
Definition default_http_port : string :=
match Sys.getenv_opt "TEZOS_SIGNER_HTTP_PORT" % string with
| None => "6732" % string
| Some port => port
end.
Import Clic.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "signer" % string;
Clic.title := "Commands specific to the signing daemon" % string |}.
Definition magic_bytes_arg
: Tezos_base__TzPervasives.Clic.arg (option (list Z))
Tezos_client_base.Client_context.full :=
Clic.arg "values allowed for the magic bytes, defaults to any" % string
(Some "M" % char) "magic-bytes" % string "0xHH,0xHH,..." % string
(Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try
(_return
(List.map
(fun s =>
let b := OCaml.Stdlib.int_of_string s in
if orb (OCaml.Stdlib.lt b 0) (OCaml.Stdlib.gt b 255) then
Stdlib.raise Exit
else
b) (String.split "," % char None None s))))).
Definition high_watermark_switch
: Tezos_base__TzPervasives.Clic.arg bool Tezos_client_base.Client_context.full :=
Clic.switch
"high watermark restriction
Stores the highest level signed for blocks and endorsements for each address, and forbids to sign a level that is inferior or equal afterwards, except for the exact same input data."
% string (Some "W" % char) "check-high-watermark" % string tt.
Definition pidfile_arg
: Tezos_base__TzPervasives.Clic.arg (option string)
Tezos_client_base.Client_context.full :=
arg "write process id in file" % string (Some "P" % char) "pidfile" % string
"filename" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s)).
Definition may_setup_pidfile (function_parameter : option string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match function_parameter with
| None => return_unit
| Some pidfile =>
apply
(trace
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to create the pidfile: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Failed to create the pidfile: %s" % string) pidfile))
(Lwt_lock_file.create None (Some true) pidfile)
end.
Definition commands (base_dir : string) (require_auth : bool)
: list
(Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
OCaml.Stdlib.app (Tezos_signer_backends_unix.Ledger.commands tt)
(OCaml.Stdlib.app (Client_keys_commands.commands None)
(cons
(command (Some group)
"Launch a signer daemon over a TCP socket." % string
(args5 pidfile_arg magic_bytes_arg high_watermark_switch
(default_arg "listening address or host name" % string
(Some "a" % char) "address" % string "host|address" % string
default_tcp_host
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s)))
(default_arg "listening TCP port or service name" % string
(Some "p" % char) "port" % string "port number" % string
default_tcp_port
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s))))
(apply
(prefixes
(cons "launch" % string
(cons "socket" % string (cons "signer" % string [])))) stop)
(fun function_parameter =>
let '(pidfile, magic_bytes, check_high_watermark, host, port) :=
function_parameter in
fun cctxt =>
op_gtgteqquestion (may_setup_pidfile pidfile)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.decrypt_all cctxt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Socket_daemon.run cctxt
(Tezos_stdlib_unix.Lwt_utils_unix.Socket.Tcp host port
(cons (Unix.AI_SOCKTYPE Unix.SOCK_STREAM) []))
magic_bytes check_high_watermark require_auth)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)))))
(cons
(command (Some group)
"Launch a signer daemon over a local Unix socket." % string
(args4 pidfile_arg magic_bytes_arg high_watermark_switch
(default_arg "path to the local socket file" % string
(Some "s" % char) "socket" % string "path" % string
(Filename.concat base_dir "socket" % string)
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s))))
(apply
(prefixes
(cons "launch" % string
(cons "local" % string (cons "signer" % string [])))) stop)
(fun function_parameter =>
let '(pidfile, magic_bytes, check_high_watermark, path) :=
function_parameter in
fun cctxt =>
op_gtgteqquestion (may_setup_pidfile pidfile)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.decrypt_all cctxt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Socket_daemon.run cctxt
(Tezos_stdlib_unix.Lwt_utils_unix.Socket.Unix path)
magic_bytes check_high_watermark require_auth)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)))))
(cons
(command (Some group) "Launch a signer daemon over HTTP." % string
(args5 pidfile_arg magic_bytes_arg high_watermark_switch
(default_arg "listening address or host name" % string
(Some "a" % char) "address" % string "host|address" % string
default_http_host
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s)))
(default_arg "listening HTTP port" % string (Some "p" % char)
"port" % string "port number" % string default_http_port
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x =>
(* ❌ Try-with are not handled *)
try (_return (OCaml.Stdlib.int_of_string x))))))
(apply
(prefixes
(cons "launch" % string
(cons "http" % string (cons "signer" % string [])))) stop)
(fun function_parameter =>
let '(pidfile, magic_bytes, check_high_watermark, host, port) :=
function_parameter in
fun cctxt =>
op_gtgteqquestion (may_setup_pidfile pidfile)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.decrypt_all cctxt)
(fun function_parameter =>
let 'tt := function_parameter in
Http_daemon.run_http cctxt host port magic_bytes
check_high_watermark require_auth))))
(cons
(command (Some group)
"Launch a signer daemon over HTTPS." % string
(args5 pidfile_arg magic_bytes_arg high_watermark_switch
(default_arg "listening address or host name" % string
(Some "a" % char) "address" % string "host|address" % string
default_https_host
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s)))
(default_arg "listening HTTPS port" % string (Some "p" % char)
"port" % string "port number" % string default_https_port
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x =>
(* ❌ Try-with are not handled *)
try (_return (OCaml.Stdlib.int_of_string x))))))
(apply
(prefixes
(cons "launch" % string
(cons "https" % string (cons "signer" % string []))))
(apply
(param "cert" % string
"path to the TLS certificate" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
if negb (Sys.file_exists s) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No such TLS certificate file " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"No such TLS certificate file %s" % string) s
else
_return s)))
(apply
(param "key" % string "path to the TLS key" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
if negb (Sys.file_exists s) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No such TLS key file " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"No such TLS key file %s" % string) s
else
_return s))) stop)))
(fun function_parameter =>
let
'(pidfile, magic_bytes, check_high_watermark, host, port) :=
function_parameter in
fun cert =>
fun key =>
fun cctxt =>
op_gtgteqquestion (may_setup_pidfile pidfile)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.decrypt_all cctxt)
(fun function_parameter =>
let 'tt := function_parameter in
Http_daemon.run_https cctxt host port cert key
magic_bytes check_high_watermark require_auth))))
(cons
(command (Some group)
"Authorize a given public key to perform signing requests." %
string
(args1
(arg
"an optional name for the key (defaults to the hash)" %
string (Some "N" % char) "name" % string "name" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s))))
(apply
(prefixes
(cons "add" % string
(cons "authorized" % string (cons "key" % string []))))
(apply
(param "pk" % string
"full public key (Base58 encoded)" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
Lwt._return (Signature.Public_key.of_b58check s))))
stop))
(fun name =>
fun key =>
fun cctxt =>
let pkh := Signature.Public_key.hash key in
let name :=
match name with
| Some name => name
| None => Signature.Public_key_hash.to_b58check pkh
end in
Handler.Authorized_key.add false cctxt name key)) [])))))).
Definition home : string :=
(* ❌ Try-with are not handled *)
try (Sys.getenv "HOME" % string).
Definition default_base_dir : string :=
Filename.concat home ".tezos-signer" % string.
Definition string_parameter {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter string A :=
let 'tt := function_parameter in
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x => _return x).
Definition base_dir_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option string) A :=
let 'tt := function_parameter in
arg
(String.append
"signer data directory
The directory where the Tezos client will store all its data.
By default: '"
% string (String.append default_base_dir "'." % string))
(Some "d" % char) "base-dir" % string "path" % string (string_parameter tt).
Definition require_auth_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg bool A :=
let 'tt := function_parameter in
switch "Require a signature from the caller to sign." % string
(Some "A" % char) "require-authentication" % string tt.
Definition password_filename_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option string) A :=
let 'tt := function_parameter in
arg "Absolute path of the password file" % string (Some "f" % char)
"password-file" % string "filename" % string (string_parameter tt).
Definition global_options {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.options
((option string) * bool * (option string)) A :=
let 'tt := function_parameter in
args3 (base_dir_arg tt) (require_auth_arg tt) (password_filename_arg tt).
Module C.
Definition t := (option string) * bool * (option string).
Definition global_options {A : Type}
: unit ->
Tezos_base__TzPervasives.Clic.options
((option string) * bool * (option string)) A := global_options.
Definition parse_config_args {A : Type} (ctx : A) (argv : list string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_client_base_unix.Client_config.parsed_config_args * (list string))) :=
op_gtgteqquestion (Clic.parse_global_options (global_options tt) ctx argv)
(fun function_parameter =>
let '((base_dir, require_auth, password_filename), remaining) :=
function_parameter in
_return
((* ❌ Record substitution not handled *)
record_substitution, remaining)).
Definition default_chain : variant := Client_config.default_chain.
Definition default_block : variant := Client_config.default_block.
Definition default_base_dir : string := default_base_dir.
Definition other_registrations {A : Type} : option A := None.
Definition clic_commands {A B : Type}
(base_dir : string) (function_parameter : A)
: B ->
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full)) ->
bool ->
list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full) :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun other_commands =>
fun require_auth =>
OCaml.Stdlib.app (commands base_dir require_auth) other_commands.
Definition logger
: option Tezos_rpc_http_client_unix.RPC_client_unix.logger :=
Some (RPC_client_unix.full_logger Format.err_formatter).
End C.
src/bin_signer/signer_logging.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Internal_event.Legacy_logging.Make_semantic (struct let name = "client.signer" end) let host_name = Tag.def ~doc:"Host name" "host" Format.pp_print_text let service_name = Tag.def ~doc:"Service name" "service" Format.pp_print_text let port_number = Tag.def ~doc:"Port number" "port" Format.pp_print_int let magic_byte = Tag.def ~doc:"Magic byte" "magic_byte" Format.pp_print_int let num_bytes = Tag.def ~doc:"Number of bytes" "num_bytes" Format.pp_print_int let unix_socket_path = Tag.def ~doc:"UNIX socket file path" "unix_socket" Format.pp_print_text
src/bin_signer/signer_logging.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition host_name : Tag.def string :=
Tag.def (Some "Host name" % string) "host" % string Format.pp_print_text.
Definition service_name : Tag.def string :=
Tag.def (Some "Service name" % string) "service" % string Format.pp_print_text.
Definition port_number : Tag.def Z :=
Tag.def (Some "Port number" % string) "port" % string Format.pp_print_int.
Definition magic_byte : Tag.def Z :=
Tag.def (Some "Magic byte" % string) "magic_byte" % string Format.pp_print_int.
Definition num_bytes : Tag.def Z :=
Tag.def (Some "Number of bytes" % string) "num_bytes" % string
Format.pp_print_int.
Definition unix_socket_path : Tag.def string :=
Tag.def (Some "UNIX socket file path" % string) "unix_socket" % string
Format.pp_print_text.
src/bin_signer/socket_daemon.ml 56 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Signer_logging
open Signer_messages
let log = lwt_log_notice
let handle_client ?magic_bytes ~check_high_watermark ~require_auth cctxt fd =
Lwt_utils_unix.Socket.recv fd Request.encoding
>>=? function
| Sign req ->
let encoding = result_encoding Sign.Response.encoding in
Handler.sign cctxt req ?magic_bytes ~check_high_watermark ~require_auth
>>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res
>>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
| Deterministic_nonce req ->
let encoding = result_encoding Deterministic_nonce.Response.encoding in
Handler.deterministic_nonce cctxt req ~require_auth
>>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res
>>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
| Deterministic_nonce_hash req ->
let encoding =
result_encoding Deterministic_nonce_hash.Response.encoding
in
Handler.deterministic_nonce_hash cctxt req ~require_auth
>>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res
>>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
| Supports_deterministic_nonces req ->
let encoding =
result_encoding Supports_deterministic_nonces.Response.encoding
in
Handler.supports_deterministic_nonces cctxt req
>>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res
>>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
| Public_key pkh ->
let encoding = result_encoding Public_key.Response.encoding in
Handler.public_key cctxt pkh
>>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res
>>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
| Authorized_keys ->
let encoding = result_encoding Authorized_keys.Response.encoding in
( if require_auth then
Handler.Authorized_key.load cctxt
>>=? fun keys ->
return
(Authorized_keys.Response.Authorized_keys
(keys |> List.split |> snd |> List.map Signature.Public_key.hash))
else return Authorized_keys.Response.No_authentication )
>>= fun res ->
Lwt_utils_unix.Socket.send fd encoding res
>>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
let run (cctxt : #Client_context.wallet) path ?magic_bytes
~check_high_watermark ~require_auth =
let open Lwt_utils_unix.Socket in
( match path with
| Tcp (host, service, _opts) ->
log
Tag.DSL.(
fun f ->
f "Accepting TCP requests on %s:%s"
-% t event "accepting_tcp_requests"
-% s host_name host -% s service_name service)
| Unix path ->
ListLabels.iter
Sys.[sigint; sigterm]
~f:(fun signal ->
Sys.set_signal
signal
(Signal_handle
(fun _ ->
Format.printf "Removing the local socket file and quitting.@." ;
Unix.unlink path ;
exit 0))) ;
log
Tag.DSL.(
fun f ->
f "Accepting UNIX requests on %s"
-% t event "accepting_unix_requests"
-% s unix_socket_path path) )
>>= fun () ->
bind path
>>=? fun fds ->
let rec loop fd =
Lwt_unix.accept fd
>>= fun (cfd, _) ->
Lwt.async (fun () ->
protect
~on_error:(function
| Exn End_of_file :: _ ->
return_unit
| errs ->
Lwt.return_error errs)
(fun () ->
handle_client
?magic_bytes
~check_high_watermark
~require_auth
cctxt
cfd)) ;
loop fd
in
Lwt_list.map_p loop fds >>= return
src/bin_signer/socket_daemon.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Signer_logging.
Import Signer_messages.
Definition log {A : Type}
: Tezos_base__TzPervasives.Internal_event.Legacy_logging.log A (Lwt.t unit) :=
lwt_log_notice.
Definition handle_client {B a : Type}
(magic_bytes : option (list Z)) (check_high_watermark : bool)
(require_auth : bool)
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (fd : Lwt_unix.file_descr)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (Lwt_utils_unix.Socket.recv fd Request.encoding)
(fun function_parameter =>
match function_parameter with
| Tezos_signer_services.Signer_messages.Request.Sign req =>
let encoding := result_encoding Sign.Response.encoding in
op_gtgteq
(Handler.sign cctxt req magic_bytes check_high_watermark require_auth)
(fun res =>
op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Lwt_unix.close fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
| Tezos_signer_services.Signer_messages.Request.Deterministic_nonce req =>
let encoding := result_encoding Deterministic_nonce.Response.encoding in
op_gtgteq (Handler.deterministic_nonce cctxt req require_auth)
(fun res =>
op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Lwt_unix.close fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
|
Tezos_signer_services.Signer_messages.Request.Deterministic_nonce_hash
req =>
let encoding :=
result_encoding Deterministic_nonce_hash.Response.encoding in
op_gtgteq (Handler.deterministic_nonce_hash cctxt req require_auth)
(fun res =>
op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Lwt_unix.close fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
|
Tezos_signer_services.Signer_messages.Request.Supports_deterministic_nonces
req =>
let encoding :=
result_encoding Supports_deterministic_nonces.Response.encoding in
op_gtgteq (Handler.supports_deterministic_nonces cctxt req)
(fun res =>
op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Lwt_unix.close fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
| Tezos_signer_services.Signer_messages.Request.Public_key pkh =>
let encoding := result_encoding Public_key.Response.encoding in
op_gtgteq (Handler.public_key cctxt pkh)
(fun res =>
op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Lwt_unix.close fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
| Tezos_signer_services.Signer_messages.Request.Authorized_keys =>
let encoding := result_encoding Authorized_keys.Response.encoding in
op_gtgteq
(if require_auth then
op_gtgteqquestion (Handler.Authorized_key.load cctxt)
(fun keys =>
_return
(Tezos_signer_services.Signer_messages.Authorized_keys.Response.Authorized_keys
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply keys List.split) snd)
(List.map Signature.Public_key.hash))))
else
_return
Tezos_signer_services.Signer_messages.Authorized_keys.Response.No_authentication)
(fun res =>
op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Lwt_unix.close fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
end).
Definition run {B C a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (path : Tezos_stdlib_unix.Lwt_utils_unix.Socket.addr)
(magic_bytes : option (list Z)) (check_high_watermark : bool)
(require_auth : bool) : Lwt.t (Tezos_base__TzPervasives.tzresult (list C)) :=
op_gtgteq
match path with
| Tezos_stdlib_unix.Lwt_utils_unix.Socket.Tcp host service _opts =>
log
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Accepting TCP requests on " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"Accepting TCP requests on %s:%s" % string))
(t event "accepting_tcp_requests" % string)) (s host_name host))
(s service_name service))
| Tezos_stdlib_unix.Lwt_utils_unix.Socket.Unix path =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
ListLabels.iter
(fun signal =>
Sys.set_signal signal
(Stdlib.Sys.Signal_handle
(fun function_parameter =>
let '_ := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Removing the local socket file and quitting." %
string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))
"Removing the local socket file and quitting.@." %
string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Unix.unlink path in
Stdlib.exit 0))) (cons sigint (cons sigterm [])) in
log
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Accepting UNIX requests on " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Accepting UNIX requests on %s" % string))
(t event "accepting_unix_requests" % string))
(s unix_socket_path path))
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (bind None path)
(fun fds =>
let fix loop {D : Type} (fd : Lwt_unix.file_descr) : Lwt.t D :=
op_gtgteq (Lwt_unix.accept fd)
(fun function_parameter =>
let '(cfd, _) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
protect
(Some
(fun function_parameter =>
match function_parameter with
|
cons
(Tezos_base__TzPervasives.Exn OCaml.End_of_file)
_ => return_unit
| errs => Lwt.return_error errs
end)) None
(fun function_parameter =>
let 'tt := function_parameter in
handle_client magic_bytes check_high_watermark
require_auth cctxt cfd)) in
loop fd) in
op_gtgteq (Lwt_list.map_p loop fds) _return)).
src/bin_validation/main_validator.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Nomadic Labs. <contact@nomadic-labs.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) let () = Pervasives.exit (Lwt_main.run @@ Validator.main ())
src/bin_validation/main_validator.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations.
src/bin_validation/validator.ml 10 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs. <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let ( // ) = Filename.concat
let load_protocol proto protocol_root =
if Registered_protocol.mem proto then return_unit
else
let cmxs_file =
protocol_root
// Protocol_hash.to_short_b58check proto
// Format.asprintf "protocol_%a" Protocol_hash.pp proto
in
try
Dynlink.loadfile_private (cmxs_file ^ ".cmxs") ;
return_unit
with Dynlink.Error err ->
Format.ksprintf
(fun msg ->
fail
Block_validator_errors.(
Validation_process_failed (Protocol_dynlink_failure msg)))
"Cannot load file: %s. (Expected location: %s.)"
(Dynlink.error_message err)
cmxs_file
let inconsistent_handshake msg =
Block_validator_errors.(
Validation_process_failed (Inconsistent_handshake msg))
let run stdin stdout =
External_validation.recv stdin Data_encoding.Variable.bytes
>>= fun magic ->
fail_when
(not (Bytes.equal magic External_validation.magic))
(inconsistent_handshake "bad magic")
>>=? fun () ->
External_validation.recv stdin External_validation.parameters_encoding
>>= fun {context_root; protocol_root; sandbox_parameters} ->
let genesis_block = ref Block_hash.zero in
let genesis_time = ref Time.Protocol.epoch in
let genesis_protocol = ref Protocol_hash.zero in
let sandbox_param =
Option.map ~f:(fun p -> ("sandbox_parameter", p)) sandbox_parameters
in
let patch_context ctxt =
( match sandbox_param with
| None ->
Lwt.return ctxt
| Some (key, json) ->
Tezos_storage.Context.set
ctxt
[key]
(Data_encoding.Binary.to_bytes_exn Data_encoding.json json) )
>>= fun ctxt ->
match Registered_protocol.get !genesis_protocol with
| None ->
assert false (* FIXME error *)
| Some proto -> (
let module Proto = (val proto) in
let ctxt = Shell_context.wrap_disk_context ctxt in
Proto.init
ctxt
{
level = 0l;
proto_level = 0;
predecessor = !genesis_block;
timestamp = !genesis_time;
validation_passes = 0;
operations_hash = Operation_list_list_hash.empty;
fitness = [];
context = Context_hash.zero;
}
>>= function
| Error _ ->
assert false (* FIXME error *)
| Ok {context; _} ->
let context = Shell_context.unwrap_disk_context context in
Lwt.return context )
in
Context.init ~patch_context context_root
>>= fun context_index ->
let rec loop () =
External_validation.recv stdin External_validation.request_encoding
>>= (function
| External_validation.Validate
{ chain_id;
block_header;
predecessor_block_header;
operations;
max_operations_ttl } ->
Error_monad.protect (fun () ->
let pred_context_hash =
predecessor_block_header.shell.context
in
Context.checkout context_index pred_context_hash
>>= function
| Some context ->
return context
| None ->
fail
(Block_validator_errors.Failed_to_checkout_context
pred_context_hash))
>>=? (fun predecessor_context ->
Context.get_protocol predecessor_context
>>= fun protocol_hash ->
load_protocol protocol_hash protocol_root
>>=? fun () ->
Block_validation.apply
chain_id
~max_operations_ttl
~predecessor_block_header
~predecessor_context
~block_header
operations
>>= function
| Error
[ Block_validator_errors.Unavailable_protocol
{protocol; _} ] as err -> (
(* If `next_protocol` is missing, try to load it *)
load_protocol protocol protocol_root
>>= function
| Error _ ->
Lwt.return err
| Ok () ->
Block_validation.apply
chain_id
~max_operations_ttl
~predecessor_block_header
~predecessor_context
~block_header
operations )
| result ->
Lwt.return result)
>>= fun res ->
External_validation.send
stdout
(Error_monad.result_encoding Block_validation.result_encoding)
res
| External_validation.Commit_genesis
{chain_id; time; genesis_hash; protocol} ->
genesis_time := time ;
genesis_block := genesis_hash ;
genesis_protocol := protocol ;
Error_monad.protect (fun () ->
Context.commit_genesis
context_index
~chain_id
~time
~protocol
>>= fun commit -> return commit)
>>= fun commit ->
External_validation.send
stdout
(Error_monad.result_encoding Context_hash.encoding)
commit
| External_validation.Init ->
External_validation.send
stdout
(Error_monad.result_encoding Data_encoding.empty)
(Ok ())
| External_validation.Fork_test_chain {context_hash; forked_header}
-> (
Context.checkout context_index context_hash
>>= function
| Some ctxt ->
Block_validation.init_test_chain ctxt forked_header
>>= (function
| Error
[ Block_validator_errors.Missing_test_protocol
protocol ] ->
load_protocol protocol protocol_root
>>=? fun () ->
Block_validation.init_test_chain ctxt forked_header
| result ->
Lwt.return result)
>>= fun result ->
External_validation.send
stdout
(Error_monad.result_encoding Block_header.encoding)
result
| None ->
External_validation.send
stdout
(Error_monad.result_encoding Data_encoding.empty)
(error
(Block_validator_errors.Failed_to_checkout_context
context_hash)) )
| External_validation.Terminate ->
Lwt_io.flush_all () >>= fun () -> exit 0)
>>= fun () -> loop ()
in
loop ()
let main () =
let stdin = Lwt_io.of_fd ~mode:Input Lwt_unix.stdin in
let stdout = Lwt_io.of_fd ~mode:Output Lwt_unix.stdout in
Lwt.catch
(fun () -> run stdin stdout >>=? fun () -> return 0)
(fun e -> Lwt.return (error_exn e))
>>= function
| Ok v ->
Lwt.return v
| Error _ as errs ->
External_validation.send
stdout
(Error_monad.result_encoding Data_encoding.unit)
errs
>>= fun () -> Lwt.return 1
src/bin_validation/validator.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition load_protocol
(proto : Tezos_base__TzPervasives.Protocol_hash.t) (protocol_root : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if Registered_protocol.mem proto then
return_unit
else
let cmxs_file :=
op_divdiv
(op_divdiv protocol_root (Protocol_hash.to_short_b58check proto))
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "protocol_" % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "protocol_%a" % string)
Protocol_hash.pp proto) in
(* ❌ Try-with are not handled *)
try
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ :=
Dynlink.loadfile_private (String.append cmxs_file ".cmxs" % string) in
return_unit).
Definition inconsistent_handshake (msg : string)
: Tezos_base__TzPervasives.error :=
Tezos_base__TzPervasives.Validation_process_failed
(Tezos_shell_services.Block_validator_errors.Inconsistent_handshake msg).
Definition run {A : Type}
(stdin : Lwt_io.input_channel) (stdout : Lwt_io.output_channel)
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
op_gtgteq (External_validation.recv stdin Data_encoding.Variable.bytes)
(fun magic =>
op_gtgteqquestion
(fail_when (negb (Stdlib.Bytes.equal magic External_validation.magic))
(inconsistent_handshake "bad magic" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(External_validation.recv stdin
External_validation.parameters_encoding)
(fun function_parameter =>
let '{|
context_root := context_root;
protocol_root := protocol_root;
sandbox_parameters := sandbox_parameters
|} := function_parameter in
let genesis_block := Stdlib.ref Block_hash.zero in
let genesis_time := Stdlib.ref Time.Protocol.epoch in
let genesis_protocol := Stdlib.ref Protocol_hash.zero in
let sandbox_param :=
Option.map (fun p => ("sandbox_parameter" % string, p))
sandbox_parameters in
let patch_context (ctxt : Tezos_storage.Context.context)
: Lwt.t Tezos_storage.Context.t :=
op_gtgteq
match sandbox_param with
| None => Lwt._return ctxt
| Some (key, json) =>
Tezos_storage.Context.set ctxt (cons key [])
(Data_encoding.Binary.to_bytes_exn Data_encoding.json json)
end
(fun ctxt =>
match
Registered_protocol.get
(Stdlib.op_exclamation genesis_protocol) with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some proto =>
let Proto := projT2 proto in
let ctxt := Shell_context.wrap_disk_context ctxt in
op_gtgteq
(Proto.(Tezos_protocol_updater__Registered_protocol.T.init)
ctxt
{|
level :=
(* ❌ Constant of type int32 is converted to int *)
0; proto_level := 0;
predecessor := Stdlib.op_exclamation genesis_block;
timestamp := Stdlib.op_exclamation genesis_time;
validation_passes := 0;
operations_hash := Operation_list_list_hash.empty;
fitness := []; context := Context_hash.zero |})
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| Stdlib.Ok {| context := context |} =>
let context :=
Shell_context.unwrap_disk_context context in
Lwt._return context
end)
end) in
op_gtgteq
(Context.init (Some patch_context) None None context_root)
(fun context_index =>
let fix loop {B : Type} (function_parameter : unit)
: Lwt.t B :=
let 'tt := function_parameter in
op_gtgteq
(op_gtgteq
(External_validation.recv stdin
External_validation.request_encoding)
(fun function_parameter =>
match function_parameter with
|
Tezos_validation.External_validation.Validate {|
chain_id := chain_id;
block_header := block_header;
predecessor_block_header :=
predecessor_block_header;
operations := operations;
max_operations_ttl := max_operations_ttl
|} =>
op_gtgteq
(op_gtgteqquestion
(Error_monad.protect None None
(fun function_parameter =>
let 'tt := function_parameter in
let pred_context_hash :=
context (shell predecessor_block_header)
in
op_gtgteq
(Context.checkout context_index
pred_context_hash)
(fun function_parameter =>
match function_parameter with
| Some context => _return context
| None =>
fail
(Tezos_base__TzPervasives.Failed_to_checkout_context
pred_context_hash)
end)))
(fun predecessor_context =>
op_gtgteq
(Context.get_protocol predecessor_context)
(fun protocol_hash =>
op_gtgteqquestion
(load_protocol protocol_hash
protocol_root)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Block_validation.apply chain_id
max_operations_ttl
predecessor_block_header
predecessor_context block_header
operations)
(fun function_parameter =>
match function_parameter with
|
(Stdlib.Error
(cons
(Tezos_base__TzPervasives.Unavailable_protocol
{| protocol := protocol |})
[])) as err =>
op_gtgteq
(load_protocol protocol
protocol_root)
(fun function_parameter =>
match function_parameter
with
| Stdlib.Error _ =>
Lwt._return err
| Stdlib.Ok tt =>
Block_validation.apply
chain_id
max_operations_ttl
predecessor_block_header
predecessor_context
block_header operations
end)
| result => Lwt._return result
end)))))
(fun res =>
External_validation.send stdout
(Error_monad.result_encoding
Block_validation.result_encoding) res)
|
Tezos_validation.External_validation.Commit_genesis
{|
chain_id := chain_id;
genesis_hash := genesis_hash;
time := time;
protocol := protocol
|} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq genesis_time time in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq genesis_block genesis_hash in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq genesis_protocol protocol
in
op_gtgteq
(Error_monad.protect None None
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Context.commit_genesis context_index
chain_id time protocol)
(fun commit => _return commit)))
(fun commit =>
External_validation.send stdout
(Error_monad.result_encoding
Context_hash.encoding) commit)
| Tezos_validation.External_validation.Init =>
External_validation.send stdout
(Error_monad.result_encoding Data_encoding.empty)
(Stdlib.Ok tt)
|
Tezos_validation.External_validation.Fork_test_chain
{|
context_hash := context_hash;
forked_header := forked_header
|} =>
op_gtgteq
(Context.checkout context_index context_hash)
(fun function_parameter =>
match function_parameter with
| Some ctxt =>
op_gtgteq
(op_gtgteq
(Block_validation.init_test_chain ctxt
forked_header)
(fun function_parameter =>
match function_parameter with
|
Stdlib.Error
(cons
(Tezos_base__TzPervasives.Missing_test_protocol
protocol) []) =>
op_gtgteqquestion
(load_protocol protocol
protocol_root)
(fun function_parameter =>
let 'tt := function_parameter in
Block_validation.init_test_chain
ctxt forked_header)
| result => Lwt._return result
end))
(fun result =>
External_validation.send stdout
(Error_monad.result_encoding
Block_header.encoding) result)
| None =>
External_validation.send stdout
(Error_monad.result_encoding
Data_encoding.empty)
(error
(Tezos_base__TzPervasives.Failed_to_checkout_context
context_hash))
end)
| Tezos_validation.External_validation.Terminate =>
op_gtgteq (Lwt_io.flush_all tt)
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.exit 0)
end))
(fun function_parameter =>
let 'tt := function_parameter in
loop tt) in
loop tt)))).
Definition main (function_parameter : unit) : Lwt.t Z :=
let 'tt := function_parameter in
let stdin := Lwt_io.of_fd None None Lwt_io.Input Lwt_unix.stdin in
let stdout := Lwt_io.of_fd None None Lwt_io.Output Lwt_unix.stdout in
op_gtgteq
(Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (run stdin stdout)
(fun function_parameter =>
let 'tt := function_parameter in
_return 0)) (fun e => Lwt._return (error_exn e)))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok v => Lwt._return v
| (Stdlib.Error _) as errs =>
op_gtgteq
(External_validation.send stdout
(Error_monad.result_encoding Data_encoding.unit) errs)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return 1)
end).
src/lib_base/base_logging.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make_semantic (struct
let name = "base"
end)
let pp_exn_trace ppf backtrace =
if String.length backtrace <> 0 then
Format.fprintf
ppf
"@,Backtrace:@, @[<h>%a@]"
Format.pp_print_text
backtrace
let pid =
Tag.def
~doc:"unix process ID where problem occurred"
"pid"
Format.pp_print_int
let exn_trace =
Tag.def ~doc:"backtrace from native Ocaml exception" "exn_trace" pp_exn_trace
src/lib_base/base_logging.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition pp_exn_trace (ppf : Stdlib.Format.formatter) (backtrace : string)
: unit :=
if nequiv_decb (OCaml.String.length backtrace) 0 then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Backtrace:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal " " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<h>" % string
CamlinternalFormatBasics.End_of_format) "<h>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@,Backtrace:@, @[<h>%a@]" % string) Format.pp_print_text backtrace
else
tt.
Definition pid : Tag.def Z :=
Tag.def (Some "unix process ID where problem occurred" % string)
"pid" % string Format.pp_print_int.
Definition exn_trace : Tag.def string :=
Tag.def (Some "backtrace from native Ocaml exception" % string)
"exn_trace" % string pp_exn_trace.
src/lib_base/block_header.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type shell_header = {
level : Int32.t;
proto_level : int;
(* uint8 *)
predecessor : Block_hash.t;
timestamp : Time.Protocol.t;
validation_passes : int;
(* uint8 *)
operations_hash : Operation_list_list_hash.t;
fitness : Fitness.t;
context : Context_hash.t;
}
let shell_header_encoding =
let open Data_encoding in
def
"block_header.shell"
~title:"Shell header"
~description:
"Block header's shell-related content. It contains information such as \
the block level, its predecessor and timestamp."
@@ conv
(fun { level;
proto_level;
predecessor;
timestamp;
validation_passes;
operations_hash;
fitness;
context } ->
( level,
proto_level,
predecessor,
timestamp,
validation_passes,
operations_hash,
fitness,
context ))
(fun ( level,
proto_level,
predecessor,
timestamp,
validation_passes,
operations_hash,
fitness,
context ) ->
{
level;
proto_level;
predecessor;
timestamp;
validation_passes;
operations_hash;
fitness;
context;
})
(obj8
(req "level" int32)
(req "proto" uint8)
(req "predecessor" Block_hash.encoding)
(req "timestamp" Time.Protocol.encoding)
(req "validation_pass" uint8)
(req "operations_hash" Operation_list_list_hash.encoding)
(req "fitness" Fitness.encoding)
(req "context" Context_hash.encoding))
type t = {shell : shell_header; protocol_data : Bytes.t}
include Compare.Make (struct
type nonrec t = t
let compare b1 b2 =
let ( >> ) x y = if x = 0 then y () else x in
let rec list compare xs ys =
match (xs, ys) with
| ([], []) ->
0
| (_ :: _, []) ->
-1
| ([], _ :: _) ->
1
| (x :: xs, y :: ys) ->
compare x y >> fun () -> list compare xs ys
in
Block_hash.compare b1.shell.predecessor b2.shell.predecessor
>> fun () ->
compare b1.protocol_data b2.protocol_data
>> fun () ->
Operation_list_list_hash.compare
b1.shell.operations_hash
b2.shell.operations_hash
>> fun () ->
Time.Protocol.compare b1.shell.timestamp b2.shell.timestamp
>> fun () -> list compare b1.shell.fitness b2.shell.fitness
end)
let encoding =
let open Data_encoding in
def
"block_header"
~title:"Block header"
~description:
"Block header. It contains both shell and protocol specific data."
@@ conv
(fun {shell; protocol_data} -> (shell, protocol_data))
(fun (shell, protocol_data) -> {shell; protocol_data})
(merge_objs
shell_header_encoding
(obj1 (req "protocol_data" Variable.bytes)))
let bounded_encoding ?max_size () =
match max_size with
| None ->
encoding
| Some max_size ->
Data_encoding.check_size max_size encoding
let pp ppf op =
Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding op)
let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v
let of_bytes b = Data_encoding.Binary.of_bytes encoding b
let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b
let to_b58check v = Base58.safe_encode (Bytes.to_string (to_bytes v))
let of_b58check b =
Option.apply (Base58.safe_decode b) ~f:(fun s ->
Data_encoding.Binary.of_bytes encoding (Bytes.of_string s))
let hash block = Block_hash.hash_bytes [to_bytes block]
let hash_raw bytes = Block_hash.hash_bytes [bytes]
let forced_protocol_upgrades : (Int32.t * Protocol_hash.t) list =
[ (* nothing *) ]
let voted_protocol_overrides : (Protocol_hash.t * Protocol_hash.t) list =
List.map
(fun (a, b) ->
(Protocol_hash.of_b58check_exn a, Protocol_hash.of_b58check_exn b))
[ (* nothing *) ]
module LevelMap = Map.Make (struct
type t = Int32.t
let compare = Int32.compare
end)
let get_forced_protocol_upgrade =
let table =
List.fold_left
(fun map (level, hash) -> LevelMap.add level hash map)
LevelMap.empty
forced_protocol_upgrades
in
fun ~level -> LevelMap.find_opt level table
let get_voted_protocol_overrides proto_hash =
List.assoc_opt proto_hash voted_protocol_overrides
let () =
Data_encoding.Registration.register shell_header_encoding ;
Data_encoding.Registration.register encoding
src/lib_base/block_header.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record shell_header := {
level : Stdlib.Int32.t;
proto_level : Z;
predecessor : Tezos_crypto.Block_hash.t;
timestamp : Tezos_base.Time.Protocol.t;
validation_passes : Z;
operations_hash : Tezos_crypto.Operation_list_list_hash.t;
fitness : Tezos_base.Fitness.t;
context : Tezos_crypto.Context_hash.t }.
Definition shell_header_encoding
: Tezos_data_encoding.Data_encoding.encoding shell_header :=
apply
(def "block_header.shell" % string (Some "Shell header" % string)
(Some
"Block header's shell-related content. It contains information such as the block level, its predecessor and timestamp."
% string))
(conv
(fun function_parameter =>
let '{|
level := level;
proto_level := proto_level;
predecessor := predecessor;
timestamp := timestamp;
validation_passes := validation_passes;
operations_hash := operations_hash;
fitness := fitness;
context := context
|} := function_parameter in
(level, proto_level, predecessor, timestamp, validation_passes,
operations_hash, fitness, context))
(fun function_parameter =>
let
'(level, proto_level, predecessor, timestamp, validation_passes,
operations_hash, fitness, context) := function_parameter in
{| level := level; proto_level := proto_level;
predecessor := predecessor; timestamp := timestamp;
validation_passes := validation_passes;
operations_hash := operations_hash; fitness := fitness;
context := context |}) None
(obj8 (req None None "level" % string int32)
(req None None "proto" % string uint8)
(req None None "predecessor" % string Block_hash.encoding)
(req None None "timestamp" % string Time.Protocol.encoding)
(req None None "validation_pass" % string uint8)
(req None None "operations_hash" % string
Operation_list_list_hash.encoding)
(req None None "fitness" % string Fitness.encoding)
(req None None "context" % string Context_hash.encoding))).
Record t := {
shell : shell_header;
protocol_data : Stdlib.Bytes.t }.
(* ❌ Structure item `include` not handled. *)
include
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(def "block_header" % string (Some "Block header" % string)
(Some
"Block header. It contains both shell and protocol specific data." %
string))
(conv
(fun function_parameter =>
let '{| shell := shell; protocol_data := protocol_data |} :=
function_parameter in
(shell, protocol_data))
(fun function_parameter =>
let '(shell, protocol_data) := function_parameter in
{| shell := shell; protocol_data := protocol_data |}) None
(merge_objs shell_header_encoding
(obj1 (req None None "protocol_data" % string Variable.bytes)))).
Definition bounded_encoding (max_size : option Z) (function_parameter : unit)
: Tezos_data_encoding.Data_encoding.encoding t :=
let 'tt := function_parameter in
match max_size with
| None => encoding
| Some max_size => Data_encoding.check_size max_size encoding
end.
Definition pp (ppf : Stdlib.Format.formatter) (op : t) : unit :=
Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding op).
Definition to_bytes (v : t) : Stdlib.Bytes.t :=
Data_encoding.Binary.to_bytes_exn encoding v.
Definition of_bytes (b : Stdlib.Bytes.t) : option t :=
Data_encoding.Binary.of_bytes encoding b.
Definition of_bytes_exn (b : Stdlib.Bytes.t) : t :=
Data_encoding.Binary.of_bytes_exn encoding b.
Definition to_b58check (v : t) : string :=
Base58.safe_encode None (Stdlib.Bytes.to_string (to_bytes v)).
Definition of_b58check (b : string) : option t :=
Option.apply
(fun s => Data_encoding.Binary.of_bytes encoding (Stdlib.Bytes.of_string s))
(Base58.safe_decode None b).
Definition hash (block : t) : Tezos_crypto.Block_hash.t :=
Block_hash.hash_bytes None (cons (to_bytes block) []).
Definition hash_raw (bytes : Stdlib.Bytes.t) : Tezos_crypto.Block_hash.t :=
Block_hash.hash_bytes None (cons string []).
Definition forced_protocol_upgrades
: list (Stdlib.Int32.t * Tezos_crypto.Protocol_hash.t) := [].
Definition voted_protocol_overrides
: list (Tezos_crypto.Protocol_hash.t * Tezos_crypto.Protocol_hash.t) :=
List.map
(fun function_parameter =>
let '(a, b) := function_parameter in
((Protocol_hash.of_b58check_exn a), (Protocol_hash.of_b58check_exn b))) [].
(* ❌ Applications of functors are not handled. *)
functor_application
Definition get_forced_protocol_upgrade
: LevelMap.key -> option Tezos_crypto.Protocol_hash.t :=
let table :=
Stdlib.List.fold_left
(fun map =>
fun function_parameter =>
let '(level, hash) := function_parameter in
LevelMap.add level hash map) LevelMap.empty forced_protocol_upgrades
in
fun level => LevelMap.find_opt level table.
Definition get_voted_protocol_overrides
(proto_hash : Tezos_crypto.Protocol_hash.t)
: option Tezos_crypto.Protocol_hash.t :=
Stdlib.List.assoc_opt proto_hash voted_protocol_overrides.
src/lib_base/block_locator.ml 7 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Lwt.Infix
type t = raw
and raw = Block_header.t * Block_hash.t list
let raw x = x
let pp ppf (hd, h_lst) =
let repeats = 10 in
let coef = 2 in
(* list of hashes *)
let rec pp_hash_list ppf (h_lst, acc, d, r) =
match h_lst with
| [] ->
Format.fprintf ppf ""
| hd :: tl ->
let new_d = if r > 1 then d else d * coef in
let new_r = if r > 1 then r - 1 else repeats in
Format.fprintf
ppf
"%a (%i)\n%a"
Block_hash.pp
hd
acc
pp_hash_list
(tl, acc - d, new_d, new_r)
in
Format.fprintf
ppf
"%a (head)\n%a"
Block_hash.pp
(Block_header.hash hd)
pp_hash_list
(h_lst, -1, 1, repeats - 1)
let pp_short ppf (hd, h_lst) =
Format.fprintf
ppf
"head: %a, %d predecessors"
Block_hash.pp
(Block_header.hash hd)
(List.length h_lst)
let encoding =
let open Data_encoding in
def "block_locator" ~description:"A sparse block locator à la Bitcoin"
@@ obj2
(req "current_head" (dynamic_size Block_header.encoding))
(req "history" (Variable.list Block_hash.encoding))
let bounded_encoding ?max_header_size ?max_length () =
let open Data_encoding in
obj2
(req
"current_head"
(dynamic_size
(Block_header.bounded_encoding ?max_size:max_header_size ())))
(req "history" (Variable.list ?max_length Block_hash.encoding))
type seed = {sender_id : P2p_peer.Id.t; receiver_id : P2p_peer.Id.t}
(* Random generator for locator steps.
We draw steps by sequence of 10. The first sequence's steps are of
length 1 (consecutive). The second sequence's steps are of a random
length between 1 and 2. The third sequence's steps are of a random
length between 2 and 4, and so on...
The sequence is deterministic for a given triple of sender,
receiver and block hash. *)
module Step : sig
type state
val init : seed -> Block_hash.t -> state
val next : state -> int * state
end = struct
(* (step, counter, seed) .
The seed is stored in a bigstring and should be mlocked *)
type state = Int32.t * int * Bigstring.t
let update st b = Hacl.Hash.SHA256.update st (Bigstring.of_bytes b)
let init seed head =
let open Hacl.Hash in
let st = SHA256.init () in
List.iter
(update st)
[ P2p_peer.Id.to_bytes seed.sender_id;
P2p_peer.Id.to_bytes seed.receiver_id;
Block_hash.to_bytes head ] ;
(1l, 9, SHA256.finish st)
let draw seed n =
( Int32.rem (TzEndian.get_int32 (Bigstring.to_bytes seed) 0) n,
Hacl.Hash.SHA256.digest seed )
let next (step, counter, seed) =
let (random_gap, seed) =
if step <= 1l then (0l, seed)
else draw seed (Int32.succ (Int32.div step 2l))
in
let new_state =
if counter = 0 then (Int32.mul step 2l, 9, seed)
else (step, counter - 1, seed)
in
(Int32.to_int (Int32.sub step random_gap), new_state)
end
let estimated_length seed (head, hist) =
let rec loop acc state = function
| [] ->
acc
| _ :: hist ->
let (step, state) = Step.next state in
loop (acc + step) state hist
in
let state = Step.init seed (Block_header.hash head) in
let (step, state) = Step.next state in
loop step state hist
let fold ~f ~init (head, hist) seed =
let rec loop state acc = function
| [] | [_] ->
acc
| block :: (pred :: rem as hist) ->
let (step, state) = Step.next state in
let acc = f acc ~block ~pred ~step ~strict_step:(rem <> []) in
loop state acc hist
in
let head = Block_header.hash head in
let state = Step.init seed head in
loop state init (head :: hist)
type step = {
block : Block_hash.t;
predecessor : Block_hash.t;
step : int;
strict_step : bool;
}
let pp_step ppf step =
Format.fprintf ppf "%d%s" step.step (if step.strict_step then "" else " max")
let to_steps seed locator =
fold locator seed ~init:[] ~f:(fun acc ~block ~pred ~step ~strict_step ->
{block; predecessor = pred; step; strict_step} :: acc)
let fold_truncate ~f ~init ~save_point ~limit (head, hist) seed =
let rec loop state step_sum acc = function
| [] | [_] ->
acc
| block :: (pred :: rem as hist) ->
let (step, state) = Step.next state in
let new_step_sum = step + step_sum in
if new_step_sum >= limit then
f acc ~block ~pred:save_point ~step ~strict_step:false
else
let acc = f acc ~block ~pred ~step ~strict_step:(rem <> []) in
loop state new_step_sum acc hist
in
let hash = Block_header.hash head in
let initial_state = Step.init seed hash in
loop initial_state 0 init (hash :: hist)
let to_steps_truncate ~limit ~save_point seed locator =
fold_truncate
locator
seed
~init:[]
~save_point
~limit
~f:(fun acc ~block ~pred ~step ~strict_step ->
{block; predecessor = pred; step; strict_step} :: acc)
let compute ~get_predecessor ~caboose ~size block_hash header seed =
let rec loop acc size state current_block_hash =
if size = 0 then Lwt.return acc
else
let (step, state) = Step.next state in
get_predecessor current_block_hash step
>>= function
| None ->
if Block_hash.equal caboose current_block_hash then Lwt.return acc
else Lwt.return (caboose :: acc)
| Some predecessor ->
loop (predecessor :: acc) (pred size) state predecessor
in
if size <= 0 then Lwt.return (header, [])
else
let initial_state = Step.init seed block_hash in
loop [] size initial_state block_hash
>>= fun hist -> Lwt.return (header, List.rev hist)
type validity = Unknown | Known_valid | Known_invalid
let unknown_prefix ~is_known locator =
let (head, history) = locator in
let rec loop hist acc =
match hist with
| [] ->
Lwt.return (Unknown, locator)
| h :: t -> (
is_known h
>>= function
| Known_valid ->
Lwt.return (Known_valid, (head, List.rev (h :: acc)))
| Known_invalid ->
Lwt.return (Known_invalid, (head, List.rev (h :: acc)))
| Unknown ->
loop t (h :: acc) )
in
is_known (Block_header.hash head)
>>= function
| Known_valid ->
Lwt.return (Known_valid, (head, []))
| Known_invalid ->
Lwt.return (Known_invalid, (head, []))
| Unknown ->
loop history []
let () = Data_encoding.Registration.register ~pp:pp_short encoding
src/lib_base/block_locator.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
Reserved Notation "'t".
Reserved Notation "'raw".
where "'t" := ( 'raw)
and "'raw" := ( Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)).
Definition t := 't.
Definition raw := 'raw.
Definition raw {A : Type} (x : A) : A := x.
Definition pp
(ppf : Stdlib.Format.formatter)
(function_parameter :
Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) : unit :=
let '(hd, h_lst) := function_parameter in
let repeats := 10 in
let coef := 2 in
let fix pp_hash_list
(ppf : Stdlib.Format.formatter) (function_parameter :
(list Tezos_crypto.Block_hash.t) * Z * Z * Z) : unit :=
let '(h_lst, acc, d, r) := function_parameter in
match h_lst with
| [] =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format CamlinternalFormatBasics.End_of_format
"" % string)
| cons hd tl =>
let new_d :=
if OCaml.Stdlib.gt r 1 then
d
else
Z.mul d coef in
let new_r :=
if OCaml.Stdlib.gt r 1 then
Z.sub r 1
else
repeats in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ")
" % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))))
"%a (%i)
%a" % string) Block_hash.pp hd acc pp_hash_list
(tl, (Z.sub acc d), new_d, new_r)
end in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (head)
" % string
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)))
"%a (head)
%a" % string) Block_hash.pp (Block_header.hash hd) pp_hash_list
(h_lst, (-1), 1, (Z.sub repeats 1)).
Definition pp_short {A : Type}
(ppf : Stdlib.Format.formatter)
(function_parameter : Tezos_base.Block_header.t * (list A)) : unit :=
let '(hd, h_lst) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "head: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ", " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " predecessors" % string
CamlinternalFormatBasics.End_of_format)))))
"head: %a, %d predecessors" % string) Block_hash.pp (Block_header.hash hd)
(OCaml.List.length h_lst).
Definition encoding
: Tezos_data_encoding.Data_encoding.encoding
(Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) :=
apply
(let arg :=
def "block_locator" % string
(* ❌ expected an argument *)
expected_argument (Some "A sparse block locator à la Bitcoin" % string)
in
fun eta => arg None eta)
(obj2
(req None None "current_head" % string
(dynamic_size None Block_header.encoding))
(req None None "history" % string (Variable.list None Block_hash.encoding))).
Definition bounded_encoding
(max_header_size : option Z) (max_length : option Z)
(function_parameter : unit)
: Tezos_data_encoding.Data_encoding.encoding
(Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) :=
let 'tt := function_parameter in
obj2
(req None None "current_head" % string
(dynamic_size None (Block_header.bounded_encoding max_header_size tt)))
(req None None "history" % string
(Variable.list max_length Block_hash.encoding)).
Record seed := {
sender_id : Tezos_base.P2p_peer.Id.t;
receiver_id : Tezos_base.P2p_peer.Id.t }.
Module Step.
Definition state := Stdlib.Int32.t * Z * Bigstring.t.
Definition update
(st : Hacl.Hash.SHA256.(Hacl.S.Hash.state)) (b : Stdlib.Bytes.t) : unit :=
Hacl.Hash.SHA256.(Hacl.S.Hash.update) st (Bigstring.of_bytes b).
Definition init (seed : seed) (head : Tezos_crypto.Block_hash.t)
: int32 * Z * Bigstring.t :=
let st := Hacl.Hash.SHA256.(Hacl.Hash.S.init) tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.List.iter (update st)
(cons (P2p_peer.Id.to_bytes (sender_id seed))
(cons (P2p_peer.Id.to_bytes (receiver_id seed))
(cons (Block_hash.to_bytes head) []))) in
((* ❌ Constant of type int32 is converted to int *)
1, 9, (Hacl.Hash.SHA256.(Hacl.Hash.S.finish) st)).
Definition draw (seed : Bigstring.t) (n : int32) : int32 * Bigstring.t :=
((Int32.rem (TzEndian.get_int32 (Bigstring.to_bytes seed) 0) n),
(Hacl.Hash.SHA256.(Hacl.S.Hash.digest) seed)).
Definition next (function_parameter : int32 * Z * Bigstring.t)
: Z * (int32 * Z * Bigstring.t) :=
let '(step, counter, seed) := function_parameter in
let '(random_gap, seed) :=
if
OCaml.Stdlib.le step
(* ❌ Constant of type int32 is converted to int *)
1 then
((* ❌ Constant of type int32 is converted to int *)
0, seed)
else
draw seed
(Int32.succ
(Int32.div step
(* ❌ Constant of type int32 is converted to int *)
2)) in
let new_state :=
if equiv_decb counter 0 then
((Int32.mul step
(* ❌ Constant of type int32 is converted to int *)
2), 9, seed)
else
(step, (Z.sub counter 1), seed) in
((Int32.to_int (Int32.sub step random_gap)), new_state).
End Step.
Definition estimated_length {A : Type}
(seed : seed) (function_parameter : Tezos_base.Block_header.t * (list A))
: Z :=
let '(head, hist) := function_parameter in
let fix loop {B : Type}
(acc : Z) (state : Step.state) (function_parameter : list B) : Z :=
match function_parameter with
| [] => acc
| cons _ hist =>
let '(step, state) := Step.next state in
loop (Z.add acc step) state hist
end in
let state := Step.init seed (Block_header.hash head) in
let '(step, state) := Step.next state in
loop step state hist.
Definition fold {A : Type}
(f :
A ->
Tezos_crypto.Block_hash.t -> Tezos_crypto.Block_hash.t -> Z -> bool -> A)
(init : A)
(function_parameter :
Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) : seed -> A :=
let '(head, hist) := function_parameter in
fun seed =>
let fix loop
(state : Step.state) (acc : A) (function_parameter :
list Tezos_crypto.Block_hash.t) : A :=
match function_parameter with
| [] | cons _ [] => acc
| cons block ((cons pred rem) as hist) =>
let '(step, state) := Step.next state in
let acc := f acc block pred step (nequiv_decb rem []) in
loop state acc hist
end in
let head := Block_header.hash head in
let state := Step.init seed head in
loop state init (cons head hist).
Record step := {
block : Tezos_crypto.Block_hash.t;
predecessor : Tezos_crypto.Block_hash.t;
step : Z;
strict_step : bool }.
Definition pp_step (ppf : Stdlib.Format.formatter) (step : step) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "%d%s" % string) (step step)
(if strict_step step then
"" % string
else
" max" % string).
Definition to_steps
(seed : seed)
(locator : Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))
: list step :=
fold
(fun acc =>
fun block =>
fun pred =>
fun step =>
fun strict_step =>
cons
{| block := block; predecessor := pred; step := step;
strict_step := strict_step |} acc) [] locator seed.
Definition fold_truncate {A : Type}
(f :
A ->
Tezos_crypto.Block_hash.t -> Tezos_crypto.Block_hash.t -> Z -> bool -> A)
(init : A) (save_point : Tezos_crypto.Block_hash.t) (limit : Z)
(function_parameter :
Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) : seed -> A :=
let '(head, hist) := function_parameter in
fun seed =>
let fix loop
(state : Step.state) (step_sum : Z) (acc : A) (function_parameter :
list Tezos_crypto.Block_hash.t) : A :=
match function_parameter with
| [] | cons _ [] => acc
| cons block ((cons pred rem) as hist) =>
let '(step, state) := Step.next state in
let new_step_sum := Z.add step step_sum in
if OCaml.Stdlib.ge new_step_sum limit then
f acc block save_point step false
else
let acc := f acc block pred step (nequiv_decb rem []) in
loop state new_step_sum acc hist
end in
let hash := Block_header.hash head in
let initial_state := Step.init seed hash in
loop initial_state 0 init (cons hash hist).
Definition to_steps_truncate
(limit : Z) (save_point : Tezos_crypto.Block_hash.t) (seed : seed)
(locator : Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))
: list step :=
fold_truncate
(fun acc =>
fun block =>
fun pred =>
fun step =>
fun strict_step =>
cons
{| block := block; predecessor := pred; step := step;
strict_step := strict_step |} acc) [] save_point limit locator
seed.
Definition compute {A : Type}
(get_predecessor :
Tezos_crypto.Block_hash.t -> Z -> Lwt.t (option Tezos_crypto.Block_hash.t))
(caboose : Tezos_crypto.Block_hash.t) (size : Z)
(block_hash : Tezos_crypto.Block_hash.t) (header : A) (seed : seed)
: Lwt.t (A * (list Tezos_crypto.Block_hash.t)) :=
let fix loop
(acc : list Tezos_crypto.Block_hash.t) (size : Z) (state : Step.state)
(current_block_hash : Tezos_crypto.Block_hash.t)
: Lwt.t (list Tezos_crypto.Block_hash.t) :=
if equiv_decb size 0 then
Lwt._return acc
else
let '(step, state) := Step.next state in
op_gtgteq (get_predecessor current_block_hash step)
(fun function_parameter =>
match function_parameter with
| None =>
if Block_hash.equal caboose current_block_hash then
Lwt._return acc
else
Lwt._return (cons caboose acc)
| Some predecessor =>
loop (cons predecessor acc) (Z.pred size) state predecessor
end) in
if OCaml.Stdlib.le size 0 then
Lwt._return (header, [])
else
let initial_state := Step.init seed block_hash in
op_gtgteq (loop [] size initial_state block_hash)
(fun hist => Lwt._return (header, (List.rev hist))).
Inductive validity : Type :=
| Unknown : validity
| Known_valid : validity
| Known_invalid : validity.
Definition unknown_prefix
(is_known : Tezos_crypto.Block_hash.t -> Lwt.t validity)
(locator : Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))
: Lwt.t
(validity * (Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))) :=
let '(head, history) := locator in
let fix loop
(hist : list Tezos_crypto.Block_hash.t) (acc :
list Tezos_crypto.Block_hash.t)
: Lwt.t
(validity * (Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))) :=
match hist with
| [] => Lwt._return (Unknown, locator)
| cons h t =>
op_gtgteq (is_known h)
(fun function_parameter =>
match function_parameter with
| Known_valid =>
Lwt._return (Known_valid, (head, (List.rev (cons h acc))))
| Known_invalid =>
Lwt._return (Known_invalid, (head, (List.rev (cons h acc))))
| Unknown => loop t (cons h acc)
end)
end in
op_gtgteq (is_known (Block_header.hash head))
(fun function_parameter =>
match function_parameter with
| Known_valid => Lwt._return (Known_valid, (head, []))
| Known_invalid => Lwt._return (Known_invalid, (head, []))
| Unknown => loop history []
end).
src/lib_base/distributed_db_version.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Distributed_db protocol version. *)
type name = string
let pp_name = Format.pp_print_string
let name_encoding =
let open Data_encoding in
def
"distributed_db_version.name"
~description:"A name for the distributed DB protocol"
string
let chain_name = "TEZOS"
let sandboxed_chain_name = "SANDBOXED_TEZOS"
type t = int
let pp = Format.pp_print_int
let encoding =
let open Data_encoding in
def
"distributed_db_version"
~description:"A version number for the distributed DB protocol"
uint16
let zero = 0
let () =
Data_encoding.Registration.register ~pp:pp_name name_encoding ;
Data_encoding.Registration.register ~pp encoding
src/lib_base/distributed_db_version.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition name := string.
Definition pp_name : Stdlib.Format.formatter -> string -> unit :=
Format.pp_print_string.
Definition name_encoding : Tezos_data_encoding.Data_encoding.encoding string :=
def "distributed_db_version.name" % string None
(Some "A name for the distributed DB protocol" % string) string.
Definition chain_name : string := "TEZOS" % string.
Definition sandboxed_chain_name : string := "SANDBOXED_TEZOS" % string.
Definition t := Z.
Definition pp : Stdlib.Format.formatter -> Z -> unit := Format.pp_print_int.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding Z :=
def "distributed_db_version" % string None
(Some "A version number for the distributed DB protocol" % string) uint16.
Definition zero : Z := 0.
src/lib_base/fitness.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = Bytes.t list
include Compare.Make (struct
type nonrec t = t
(* Fitness comparison:
- shortest lists are smaller ;
- lexicographical order for lists of the same length. *)
let compare_bytes b1 b2 =
let len1 = Bytes.length b1 in
let len2 = Bytes.length b2 in
let c = compare len1 len2 in
if c <> 0 then c
else
let rec compare_byte b1 b2 pos len =
if pos = len then 0
else
let c = compare (Bytes.get b1 pos) (Bytes.get b2 pos) in
if c <> 0 then c else compare_byte b1 b2 (pos + 1) len
in
compare_byte b1 b2 0 len1
let compare f1 f2 =
let rec compare_rec f1 f2 =
match (f1, f2) with
| ([], []) ->
0
| (i1 :: f1, i2 :: f2) ->
let i = compare_bytes i1 i2 in
if i = 0 then compare_rec f1 f2 else i
| (_, _) ->
assert false
in
let len = compare (List.length f1) (List.length f2) in
if len = 0 then compare_rec f1 f2 else len
end)
let rec pp fmt = function
| [] ->
()
| [f] ->
Format.fprintf fmt "%a" Hex.pp (Hex.of_bytes f)
| f1 :: f ->
Format.fprintf fmt "%a::%a" Hex.pp (Hex.of_bytes f1) pp f
let encoding =
let open Data_encoding in
def
"fitness"
~title:"Block fitness"
~description:
"The fitness, or score, of a block, that allow the Tezos to decide \
which chain is the best. A fitness value is a list of byte sequences. \
They are compared as follows: shortest lists are smaller; lists of the \
same length are compared according to the lexicographical order."
@@ splitted ~json:(list bytes) ~binary:(list (def "fitness.elem" bytes))
let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v
let of_bytes b = Data_encoding.Binary.of_bytes encoding b
src/lib_base/fitness.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := list Stdlib.Bytes.t.
(* ❌ Structure item `include` not handled. *)
include
Fixpoint pp (fmt : Stdlib.Format.formatter) (function_parameter : list string)
: unit :=
match function_parameter with
| [] => tt
| cons f [] =>
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) Hex.pp (Hex.of_bytes None f)
| cons f1 f =>
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "::" % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))) "%a::%a" % string)
Hex.pp (Hex.of_bytes None f1) pp f
end.
Definition encoding
: Tezos_data_encoding.Data_encoding.encoding (list Stdlib.Bytes.t) :=
apply
(def "fitness" % string (Some "Block fitness" % string)
(Some
"The fitness, or score, of a block, that allow the Tezos to decide which chain is the best. A fitness value is a list of byte sequences. They are compared as follows: shortest lists are smaller; lists of the same length are compared according to the lexicographical order."
% string))
(splitted (list None bytes)
(list None (def "fitness.elem" % string None None bytes))).
Definition to_bytes (v : list Stdlib.Bytes.t) : Stdlib.Bytes.t :=
Data_encoding.Binary.to_bytes_exn encoding v.
Definition of_bytes (b : Stdlib.Bytes.t) : option (list Stdlib.Bytes.t) :=
Data_encoding.Binary.of_bytes encoding b.
src/lib_base/mempool.ml 5 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {known_valid : Operation_hash.t list; pending : Operation_hash.Set.t}
type mempool = t
let encoding =
let open Data_encoding in
def
"mempool"
~description:
"A batch of operation. This format is used to gossip operations between \
peers."
@@ conv
(fun {known_valid; pending} -> (known_valid, pending))
(fun (known_valid, pending) -> {known_valid; pending})
(obj2
(req "known_valid" (list Operation_hash.encoding))
(req "pending" (dynamic_size Operation_hash.Set.encoding)))
let bounded_encoding ?max_operations () =
match max_operations with
| None ->
encoding
| Some max_operations ->
Data_encoding.check_size
(8 + (max_operations * Operation_hash.size))
encoding
let empty = {known_valid = []; pending = Operation_hash.Set.empty}
let () = Data_encoding.Registration.register encoding
src/lib_base/mempool.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record t := {
known_valid : list Tezos_crypto.Operation_hash.t;
pending : Tezos_crypto.Operation_hash.Set.t }.
Definition mempool := t.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "mempool" % string
(* ❌ expected an argument *)
expected_argument
(Some
"A batch of operation. This format is used to gossip operations between peers."
% string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{| known_valid := known_valid; pending := pending |} :=
function_parameter in
(known_valid, pending))
(fun function_parameter =>
let '(known_valid, pending) := function_parameter in
{| known_valid := known_valid; pending := pending |}) None
(obj2
(req None None "known_valid" % string
(list None Operation_hash.encoding))
(req None None "pending" % string
(dynamic_size None Operation_hash.Set.encoding)))).
Definition bounded_encoding
(max_operations : option Z) (function_parameter : unit)
: Tezos_data_encoding.Data_encoding.encoding t :=
let 'tt := function_parameter in
match max_operations with
| None => encoding
| Some max_operations =>
Data_encoding.check_size
(Z.add 8 (Z.mul max_operations Operation_hash.size)) encoding
end.
Definition empty : t :=
{| known_valid := []; pending := Operation_hash.Set.empty |}.
src/lib_base/network_version.ml 10 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {
chain_name : Distributed_db_version.name;
distributed_db_version : Distributed_db_version.t;
p2p_version : P2p_version.t;
}
let pp ppf {chain_name; distributed_db_version; p2p_version} =
Format.fprintf
ppf
"%a.%a (p2p: %a)"
Distributed_db_version.pp_name
chain_name
Distributed_db_version.pp
distributed_db_version
P2p_version.pp
p2p_version
let encoding =
let open Data_encoding in
def
"network_version"
~description:
"A version number for the network protocol (includes distributed DB \
version and p2p version)"
@@ conv
(fun {chain_name; distributed_db_version; p2p_version} ->
(chain_name, distributed_db_version, p2p_version))
(fun (chain_name, distributed_db_version, p2p_version) ->
{chain_name; distributed_db_version; p2p_version})
(obj3
(req "chain_name" Distributed_db_version.name_encoding)
(req "distributed_db_version" Distributed_db_version.encoding)
(req "p2p_version" P2p_version.encoding))
let greatest = function
| [] ->
raise (Invalid_argument "Network_version.greatest")
| h :: t ->
List.fold_left max h t
let announced ~chain_name ~distributed_db_versions ~p2p_versions =
assert (distributed_db_versions <> []) ;
assert (p2p_versions <> []) ;
{
chain_name;
distributed_db_version = greatest distributed_db_versions;
p2p_version = greatest p2p_versions;
}
let may_select_version accepted_versions remote_version =
let best_local_version = greatest accepted_versions in
if best_local_version <= remote_version then Some best_local_version
else if List.mem remote_version accepted_versions then Some remote_version
else None
let select ~chain_name ~distributed_db_versions ~p2p_versions remote =
assert (distributed_db_versions <> []) ;
assert (p2p_versions <> []) ;
if chain_name <> remote.chain_name then None
else
let open Option in
may_select_version distributed_db_versions remote.distributed_db_version
>>= fun distributed_db_version ->
may_select_version p2p_versions remote.p2p_version
>>= fun p2p_version ->
some {chain_name; distributed_db_version; p2p_version}
let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/network_version.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record t := {
chain_name : Tezos_base.Distributed_db_version.name;
distributed_db_version : Tezos_base.Distributed_db_version.t;
p2p_version : Tezos_base.P2p_version.t }.
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
let '{|
chain_name := chain_name;
distributed_db_version := distributed_db_version;
p2p_version := p2p_version
|} := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (p2p: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))))
"%a.%a (p2p: %a)" % string) Distributed_db_version.pp_name chain_name
Distributed_db_version.pp distributed_db_version P2p_version.pp p2p_version.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "network_version" % string
(* ❌ expected an argument *)
expected_argument
(Some
"A version number for the network protocol (includes distributed DB version and p2p version)"
% string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{|
chain_name := chain_name;
distributed_db_version := distributed_db_version;
p2p_version := p2p_version
|} := function_parameter in
(chain_name, distributed_db_version, p2p_version))
(fun function_parameter =>
let '(chain_name, distributed_db_version, p2p_version) :=
function_parameter in
{| chain_name := chain_name;
distributed_db_version := distributed_db_version;
p2p_version := p2p_version |}) None
(obj3
(req None None "chain_name" % string
Distributed_db_version.name_encoding)
(req None None "distributed_db_version" % string
Distributed_db_version.encoding)
(req None None "p2p_version" % string P2p_version.encoding))).
Definition greatest {A : Type} (function_parameter : list A) : A :=
match function_parameter with
| [] =>
Stdlib.raise (OCaml.Invalid_argument "Network_version.greatest" % string)
| cons h t => Stdlib.List.fold_left OCaml.Stdlib.max h t
end.
Definition announced
(chain_name : Tezos_base.Distributed_db_version.name)
(distributed_db_versions : list Tezos_base.Distributed_db_version.t)
(p2p_versions : list Tezos_base.P2p_version.t) : t :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (nequiv_decb distributed_db_versions []) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (nequiv_decb p2p_versions []) in
{| chain_name := chain_name;
distributed_db_version := greatest distributed_db_versions;
p2p_version := greatest p2p_versions |}.
Definition may_select_version {A : Type}
(accepted_versions : list A) (remote_version : A) : option A :=
let best_local_version := greatest accepted_versions in
if OCaml.Stdlib.le best_local_version remote_version then
Some best_local_version
else
if Stdlib.List.mem remote_version accepted_versions then
Some remote_version
else
None.
Definition select
(chain_name : Tezos_base.Distributed_db_version.name)
(distributed_db_versions : list Tezos_base.Distributed_db_version.t)
(p2p_versions : list Tezos_base.P2p_version.t) (remote : t) : option t :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (nequiv_decb distributed_db_versions []) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (nequiv_decb p2p_versions []) in
if nequiv_decb chain_name (chain_name remote) then
None
else
op_gtgteq
(may_select_version distributed_db_versions
(distributed_db_version remote))
(fun distributed_db_version =>
op_gtgteq (may_select_version p2p_versions (p2p_version remote))
(fun p2p_version =>
some
{| chain_name := chain_name;
distributed_db_version := distributed_db_version;
p2p_version := p2p_version |})).
src/lib_base/operation.ml 13 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type shell_header = {branch : Block_hash.t}
let shell_header_encoding =
let open Data_encoding in
def "operation.shell_header" ~description:"An operation's shell header."
@@ conv
(fun {branch} -> branch)
(fun branch -> {branch})
(obj1 (req "branch" Block_hash.encoding))
type t = {shell : shell_header; proto : Bytes.t}
include Compare.Make (struct
type nonrec t = t
let compare o1 o2 =
let ( >> ) x y = if x = 0 then y () else x in
Block_hash.compare o1.shell.branch o1.shell.branch
>> fun () -> Bytes.compare o1.proto o2.proto
end)
let encoding =
let open Data_encoding in
def
"operation"
~description:
"An operation. The shell_header part indicates a block an operation is \
meant to apply on top of. The proto part is protocol-specific and \
appears as a binary blob."
@@ conv
(fun {shell; proto} -> (shell, proto))
(fun (shell, proto) -> {shell; proto})
(merge_objs shell_header_encoding (obj1 (req "data" Variable.bytes)))
let bounded_encoding ?max_size () =
match max_size with
| None ->
encoding
| Some max_size ->
Data_encoding.check_size max_size encoding
let bounded_list_encoding ?max_length ?max_size ?max_operation_size ?max_pass
() =
let open Data_encoding in
let op_encoding = bounded_encoding ?max_size:max_operation_size () in
let op_list_encoding =
match max_size with
| None ->
Variable.list ?max_length (dynamic_size op_encoding)
| Some max_size ->
check_size
max_size
(Variable.list ?max_length (dynamic_size op_encoding))
in
obj2
(req
"operation_hashes_path"
(Operation_list_list_hash.bounded_path_encoding ?max_length:max_pass ()))
(req "operations" op_list_encoding)
let bounded_hash_list_encoding ?max_length ?max_pass () =
let open Data_encoding in
obj2
(req
"operation_hashes_path"
(Operation_list_list_hash.bounded_path_encoding ?max_length:max_pass ()))
(req "operation_hashes" (Variable.list ?max_length Operation_hash.encoding))
let pp fmt op =
Data_encoding.Json.pp fmt (Data_encoding.Json.construct encoding op)
let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v
let of_bytes b = Data_encoding.Binary.of_bytes encoding b
let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b
let hash op = Operation_hash.hash_bytes [to_bytes op]
let hash_raw bytes = Operation_hash.hash_bytes [bytes]
let () =
Data_encoding.Registration.register ~pp encoding ;
Data_encoding.Registration.register shell_header_encoding
src/lib_base/operation.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record shell_header := {
branch : Tezos_crypto.Block_hash.t }.
Definition shell_header_encoding
: Tezos_data_encoding.Data_encoding.encoding shell_header :=
apply
(let arg :=
def "operation.shell_header" % string
(* ❌ expected an argument *)
expected_argument (Some "An operation's shell header." % string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{| branch := branch |} := function_parameter in
branch) (fun branch => {| branch := branch |}) None
(obj1 (req None None "branch" % string Block_hash.encoding))).
Record t := {
shell : shell_header;
proto : Stdlib.Bytes.t }.
(* ❌ Structure item `include` not handled. *)
include
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "operation" % string
(* ❌ expected an argument *)
expected_argument
(Some
"An operation. The shell_header part indicates a block an operation is meant to apply on top of. The proto part is protocol-specific and appears as a binary blob."
% string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{| shell := shell; proto := proto |} := function_parameter in
(shell, proto))
(fun function_parameter =>
let '(shell, proto) := function_parameter in
{| shell := shell; proto := proto |}) None
(merge_objs shell_header_encoding
(obj1 (req None None "data" % string Variable.bytes)))).
Definition bounded_encoding (max_size : option Z) (function_parameter : unit)
: Tezos_data_encoding.Data_encoding.encoding t :=
let 'tt := function_parameter in
match max_size with
| None => encoding
| Some max_size => Data_encoding.check_size max_size encoding
end.
Definition bounded_list_encoding
(max_length : option Z) (max_size : option Z) (max_operation_size : option Z)
(max_pass : option Z) (function_parameter : unit)
: Tezos_data_encoding.Data_encoding.encoding
(Tezos_crypto.Operation_list_list_hash.path * (list t)) :=
let 'tt := function_parameter in
let op_encoding := bounded_encoding max_operation_size tt in
let op_list_encoding :=
match max_size with
| None => Variable.list max_length (dynamic_size None op_encoding)
| Some max_size =>
check_size max_size
(Variable.list max_length (dynamic_size None op_encoding))
end in
obj2
(req None None "operation_hashes_path" % string
(Operation_list_list_hash.bounded_path_encoding max_pass tt))
(req None None "operations" % string op_list_encoding).
Definition bounded_hash_list_encoding
(max_length : option Z) (max_pass : option Z) (function_parameter : unit)
: Tezos_data_encoding.Data_encoding.encoding
(Tezos_crypto.Operation_list_list_hash.path *
(list Tezos_crypto.Operation_hash.t)) :=
let 'tt := function_parameter in
obj2
(req None None "operation_hashes_path" % string
(Operation_list_list_hash.bounded_path_encoding max_pass tt))
(req None None "operation_hashes" % string
(Variable.list max_length Operation_hash.encoding)).
Definition pp (fmt : Stdlib.Format.formatter) (op : t) : unit :=
Data_encoding.Json.pp fmt (Data_encoding.Json.construct encoding op).
Definition to_bytes (v : t) : Stdlib.Bytes.t :=
Data_encoding.Binary.to_bytes_exn encoding v.
Definition of_bytes (b : Stdlib.Bytes.t) : option t :=
Data_encoding.Binary.of_bytes encoding b.
Definition of_bytes_exn (b : Stdlib.Bytes.t) : t :=
Data_encoding.Binary.of_bytes_exn encoding b.
Definition hash (op : t) : Tezos_crypto.Operation_hash.t :=
Operation_hash.hash_bytes None (cons (to_bytes op) []).
Definition hash_raw (bytes : Stdlib.Bytes.t) : Tezos_crypto.Operation_hash.t :=
Operation_hash.hash_bytes None (cons string []).
src/lib_base/p2p_addr.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = Ipaddr.V6.t
let encoding =
let open Data_encoding in
def "p2p_address" ~description:"An address for locating peers."
@@ splitted
~json:(conv Ipaddr.V6.to_string Ipaddr.V6.of_string_exn string)
~binary:(conv Ipaddr.V6.to_octets Ipaddr.V6.of_octets_exn string)
type port = int
let pp ppf addr =
match Ipaddr.v4_of_v6 addr with
| Some addr ->
Format.fprintf ppf "%a" Ipaddr.V4.pp addr
| None ->
Format.fprintf ppf "[%a]" Ipaddr.V6.pp addr
let of_string_opt str =
match Ipaddr.of_string str with
| Ok (Ipaddr.V4 addr) ->
Some (Ipaddr.v6_of_v4 addr)
| Ok (V6 addr) ->
Some addr
| Error (`Msg _) ->
None
let of_string_exn str =
match of_string_opt str with
| None ->
Pervasives.failwith "P2p_addr.of_string"
| Some t ->
t
let to_string saddr = Format.asprintf "%a" pp saddr
let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/p2p_addr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := Ipaddr.V6.t.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding Ipaddr.V6.t :=
apply
(let arg :=
def "p2p_address" % string
(* ❌ expected an argument *)
expected_argument (Some "An address for locating peers." % string) in
fun eta => arg None eta)
(splitted (conv Ipaddr.V6.to_string Ipaddr.V6.of_string_exn None string)
(conv Ipaddr.V6.to_octets
(let arg := Ipaddr.V6.of_octets_exn in
fun eta => arg None eta) None string)).
Definition port := Z.
Definition pp (ppf : Stdlib.Format.formatter) (addr : Ipaddr.V6.t) : unit :=
match Ipaddr.v4_of_v6 addr with
| Some addr =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) Ipaddr.V4.pp addr
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "]" % char
CamlinternalFormatBasics.End_of_format))) "[%a]" % string)
Ipaddr.V6.pp addr
end.
Definition of_string_opt (str : string) : option Ipaddr.V6.t :=
match Ipaddr.of_string str with
| Stdlib.Ok (Ipaddr.V4 addr) => Some (Ipaddr.v6_of_v4 addr)
| Stdlib.Ok (Ipaddr.V6 addr) => Some addr
| Stdlib.Error (Msg _) => None
end.
Definition of_string_exn (str : string) : Ipaddr.V6.t :=
match of_string_opt str with
| None => Pervasives.failwith "P2p_addr.of_string" % string
| Some t => t
end.
Definition to_string (saddr : Ipaddr.V6.t) : string :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) pp saddr.
src/lib_base/p2p_connection.ml 54 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Id = struct
(* A net point (address x port). *)
type t = P2p_addr.t * P2p_addr.port option
let compare (a1, p1) (a2, p2) =
match Ipaddr.V6.compare a1 a2 with 0 -> Pervasives.compare p1 p2 | x -> x
let equal p1 p2 = compare p1 p2 = 0
let hash = Hashtbl.hash
let pp ppf (addr, port) =
match port with
| None ->
Format.fprintf ppf "[%a]:??" Ipaddr.V6.pp addr
| Some port ->
Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp addr port
let pp_opt ppf = function
| None ->
Format.pp_print_string ppf "none"
| Some point ->
pp ppf point
let to_string t = Format.asprintf "%a" pp t
let is_local (addr, _) = Ipaddr.V6.is_private addr
let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr
let of_point (addr, port) = (addr, Some port)
let to_point = function
| (_, None) ->
None
| (addr, Some port) ->
Some (addr, port)
let to_point_exn = function
| (_, None) ->
invalid_arg "to_point_exn"
| (addr, Some port) ->
(addr, port)
let encoding =
let open Data_encoding in
def
"p2p_connection.id"
~description:
"The identifier for a p2p connection. It includes an address and a \
port number."
@@ obj2 (req "addr" P2p_addr.encoding) (opt "port" uint16)
end
module Map = Map.Make (Id)
module Set = Set.Make (Id)
module Table = Hashtbl.Make (Id)
module Info = struct
type 'meta t = {
incoming : bool;
peer_id : P2p_peer_id.t;
id_point : Id.t;
remote_socket_port : P2p_addr.port;
announced_version : Network_version.t;
private_node : bool;
local_metadata : 'meta;
remote_metadata : 'meta;
}
let encoding metadata_encoding =
let open Data_encoding in
conv
(fun { incoming;
peer_id;
id_point;
remote_socket_port;
announced_version;
private_node;
local_metadata;
remote_metadata } ->
( incoming,
peer_id,
id_point,
remote_socket_port,
announced_version,
private_node,
local_metadata,
remote_metadata ))
(fun ( incoming,
peer_id,
id_point,
remote_socket_port,
announced_version,
private_node,
local_metadata,
remote_metadata ) ->
{
incoming;
peer_id;
id_point;
remote_socket_port;
announced_version;
private_node;
local_metadata;
remote_metadata;
})
(obj8
(req "incoming" bool)
(req "peer_id" P2p_peer_id.encoding)
(req "id_point" Id.encoding)
(req "remote_socket_port" uint16)
(req "announced_version" Network_version.encoding)
(req "private" bool)
(req "local_metadata" metadata_encoding)
(req "remote_metadata" metadata_encoding))
let pp pp_meta ppf
{ incoming;
id_point = (remote_addr, remote_port);
remote_socket_port;
peer_id;
announced_version;
private_node;
local_metadata = _;
remote_metadata } =
let point =
match remote_port with
| None ->
(remote_addr, remote_socket_port)
| Some port ->
(remote_addr, port)
in
Format.fprintf
ppf
"%s %a %a (%a) %s%a"
(if incoming then "â" else "â")
P2p_peer_id.pp
peer_id
P2p_point.Id.pp
point
Network_version.pp
announced_version
(if private_node then " private" else "")
pp_meta
remote_metadata
end
module P2p_event = struct
(** Pool-level events *)
type t =
| Too_few_connections
| Too_many_connections
| New_point of P2p_point.Id.t
| New_peer of P2p_peer_id.t
| Gc_points
| Gc_peer_ids
| Incoming_connection of P2p_point.Id.t
| Outgoing_connection of P2p_point.Id.t
| Authentication_failed of P2p_point.Id.t
| Accepting_request of P2p_point.Id.t * Id.t * P2p_peer_id.t
| Rejecting_request of P2p_point.Id.t * Id.t * P2p_peer_id.t
| Request_rejected of P2p_point.Id.t * (Id.t * P2p_peer_id.t) option
| Connection_established of Id.t * P2p_peer_id.t
| Swap_request_received of {source : P2p_peer_id.t}
| Swap_ack_received of {source : P2p_peer_id.t}
| Swap_request_sent of {source : P2p_peer_id.t}
| Swap_ack_sent of {source : P2p_peer_id.t}
| Swap_request_ignored of {source : P2p_peer_id.t}
| Swap_success of {source : P2p_peer_id.t}
| Swap_failure of {source : P2p_peer_id.t}
| Disconnection of P2p_peer_id.t
| External_disconnection of P2p_peer_id.t
let pp ppf (event : t) =
match event with
| Too_few_connections ->
Format.pp_print_string ppf "Too_few_connections"
| Too_many_connections ->
Format.pp_print_string ppf "Too_many_connections"
| New_point p ->
Format.pp_print_string ppf "New_point " ;
P2p_point.Id.pp ppf p
| New_peer p ->
Format.pp_print_string ppf "New_peer " ;
P2p_peer_id.pp ppf p
| Gc_points ->
Format.pp_print_string ppf "Gc_points"
| Gc_peer_ids ->
Format.pp_print_string ppf "Gc_peer_ids"
| Incoming_connection p ->
Format.pp_print_string ppf "Incoming_connection " ;
P2p_point.Id.pp ppf p
| Outgoing_connection p ->
Format.pp_print_string ppf "Outgoing_connection " ;
P2p_point.Id.pp ppf p
| Authentication_failed p ->
Format.pp_print_string ppf "Authentication_failed " ;
P2p_point.Id.pp ppf p
| Accepting_request (pi, _, _) ->
Format.pp_print_string ppf "Accepting_request " ;
P2p_point.Id.pp ppf pi
| Rejecting_request (pi, _, _) ->
Format.pp_print_string ppf "Rejecting_request " ;
P2p_point.Id.pp ppf pi
| Request_rejected (pi, _) ->
Format.pp_print_string ppf "Request_rejected " ;
P2p_point.Id.pp ppf pi
| Connection_established (_, pi) ->
Format.pp_print_string ppf "Connection_established " ;
P2p_peer_id.pp ppf pi
| Swap_request_received {source} ->
Format.pp_print_string ppf "Swap_request_received " ;
P2p_peer_id.pp ppf source
| Swap_ack_received {source} ->
Format.pp_print_string ppf "Swap_ack_received " ;
P2p_peer_id.pp ppf source
| Swap_request_sent {source} ->
Format.pp_print_string ppf "Swap_request_sent " ;
P2p_peer_id.pp ppf source
| Swap_ack_sent {source} ->
Format.pp_print_string ppf "Swap_ack_sent " ;
P2p_peer_id.pp ppf source
| Swap_request_ignored {source} ->
Format.pp_print_string ppf "Swap_request_ignored " ;
P2p_peer_id.pp ppf source
| Swap_success {source} ->
Format.pp_print_string ppf "Swap_success " ;
P2p_peer_id.pp ppf source
| Swap_failure {source} ->
Format.pp_print_string ppf "Swap_failure " ;
P2p_peer_id.pp ppf source
| Disconnection source ->
Format.pp_print_string ppf "Disconnection " ;
P2p_peer_id.pp ppf source
| External_disconnection source ->
Format.pp_print_string ppf "External_disconnection " ;
P2p_peer_id.pp ppf source
let encoding =
let open Data_encoding in
let branch_encoding name obj =
conv
(fun x -> ((), x))
(fun ((), x) -> x)
(merge_objs (obj1 (req "event" (constant name))) obj)
in
def
"p2p_connection.pool_event"
~description:
"An event that may happen during maintenance of and other operations \
on the p2p connection pool. Typically, it includes connection \
errors, peer swaps, etc."
@@ union
~tag_size:`Uint8
[ case
(Tag 0)
~title:"Too_few_connections"
(branch_encoding "too_few_connections" empty)
(function Too_few_connections -> Some () | _ -> None)
(fun () -> Too_few_connections);
case
(Tag 1)
~title:"Too_many_connections"
(branch_encoding "too_many_connections" empty)
(function Too_many_connections -> Some () | _ -> None)
(fun () -> Too_many_connections);
case
(Tag 2)
~title:"New_point"
(branch_encoding
"new_point"
(obj1 (req "point" P2p_point.Id.encoding)))
(function New_point p -> Some p | _ -> None)
(fun p -> New_point p);
case
(Tag 3)
~title:"New_peer"
(branch_encoding
"new_peer"
(obj1 (req "peer_id" P2p_peer_id.encoding)))
(function New_peer p -> Some p | _ -> None)
(fun p -> New_peer p);
case
(Tag 4)
~title:"Incoming_connection"
(branch_encoding
"incoming_connection"
(obj1 (req "point" P2p_point.Id.encoding)))
(function Incoming_connection p -> Some p | _ -> None)
(fun p -> Incoming_connection p);
case
(Tag 5)
~title:"Outgoing_connection"
(branch_encoding
"outgoing_connection"
(obj1 (req "point" P2p_point.Id.encoding)))
(function Outgoing_connection p -> Some p | _ -> None)
(fun p -> Outgoing_connection p);
case
(Tag 6)
~title:"Authentication_failed"
(branch_encoding
"authentication_failed"
(obj1 (req "point" P2p_point.Id.encoding)))
(function Authentication_failed p -> Some p | _ -> None)
(fun p -> Authentication_failed p);
case
(Tag 7)
~title:"Accepting_request"
(branch_encoding
"accepting_request"
(obj3
(req "point" P2p_point.Id.encoding)
(req "id_point" Id.encoding)
(req "peer_id" P2p_peer_id.encoding)))
(function
| Accepting_request (p, id_p, g) ->
Some (p, id_p, g)
| _ ->
None)
(fun (p, id_p, g) -> Accepting_request (p, id_p, g));
case
(Tag 8)
~title:"Rejecting_request"
(branch_encoding
"rejecting_request"
(obj3
(req "point" P2p_point.Id.encoding)
(req "id_point" Id.encoding)
(req "peer_id" P2p_peer_id.encoding)))
(function
| Rejecting_request (p, id_p, g) ->
Some (p, id_p, g)
| _ ->
None)
(fun (p, id_p, g) -> Rejecting_request (p, id_p, g));
case
(Tag 9)
~title:"Request_rejected"
(branch_encoding
"request_rejected"
(obj2
(req "point" P2p_point.Id.encoding)
(opt "identity" (tup2 Id.encoding P2p_peer_id.encoding))))
(function Request_rejected (p, id) -> Some (p, id) | _ -> None)
(fun (p, id) -> Request_rejected (p, id));
case
(Tag 10)
~title:"Connection_established"
(branch_encoding
"connection_established"
(obj2
(req "id_point" Id.encoding)
(req "peer_id" P2p_peer_id.encoding)))
(function
| Connection_established (id_p, g) -> Some (id_p, g) | _ -> None)
(fun (id_p, g) -> Connection_established (id_p, g));
case
(Tag 11)
~title:"Disconnection"
(branch_encoding
"disconnection"
(obj1 (req "peer_id" P2p_peer_id.encoding)))
(function Disconnection g -> Some g | _ -> None)
(fun g -> Disconnection g);
case
(Tag 12)
~title:"External_disconnection"
(branch_encoding
"external_disconnection"
(obj1 (req "peer_id" P2p_peer_id.encoding)))
(function External_disconnection g -> Some g | _ -> None)
(fun g -> External_disconnection g);
case
(Tag 13)
~title:"Gc_points"
(branch_encoding "gc_points" empty)
(function Gc_points -> Some () | _ -> None)
(fun () -> Gc_points);
case
(Tag 14)
~title:"Gc_peer_ids"
(branch_encoding "gc_peer_ids" empty)
(function Gc_peer_ids -> Some () | _ -> None)
(fun () -> Gc_peer_ids);
case
(Tag 15)
~title:"Swap_request_received"
(branch_encoding
"swap_request_received"
(obj1 (req "source" P2p_peer_id.encoding)))
(function
| Swap_request_received {source} -> Some source | _ -> None)
(fun source -> Swap_request_received {source});
case
(Tag 16)
~title:"Swap_ack_received"
(branch_encoding
"swap_ack_received"
(obj1 (req "source" P2p_peer_id.encoding)))
(function Swap_ack_received {source} -> Some source | _ -> None)
(fun source -> Swap_ack_received {source});
case
(Tag 17)
~title:"Swap_request_sent"
(branch_encoding
"swap_request_sent"
(obj1 (req "source" P2p_peer_id.encoding)))
(function Swap_request_sent {source} -> Some source | _ -> None)
(fun source -> Swap_request_sent {source});
case
(Tag 18)
~title:"Swap_ack_sent"
(branch_encoding
"swap_ack_sent"
(obj1 (req "source" P2p_peer_id.encoding)))
(function Swap_ack_sent {source} -> Some source | _ -> None)
(fun source -> Swap_ack_sent {source});
case
(Tag 19)
~title:"Swap_request_ignored"
(branch_encoding
"swap_request_ignored"
(obj1 (req "source" P2p_peer_id.encoding)))
(function
| Swap_request_ignored {source} -> Some source | _ -> None)
(fun source -> Swap_request_ignored {source});
case
(Tag 20)
~title:"Swap_success"
(branch_encoding
"swap_success"
(obj1 (req "source" P2p_peer_id.encoding)))
(function Swap_success {source} -> Some source | _ -> None)
(fun source -> Swap_success {source});
case
(Tag 21)
~title:"Swap_failure"
(branch_encoding
"swap_failure"
(obj1 (req "source" P2p_peer_id.encoding)))
(function Swap_failure {source} -> Some source | _ -> None)
(fun source -> Swap_failure {source}) ]
end
let () =
Data_encoding.Registration.register ~pp:Id.pp Id.encoding ;
Data_encoding.Registration.register ~pp:P2p_event.pp P2p_event.encoding
src/lib_base/p2p_connection.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Id.
Definition t := Tezos_base.P2p_addr.t * (option Tezos_base.P2p_addr.port).
Definition compare {A : Type} (function_parameter : Ipaddr.V6.t * A)
: (Ipaddr.V6.t * A) -> Z :=
let '(a1, p1) := function_parameter in
fun function_parameter =>
let '(a2, p2) := function_parameter in
match Ipaddr.V6.compare a1 a2 with
| 0 => Pervasives.compare p1 p2
| x => x
end.
Definition equal {A : Type} (p1 : Ipaddr.V6.t * A) (p2 : Ipaddr.V6.t * A)
: bool := equiv_decb (compare p1 p2) 0.
Definition hash {A : Type} : A -> Z := Hashtbl.hash.
Definition pp
(ppf : Stdlib.Format.formatter)
(function_parameter : Ipaddr.V6.t * (option Z)) : unit :=
let '(addr, port) := function_parameter in
match port with
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "]:??" % string
CamlinternalFormatBasics.End_of_format))) "[%a]:??" % string)
Ipaddr.V6.pp addr
| Some port =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "]:" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)))) "[%a]:%d" % string)
Ipaddr.V6.pp addr port
end.
Definition pp_opt
(ppf : Stdlib.Format.formatter)
(function_parameter : option (Ipaddr.V6.t * (option Z))) : unit :=
match function_parameter with
| None => Format.pp_print_string ppf "none" % string
| Some point => pp ppf point
end.
Definition to_string (t : Ipaddr.V6.t * (option Z)) : string :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) pp t.
Definition is_local {A : Type} (function_parameter : Ipaddr.V6.t * A)
: bool :=
let '(addr, _) := function_parameter in
Ipaddr.V6.is_private addr.
Definition is_global {A : Type} (function_parameter : Ipaddr.V6.t * A)
: bool :=
let '(addr, _) := function_parameter in
apply negb (Ipaddr.V6.is_private addr).
Definition of_point {A B : Type} (function_parameter : A * B)
: A * (option B) :=
let '(addr, port) := function_parameter in
(addr, (Some port)).
Definition to_point {A B : Type} (function_parameter : A * (option B))
: option (A * B) :=
match function_parameter with
| (_, None) => None
| (addr, Some port) => Some (addr, port)
end.
Definition to_point_exn {A B : Type} (function_parameter : A * (option B))
: A * B :=
match function_parameter with
| (_, None) => OCaml.Stdlib.invalid_arg "to_point_exn" % string
| (addr, Some port) => (addr, port)
end.
Definition encoding
: Tezos_data_encoding.Data_encoding.encoding
(Tezos_base.P2p_addr.t * (option Z)) :=
apply
(let arg :=
def "p2p_connection.id" % string
(* ❌ expected an argument *)
expected_argument
(Some
"The identifier for a p2p connection. It includes an address and a port number."
% string) in
fun eta => arg None eta)
(obj2 (req None None "addr" % string P2p_addr.encoding)
(opt None None "port" % string uint16)).
End Id.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Module Info.
Record t {meta : Type} := {
incoming : bool;
peer_id : Tezos_base.P2p_peer_id.t;
id_point : Id.t;
remote_socket_port : Tezos_base.P2p_addr.port;
announced_version : Tezos_base.Network_version.t;
private_node : bool;
local_metadata : meta;
remote_metadata : meta }.
Arguments t : clear implicits.
Definition encoding {A : Type}
(metadata_encoding : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding (t A) :=
conv
(fun function_parameter =>
let '{|
incoming := incoming;
peer_id := peer_id;
id_point := id_point;
remote_socket_port := remote_socket_port;
announced_version := announced_version;
private_node := private_node;
local_metadata := local_metadata;
remote_metadata := remote_metadata
|} := function_parameter in
(incoming, peer_id, id_point, remote_socket_port, announced_version,
private_node, local_metadata, remote_metadata))
(fun function_parameter =>
let
'(incoming, peer_id, id_point, remote_socket_port, announced_version,
private_node, local_metadata, remote_metadata) := function_parameter
in
{| incoming := incoming; peer_id := peer_id; id_point := id_point;
remote_socket_port := remote_socket_port;
announced_version := announced_version; private_node := private_node;
local_metadata := local_metadata; remote_metadata := remote_metadata
|}) None
(obj8 (req None None "incoming" % string bool)
(req None None "peer_id" % string P2p_peer_id.encoding)
(req None None "id_point" % string Id.encoding)
(req None None "remote_socket_port" % string uint16)
(req None None "announced_version" % string Network_version.encoding)
(req None None "private" % string bool)
(req None None "local_metadata" % string metadata_encoding)
(req None None "remote_metadata" % string metadata_encoding)).
Definition pp {A : Type}
(pp_meta : Stdlib.Format.formatter -> A -> unit)
(ppf : Stdlib.Format.formatter) (function_parameter : t A) : unit :=
let '{|
incoming := incoming;
peer_id := peer_id;
id_point := (remote_addr, remote_port);
remote_socket_port := remote_socket_port;
announced_version := announced_version;
private_node := private_node;
local_metadata := _;
remote_metadata := remote_metadata
|} := function_parameter in
let point :=
match remote_port with
| None => (remote_addr, remote_socket_port)
| Some port => (remote_addr, port)
end in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ") " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))))))))
"%s %a %a (%a) %s%a" % string)
(if incoming then
"↘" % string
else
"↗" % string) P2p_peer_id.pp peer_id P2p_point.Id.pp point
Network_version.pp announced_version
(if private_node then
" private" % string
else
"" % string) pp_meta remote_metadata.
End Info.
Module P2p_event.
Inductive t : Type :=
| Too_few_connections : t
| Too_many_connections : t
| New_point : Tezos_base.P2p_point.Id.t -> t
| New_peer : Tezos_base.P2p_peer_id.t -> t
| Gc_points : t
| Gc_peer_ids : t
| Incoming_connection : Tezos_base.P2p_point.Id.t -> t
| Outgoing_connection : Tezos_base.P2p_point.Id.t -> t
| Authentication_failed : Tezos_base.P2p_point.Id.t -> t
| Accepting_request : Tezos_base.P2p_point.Id.t -> Id.t ->
Tezos_base.P2p_peer_id.t -> t
| Rejecting_request : Tezos_base.P2p_point.Id.t -> Id.t ->
Tezos_base.P2p_peer_id.t -> t
| Request_rejected : Tezos_base.P2p_point.Id.t ->
(option (Id.t * Tezos_base.P2p_peer_id.t)) -> t
| Connection_established : Id.t -> Tezos_base.P2p_peer_id.t -> t
| Swap_request_received : Tezos_base.P2p_peer_id.t -> t
| Swap_ack_received : Tezos_base.P2p_peer_id.t -> t
| Swap_request_sent : Tezos_base.P2p_peer_id.t -> t
| Swap_ack_sent : Tezos_base.P2p_peer_id.t -> t
| Swap_request_ignored : Tezos_base.P2p_peer_id.t -> t
| Swap_success : Tezos_base.P2p_peer_id.t -> t
| Swap_failure : Tezos_base.P2p_peer_id.t -> t
| Disconnection : Tezos_base.P2p_peer_id.t -> t
| External_disconnection : Tezos_base.P2p_peer_id.t -> t.
Definition pp (ppf : Stdlib.Format.formatter) (event : t) : unit :=
match event with
| Too_few_connections =>
Format.pp_print_string ppf "Too_few_connections" % string
| Too_many_connections =>
Format.pp_print_string ppf "Too_many_connections" % string
| New_point p =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "New_point " % string in
P2p_point.Id.pp ppf p
| New_peer p =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "New_peer " % string in
P2p_peer_id.pp ppf p
| Gc_points => Format.pp_print_string ppf "Gc_points" % string
| Gc_peer_ids => Format.pp_print_string ppf "Gc_peer_ids" % string
| Incoming_connection p =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Incoming_connection " % string in
P2p_point.Id.pp ppf p
| Outgoing_connection p =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Outgoing_connection " % string in
P2p_point.Id.pp ppf p
| Authentication_failed p =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Authentication_failed " % string in
P2p_point.Id.pp ppf p
| Accepting_request pi _ _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Accepting_request " % string in
P2p_point.Id.pp ppf pi
| Rejecting_request pi _ _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Rejecting_request " % string in
P2p_point.Id.pp ppf pi
| Request_rejected pi _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Request_rejected " % string in
P2p_point.Id.pp ppf pi
| Connection_established _ pi =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Connection_established " % string in
P2p_peer_id.pp ppf pi
| Swap_request_received {| source := source |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Swap_request_received " % string in
P2p_peer_id.pp ppf source
| Swap_ack_received {| source := source |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Swap_ack_received " % string in
P2p_peer_id.pp ppf source
| Swap_request_sent {| source := source |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Swap_request_sent " % string in
P2p_peer_id.pp ppf source
| Swap_ack_sent {| source := source |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Swap_ack_sent " % string in
P2p_peer_id.pp ppf source
| Swap_request_ignored {| source := source |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Swap_request_ignored " % string in
P2p_peer_id.pp ppf source
| Swap_success {| source := source |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Swap_success " % string in
P2p_peer_id.pp ppf source
| Swap_failure {| source := source |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Swap_failure " % string in
P2p_peer_id.pp ppf source
| Disconnection source =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "Disconnection " % string in
P2p_peer_id.pp ppf source
| External_disconnection source =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_string ppf "External_disconnection " % string in
P2p_peer_id.pp ppf source
end.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
let branch_encoding {A : Type}
(name : string) (obj : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding A :=
conv (fun x => (tt, x))
(fun function_parameter =>
let '(tt, x) := function_parameter in
x) None
(merge_objs (obj1 (req None None "event" % string (constant name))) obj)
in
apply
(let arg :=
def "p2p_connection.pool_event" % string
(* ❌ expected an argument *)
expected_argument
(Some
"An event that may happen during maintenance of and other operations on the p2p connection pool. Typically, it includes connection errors, peer swaps, etc."
% string) in
fun eta => arg None eta)
(union
(Some
(* ❌ Variants not supported *)
variant)
(cons
(case "Too_few_connections" % string None
(Tezos_data_encoding.Data_encoding.Tag 0)
(branch_encoding "too_few_connections" % string empty)
(fun function_parameter =>
match function_parameter with
| Too_few_connections => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Too_few_connections))
(cons
(case "Too_many_connections" % string None
(Tezos_data_encoding.Data_encoding.Tag 1)
(branch_encoding "too_many_connections" % string empty)
(fun function_parameter =>
match function_parameter with
| Too_many_connections => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Too_many_connections))
(cons
(case "New_point" % string None
(Tezos_data_encoding.Data_encoding.Tag 2)
(branch_encoding "new_point" % string
(obj1 (req None None "point" % string P2p_point.Id.encoding)))
(fun function_parameter =>
match function_parameter with
| New_point p => Some p
| _ => None
end) (fun p => New_point p))
(cons
(case "New_peer" % string None
(Tezos_data_encoding.Data_encoding.Tag 3)
(branch_encoding "new_peer" % string
(obj1
(req None None "peer_id" % string P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| New_peer p => Some p
| _ => None
end) (fun p => New_peer p))
(cons
(case "Incoming_connection" % string None
(Tezos_data_encoding.Data_encoding.Tag 4)
(branch_encoding "incoming_connection" % string
(obj1
(req None None "point" % string P2p_point.Id.encoding)))
(fun function_parameter =>
match function_parameter with
| Incoming_connection p => Some p
| _ => None
end) (fun p => Incoming_connection p))
(cons
(case "Outgoing_connection" % string None
(Tezos_data_encoding.Data_encoding.Tag 5)
(branch_encoding "outgoing_connection" % string
(obj1
(req None None "point" % string P2p_point.Id.encoding)))
(fun function_parameter =>
match function_parameter with
| Outgoing_connection p => Some p
| _ => None
end) (fun p => Outgoing_connection p))
(cons
(case "Authentication_failed" % string None
(Tezos_data_encoding.Data_encoding.Tag 6)
(branch_encoding "authentication_failed" % string
(obj1
(req None None "point" % string
P2p_point.Id.encoding)))
(fun function_parameter =>
match function_parameter with
| Authentication_failed p => Some p
| _ => None
end) (fun p => Authentication_failed p))
(cons
(case "Accepting_request" % string None
(Tezos_data_encoding.Data_encoding.Tag 7)
(branch_encoding "accepting_request" % string
(obj3
(req None None "point" % string
P2p_point.Id.encoding)
(req None None "id_point" % string Id.encoding)
(req None None "peer_id" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Accepting_request p id_p g => Some (p, id_p, g)
| _ => None
end)
(fun function_parameter =>
let '(p, id_p, g) := function_parameter in
Accepting_request p id_p g))
(cons
(case "Rejecting_request" % string None
(Tezos_data_encoding.Data_encoding.Tag 8)
(branch_encoding "rejecting_request" % string
(obj3
(req None None "point" % string
P2p_point.Id.encoding)
(req None None "id_point" % string Id.encoding)
(req None None "peer_id" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Rejecting_request p id_p g => Some (p, id_p, g)
| _ => None
end)
(fun function_parameter =>
let '(p, id_p, g) := function_parameter in
Rejecting_request p id_p g))
(cons
(case "Request_rejected" % string None
(Tezos_data_encoding.Data_encoding.Tag 9)
(branch_encoding "request_rejected" % string
(obj2
(req None None "point" % string
P2p_point.Id.encoding)
(opt None None "identity" % string
(tup2 Id.encoding P2p_peer_id.encoding))))
(fun function_parameter =>
match function_parameter with
| Request_rejected p id => Some (p, id)
| _ => None
end)
(fun function_parameter =>
let '(p, id) := function_parameter in
Request_rejected p id))
(cons
(case "Connection_established" % string None
(Tezos_data_encoding.Data_encoding.Tag 10)
(branch_encoding
"connection_established" % string
(obj2
(req None None "id_point" % string
Id.encoding)
(req None None "peer_id" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Connection_established id_p g =>
Some (id_p, g)
| _ => None
end)
(fun function_parameter =>
let '(id_p, g) := function_parameter in
Connection_established id_p g))
(cons
(case "Disconnection" % string None
(Tezos_data_encoding.Data_encoding.Tag 11)
(branch_encoding "disconnection" % string
(obj1
(req None None "peer_id" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Disconnection g => Some g
| _ => None
end) (fun g => Disconnection g))
(cons
(case "External_disconnection" % string None
(Tezos_data_encoding.Data_encoding.Tag 12)
(branch_encoding
"external_disconnection" % string
(obj1
(req None None "peer_id" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| External_disconnection g => Some g
| _ => None
end) (fun g => External_disconnection g))
(cons
(case "Gc_points" % string None
(Tezos_data_encoding.Data_encoding.Tag 13)
(branch_encoding "gc_points" % string
empty)
(fun function_parameter =>
match function_parameter with
| Gc_points => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Gc_points))
(cons
(case "Gc_peer_ids" % string None
(Tezos_data_encoding.Data_encoding.Tag
14)
(branch_encoding "gc_peer_ids" % string
empty)
(fun function_parameter =>
match function_parameter with
| Gc_peer_ids => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Gc_peer_ids))
(cons
(case "Swap_request_received" % string
None
(Tezos_data_encoding.Data_encoding.Tag
15)
(branch_encoding
"swap_request_received" % string
(obj1
(req None None "source" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
|
Swap_request_received {|
source := source |} =>
Some source
| _ => None
end)
(fun source =>
Swap_request_received
{| source := source |}))
(cons
(case "Swap_ack_received" % string
None
(Tezos_data_encoding.Data_encoding.Tag
16)
(branch_encoding
"swap_ack_received" % string
(obj1
(req None None "source" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
|
Swap_ack_received {|
source := source |} =>
Some source
| _ => None
end)
(fun source =>
Swap_ack_received
{| source := source |}))
(cons
(case "Swap_request_sent" % string
None
(Tezos_data_encoding.Data_encoding.Tag
17)
(branch_encoding
"swap_request_sent" % string
(obj1
(req None None
"source" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
|
Swap_request_sent {|
source := source |} =>
Some source
| _ => None
end)
(fun source =>
Swap_request_sent
{| source := source |}))
(cons
(case "Swap_ack_sent" % string
None
(Tezos_data_encoding.Data_encoding.Tag
18)
(branch_encoding
"swap_ack_sent" % string
(obj1
(req None None
"source" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
|
Swap_ack_sent {|
source := source |} =>
Some source
| _ => None
end)
(fun source =>
Swap_ack_sent
{| source := source |}))
(cons
(case
"Swap_request_ignored" %
string None
(Tezos_data_encoding.Data_encoding.Tag
19)
(branch_encoding
"swap_request_ignored" %
string
(obj1
(req None None
"source" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter
with
|
Swap_request_ignored {|
source := source |}
=> Some source
| _ => None
end)
(fun source =>
Swap_request_ignored
{| source := source |}))
(cons
(case "Swap_success" % string
None
(Tezos_data_encoding.Data_encoding.Tag
20)
(branch_encoding
"swap_success" % string
(obj1
(req None None
"source" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter
with
|
Swap_success {|
source := source
|} => Some source
| _ => None
end)
(fun source =>
Swap_success
{| source := source |}))
(cons
(case
"Swap_failure" % string
None
(Tezos_data_encoding.Data_encoding.Tag
21)
(branch_encoding
"swap_failure" % string
(obj1
(req None None
"source" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter
with
|
Swap_failure {|
source := source
|} => Some source
| _ => None
end)
(fun source =>
Swap_failure
{| source := source |}))
[]))))))))))))))))))))))).
End P2p_event.
src/lib_base/p2p_identity.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {
peer_id : P2p_peer.Id.t;
public_key : Crypto_box.public_key;
secret_key : Crypto_box.secret_key;
proof_of_work_stamp : Crypto_box.nonce;
}
let encoding =
let open Data_encoding in
def
"p2p_identity"
~description:
"The identity of a peer. This includes cryptographic keys as well as a \
proof-of-work."
@@ conv
(fun {peer_id; public_key; secret_key; proof_of_work_stamp} ->
(Some peer_id, public_key, secret_key, proof_of_work_stamp))
(fun (peer_id_opt, public_key, secret_key, proof_of_work_stamp) ->
let peer_id =
match peer_id_opt with
| Some peer_id ->
peer_id
| None ->
Tezos_crypto.Crypto_box.hash public_key
in
{peer_id; public_key; secret_key; proof_of_work_stamp})
(obj4
(opt "peer_id" P2p_peer_id.encoding)
(req "public_key" Crypto_box.public_key_encoding)
(req "secret_key" Crypto_box.secret_key_encoding)
(req "proof_of_work_stamp" Crypto_box.nonce_encoding))
let generate_with_bound ?max target =
let (secret_key, public_key, peer_id) = Crypto_box.random_keypair () in
let proof_of_work_stamp =
Crypto_box.generate_proof_of_work ?max public_key target
in
{peer_id; public_key; secret_key; proof_of_work_stamp}
let generate target = generate_with_bound target
let () = Data_encoding.Registration.register encoding
src/lib_base/p2p_identity.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record t := {
peer_id : Tezos_base.P2p_peer.Id.t;
public_key : Tezos_crypto.Crypto_box.public_key;
secret_key : Tezos_crypto.Crypto_box.secret_key;
proof_of_work_stamp : Tezos_crypto.Crypto_box.nonce }.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "p2p_identity" % string
(* ❌ expected an argument *)
expected_argument
(Some
"The identity of a peer. This includes cryptographic keys as well as a proof-of-work."
% string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{|
peer_id := peer_id;
public_key := public_key;
secret_key := secret_key;
proof_of_work_stamp := proof_of_work_stamp
|} := function_parameter in
((Some peer_id), public_key, secret_key, proof_of_work_stamp))
(fun function_parameter =>
let '(peer_id_opt, public_key, secret_key, proof_of_work_stamp) :=
function_parameter in
let peer_id :=
match peer_id_opt with
| Some peer_id => peer_id
| None => Tezos_crypto.Crypto_box.hash public_key
end in
{| peer_id := peer_id; public_key := public_key;
secret_key := secret_key; proof_of_work_stamp := proof_of_work_stamp
|}) None
(obj4 (opt None None "peer_id" % string P2p_peer_id.encoding)
(req None None "public_key" % string Crypto_box.public_key_encoding)
(req None None "secret_key" % string Crypto_box.secret_key_encoding)
(req None None "proof_of_work_stamp" % string Crypto_box.nonce_encoding))).
Definition generate_with_bound
(max : option Z) (target : Tezos_crypto.Crypto_box.target) : t :=
let '(secret_key, public_key, peer_id) := Crypto_box.random_keypair tt in
let proof_of_work_stamp :=
Crypto_box.generate_proof_of_work max public_key target in
{| peer_id := peer_id; public_key := public_key; secret_key := secret_key;
proof_of_work_stamp := proof_of_work_stamp |}.
Definition generate (target : Tezos_crypto.Crypto_box.target) : t :=
generate_with_bound None target.
src/lib_base/p2p_peer.ml 37 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Id = P2p_peer_id
module Table = Id.Table
module Error_table = Id.Error_table
module Map = Id.Map
module Set = Id.Set
module Filter = struct
type t = Accepted | Running | Disconnected
let rpc_arg =
RPC_arg.make
~name:"p2p.point.state_filter"
~destruct:(function
| "accepted" ->
Ok Accepted
| "running" ->
Ok Running
| "disconnected" ->
Ok Disconnected
| s ->
Error (Format.asprintf "Invalid state: %s" s))
~construct:(function
| Accepted ->
"accepted"
| Running ->
"running"
| Disconnected ->
"disconnected")
()
end
module State = struct
type t = Accepted | Running | Disconnected
let pp_digram ppf = function
| Accepted ->
Format.fprintf ppf "â"
| Running ->
Format.fprintf ppf "â"
| Disconnected ->
Format.fprintf ppf "â"
let encoding =
let open Data_encoding in
def
"p2p_peer.state"
~description:
"The state a peer connection can be in: accepted (when the connection \
is being established), running (when the connection is already \
established), disconnected (otherwise)."
@@ string_enum
[ ("accepted", Accepted);
("running", Running);
("disconnected", Disconnected) ]
let raw_filter (f : Filter.t) (s : t) =
match (f, s) with
| (Accepted, Accepted) ->
true
| (Accepted, (Running | Disconnected))
| ((Running | Disconnected), Accepted) ->
false
| (Running, Running) ->
true
| (Disconnected, Disconnected) ->
true
| (Running, Disconnected) | (Disconnected, Running) ->
false
let filter filters state = List.exists (fun f -> raw_filter f state) filters
end
module Info = struct
type ('peer_meta, 'conn_meta) t = {
score : float;
trusted : bool;
conn_metadata : 'conn_meta option;
peer_metadata : 'peer_meta;
state : State.t;
id_point : P2p_connection.Id.t option;
stat : P2p_stat.t;
last_failed_connection : (P2p_connection.Id.t * Time.System.t) option;
last_rejected_connection : (P2p_connection.Id.t * Time.System.t) option;
last_established_connection : (P2p_connection.Id.t * Time.System.t) option;
last_disconnection : (P2p_connection.Id.t * Time.System.t) option;
last_seen : (P2p_connection.Id.t * Time.System.t) option;
last_miss : (P2p_connection.Id.t * Time.System.t) option;
}
let encoding peer_metadata_encoding conn_metadata_encoding =
let open Data_encoding in
conv
(fun { score;
trusted;
conn_metadata;
peer_metadata;
state;
id_point;
stat;
last_failed_connection;
last_rejected_connection;
last_established_connection;
last_disconnection;
last_seen;
last_miss } ->
( (score, trusted, conn_metadata, peer_metadata, state, id_point, stat),
( last_failed_connection,
last_rejected_connection,
last_established_connection,
last_disconnection,
last_seen,
last_miss ) ))
(fun ( ( score,
trusted,
conn_metadata,
peer_metadata,
state,
id_point,
stat ),
( last_failed_connection,
last_rejected_connection,
last_established_connection,
last_disconnection,
last_seen,
last_miss ) ) ->
{
score;
trusted;
conn_metadata;
peer_metadata;
state;
id_point;
stat;
last_failed_connection;
last_rejected_connection;
last_established_connection;
last_disconnection;
last_seen;
last_miss;
})
(merge_objs
(obj7
(req "score" float)
(req "trusted" bool)
(opt "conn_metadata" conn_metadata_encoding)
(req "peer_metadata" peer_metadata_encoding)
(req "state" State.encoding)
(opt "reachable_at" P2p_connection.Id.encoding)
(req "stat" P2p_stat.encoding))
(obj6
(opt
"last_failed_connection"
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt
"last_rejected_connection"
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt
"last_established_connection"
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt
"last_disconnection"
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt
"last_seen"
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt
"last_miss"
(tup2 P2p_connection.Id.encoding Time.System.encoding))))
end
module Pool_event = struct
type kind =
| Accepting_request
| Rejecting_request
| Request_rejected
| Connection_established
| Disconnection
| External_disconnection
let kind_encoding =
Data_encoding.string_enum
[ ("incoming_request", Accepting_request);
("rejecting_request", Rejecting_request);
("request_rejected", Request_rejected);
("connection_established", Connection_established);
("disconnection", Disconnection);
("external_disconnection", External_disconnection) ]
type t = {
kind : kind;
timestamp : Time.System.t;
point : P2p_connection.Id.t;
}
let encoding =
let open Data_encoding in
def
"p2p_peer.pool_event"
~description:
"An event that may happen during maintenance of and other operations \
on the connection to a specific peer."
@@ conv
(fun {kind; timestamp; point = (addr, port)} ->
(kind, timestamp, addr, port))
(fun (kind, timestamp, addr, port) ->
{kind; timestamp; point = (addr, port)})
(obj4
(req "kind" kind_encoding)
(req "timestamp" Time.System.encoding)
(req "addr" P2p_addr.encoding)
(opt "port" uint16))
end
let () =
Data_encoding.Registration.register ~pp:State.pp_digram State.encoding ;
Data_encoding.Registration.register Pool_event.encoding
src/lib_base/p2p_peer.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
Module Filter.
Inductive t : Type :=
| Accepted : t
| Running : t
| Disconnected : t.
Definition rpc_arg : Tezos_rpc.RPC_arg.arg t :=
RPC_arg.make None "p2p.point.state_filter" % string
(fun function_parameter =>
match function_parameter with
| "accepted" % string => Stdlib.Ok Accepted
| "running" % string => Stdlib.Ok Running
| "disconnected" % string => Stdlib.Ok Disconnected
| s =>
Stdlib.Error
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid state: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Invalid state: %s" % string) s)
end)
(fun function_parameter =>
match function_parameter with
| Accepted => "accepted" % string
| Running => "running" % string
| Disconnected => "disconnected" % string
end) tt.
End Filter.
Module State.
Inductive t : Type :=
| Accepted : t
| Running : t
| Disconnected : t.
Definition pp_digram (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
match function_parameter with
| Accepted =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "⚎" % string
CamlinternalFormatBasics.End_of_format) "⚎" % string)
| Running =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "⚌" % string
CamlinternalFormatBasics.End_of_format) "⚌" % string)
| Disconnected =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "⚏" % string
CamlinternalFormatBasics.End_of_format) "⚏" % string)
end.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "p2p_peer.state" % string
(* ❌ expected an argument *)
expected_argument
(Some
"The state a peer connection can be in: accepted (when the connection is being established), running (when the connection is already established), disconnected (otherwise)."
% string) in
fun eta => arg None eta)
(string_enum
(cons ("accepted" % string, Accepted)
(cons ("running" % string, Running)
(cons ("disconnected" % string, Disconnected) [])))).
Definition raw_filter (f : Filter.t) (s : t) : bool :=
match (f, s) with
| (Filter.Accepted, Accepted) => true
|
(Filter.Accepted, Running | Disconnected) |
(Filter.Running | Filter.Disconnected, Accepted) => false
| (Filter.Running, Running) => true
| (Filter.Disconnected, Disconnected) => true
| (Filter.Running, Disconnected) | (Filter.Disconnected, Running) => false
end.
Definition filter (filters : list Filter.t) (state : t) : bool :=
Stdlib.List._exists (fun f => raw_filter f state) filters.
End State.
Module Info.
Record t {peer_meta conn_meta : Type} := {
score : Z;
trusted : bool;
conn_metadata : option conn_meta;
peer_metadata : peer_meta;
state : State.t;
id_point : option Tezos_base.P2p_connection.Id.t;
stat : Tezos_base.P2p_stat.t;
last_failed_connection :
option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
last_rejected_connection :
option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
last_established_connection :
option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
last_disconnection :
option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
last_seen :
option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
last_miss :
option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t) }.
Arguments t : clear implicits.
Definition encoding {A B : Type}
(peer_metadata_encoding : Tezos_data_encoding.Data_encoding.encoding A)
(conn_metadata_encoding : Tezos_data_encoding.Data_encoding.encoding B)
: Tezos_data_encoding.Data_encoding.encoding (t A B) :=
conv
(fun function_parameter =>
let '{|
score := score;
trusted := trusted;
conn_metadata := conn_metadata;
peer_metadata := peer_metadata;
state := state;
id_point := id_point;
stat := stat;
last_failed_connection := last_failed_connection;
last_rejected_connection := last_rejected_connection;
last_established_connection := last_established_connection;
last_disconnection := last_disconnection;
last_seen := last_seen;
last_miss := last_miss
|} := function_parameter in
((score, trusted, conn_metadata, peer_metadata, state, id_point, stat),
(last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection, last_seen,
last_miss)))
(fun function_parameter =>
let
'((score, trusted, conn_metadata, peer_metadata, state, id_point, stat),
(last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection, last_seen,
last_miss)) := function_parameter in
{| score := score; trusted := trusted; conn_metadata := conn_metadata;
peer_metadata := peer_metadata; state := state; id_point := id_point;
stat := stat; last_failed_connection := last_failed_connection;
last_rejected_connection := last_rejected_connection;
last_established_connection := last_established_connection;
last_disconnection := last_disconnection; last_seen := last_seen;
last_miss := last_miss |}) None
(merge_objs
(obj7 (req None None "score" % string float)
(req None None "trusted" % string bool)
(opt None None "conn_metadata" % string conn_metadata_encoding)
(req None None "peer_metadata" % string peer_metadata_encoding)
(req None None "state" % string State.encoding)
(opt None None "reachable_at" % string P2p_connection.Id.encoding)
(req None None "stat" % string P2p_stat.encoding))
(obj6
(opt None None "last_failed_connection" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt None None "last_rejected_connection" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt None None "last_established_connection" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt None None "last_disconnection" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt None None "last_seen" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt None None "last_miss" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding)))).
End Info.
Module Pool_event.
Inductive kind : Type :=
| Accepting_request : kind
| Rejecting_request : kind
| Request_rejected : kind
| Connection_established : kind
| Disconnection : kind
| External_disconnection : kind.
Definition kind_encoding : Tezos_data_encoding.Data_encoding.encoding kind :=
Data_encoding.string_enum
(cons ("incoming_request" % string, Accepting_request)
(cons ("rejecting_request" % string, Rejecting_request)
(cons ("request_rejected" % string, Request_rejected)
(cons ("connection_established" % string, Connection_established)
(cons ("disconnection" % string, Disconnection)
(cons
("external_disconnection" % string, External_disconnection) [])))))).
Record t := {
kind : kind;
timestamp : Tezos_base.Time.System.t;
point : Tezos_base.P2p_connection.Id.t }.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "p2p_peer.pool_event" % string
(* ❌ expected an argument *)
expected_argument
(Some
"An event that may happen during maintenance of and other operations on the connection to a specific peer."
% string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{|
kind := kind; timestamp := timestamp; point := (addr, port) |} :=
function_parameter in
(kind, timestamp, addr, port))
(fun function_parameter =>
let '(kind, timestamp, addr, port) := function_parameter in
{| kind := kind; timestamp := timestamp; point := (addr, port) |})
None
(obj4 (req None None "kind" % string kind_encoding)
(req None None "timestamp" % string Time.System.encoding)
(req None None "addr" % string P2p_addr.encoding)
(opt None None "port" % string uint16))).
End Pool_event.
src/lib_base/p2p_peer_id.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Crypto_box.Public_key_hash
let rpc_arg =
RPC_arg.like
rpc_arg
~descr:"A cryptographic node identity (Base58Check-encoded)"
"peer_id"
let pp_source ppf = function
| None ->
()
| Some peer ->
Format.fprintf ppf " from peer %a" pp peer
module Logging = struct
include Internal_event.Legacy_logging.Make_semantic (struct
let name = "node.distributed_db.p2p_peer_id"
end)
let mk_tag pp = Tag.def ~doc:"P2P peer ID" "p2p_peer_id" pp
let tag = mk_tag pp_short
let tag_opt =
mk_tag (fun ppf -> function None -> () | Some peer -> pp_short ppf peer)
let tag_source =
Tag.def
~doc:"Peer which provided information"
"p2p_peer_id_source"
pp_source
end
src/lib_base/p2p_peer_id.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition rpc_arg : Tezos_rpc.RPC_arg.arg t :=
RPC_arg.like rpc_arg
(Some "A cryptographic node identity (Base58Check-encoded)" % string)
"peer_id" % string.
Definition pp_source
(ppf : Stdlib.Format.formatter) (function_parameter : option t) : unit :=
match function_parameter with
| None => tt
| Some peer =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal " from peer " % string
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
" from peer %a" % string) pp peer
end.
Module Logging.
(* ❌ Structure item `include` not handled. *)
include
Definition mk_tag {A : Type} (pp : Stdlib.Format.formatter -> A -> unit)
: Tag.def A :=
Tag.def (Some "P2P peer ID" % string) "p2p_peer_id" % string pp.
Definition tag : Tag.def t := mk_tag pp_short.
Definition tag_opt : Tag.def (option t) :=
mk_tag
(fun ppf =>
fun function_parameter =>
match function_parameter with
| None => tt
| Some peer => pp_short ppf peer
end).
Definition tag_source : Tag.def (option t) :=
Tag.def (Some "Peer which provided information" % string)
"p2p_peer_id_source" % string pp_source.
End Logging.
src/lib_base/p2p_point.ml 33 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Id = struct
(* A net point (address x port). *)
type t = P2p_addr.t * P2p_addr.port
let compare (a1, p1) (a2, p2) =
match Ipaddr.V6.compare a1 a2 with 0 -> p1 - p2 | x -> x
let equal p1 p2 = compare p1 p2 = 0
let hash = Hashtbl.hash
let pp ppf (addr, port) =
match Ipaddr.v4_of_v6 addr with
| Some addr ->
Format.fprintf ppf "%a:%d" Ipaddr.V4.pp addr port
| None ->
Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp addr port
let pp_opt ppf = function
| None ->
Format.pp_print_string ppf "none"
| Some point ->
pp ppf point
let pp_list ppf point_list =
Format.pp_print_list ~pp_sep:Format.pp_print_space pp ppf point_list
let is_local (addr, _) = Ipaddr.V6.is_private addr
let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr
let check_port port =
if
TzString.mem_char port '[' || TzString.mem_char port ']'
|| TzString.mem_char port ':'
then invalid_arg "Utils.parse_addr_port (invalid character in port)"
let parse_addr_port s =
let len = String.length s in
if len = 0 then ("", "")
else if s.[0] = '[' then (
(* inline IPv6 *)
match String.rindex_opt s ']' with
| None ->
invalid_arg "Utils.parse_addr_port (missing ']')"
| Some pos ->
let addr = String.sub s 1 (pos - 1) in
let port =
if pos = len - 1 then ""
else if s.[pos + 1] <> ':' then
invalid_arg "Utils.parse_addr_port (unexpected char after ']')"
else String.sub s (pos + 2) (len - pos - 2)
in
check_port port ; (addr, port) )
else
match String.rindex_opt s ']' with
| Some _pos ->
invalid_arg "Utils.parse_addr_port (unexpected char ']')"
| None -> (
match String.index s ':' with
| exception _ ->
(s, "")
| pos -> (
match String.index_from s (pos + 1) ':' with
| exception _ ->
let addr = String.sub s 0 pos in
let port = String.sub s (pos + 1) (len - pos - 1) in
check_port port ; (addr, port)
| _pos ->
invalid_arg
"Utils.parse_addr_port: IPv6 addresses must be bracketed" ) )
let of_string_exn ?default_port str =
let (addr, port) = parse_addr_port str in
let port =
if port = "" then
Option.unopt_exn
(Invalid_argument "P2p_point.of_string_exn: no port")
default_port
else int_of_string port
in
if port < 0 && port > (1 lsl 16) - 1 then
invalid_arg "port must be between 0 and 65535" ;
match Ipaddr.of_string_exn addr with
| V4 addr ->
(Ipaddr.v6_of_v4 addr, port)
| V6 addr ->
(addr, port)
let of_string ?default_port str =
try Ok (of_string_exn ?default_port str) with
| Invalid_argument s ->
Error s
| Failure s ->
Error s
| _ ->
Error "P2p_point.of_string"
let to_string saddr = Format.asprintf "%a" pp saddr
let encoding =
let open Data_encoding in
def "p2p_point.id" ~description:"Identifier for a peer point"
@@ conv to_string of_string_exn string
let rpc_arg =
RPC_arg.make
~name:"point"
~descr:"A network point (ipv4:port or [ipv6]:port)."
~destruct:of_string
~construct:to_string
()
end
module Map = Map.Make (Id)
module Set = Set.Make (Id)
module Table = Hashtbl.Make (Id)
module Filter = struct
type t = Requested | Accepted | Running | Disconnected
let rpc_arg =
RPC_arg.make
~name:"p2p.point.state_filter"
~destruct:(function
| "requested" ->
Ok Requested
| "accepted" ->
Ok Accepted
| "running" ->
Ok Running
| "disconnected" ->
Ok Disconnected
| s ->
Error (Format.asprintf "Invalid state: %s" s))
~construct:(function
| Requested ->
"requested"
| Accepted ->
"accepted"
| Running ->
"running"
| Disconnected ->
"disconnected")
()
end
module State = struct
type t =
| Requested
| Accepted of P2p_peer_id.t
| Running of P2p_peer_id.t
| Disconnected
let of_p2p_peer_id = function
| Requested ->
None
| Accepted pi ->
Some pi
| Running pi ->
Some pi
| Disconnected ->
None
let of_peerid_state state pi =
match (state, pi) with
| (Requested, _) ->
Requested
| (Accepted _, Some pi) ->
Accepted pi
| (Running _, Some pi) ->
Running pi
| (Disconnected, _) ->
Disconnected
| _ ->
invalid_arg "state_of_state_peerid"
let pp_digram ppf = function
| Requested ->
Format.fprintf ppf "â"
| Accepted _ ->
Format.fprintf ppf "â"
| Running _ ->
Format.fprintf ppf "â"
| Disconnected ->
Format.fprintf ppf "â"
let encoding =
let open Data_encoding in
let branch_encoding name obj =
conv
(fun x -> ((), x))
(fun ((), x) -> x)
(merge_objs (obj1 (req "event_kind" (constant name))) obj)
in
def
"p2p_point.state"
~description:
"The state a connection to a peer point can be in: requested \
(connection open from here), accepted (handshake), running \
(connection already established), disconnected (no connection)."
@@ union
~tag_size:`Uint8
[ case
(Tag 0)
~title:"Requested"
(branch_encoding "requested" empty)
(function Requested -> Some () | _ -> None)
(fun () -> Requested);
case
(Tag 1)
~title:"Accepted"
(branch_encoding
"accepted"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function Accepted p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Accepted p2p_peer_id);
case
(Tag 2)
~title:"Running"
(branch_encoding
"running"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function Running p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Running p2p_peer_id);
case
(Tag 3)
~title:"Disconnected"
(branch_encoding "disconnected" empty)
(function Disconnected -> Some () | _ -> None)
(fun () -> Disconnected) ]
let raw_filter (f : Filter.t) (s : t) =
match (f, s) with
| (Requested, Requested) ->
true
| (Requested, (Accepted _ | Running _ | Disconnected))
| ((Accepted | Running | Disconnected), Requested) ->
false
| (Accepted, Accepted _) ->
true
| (Accepted, (Running _ | Disconnected))
| ((Running | Disconnected), Accepted _) ->
false
| (Running, Running _) ->
true
| (Disconnected, Disconnected) ->
true
| (Running, Disconnected) | (Disconnected, Running _) ->
false
let filter filters state = List.exists (fun f -> raw_filter f state) filters
end
module Info = struct
type t = {
trusted : bool;
greylisted_until : Time.System.t;
state : State.t;
last_failed_connection : Time.System.t option;
last_rejected_connection : (P2p_peer_id.t * Time.System.t) option;
last_established_connection : (P2p_peer_id.t * Time.System.t) option;
last_disconnection : (P2p_peer_id.t * Time.System.t) option;
last_seen : (P2p_peer_id.t * Time.System.t) option;
last_miss : Time.System.t option;
}
let encoding =
let open Data_encoding in
def
"p2p_point.info"
~description:
"Information about a peer point. Includes flags, state, and records \
about past events."
@@ conv
(fun { trusted;
greylisted_until;
state;
last_failed_connection;
last_rejected_connection;
last_established_connection;
last_disconnection;
last_seen;
last_miss } ->
let p2p_peer_id = State.of_p2p_peer_id state in
( trusted,
greylisted_until,
state,
p2p_peer_id,
last_failed_connection,
last_rejected_connection,
last_established_connection,
last_disconnection,
last_seen,
last_miss ))
(fun ( trusted,
greylisted_until,
state,
p2p_peer_id,
last_failed_connection,
last_rejected_connection,
last_established_connection,
last_disconnection,
last_seen,
last_miss ) ->
let state = State.of_peerid_state state p2p_peer_id in
{
trusted;
greylisted_until;
state;
last_failed_connection;
last_rejected_connection;
last_established_connection;
last_disconnection;
last_seen;
last_miss;
})
(obj10
(req "trusted" bool)
(dft "greylisted_until" Time.System.encoding Time.System.epoch)
(req "state" State.encoding)
(opt "p2p_peer_id" P2p_peer_id.encoding)
(opt "last_failed_connection" Time.System.encoding)
(opt
"last_rejected_connection"
(tup2 P2p_peer_id.encoding Time.System.encoding))
(opt
"last_established_connection"
(tup2 P2p_peer_id.encoding Time.System.encoding))
(opt
"last_disconnection"
(tup2 P2p_peer_id.encoding Time.System.encoding))
(opt "last_seen" (tup2 P2p_peer_id.encoding Time.System.encoding))
(opt "last_miss" Time.System.encoding))
end
module Pool_event = struct
type kind =
| Outgoing_request
| Accepting_request of P2p_peer_id.t
| Rejecting_request of P2p_peer_id.t
| Request_rejected of P2p_peer_id.t option
| Connection_established of P2p_peer_id.t
| Disconnection of P2p_peer_id.t
| External_disconnection of P2p_peer_id.t
let kind_encoding =
let open Data_encoding in
let branch_encoding name obj =
conv
(fun x -> ((), x))
(fun ((), x) -> x)
(merge_objs (obj1 (req "event_kind" (constant name))) obj)
in
union
~tag_size:`Uint8
[ case
(Tag 0)
~title:"Outgoing_request"
(branch_encoding "outgoing_request" empty)
(function Outgoing_request -> Some () | _ -> None)
(fun () -> Outgoing_request);
case
(Tag 1)
~title:"Accepting_request"
(branch_encoding
"accepting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function
| Accepting_request p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Accepting_request p2p_peer_id);
case
(Tag 2)
~title:"Rejecting_request"
(branch_encoding
"rejecting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function
| Rejecting_request p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Rejecting_request p2p_peer_id);
case
(Tag 3)
~title:"Rejecting_rejected"
(branch_encoding
"request_rejected"
(obj1 (opt "p2p_peer_id" P2p_peer_id.encoding)))
(function
| Request_rejected p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Request_rejected p2p_peer_id);
case
(Tag 4)
~title:"Connection_established"
(branch_encoding
"rejecting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function
| Connection_established p2p_peer_id ->
Some p2p_peer_id
| _ ->
None)
(fun p2p_peer_id -> Connection_established p2p_peer_id);
case
(Tag 5)
~title:"Disconnection"
(branch_encoding
"rejecting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function
| Disconnection p2p_peer_id -> Some p2p_peer_id | _ -> None)
(fun p2p_peer_id -> Disconnection p2p_peer_id);
case
(Tag 6)
~title:"External_disconnection"
(branch_encoding
"rejecting_request"
(obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
(function
| External_disconnection p2p_peer_id ->
Some p2p_peer_id
| _ ->
None)
(fun p2p_peer_id -> External_disconnection p2p_peer_id) ]
type t = kind Time.System.stamped
let encoding =
Data_encoding.def
"p2p_point.pool_event"
~description:
"Events happening during maintenance of and operations on a peer \
point pool (such as connections, disconnections, connection \
requests)."
@@ Time.System.stamped_encoding kind_encoding
end
let () =
Data_encoding.Registration.register ~pp:Id.pp Id.encoding ;
Data_encoding.Registration.register ~pp:State.pp_digram State.encoding ;
Data_encoding.Registration.register Info.encoding ;
Data_encoding.Registration.register Pool_event.encoding
src/lib_base/p2p_point.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Id.
Definition t := Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port.
Definition compare (function_parameter : Ipaddr.V6.t * Z)
: (Ipaddr.V6.t * Z) -> Z :=
let '(a1, p1) := function_parameter in
fun function_parameter =>
let '(a2, p2) := function_parameter in
match Ipaddr.V6.compare a1 a2 with
| 0 => Z.sub p1 p2
| x => x
end.
Definition equal (p1 : Ipaddr.V6.t * Z) (p2 : Ipaddr.V6.t * Z) : bool :=
equiv_decb (compare p1 p2) 0.
Definition hash {A : Type} : A -> Z := Hashtbl.hash.
Definition pp
(ppf : Stdlib.Format.formatter) (function_parameter : Ipaddr.V6.t * Z)
: unit :=
let '(addr, port) := function_parameter in
match Ipaddr.v4_of_v6 addr with
| Some addr =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))) "%a:%d" % string)
Ipaddr.V4.pp addr port
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "]:" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)))) "[%a]:%d" % string)
Ipaddr.V6.pp addr port
end.
Definition pp_opt
(ppf : Stdlib.Format.formatter)
(function_parameter : option (Ipaddr.V6.t * Z)) : unit :=
match function_parameter with
| None => Format.pp_print_string ppf "none" % string
| Some point => pp ppf point
end.
Definition pp_list
(ppf : Stdlib.Format.formatter) (point_list : list (Ipaddr.V6.t * Z))
: unit :=
Format.pp_print_list (Some Format.pp_print_space) pp ppf point_list.
Definition is_local {A : Type} (function_parameter : Ipaddr.V6.t * A)
: bool :=
let '(addr, _) := function_parameter in
Ipaddr.V6.is_private addr.
Definition is_global {A : Type} (function_parameter : Ipaddr.V6.t * A)
: bool :=
let '(addr, _) := function_parameter in
apply negb (Ipaddr.V6.is_private addr).
Definition check_port (port : string) : unit :=
if
orb (TzString.mem_char port "[" % char)
(orb (TzString.mem_char port "]" % char)
(TzString.mem_char port ":" % char)) then
OCaml.Stdlib.invalid_arg
"Utils.parse_addr_port (invalid character in port)" % string
else
tt.
Definition parse_addr_port (s : string) : string * string :=
let len := OCaml.String.length s in
if equiv_decb len 0 then
("" % string, "" % string)
else
if equiv_decb (Stdlib.String.get s 0) "[" % char then
match Stdlib.String.rindex_opt s "]" % char with
| None =>
OCaml.Stdlib.invalid_arg
"Utils.parse_addr_port (missing ']')" % string
| Some pos =>
let addr := Stdlib.String.sub s 1 (Z.sub pos 1) in
let port :=
if equiv_decb pos (Z.sub len 1) then
"" % string
else
if nequiv_decb (Stdlib.String.get s (Z.add pos 1)) ":" % char then
OCaml.Stdlib.invalid_arg
"Utils.parse_addr_port (unexpected char after ']')" % string
else
Stdlib.String.sub s (Z.add pos 2) (Z.sub (Z.sub len pos) 2) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := check_port port in
(addr, port)
end
else
match Stdlib.String.rindex_opt s "]" % char with
| Some _pos =>
OCaml.Stdlib.invalid_arg
"Utils.parse_addr_port (unexpected char ']')" % string
| None =>
let 'pos := Stdlib.String.index s ":" % char in
let '_pos := Stdlib.String.index_from s (Z.add pos 1) ":" % char in
OCaml.Stdlib.invalid_arg
"Utils.parse_addr_port: IPv6 addresses must be bracketed" % string
end.
Definition of_string_exn (default_port : option Z) (str : string)
: Ipaddr.V6.t * Z :=
let '(addr, port) := parse_addr_port str in
let port :=
if equiv_decb port "" % string then
Option.unopt_exn
(OCaml.Invalid_argument "P2p_point.of_string_exn: no port" % string)
default_port
else
OCaml.Stdlib.int_of_string port in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
andb (OCaml.Stdlib.lt port 0)
(OCaml.Stdlib.gt port (Z.sub (Z.shiftl 1 16) 1)) then
OCaml.Stdlib.invalid_arg "port must be between 0 and 65535" % string
else
tt in
match Ipaddr.of_string_exn addr with
| Ipaddr.V4 addr => ((Ipaddr.v6_of_v4 addr), port)
| Ipaddr.V6 addr => (addr, port)
end.
Definition of_string (default_port : option Z) (str : string)
: sum (Ipaddr.V6.t * Z) string :=
(* ❌ Try-with are not handled *)
try (Stdlib.Ok (of_string_exn default_port str)).
Definition to_string (saddr : Ipaddr.V6.t * Z) : string :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) pp saddr.
Definition encoding
: Tezos_data_encoding.Data_encoding.encoding (Ipaddr.V6.t * Z) :=
apply
(let arg :=
def "p2p_point.id" % string
(* ❌ expected an argument *)
expected_argument (Some "Identifier for a peer point" % string) in
fun eta => arg None eta)
(conv to_string
(let arg := of_string_exn in
fun eta => arg None eta) None string).
Definition rpc_arg : Tezos_rpc.RPC_arg.arg (Ipaddr.V6.t * Z) :=
RPC_arg.make (Some "A network point (ipv4:port or [ipv6]:port)." % string)
"point" % string
(let arg := of_string in
fun eta => arg None eta) to_string tt.
End Id.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Module Filter.
Inductive t : Type :=
| Requested : t
| Accepted : t
| Running : t
| Disconnected : t.
Definition rpc_arg : Tezos_rpc.RPC_arg.arg t :=
RPC_arg.make None "p2p.point.state_filter" % string
(fun function_parameter =>
match function_parameter with
| "requested" % string => Stdlib.Ok Requested
| "accepted" % string => Stdlib.Ok Accepted
| "running" % string => Stdlib.Ok Running
| "disconnected" % string => Stdlib.Ok Disconnected
| s =>
Stdlib.Error
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid state: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Invalid state: %s" % string) s)
end)
(fun function_parameter =>
match function_parameter with
| Requested => "requested" % string
| Accepted => "accepted" % string
| Running => "running" % string
| Disconnected => "disconnected" % string
end) tt.
End Filter.
Module State.
Inductive t : Type :=
| Requested : t
| Accepted : Tezos_base.P2p_peer_id.t -> t
| Running : Tezos_base.P2p_peer_id.t -> t
| Disconnected : t.
Definition of_p2p_peer_id (function_parameter : t)
: option Tezos_base.P2p_peer_id.t :=
match function_parameter with
| Requested => None
| Accepted pi => Some pi
| Running pi => Some pi
| Disconnected => None
end.
Definition of_peerid_state (state : t) (pi : option Tezos_base.P2p_peer_id.t)
: t :=
match (state, pi) with
| (Requested, _) => Requested
| (Accepted _, Some pi) => Accepted pi
| (Running _, Some pi) => Running pi
| (Disconnected, _) => Disconnected
| _ => OCaml.Stdlib.invalid_arg "state_of_state_peerid" % string
end.
Definition pp_digram (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
match function_parameter with
| Requested =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "⚎" % string
CamlinternalFormatBasics.End_of_format) "⚎" % string)
| Accepted _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "⚍" % string
CamlinternalFormatBasics.End_of_format) "⚍" % string)
| Running _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "⚌" % string
CamlinternalFormatBasics.End_of_format) "⚌" % string)
| Disconnected =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "⚏" % string
CamlinternalFormatBasics.End_of_format) "⚏" % string)
end.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
let branch_encoding {A : Type}
(name : string) (obj : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding A :=
conv (fun x => (tt, x))
(fun function_parameter =>
let '(tt, x) := function_parameter in
x) None
(merge_objs (obj1 (req None None "event_kind" % string (constant name)))
obj) in
apply
(let arg :=
def "p2p_point.state" % string
(* ❌ expected an argument *)
expected_argument
(Some
"The state a connection to a peer point can be in: requested (connection open from here), accepted (handshake), running (connection already established), disconnected (no connection)."
% string) in
fun eta => arg None eta)
(union
(Some
(* ❌ Variants not supported *)
variant)
(cons
(case "Requested" % string None
(Tezos_data_encoding.Data_encoding.Tag 0)
(branch_encoding "requested" % string empty)
(fun function_parameter =>
match function_parameter with
| Requested => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Requested))
(cons
(case "Accepted" % string None
(Tezos_data_encoding.Data_encoding.Tag 1)
(branch_encoding "accepted" % string
(obj1
(req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Accepted p2p_peer_id => Some p2p_peer_id
| _ => None
end) (fun p2p_peer_id => Accepted p2p_peer_id))
(cons
(case "Running" % string None
(Tezos_data_encoding.Data_encoding.Tag 2)
(branch_encoding "running" % string
(obj1
(req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Running p2p_peer_id => Some p2p_peer_id
| _ => None
end) (fun p2p_peer_id => Running p2p_peer_id))
(cons
(case "Disconnected" % string None
(Tezos_data_encoding.Data_encoding.Tag 3)
(branch_encoding "disconnected" % string empty)
(fun function_parameter =>
match function_parameter with
| Disconnected => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Disconnected)) []))))).
Definition raw_filter (f : Filter.t) (s : t) : bool :=
match (f, s) with
| (Filter.Requested, Requested) => true
|
(Filter.Requested, Accepted _ | Running _ | Disconnected) |
(Filter.Accepted | Filter.Running | Filter.Disconnected, Requested) =>
false
| (Filter.Accepted, Accepted _) => true
|
(Filter.Accepted, Running _ | Disconnected) |
(Filter.Running | Filter.Disconnected, Accepted _) => false
| (Filter.Running, Running _) => true
| (Filter.Disconnected, Disconnected) => true
| (Filter.Running, Disconnected) | (Filter.Disconnected, Running _) => false
end.
Definition filter (filters : list Filter.t) (state : t) : bool :=
Stdlib.List._exists (fun f => raw_filter f state) filters.
End State.
Module Info.
Record t := {
trusted : bool;
greylisted_until : Tezos_base.Time.System.t;
state : State.t;
last_failed_connection : option Tezos_base.Time.System.t;
last_rejected_connection :
option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
last_established_connection :
option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
last_disconnection :
option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
last_seen : option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
last_miss : option Tezos_base.Time.System.t }.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "p2p_point.info" % string
(* ❌ expected an argument *)
expected_argument
(Some
"Information about a peer point. Includes flags, state, and records about past events."
% string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{|
trusted := trusted;
greylisted_until := greylisted_until;
state := state;
last_failed_connection := last_failed_connection;
last_rejected_connection := last_rejected_connection;
last_established_connection := last_established_connection;
last_disconnection := last_disconnection;
last_seen := last_seen;
last_miss := last_miss
|} := function_parameter in
let p2p_peer_id := State.of_p2p_peer_id state in
(trusted, greylisted_until, state, p2p_peer_id,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection, last_seen,
last_miss))
(fun function_parameter =>
let
'(trusted, greylisted_until, state, p2p_peer_id,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection, last_seen,
last_miss) := function_parameter in
let state := State.of_peerid_state state p2p_peer_id in
{| trusted := trusted; greylisted_until := greylisted_until;
state := state; last_failed_connection := last_failed_connection;
last_rejected_connection := last_rejected_connection;
last_established_connection := last_established_connection;
last_disconnection := last_disconnection; last_seen := last_seen;
last_miss := last_miss |}) None
(obj10 (req None None "trusted" % string bool)
(dft None None "greylisted_until" % string Time.System.encoding
Time.System.epoch) (req None None "state" % string State.encoding)
(opt None None "p2p_peer_id" % string P2p_peer_id.encoding)
(opt None None "last_failed_connection" % string Time.System.encoding)
(opt None None "last_rejected_connection" % string
(tup2 P2p_peer_id.encoding Time.System.encoding))
(opt None None "last_established_connection" % string
(tup2 P2p_peer_id.encoding Time.System.encoding))
(opt None None "last_disconnection" % string
(tup2 P2p_peer_id.encoding Time.System.encoding))
(opt None None "last_seen" % string
(tup2 P2p_peer_id.encoding Time.System.encoding))
(opt None None "last_miss" % string Time.System.encoding))).
End Info.
Module Pool_event.
Inductive kind : Type :=
| Outgoing_request : kind
| Accepting_request : Tezos_base.P2p_peer_id.t -> kind
| Rejecting_request : Tezos_base.P2p_peer_id.t -> kind
| Request_rejected : (option Tezos_base.P2p_peer_id.t) -> kind
| Connection_established : Tezos_base.P2p_peer_id.t -> kind
| Disconnection : Tezos_base.P2p_peer_id.t -> kind
| External_disconnection : Tezos_base.P2p_peer_id.t -> kind.
Definition kind_encoding : Tezos_data_encoding.Data_encoding.encoding kind :=
let branch_encoding {A : Type}
(name : string) (obj : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding A :=
conv (fun x => (tt, x))
(fun function_parameter =>
let '(tt, x) := function_parameter in
x) None
(merge_objs (obj1 (req None None "event_kind" % string (constant name)))
obj) in
union
(Some
(* ❌ Variants not supported *)
variant)
(cons
(case "Outgoing_request" % string None
(Tezos_data_encoding.Data_encoding.Tag 0)
(branch_encoding "outgoing_request" % string empty)
(fun function_parameter =>
match function_parameter with
| Outgoing_request => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Outgoing_request))
(cons
(case "Accepting_request" % string None
(Tezos_data_encoding.Data_encoding.Tag 1)
(branch_encoding "accepting_request" % string
(obj1 (req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Accepting_request p2p_peer_id => Some p2p_peer_id
| _ => None
end) (fun p2p_peer_id => Accepting_request p2p_peer_id))
(cons
(case "Rejecting_request" % string None
(Tezos_data_encoding.Data_encoding.Tag 2)
(branch_encoding "rejecting_request" % string
(obj1
(req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Rejecting_request p2p_peer_id => Some p2p_peer_id
| _ => None
end) (fun p2p_peer_id => Rejecting_request p2p_peer_id))
(cons
(case "Rejecting_rejected" % string None
(Tezos_data_encoding.Data_encoding.Tag 3)
(branch_encoding "request_rejected" % string
(obj1
(opt None None "p2p_peer_id" % string P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Request_rejected p2p_peer_id => Some p2p_peer_id
| _ => None
end) (fun p2p_peer_id => Request_rejected p2p_peer_id))
(cons
(case "Connection_established" % string None
(Tezos_data_encoding.Data_encoding.Tag 4)
(branch_encoding "rejecting_request" % string
(obj1
(req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Connection_established p2p_peer_id => Some p2p_peer_id
| _ => None
end) (fun p2p_peer_id => Connection_established p2p_peer_id))
(cons
(case "Disconnection" % string None
(Tezos_data_encoding.Data_encoding.Tag 5)
(branch_encoding "rejecting_request" % string
(obj1
(req None None "p2p_peer_id" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| Disconnection p2p_peer_id => Some p2p_peer_id
| _ => None
end) (fun p2p_peer_id => Disconnection p2p_peer_id))
(cons
(case "External_disconnection" % string None
(Tezos_data_encoding.Data_encoding.Tag 6)
(branch_encoding "rejecting_request" % string
(obj1
(req None None "p2p_peer_id" % string
P2p_peer_id.encoding)))
(fun function_parameter =>
match function_parameter with
| External_disconnection p2p_peer_id => Some p2p_peer_id
| _ => None
end)
(fun p2p_peer_id => External_disconnection p2p_peer_id))
[]))))))).
Definition t := Tezos_base.Time.System.stamped kind.
Definition encoding
: Tezos_data_encoding.Data_encoding.encoding
(Tezos_base.Time.System.stamped kind) :=
apply
(let arg :=
Data_encoding.def "p2p_point.pool_event" % string
(* ❌ expected an argument *)
expected_argument
(Some
"Events happening during maintenance of and operations on a peer point pool (such as connections, disconnections, connection requests)."
% string) in
fun eta => arg None eta) (Time.System.stamped_encoding kind_encoding).
End Pool_event.
src/lib_base/p2p_stat.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {
total_sent : int64;
total_recv : int64;
current_inflow : int;
current_outflow : int;
}
let empty =
{total_sent = 0L; total_recv = 0L; current_inflow = 0; current_outflow = 0}
let print_size ppf sz =
let ratio n = float_of_int sz /. float_of_int (1 lsl n) in
if sz < 1 lsl 10 then Format.fprintf ppf "%d B" sz
else if sz < 1 lsl 20 then Format.fprintf ppf "%.2f kiB" (ratio 10)
else Format.fprintf ppf "%.2f MiB" (ratio 20)
let print_size64 ppf sz =
let open Int64 in
let ratio n = to_float sz /. float_of_int (1 lsl n) in
if sz < shift_left 1L 10 then Format.fprintf ppf "%Ld B" sz
else if sz < shift_left 1L 20 then Format.fprintf ppf "%.2f kiB" (ratio 10)
else if sz < shift_left 1L 30 then Format.fprintf ppf "%.2f MiB" (ratio 20)
else if sz < shift_left 1L 40 then Format.fprintf ppf "%.2f GiB" (ratio 30)
else Format.fprintf ppf "%.2f TiB" (ratio 40)
let pp ppf stat =
Format.fprintf
ppf
"â %a (%a/s) â %a (%a/s)"
print_size64
stat.total_sent
print_size
stat.current_outflow
print_size64
stat.total_recv
print_size
stat.current_inflow
let encoding =
let open Data_encoding in
def "p2p_stat" ~description:"Statistics about the p2p network."
@@ conv
(fun {total_sent; total_recv; current_inflow; current_outflow} ->
(total_sent, total_recv, current_inflow, current_outflow))
(fun (total_sent, total_recv, current_inflow, current_outflow) ->
{total_sent; total_recv; current_inflow; current_outflow})
(obj4
(req "total_sent" int64)
(req "total_recv" int64)
(req "current_inflow" int31)
(req "current_outflow" int31))
let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/p2p_stat.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record t := {
total_sent : int64;
total_recv : int64;
current_inflow : Z;
current_outflow : Z }.
Definition empty : t :=
{|
total_sent :=
(* ❌ Constant of type int64 is converted to int *)
0;
total_recv :=
(* ❌ Constant of type int64 is converted to int *)
0; current_inflow := 0; current_outflow := 0 |}.
Definition print_size (ppf : Stdlib.Format.formatter) (sz : Z) : unit :=
let ratio (n : Z) : Z :=
Stdlib.op_divpoint (Stdlib.float_of_int sz)
(Stdlib.float_of_int (Z.shiftl 1 n)) in
if OCaml.Stdlib.lt sz (Z.shiftl 1 10) then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " B" % string
CamlinternalFormatBasics.End_of_format)) "%d B" % string) sz
else
if OCaml.Stdlib.lt sz (Z.shiftl 1 20) then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal " kiB" % string
CamlinternalFormatBasics.End_of_format)) "%.2f kiB" % string)
(ratio 10)
else
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal " MiB" % string
CamlinternalFormatBasics.End_of_format)) "%.2f MiB" % string)
(ratio 20).
Definition print_size64 (ppf : Stdlib.Format.formatter) (sz : int64) : unit :=
let ratio (n : Z) : Z :=
Stdlib.op_divpoint (to_float sz) (Stdlib.float_of_int (Z.shiftl 1 n)) in
if
OCaml.Stdlib.lt sz
(shift_left
(* ❌ Constant of type int64 is converted to int *)
1 10) then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int64 CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " B" % string
CamlinternalFormatBasics.End_of_format)) "%Ld B" % string) sz
else
if
OCaml.Stdlib.lt sz
(shift_left
(* ❌ Constant of type int64 is converted to int *)
1 20) then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal " kiB" % string
CamlinternalFormatBasics.End_of_format)) "%.2f kiB" % string)
(ratio 10)
else
if
OCaml.Stdlib.lt sz
(shift_left
(* ❌ Constant of type int64 is converted to int *)
1 30) then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal " MiB" % string
CamlinternalFormatBasics.End_of_format)) "%.2f MiB" % string)
(ratio 20)
else
if
OCaml.Stdlib.lt sz
(shift_left
(* ❌ Constant of type int64 is converted to int *)
1 40) then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal " GiB" % string
CamlinternalFormatBasics.End_of_format)) "%.2f GiB" % string)
(ratio 30)
else
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal " TiB" % string
CamlinternalFormatBasics.End_of_format)) "%.2f TiB" % string)
(ratio 40).
Definition pp (ppf : Stdlib.Format.formatter) (stat : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "↗ " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "/s) ↘ " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "/s)" % string
CamlinternalFormatBasics.End_of_format)))))))))
"↗ %a (%a/s) ↘ %a (%a/s)" % string) print_size64 (total_sent stat)
print_size (current_outflow stat) print_size64 (total_recv stat) print_size
(current_inflow stat).
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "p2p_stat" % string
(* ❌ expected an argument *)
expected_argument (Some "Statistics about the p2p network." % string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{|
total_sent := total_sent;
total_recv := total_recv;
current_inflow := current_inflow;
current_outflow := current_outflow
|} := function_parameter in
(total_sent, total_recv, current_inflow, current_outflow))
(fun function_parameter =>
let '(total_sent, total_recv, current_inflow, current_outflow) :=
function_parameter in
{| total_sent := total_sent; total_recv := total_recv;
current_inflow := current_inflow; current_outflow := current_outflow
|}) None
(obj4 (req None None "total_sent" % string int64)
(req None None "total_recv" % string int64)
(req None None "current_inflow" % string int31)
(req None None "current_outflow" % string int31))).
src/lib_base/p2p_version.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) type t = int let pp = Format.pp_print_int let encoding = let open Data_encoding in def "p2p_version" ~description:"A version number for the p2p layer." uint16 let zero = 0 let supported = [zero] let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/p2p_version.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := Z.
Definition pp : Stdlib.Format.formatter -> Z -> unit := Format.pp_print_int.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding Z :=
def "p2p_version" % string None
(Some "A version number for the p2p layer." % string) uint16.
Definition zero : Z := 0.
Definition supported : list Z := cons zero [].
src/lib_base/preapply_result.ml 23 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type 'error t = {
applied : (Operation_hash.t * Operation.t) list;
refused : (Operation.t * 'error list) Operation_hash.Map.t;
branch_refused : (Operation.t * 'error list) Operation_hash.Map.t;
branch_delayed : (Operation.t * 'error list) Operation_hash.Map.t;
}
let empty =
{
applied = [];
refused = Operation_hash.Map.empty;
branch_refused = Operation_hash.Map.empty;
branch_delayed = Operation_hash.Map.empty;
}
let map f r =
{
applied = r.applied;
refused = Operation_hash.Map.map f r.refused;
branch_refused = Operation_hash.Map.map f r.branch_refused;
branch_delayed = Operation_hash.Map.map f r.branch_delayed;
}
let encoding error_encoding =
let open Data_encoding in
let operation_encoding =
merge_objs
(obj1 (req "hash" Operation_hash.encoding))
(dynamic_size Operation.encoding)
in
let refused_encoding =
merge_objs
(obj1 (req "hash" Operation_hash.encoding))
(merge_objs
(dynamic_size Operation.encoding)
(obj1 (req "error" error_encoding)))
in
let build_list map = Operation_hash.Map.bindings map in
let build_map list =
List.fold_right
(fun (k, e) m -> Operation_hash.Map.add k e m)
list
Operation_hash.Map.empty
in
conv
(fun {applied; refused; branch_refused; branch_delayed} ->
( applied,
build_list refused,
build_list branch_refused,
build_list branch_delayed ))
(fun (applied, refused, branch_refused, branch_delayed) ->
let refused = build_map refused in
let branch_refused = build_map branch_refused in
let branch_delayed = build_map branch_delayed in
{applied; refused; branch_refused; branch_delayed})
(obj4
(req "applied" (list operation_encoding))
(req "refused" (list refused_encoding))
(req "branch_refused" (list refused_encoding))
(req "branch_delayed" (list refused_encoding)))
let operations t =
let ops =
List.fold_left
(fun acc (h, op) -> Operation_hash.Map.add h op acc)
Operation_hash.Map.empty
t.applied
in
let ops =
Operation_hash.Map.fold
(fun h (op, _err) acc -> Operation_hash.Map.add h op acc)
t.branch_delayed
ops
in
let ops =
Operation_hash.Map.fold
(fun h (op, _err) acc -> Operation_hash.Map.add h op acc)
t.branch_refused
ops
in
ops
src/lib_base/preapply_result.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record t {error : Type} := {
applied : list (Tezos_crypto.Operation_hash.t * Tezos_base.Operation.t);
refused :
Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error));
branch_refused :
Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error));
branch_delayed :
Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error)) }.
Arguments t : clear implicits.
Definition empty {A : Type} : t A :=
{| applied := []; refused := Operation_hash.Map.empty;
branch_refused := Operation_hash.Map.empty;
branch_delayed := Operation_hash.Map.empty |}.
Definition map {A B : Type}
(f : (Tezos_base.Operation.t * (list A)) -> Tezos_base.Operation.t * (list B))
(r : t A) : t B :=
{| applied := applied r; refused := Operation_hash.Map.map f (refused r);
branch_refused := Operation_hash.Map.map f (branch_refused r);
branch_delayed := Operation_hash.Map.map f (branch_delayed r) |}.
Definition encoding {A : Type}
(error_encoding : Tezos_data_encoding.Data_encoding.encoding (list A))
: Tezos_data_encoding.Data_encoding.encoding (t A) :=
let operation_encoding :=
merge_objs (obj1 (req None None "hash" % string Operation_hash.encoding))
(dynamic_size None Operation.encoding) in
let refused_encoding :=
merge_objs (obj1 (req None None "hash" % string Operation_hash.encoding))
(merge_objs (dynamic_size None Operation.encoding)
(obj1 (req None None "error" % string error_encoding))) in
let build_list {B : Type} (map : Tezos_crypto.Operation_hash.Map.t B)
: list (Tezos_crypto.Operation_hash.Map.key * B) :=
Operation_hash.Map.bindings map in
let build_map {B : Type}
(list : list (Tezos_crypto.Operation_hash.Map.key * B))
: Tezos_crypto.Operation_hash.Map.t B :=
Stdlib.List.fold_right
(fun function_parameter =>
let '(k, e) := function_parameter in
fun m => Operation_hash.Map.add k e m) list Operation_hash.Map.empty in
conv
(fun function_parameter =>
let '{|
applied := applied;
refused := refused;
branch_refused := branch_refused;
branch_delayed := branch_delayed
|} := function_parameter in
(applied, (build_list refused), (build_list branch_refused),
(build_list branch_delayed)))
(fun function_parameter =>
let '(applied, refused, branch_refused, branch_delayed) :=
function_parameter in
let refused := build_map refused in
let branch_refused := build_map branch_refused in
let branch_delayed := build_map branch_delayed in
{| applied := applied; refused := refused;
branch_refused := branch_refused; branch_delayed := branch_delayed |})
None
(obj4 (req None None "applied" % string (list None operation_encoding))
(req None None "refused" % string (list None refused_encoding))
(req None None "branch_refused" % string (list None refused_encoding))
(req None None "branch_delayed" % string (list None refused_encoding))).
Definition operations {A : Type} (t : t A)
: Tezos_crypto.Operation_hash.Map.t Tezos_base.Operation.t :=
let ops :=
Stdlib.List.fold_left
(fun acc =>
fun function_parameter =>
let '(h, op) := function_parameter in
Operation_hash.Map.add h op acc) Operation_hash.Map.empty (applied t)
in
let ops :=
Operation_hash.Map.fold
(fun h =>
fun function_parameter =>
let '(op, _err) := function_parameter in
fun acc => Operation_hash.Map.add h op acc) (branch_delayed t) ops in
let ops :=
Operation_hash.Map.fold
(fun h =>
fun function_parameter =>
let '(op, _err) := function_parameter in
fun acc => Operation_hash.Map.add h op acc) (branch_refused t) ops in
ops.
src/lib_base/protocol.ml 10 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {expected_env : env_version; components : component list}
and component = {
name : string;
interface : string option;
implementation : string;
}
and env_version = V1
include Compare.Make (struct
type nonrec t = t
let compare = Pervasives.compare
end)
let component_encoding =
let open Data_encoding in
conv
(fun {name; interface; implementation} ->
(name, interface, implementation))
(fun (name, interface, implementation) ->
{name; interface; implementation})
(obj3
(req "name" string)
(opt "interface" string)
(req "implementation" string))
let env_version_encoding =
let open Data_encoding in
conv
(function V1 -> 0)
(function 0 -> V1 | _ -> failwith "unexpected environment version")
int16
let encoding =
let open Data_encoding in
def
"protocol"
~description:
"The environment a protocol relies on and the components a protocol is \
made of."
@@ conv
(fun {expected_env; components} -> (expected_env, components))
(fun (expected_env, components) -> {expected_env; components})
(obj2
(req "expected_env_version" env_version_encoding)
(req "components" (list component_encoding)))
let bounded_encoding ?max_size () =
match max_size with
| None ->
encoding
| Some max_size ->
Data_encoding.check_size max_size encoding
let pp ppf op =
Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding op)
let env_version_to_string = function V1 -> "V1"
let pp_ocaml_component ppf {name; interface; implementation} =
Format.fprintf
ppf
"@[{@[<v 1> name = %S ;@ interface = %a ;@ implementation = %S ;@]@ }@]"
name
(fun ppf -> function None -> Format.fprintf ppf "None" | Some s ->
Format.fprintf ppf "Some %S" s)
interface
implementation
let pp_ocaml ppf {expected_env; components} =
Format.fprintf
ppf
"@[{@[<v 1> expected_env = %s ;@ components = [@[<v>%a@]] ;@]@ }@]"
(env_version_to_string expected_env)
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf " ;@ ")
pp_ocaml_component)
components
let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v
let of_bytes b = Data_encoding.Binary.of_bytes encoding b
let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b
let hash proto = Protocol_hash.hash_bytes [to_bytes proto]
let hash_raw proto = Protocol_hash.hash_bytes [proto]
module Meta = struct
type t = {
hash : Protocol_hash.t option;
expected_env_version : env_version option;
modules : string list;
}
let encoding =
let open Data_encoding in
def "protocol.meta"
(* FIXME: add ~description argument *)
@@ conv
(fun {hash; expected_env_version; modules} ->
(hash, expected_env_version, modules))
(fun (hash, expected_env_version, modules) ->
{hash; expected_env_version; modules})
@@ obj3
(opt
"hash"
~description:"Used to force the hash of the protocol"
Protocol_hash.encoding)
(opt "expected_env_version" env_version_encoding)
(req
"modules"
~description:"Modules comprising the protocol"
(list string))
end
let () =
Data_encoding.Registration.register ~pp:pp_ocaml encoding ;
Data_encoding.Registration.register Meta.encoding
src/lib_base/protocol.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive env_version : Type :=
| V1 : env_version.
(* ❌ Structure item `include` not handled. *)
include
Definition component_encoding
: Tezos_data_encoding.Data_encoding.encoding component :=
conv
(fun function_parameter =>
let '{|
name := name;
interface := interface;
implementation := implementation
|} := function_parameter in
(name, interface, implementation))
(fun function_parameter =>
let '(name, interface, implementation) := function_parameter in
{| name := name; interface := interface; implementation := implementation
|}) None
(obj3 (req None None "name" % string string)
(opt None None "interface" % string string)
(req None None "implementation" % string string)).
Definition env_version_encoding
: Tezos_data_encoding.Data_encoding.encoding env_version :=
conv
(fun function_parameter =>
let 'V1 := function_parameter in
0)
(fun function_parameter =>
match function_parameter with
| 0 => V1
| _ => OCaml.Stdlib.failwith "unexpected environment version" % string
end) None int16.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "protocol" % string
(* ❌ expected an argument *)
expected_argument
(Some
"The environment a protocol relies on and the components a protocol is made of."
% string) in
fun eta => arg None eta)
(conv
(fun function_parameter =>
let '{| expected_env := expected_env; components := components |} :=
function_parameter in
(expected_env, components))
(fun function_parameter =>
let '(expected_env, components) := function_parameter in
{| expected_env := expected_env; components := components |}) None
(obj2 (req None None "expected_env_version" % string env_version_encoding)
(req None None "components" % string (list None component_encoding)))).
Definition bounded_encoding (max_size : option Z) (function_parameter : unit)
: Tezos_data_encoding.Data_encoding.encoding t :=
let 'tt := function_parameter in
match max_size with
| None => encoding
| Some max_size => Data_encoding.check_size max_size encoding
end.
Definition pp (ppf : Stdlib.Format.formatter) (op : t) : unit :=
Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding op).
Definition env_version_to_string (function_parameter : env_version) : string :=
let 'V1 := function_parameter in
"V1" % string.
Definition pp_ocaml_component
(ppf : Stdlib.Format.formatter) (function_parameter : component) : unit :=
let '{|
name := name;
interface := interface;
implementation := implementation
|} := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Char_literal "{" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 1>" % string
CamlinternalFormatBasics.End_of_format) "<v 1>" % string))
(CamlinternalFormatBasics.String_literal " name = " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " ;" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"interface = " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " ;" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"implementation = " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" ;" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Char_literal
"}" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))))))
"@[{@[<v 1> name = %S ;@ interface = %a ;@ implementation = %S ;@]@ }@]" %
string) name
(fun ppf =>
fun function_parameter =>
match function_parameter with
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "None" % string
CamlinternalFormatBasics.End_of_format) "None" % string)
| Some s =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Some " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "Some %S" % string) s
end) interface implementation.
Definition pp_ocaml (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
let '{| expected_env := expected_env; components := components |} :=
function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Char_literal "{" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 1>" % string
CamlinternalFormatBasics.End_of_format) "<v 1>" % string))
(CamlinternalFormatBasics.String_literal " expected_env = " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " ;" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"components = [" % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v>" % string
CamlinternalFormatBasics.End_of_format)
"<v>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.String_literal
"] ;" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string
1 0)
(CamlinternalFormatBasics.Char_literal
"}" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))))
"@[{@[<v 1> expected_env = %s ;@ components = [@[<v>%a@]] ;@]@ }@]" %
string) (env_version_to_string expected_env)
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal " ;" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
CamlinternalFormatBasics.End_of_format)) " ;@ " % string)))
pp_ocaml_component) components.
Definition to_bytes (v : t) : Stdlib.Bytes.t :=
Data_encoding.Binary.to_bytes_exn encoding v.
Definition of_bytes (b : Stdlib.Bytes.t) : option t :=
Data_encoding.Binary.of_bytes encoding b.
Definition of_bytes_exn (b : Stdlib.Bytes.t) : t :=
Data_encoding.Binary.of_bytes_exn encoding b.
Definition hash (proto : t) : Tezos_crypto.Protocol_hash.t :=
Protocol_hash.hash_bytes None (cons (to_bytes proto) []).
Definition hash_raw (proto : Stdlib.Bytes.t) : Tezos_crypto.Protocol_hash.t :=
Protocol_hash.hash_bytes None (cons proto []).
Module Meta.
Record t := {
hash : option Tezos_crypto.Protocol_hash.t;
expected_env_version : option env_version;
modules : list string }.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg := def "protocol.meta" % string in
fun eta => arg None None eta)
(apply
(let arg :=
conv
(fun function_parameter =>
let '{|
hash := hash;
expected_env_version := expected_env_version;
modules := modules
|} := function_parameter in
(hash, expected_env_version, modules))
(fun function_parameter =>
let '(hash, expected_env_version, modules) := function_parameter
in
{| hash := hash; expected_env_version := expected_env_version;
modules := modules |}) in
fun eta => arg None eta)
(obj3
(opt None (Some "Used to force the hash of the protocol" % string)
"hash" % string Protocol_hash.encoding)
(opt None None "expected_env_version" % string env_version_encoding)
(req None (Some "Modules comprising the protocol" % string)
"modules" % string (list None string)))).
End Meta.
src/lib_base/s.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type T = sig
type t
include Compare.S with type t := t
val pp : Format.formatter -> t -> unit
val encoding : t Data_encoding.t
val to_bytes : t -> Bytes.t
val of_bytes : Bytes.t -> t option
end
module type HASHABLE = sig
include T
type hash
val hash : t -> hash
val hash_raw : Bytes.t -> hash
end
module type SET = sig
type elt
type t
val empty : t
val is_empty : t -> bool
val mem : elt -> t -> bool
val add : elt -> t -> t
val singleton : elt -> t
val remove : elt -> t -> t
val union : t -> t -> t
val inter : t -> t -> t
val diff : t -> t -> t
val compare : t -> t -> int
val equal : t -> t -> bool
val subset : t -> t -> bool
val iter : (elt -> unit) -> t -> unit
val map : (elt -> elt) -> t -> t
val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
val for_all : (elt -> bool) -> t -> bool
val exists : (elt -> bool) -> t -> bool
val filter : (elt -> bool) -> t -> t
val partition : (elt -> bool) -> t -> t * t
val cardinal : t -> int
val elements : t -> elt list
val min_elt_opt : t -> elt option
val max_elt_opt : t -> elt option
val choose_opt : t -> elt option
val split : elt -> t -> t * bool * t
val find_opt : elt -> t -> elt option
val find_first_opt : (elt -> bool) -> t -> elt option
val find_last_opt : (elt -> bool) -> t -> elt option
val of_list : elt list -> t
end
module type MAP = sig
type key
type +'a t
val empty : 'a t
val is_empty : 'a t -> bool
val mem : key -> 'a t -> bool
val add : key -> 'a -> 'a t -> 'a t
val update : key -> ('a option -> 'a option) -> 'a t -> 'a t
val singleton : key -> 'a -> 'a t
val remove : key -> 'a t -> 'a t
val merge :
(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
val iter : (key -> 'a -> unit) -> 'a t -> unit
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val for_all : (key -> 'a -> bool) -> 'a t -> bool
val exists : (key -> 'a -> bool) -> 'a t -> bool
val filter : (key -> 'a -> bool) -> 'a t -> 'a t
val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
val cardinal : 'a t -> int
val bindings : 'a t -> (key * 'a) list
val min_binding_opt : 'a t -> (key * 'a) option
val max_binding_opt : 'a t -> (key * 'a) option
val choose_opt : 'a t -> (key * 'a) option
val split : key -> 'a t -> 'a t * 'a option * 'a t
val find_opt : key -> 'a t -> 'a option
val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option
val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option
val map : ('a -> 'b) -> 'a t -> 'b t
val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
end
src/lib_base/s.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module T.
Record signature {t : Type} := {
t := t;
include;
pp : Stdlib.Format.formatter -> t -> unit;
encoding : Tezos_data_encoding.Data_encoding.t t;
to_bytes : t -> Stdlib.Bytes.t;
of_bytes : Stdlib.Bytes.t -> option t;
}.
Arguments signature : clear implicits.
End T.
Module HASHABLE.
Record signature {t hash : Type} := {
include;
hash := hash;
hash : t -> hash;
hash_raw : Stdlib.Bytes.t -> hash;
}.
Arguments signature : clear implicits.
End HASHABLE.
Module SET.
Record signature {elt t : Type} := {
elt := elt;
t := t;
empty : t;
is_empty : t -> bool;
mem : elt -> t -> bool;
add : elt -> t -> t;
singleton : elt -> t;
remove : elt -> t -> t;
union : t -> t -> t;
inter : t -> t -> t;
diff : t -> t -> t;
compare : t -> t -> Z;
equal : t -> t -> bool;
subset : t -> t -> bool;
iter : (elt -> unit) -> t -> unit;
map : (elt -> elt) -> t -> t;
fold : forall {a : Type}, (elt -> a -> a) -> t -> a -> a;
for_all : (elt -> bool) -> t -> bool;
_exists : (elt -> bool) -> t -> bool;
filter : (elt -> bool) -> t -> t;
partition : (elt -> bool) -> t -> t * t;
cardinal : t -> Z;
elements : t -> list elt;
min_elt_opt : t -> option elt;
max_elt_opt : t -> option elt;
choose_opt : t -> option elt;
split : elt -> t -> t * bool * t;
find_opt : elt -> t -> option elt;
find_first_opt : (elt -> bool) -> t -> option elt;
find_last_opt : (elt -> bool) -> t -> option elt;
of_list : (list elt) -> t;
}.
Arguments signature : clear implicits.
End SET.
Module MAP.
Record signature {key t : Type} := {
key := key;
polymorphic_abstract_type;
empty : forall {a : Type}, t a;
is_empty : forall {a : Type}, (t a) -> bool;
mem : forall {a : Type}, key -> (t a) -> bool;
add : forall {a : Type}, key -> a -> (t a) -> t a;
update : forall {a : Type}, key -> ((option a) -> option a) -> (t a) -> t a;
singleton : forall {a : Type}, key -> a -> t a;
remove : forall {a : Type}, key -> (t a) -> t a;
merge : forall {a b c : Type}, (key -> (option a) -> (option b) -> option c)
-> (t a) -> (t b) -> t c;
union : forall {a : Type}, (key -> a -> a -> option a) ->
(t a) -> (t a) -> t a;
compare : forall {a : Type}, (a -> a -> Z) -> (t a) -> (t a) -> Z;
equal : forall {a : Type}, (a -> a -> bool) -> (t a) -> (t a) -> bool;
iter : forall {a : Type}, (key -> a -> unit) -> (t a) -> unit;
fold : forall {a b : Type}, (key -> a -> b -> b) -> (t a) -> b -> b;
for_all : forall {a : Type}, (key -> a -> bool) -> (t a) -> bool;
_exists : forall {a : Type}, (key -> a -> bool) -> (t a) -> bool;
filter : forall {a : Type}, (key -> a -> bool) -> (t a) -> t a;
partition : forall {a : Type}, (key -> a -> bool) -> (t a) -> (t a) * (t a);
cardinal : forall {a : Type}, (t a) -> Z;
bindings : forall {a : Type}, (t a) -> list (key * a);
min_binding_opt : forall {a : Type}, (t a) -> option (key * a);
max_binding_opt : forall {a : Type}, (t a) -> option (key * a);
choose_opt : forall {a : Type}, (t a) -> option (key * a);
split : forall {a : Type}, key -> (t a) -> (t a) * (option a) * (t a);
find_opt : forall {a : Type}, key -> (t a) -> option a;
find_first_opt : forall {a : Type}, (key -> bool) ->
(t a) -> option (key * a);
find_last_opt : forall {a : Type}, (key -> bool) ->
(t a) -> option (key * a);
map : forall {a b : Type}, (a -> b) -> (t a) -> t b;
mapi : forall {a b : Type}, (key -> a -> b) -> (t a) -> t b;
}.
Arguments signature : clear implicits.
End MAP.
src/lib_base/test_chain_status.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t =
| Not_running
| Forking of {protocol : Protocol_hash.t; expiration : Time.Protocol.t}
| Running of {
chain_id : Chain_id.t;
genesis : Block_hash.t;
protocol : Protocol_hash.t;
expiration : Time.Protocol.t;
}
let encoding =
let open Data_encoding in
def
"test_chain_status"
~description:
"The status of the test chain: not_running (there is no test chain at \
the moment), forking (the test chain is being setup), running (the \
test chain is running)."
@@ union
[ case
(Tag 0)
~title:"Not_running"
(obj1 (req "status" (constant "not_running")))
(function Not_running -> Some () | _ -> None)
(fun () -> Not_running);
case
(Tag 1)
~title:"Forking"
(obj3
(req "status" (constant "forking"))
(req "protocol" Protocol_hash.encoding)
(req "expiration" Time.Protocol.encoding))
(function
| Forking {protocol; expiration} ->
Some ((), protocol, expiration)
| _ ->
None)
(fun ((), protocol, expiration) -> Forking {protocol; expiration});
case
(Tag 2)
~title:"Running"
(obj5
(req "status" (constant "running"))
(req "chain_id" Chain_id.encoding)
(req "genesis" Block_hash.encoding)
(req "protocol" Protocol_hash.encoding)
(req "expiration" Time.Protocol.encoding))
(function
| Running {chain_id; genesis; protocol; expiration} ->
Some ((), chain_id, genesis, protocol, expiration)
| _ ->
None)
(fun ((), chain_id, genesis, protocol, expiration) ->
Running {chain_id; genesis; protocol; expiration}) ]
let pp ppf = function
| Not_running ->
Format.fprintf ppf "@[<v 2>Not running@]"
| Forking {protocol; expiration} ->
Format.fprintf
ppf
"@[<v 2>Forking %a (expires %a)@]"
Protocol_hash.pp
protocol
Time.System.pp_hum
(Time.System.of_protocol_exn expiration)
| Running {chain_id; genesis; protocol; expiration} ->
Format.fprintf
ppf
"@[<v 2>Running %a@ Genesis: %a@ Net id: %a@ Expiration: %a@]"
Protocol_hash.pp
protocol
Block_hash.pp
genesis
Chain_id.pp
chain_id
Time.System.pp_hum
(Time.System.of_protocol_exn expiration)
let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/test_chain_status.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive t : Type :=
| Not_running : t
| Forking : Tezos_crypto.Protocol_hash.t -> Tezos_base.Time.Protocol.t -> t
| Running : Tezos_crypto.Chain_id.t -> Tezos_crypto.Block_hash.t ->
Tezos_crypto.Protocol_hash.t -> Tezos_base.Time.Protocol.t -> t.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
apply
(let arg :=
def "test_chain_status" % string
(* ❌ expected an argument *)
expected_argument
(Some
"The status of the test chain: not_running (there is no test chain at the moment), forking (the test chain is being setup), running (the test chain is running)."
% string) in
fun eta => arg None eta)
(union None
(cons
(case "Not_running" % string None
(Tezos_data_encoding.Data_encoding.Tag 0)
(obj1
(req None None "status" % string (constant "not_running" % string)))
(fun function_parameter =>
match function_parameter with
| Not_running => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Not_running))
(cons
(case "Forking" % string None
(Tezos_data_encoding.Data_encoding.Tag 1)
(obj3
(req None None "status" % string (constant "forking" % string))
(req None None "protocol" % string Protocol_hash.encoding)
(req None None "expiration" % string Time.Protocol.encoding))
(fun function_parameter =>
match function_parameter with
| Forking {| protocol := protocol; expiration := expiration |} =>
Some (tt, protocol, expiration)
| _ => None
end)
(fun function_parameter =>
let '(tt, protocol, expiration) := function_parameter in
Forking {| protocol := protocol; expiration := expiration |}))
(cons
(case "Running" % string None
(Tezos_data_encoding.Data_encoding.Tag 2)
(obj5
(req None None "status" % string (constant "running" % string))
(req None None "chain_id" % string Chain_id.encoding)
(req None None "genesis" % string Block_hash.encoding)
(req None None "protocol" % string Protocol_hash.encoding)
(req None None "expiration" % string Time.Protocol.encoding))
(fun function_parameter =>
match function_parameter with
|
Running {|
chain_id := chain_id;
genesis := genesis;
protocol := protocol;
expiration := expiration
|} => Some (tt, chain_id, genesis, protocol, expiration)
| _ => None
end)
(fun function_parameter =>
let '(tt, chain_id, genesis, protocol, expiration) :=
function_parameter in
Running
{| chain_id := chain_id; genesis := genesis;
protocol := protocol; expiration := expiration |})) [])))).
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
match function_parameter with
| Not_running =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Not running" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))
"@[<v 2>Not running@]" % string)
| Forking {| protocol := protocol; expiration := expiration |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Forking " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (expires " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 2>Forking %a (expires %a)@]" % string) Protocol_hash.pp protocol
Time.System.pp_hum (Time.System.of_protocol_exn expiration)
|
Running {|
chain_id := chain_id;
genesis := genesis;
protocol := protocol;
expiration := expiration
|} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Running " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "Genesis: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"Net id: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"Expiration: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))
"@[<v 2>Running %a@ Genesis: %a@ Net id: %a@ Expiration: %a@]" % string)
Protocol_hash.pp protocol Block_hash.pp genesis Chain_id.pp chain_id
Time.System.pp_hum (Time.System.of_protocol_exn expiration)
end.
src/lib_base/time.ml 16 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Protocol = struct
type t = int64
let epoch = 0L
let diff = Int64.sub
let add = Int64.add
let of_ptime t =
let (days, ps) = Ptime.Span.to_d_ps (Ptime.to_span t) in
let s_days = Int64.mul (Int64.of_int days) 86_400L in
Int64.add s_days (Int64.div ps 1_000_000_000_000L)
let to_ptime t =
let days = Int64.to_int (Int64.div t 86_400L) in
let ps = Int64.mul (Int64.rem t 86_400L) 1_000_000_000_000L in
match Option.apply ~f:Ptime.of_span (Ptime.Span.of_d_ps (days, ps)) with
| None ->
invalid_arg "Time.Protocol.to_ptime"
| Some ptime ->
ptime
let of_notation s =
match Ptime.of_rfc3339 s with
| Ok (t, _, _) ->
Some (of_ptime t)
| Error _ ->
None
let of_notation_exn s =
match Ptime.(rfc3339_error_to_msg (of_rfc3339 s)) with
| Error (`Msg msg) ->
invalid_arg ("Time.Protocol.of_notation: " ^ msg)
| Ok (t, _, _) ->
of_ptime t
let to_notation t = Ptime.to_rfc3339 ~frac_s:0 ~tz_offset_s:0 (to_ptime t)
let of_seconds x = x
let to_seconds x = x
let rfc_encoding =
let open Data_encoding in
def
"timestamp.rfc"
~title:"RFC 3339 formatted timestamp"
~description:"A date in RFC 3339 notation."
@@ conv
to_notation
(fun s ->
match of_notation s with
| Some s ->
s
| None ->
Data_encoding.Json.cannot_destruct "Time.Protocol.of_notation")
string
let encoding =
let open Data_encoding in
def
"timestamp.protocol"
~description:
"A timestamp as seen by the protocol: second-level precision, epoch \
based."
@@ splitted
~binary:int64
~json:
(union
[ case
Json_only
~title:"RFC encoding"
rfc_encoding
(fun i -> Some i)
(fun i -> i);
case
Json_only
~title:"Second since epoch"
int64
(fun _ -> None)
(fun i -> i) ])
let rpc_arg =
RPC_arg.make
~name:(Format.asprintf "date")
~descr:(Format.asprintf "A date in seconds from epoch")
~destruct:(fun s ->
if s = "none" || s = "epoch" then Ok epoch
else
match Int64.of_string s with
| t ->
Ok t
| exception _ ->
Error (Format.asprintf "failed to parse time (epoch): %S" s))
~construct:Int64.to_string
()
let pp_hum ppf t = Ptime.pp_rfc3339 () ppf (to_ptime t)
include Compare.Make (Int64)
end
module System = struct
type t = Ptime.t
let epoch = Ptime.epoch
module Span = struct
type t = Ptime.Span.t
let multiply_exn f s =
let open Ptime.Span in
Option.unopt_exn
(Failure "Time.System.Span.multiply_exn")
(of_float_s (f *. Ptime.Span.to_float_s s))
let of_seconds_exn f =
match Ptime.Span.of_float_s f with
| None ->
invalid_arg "Time.System.Span.of_seconds_exn"
| Some s ->
s
let encoding =
let open Data_encoding in
def
"timespan.system"
~description:"A span of time, as seen by the local computer."
@@ conv
Ptime.Span.to_float_s
(fun f ->
match Ptime.Span.of_float_s f with
| None ->
invalid_arg "Time.System.Span.encoding"
| Some s ->
s)
float
let rpc_arg =
RPC_arg.make
~name:(Format.asprintf "timespan")
~descr:(Format.asprintf "A span of time in seconds")
~destruct:(fun s ->
match Ptime.Span.of_float_s (float_of_string s) with
| Some t ->
Ok t
| None ->
Error (Format.asprintf "failed to parse timespan: %S" s)
| exception _ ->
Error (Format.asprintf "failed to parse timespan: %S" s))
~construct:(fun s -> string_of_float (Ptime.Span.to_float_s s))
()
end
let of_seconds_opt x =
let days = Int64.to_int (Int64.div x 86_400L) in
let ps = Int64.mul (Int64.rem x 86_400L) 1_000_000_000_000L in
Option.apply ~f:Ptime.of_span (Ptime.Span.of_d_ps (days, ps))
let of_seconds_exn x =
match of_seconds_opt x with
| Some t ->
t
| None ->
invalid_arg "Time.of_seconds"
let to_seconds x =
let (days, ps) = Ptime.(Span.to_d_ps (to_span x)) in
let s_days = Int64.mul (Int64.of_int days) 86_400L in
Int64.add s_days (Int64.div ps 1_000_000_000_000L)
let of_protocol_exn = of_seconds_exn
let of_protocol_opt = of_seconds_opt
let to_protocol = to_seconds
let of_notation_opt s =
match Ptime.of_rfc3339 s with Ok (t, _, _) -> Some t | Error _ -> None
let of_notation_exn s =
match Ptime.(rfc3339_error_to_msg (of_rfc3339 s)) with
| Ok (t, _, _) ->
t
| Error (`Msg msg) ->
invalid_arg ("Time.of_notation: " ^ msg)
let to_notation t = Ptime.to_rfc3339 t
let rfc_encoding =
let open Data_encoding in
def
"timestamp.rfc"
~title:"RFC 3339 formatted timestamp"
~description:"A date in RFC 3339 notation."
@@ conv
to_notation
(fun s ->
match of_notation_opt s with
| Some s ->
s
| None ->
Data_encoding.Json.cannot_destruct "Time.of_notation")
string
let encoding =
let open Data_encoding in
let binary = conv to_seconds of_seconds_exn int64 in
let json =
union
[ case
Json_only
~title:"RFC encoding"
rfc_encoding
(fun i -> Some i)
(fun i -> i);
case
Json_only
~title:"Second since epoch"
int64
(fun _ -> None)
(fun i -> of_seconds_exn i) ]
in
def
"timestamp.system"
~description:
"A timestamp as seen by the underlying, local computer: \
subsecond-level precision, epoch or rfc3339 based."
@@ splitted ~binary ~json
let rpc_arg =
RPC_arg.make
~name:(Format.asprintf "date")
~descr:(Format.asprintf "A date in seconds from epoch")
~destruct:(fun s ->
if s = "none" || s = "epoch" then Ok Ptime.epoch
else
match of_notation_opt s with
| Some t ->
Ok t
| None -> (
match of_seconds_exn (Int64.of_string s) with
| t ->
Ok t
| exception _ ->
Error (Format.asprintf "failed to parse time (epoch): %S" s) ))
~construct:to_notation
()
let pp_hum ppf t = Ptime.pp_rfc3339 () ppf t
type 'a stamped = {data : 'a; stamp : Ptime.t}
let stamped_encoding arg_encoding =
let open Data_encoding in
conv
(fun {stamp; data} -> (stamp, data))
(fun (stamp, data) -> {stamp; data})
(tup2 encoding arg_encoding)
let pp_stamped pp fmt {data; stamp} =
Format.fprintf fmt "%a(%a)" pp data pp_hum stamp
let stamp ~time data = {data; stamp = time}
let recent a1 a2 =
match (a1, a2) with
| (None, None) ->
None
| (None, (Some _ as a)) | ((Some _ as a), None) ->
a
| (Some (_, t1), Some (_, t2)) ->
if Ptime.compare t1 t2 < 0 then a2 else a1
let hash t = Int64.to_int (to_seconds t)
include Compare.Make (Ptime)
module Set = Set.Make (Ptime)
module Map = Map.Make (Ptime)
module Table = Hashtbl.Make (struct
include Ptime
let hash = hash
end)
end
let () =
Data_encoding.Registration.register ~pp:Protocol.pp_hum Protocol.encoding ;
Data_encoding.Registration.register ~pp:System.pp_hum System.encoding ;
Data_encoding.Registration.register System.Span.encoding
src/lib_base/time.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Protocol.
Definition t := int64.
Definition epoch : int64 :=
(* ❌ Constant of type int64 is converted to int *)
0.
Definition diff : int64 -> int64 -> int64 := Int64.sub.
Definition add : int64 -> int64 -> int64 := Int64.add.
Definition of_ptime (t : Ptime.t) : int64 :=
let '(days, ps) := Ptime.Span.to_d_ps (Ptime.to_span t) in
let s_days :=
Int64.mul (Int64.of_int days)
(* ❌ Constant of type int64 is converted to int *)
86400 in
Int64.add s_days
(Int64.div ps
(* ❌ Constant of type int64 is converted to int *)
1000000000000).
Definition to_ptime (t : int64) : Ptime.t :=
let days :=
Int64.to_int
(Int64.div t
(* ❌ Constant of type int64 is converted to int *)
86400) in
let ps :=
Int64.mul
(Int64.rem t
(* ❌ Constant of type int64 is converted to int *)
86400)
(* ❌ Constant of type int64 is converted to int *)
1000000000000 in
match Option.apply Ptime.of_span (Ptime.Span.of_d_ps (days, ps)) with
| None => OCaml.Stdlib.invalid_arg "Time.Protocol.to_ptime" % string
| Some ptime => ptime
end.
Definition of_notation (s : string) : option int64 :=
match Ptime.of_rfc3339 None None None s with
| Stdlib.Ok (t, _, _) => Some (of_ptime t)
| Stdlib.Error _ => None
end.
Definition of_notation_exn (s : string) : int64 :=
match rfc3339_error_to_msg (of_rfc3339 None None None s) with
| Stdlib.Error (Msg msg) =>
OCaml.Stdlib.invalid_arg
(String.append "Time.Protocol.of_notation: " % string msg)
| Stdlib.Ok (t, _, _) => of_ptime t
end.
Definition to_notation (t : int64) : string :=
Ptime.to_rfc3339 None (Some 0) (Some 0) (to_ptime t).
Definition of_seconds {A : Type} (x : A) : A := x.
Definition to_seconds {A : Type} (x : A) : A := x.
Definition rfc_encoding : Tezos_data_encoding.Data_encoding.encoding int64 :=
apply
(def "timestamp.rfc" % string
(Some "RFC 3339 formatted timestamp" % string)
(Some "A date in RFC 3339 notation." % string))
(conv to_notation
(fun s =>
match of_notation s with
| Some s => s
| None =>
Data_encoding.Json.cannot_destruct
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Time.Protocol.of_notation" % string
CamlinternalFormatBasics.End_of_format)
"Time.Protocol.of_notation" % string)
end) None string).
Definition encoding : Tezos_data_encoding.Data_encoding.encoding int64 :=
apply
(let arg :=
def "timestamp.protocol" % string
(* ❌ expected an argument *)
expected_argument
(Some
"A timestamp as seen by the protocol: second-level precision, epoch based."
% string) in
fun eta => arg None eta)
(splitted
(union None
(cons
(case "RFC encoding" % string None
Tezos_data_encoding.Data_encoding.Json_only rfc_encoding
(fun i => Some i) (fun i => i))
(cons
(case "Second since epoch" % string None
Tezos_data_encoding.Data_encoding.Json_only int64
(fun function_parameter =>
let '_ := function_parameter in
None) (fun i => i)) []))) int64).
Definition rpc_arg : Tezos_rpc.RPC_arg.arg int64 :=
RPC_arg.make
(Some
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"A date in seconds from epoch" % string
CamlinternalFormatBasics.End_of_format)
"A date in seconds from epoch" % string)))
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "date" % string
CamlinternalFormatBasics.End_of_format) "date" % string))
(fun s =>
if orb (equiv_decb s "none" % string) (equiv_decb s "epoch" % string)
then
Stdlib.Ok epoch
else
let 't := Int64.of_string s in
Stdlib.Ok t) Int64.to_string tt.
Definition pp_hum (ppf : Stdlib.Format.formatter) (t : int64) : unit :=
Ptime.pp_rfc3339 None None None tt ppf (to_ptime t).
(* ❌ Structure item `include` not handled. *)
include
End Protocol.
Module System.
Definition t := Ptime.t.
Definition epoch : Ptime.t := Ptime.epoch.
Module Span.
Definition t := Ptime.Span.t.
Definition multiply_exn (f : Z) (s : Ptime.span) : Ptime.span :=
Option.unopt_exn (OCaml.Failure "Time.System.Span.multiply_exn" % string)
(of_float_s (Stdlib.op_starpoint f (Ptime.Span.to_float_s s))).
Definition of_seconds_exn (f : Z) : Ptime.span :=
match Ptime.Span.of_float_s f with
| None =>
OCaml.Stdlib.invalid_arg "Time.System.Span.of_seconds_exn" % string
| Some s => s
end.
Definition encoding
: Tezos_data_encoding.Data_encoding.encoding Ptime.span :=
apply
(let arg :=
def "timespan.system" % string
(* ❌ expected an argument *)
expected_argument
(Some "A span of time, as seen by the local computer." % string) in
fun eta => arg None eta)
(conv Ptime.Span.to_float_s
(fun f =>
match Ptime.Span.of_float_s f with
| None =>
OCaml.Stdlib.invalid_arg "Time.System.Span.encoding" % string
| Some s => s
end) None float).
Definition rpc_arg : Tezos_rpc.RPC_arg.arg Ptime.span :=
RPC_arg.make
(Some
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"A span of time in seconds" % string
CamlinternalFormatBasics.End_of_format)
"A span of time in seconds" % string)))
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "timespan" % string
CamlinternalFormatBasics.End_of_format) "timespan" % string))
(fun s =>
match Ptime.Span.of_float_s (Stdlib.float_of_string s) with
| Some t => Stdlib.Ok t
| None =>
Stdlib.Error
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"failed to parse timespan: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"failed to parse timespan: %S" % string) s)
end) (fun s => Stdlib.string_of_float (Ptime.Span.to_float_s s)) tt.
End Span.
Definition of_seconds_opt (x : int64) : option Ptime.t :=
let days :=
Int64.to_int
(Int64.div x
(* ❌ Constant of type int64 is converted to int *)
86400) in
let ps :=
Int64.mul
(Int64.rem x
(* ❌ Constant of type int64 is converted to int *)
86400)
(* ❌ Constant of type int64 is converted to int *)
1000000000000 in
Option.apply Ptime.of_span (Ptime.Span.of_d_ps (days, ps)).
Definition of_seconds_exn (x : int64) : Ptime.t :=
match of_seconds_opt x with
| Some t => t
| None => OCaml.Stdlib.invalid_arg "Time.of_seconds" % string
end.
Definition to_seconds (x : Ptime.t) : int64 :=
let '(days, ps) := Span.to_d_ps (to_span x) in
let s_days :=
Int64.mul (Int64.of_int days)
(* ❌ Constant of type int64 is converted to int *)
86400 in
Int64.add s_days
(Int64.div ps
(* ❌ Constant of type int64 is converted to int *)
1000000000000).
Definition of_protocol_exn : int64 -> Ptime.t := of_seconds_exn.
Definition of_protocol_opt : int64 -> option Ptime.t := of_seconds_opt.
Definition to_protocol : Ptime.t -> int64 := to_seconds.
Definition of_notation_opt (s : string) : option Ptime.t :=
match Ptime.of_rfc3339 None None None s with
| Stdlib.Ok (t, _, _) => Some t
| Stdlib.Error _ => None
end.
Definition of_notation_exn (s : string) : Ptime.t :=
match rfc3339_error_to_msg (of_rfc3339 None None None s) with
| Stdlib.Ok (t, _, _) => t
| Stdlib.Error (Msg msg) =>
OCaml.Stdlib.invalid_arg (String.append "Time.of_notation: " % string msg)
end.
Definition to_notation (t : Ptime.t) : string :=
Ptime.to_rfc3339 None None None t.
Definition rfc_encoding
: Tezos_data_encoding.Data_encoding.encoding Ptime.t :=
apply
(def "timestamp.rfc" % string
(Some "RFC 3339 formatted timestamp" % string)
(Some "A date in RFC 3339 notation." % string))
(conv to_notation
(fun s =>
match of_notation_opt s with
| Some s => s
| None =>
Data_encoding.Json.cannot_destruct
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Time.of_notation" % string
CamlinternalFormatBasics.End_of_format)
"Time.of_notation" % string)
end) None string).
Definition encoding : Tezos_data_encoding.Data_encoding.encoding Ptime.t :=
let binary := conv to_seconds of_seconds_exn None int64 in
let json :=
union None
(cons
(case "RFC encoding" % string None
Tezos_data_encoding.Data_encoding.Json_only rfc_encoding
(fun i => Some i) (fun i => i))
(cons
(case "Second since epoch" % string None
Tezos_data_encoding.Data_encoding.Json_only int64
(fun function_parameter =>
let '_ := function_parameter in
None) (fun i => of_seconds_exn i)) [])) in
apply
(let arg :=
def "timestamp.system" % string
(* ❌ expected an argument *)
expected_argument
(Some
"A timestamp as seen by the underlying, local computer: subsecond-level precision, epoch or rfc3339 based."
% string) in
fun eta => arg None eta) (splitted json binary).
Definition rpc_arg : Tezos_rpc.RPC_arg.arg Ptime.t :=
RPC_arg.make
(Some
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"A date in seconds from epoch" % string
CamlinternalFormatBasics.End_of_format)
"A date in seconds from epoch" % string)))
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "date" % string
CamlinternalFormatBasics.End_of_format) "date" % string))
(fun s =>
if orb (equiv_decb s "none" % string) (equiv_decb s "epoch" % string)
then
Stdlib.Ok Ptime.epoch
else
match of_notation_opt s with
| Some t => Stdlib.Ok t
| None =>
let 't := of_seconds_exn (Int64.of_string s) in
Stdlib.Ok t
end) to_notation tt.
Definition pp_hum (ppf : Stdlib.Format.formatter) (t : Ptime.t) : unit :=
Ptime.pp_rfc3339 None None None tt ppf t.
Record stamped {a : Type} := {
data : a;
stamp : Ptime.t }.
Arguments stamped : clear implicits.
Definition stamped_encoding {A : Type}
(arg_encoding : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding (stamped A) :=
conv
(fun function_parameter =>
let '{| data := data; stamp := stamp |} := function_parameter in
(stamp, data))
(fun function_parameter =>
let '(stamp, data) := function_parameter in
{| data := data; stamp := stamp |}) None (tup2 encoding arg_encoding).
Definition pp_stamped {A : Type}
(pp : Stdlib.Format.formatter -> A -> unit) (fmt : Stdlib.Format.formatter)
(function_parameter : stamped A) : unit :=
let '{| data := data; stamp := stamp |} := function_parameter in
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))) "%a(%a)" % string) pp
data pp_hum stamp.
Definition stamp {A : Type} (time : Ptime.t) (data : A) : stamped A :=
{| data := data; stamp := time |}.
Definition recent {A : Type}
(a1 : option (A * Ptime.t)) (a2 : option (A * Ptime.t))
: option (A * Ptime.t) :=
match (a1, a2) with
| (None, None) => None
| (None, (Some _) as a) | ((Some _) as a, None) => a
| (Some (_, t1), Some (_, t2)) =>
if OCaml.Stdlib.lt (Ptime.compare t1 t2) 0 then
a2
else
a1
end.
Definition hash (t : Ptime.t) : Z := Int64.to_int (to_seconds t).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
End System.
src/lib_base/tzPervasives.ml 32 errors
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Tezos_stdlib module Error_monad = Tezos_error_monad.Error_monad include Tezos_rpc include Tezos_clic include Tezos_crypto include Tezos_micheline module Data_encoding = Tezos_data_encoding.Data_encoding module List = struct include List include Tezos_stdlib.TzList end module String = struct include String include Tezos_stdlib.TzString end module Time = Time module Fitness = Fitness module Block_header = Block_header module Operation = Operation module Protocol = Protocol module Test_chain_status = Test_chain_status module Preapply_result = Preapply_result module Block_locator = Block_locator module Mempool = Mempool module P2p_addr = P2p_addr module P2p_identity = P2p_identity module P2p_peer = P2p_peer module P2p_point = P2p_point module P2p_connection = P2p_connection module P2p_stat = P2p_stat module P2p_version = P2p_version module Distributed_db_version = Distributed_db_version module Network_version = Network_version include Utils.Infix include Error_monad module Internal_event = Internal_event
src/lib_base/tzPervasives.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ Structure item `include` not handled. *) include (* ❌ Structure item `include` not handled. *) include (* ❌ Structure item `include` not handled. *) include (* ❌ Structure item `include` not handled. *) include (* ❌ This kind of module is not handled. *) unhandled_module Module List. (* ❌ Structure item `include` not handled. *) include (* ❌ Structure item `include` not handled. *) include End List. Module String. (* ❌ Structure item `include` not handled. *) include (* ❌ Structure item `include` not handled. *) include End String. (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ Structure item `include` not handled. *) include (* ❌ Structure item `include` not handled. *) include (* ❌ This kind of module is not handled. *) unhandled_module
src/lib_base/unix/protocol_files.ml 7 errors
open Error_monad
let name = "TEZOS_PROTOCOL"
open Protocol
let ( // ) = Filename.concat
let to_file ~dir:dirname ?hash ?env_version modules =
let config_file =
Data_encoding.Json.construct
Meta.encoding
{hash; expected_env_version = env_version; modules}
in
Lwt_utils_unix.Json.write_file (dirname // name) config_file
let of_file ~dir:dirname =
Lwt_utils_unix.Json.read_file (dirname // name)
>>=? fun json -> return (Data_encoding.Json.destruct Meta.encoding json)
let find_component dirname module_name =
let name_lowercase = String.uncapitalize_ascii module_name in
let implementation = (dirname // name_lowercase) ^ ".ml" in
let interface = implementation ^ "i" in
match (Sys.file_exists implementation, Sys.file_exists interface) with
| (false, _) ->
Pervasives.failwith @@ "Not such file: " ^ implementation
| (true, false) ->
Lwt_utils_unix.read_file implementation
>|= fun implementation ->
{name = module_name; interface = None; implementation}
| _ ->
Lwt_utils_unix.read_file interface
>>= fun interface ->
Lwt_utils_unix.read_file implementation
>|= fun implementation ->
{name = module_name; interface = Some interface; implementation}
let read_dir dir =
of_file ~dir
>>=? fun meta ->
Lwt_list.map_p (find_component dir) meta.modules
>>= fun components ->
let expected_env =
match meta.expected_env_version with None -> V1 | Some v -> v
in
return (meta.hash, {expected_env; components})
open Lwt.Infix
let create_files dir units =
Lwt_utils_unix.remove_dir dir
>>= fun () ->
Lwt_utils_unix.create_dir dir
>>= fun () ->
Lwt_list.map_s
(fun {name; interface; implementation} ->
let name = String.lowercase_ascii name in
let ml = dir // (name ^ ".ml") in
let mli = dir // (name ^ ".mli") in
Lwt_utils_unix.create_file ml implementation
>>= fun () ->
match interface with
| None ->
Lwt.return [ml]
| Some content ->
Lwt_utils_unix.create_file mli content
>>= fun () -> Lwt.return [mli; ml])
units
>>= fun files ->
let files = List.concat files in
Lwt.return files
let write_dir dir ?hash (p : t) =
create_files dir p.components
>>= fun _files ->
to_file
~dir
?hash
~env_version:p.expected_env
(List.map (fun {name; _} -> String.capitalize_ascii name) p.components)
src/lib_base/unix/protocol_files.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Definition name : string := "TEZOS_PROTOCOL" % string.
Import Protocol.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition to_file
(dirname : string) (hash : option Tezos_crypto.Protocol_hash.t)
(env_version : option Tezos_base__Protocol.env_version)
(modules : list string)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
let config_file :=
Data_encoding.Json.construct Meta.encoding
{| hash := hash; expected_env_version := env_version; modules := modules
|} in
Lwt_utils_unix.Json.write_file (op_divdiv dirname name) config_file.
Definition of_file (dirname : string)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult Tezos_base.Protocol.Meta.t) :=
op_gtgteqquestion (Lwt_utils_unix.Json.read_file (op_divdiv dirname name))
(fun json => _return (Data_encoding.Json.destruct Meta.encoding json)).
Definition find_component (dirname : string) (module_name : string)
: Lwt.t Tezos_base.Protocol.component :=
let name_lowercase := Stdlib.String.uncapitalize_ascii module_name in
let implementation :=
String.append (op_divdiv dirname name_lowercase) ".ml" % string in
let interface := String.append implementation "i" % string in
match ((Sys.file_exists implementation), (Sys.file_exists interface)) with
| (false, _) =>
apply Pervasives.failwith
(String.append "Not such file: " % string implementation)
| (true, false) =>
op_gtpipeeq (Lwt_utils_unix.read_file implementation)
(fun implementation =>
{| name := module_name; interface := None;
implementation := implementation |})
| _ =>
op_gtgteq (Lwt_utils_unix.read_file interface)
(fun interface =>
op_gtpipeeq (Lwt_utils_unix.read_file implementation)
(fun implementation =>
{| name := module_name; interface := Some interface;
implementation := implementation |}))
end.
Definition read_dir (dir : string)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
((option Tezos_crypto.Protocol_hash.t) * Tezos_base.Protocol.t)) :=
op_gtgteqquestion (of_file dir)
(fun meta =>
op_gtgteq (Lwt_list.map_p (find_component dir) (modules meta))
(fun components =>
let expected_env :=
match expected_env_version meta with
| None => Tezos_base.Protocol.V1
| Some v => v
end in
_return
((hash meta),
{| expected_env := expected_env; components := components |}))).
Import Lwt.Infix.
Definition create_files
(dir : string) (units : list Tezos_base.Protocol.component)
: Lwt.t (list string) :=
op_gtgteq (Lwt_utils_unix.remove_dir dir)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_utils_unix.create_dir None dir)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_list.map_s
(fun function_parameter =>
let '{|
name := name;
interface := interface;
implementation := implementation
|} := function_parameter in
let name := Stdlib.String.lowercase_ascii name in
let ml := op_divdiv dir (String.append name ".ml" % string) in
let mli := op_divdiv dir (String.append name ".mli" % string) in
op_gtgteq (Lwt_utils_unix.create_file None ml implementation)
(fun function_parameter =>
let 'tt := function_parameter in
match interface with
| None => Lwt._return (cons ml [])
| Some content =>
op_gtgteq (Lwt_utils_unix.create_file None mli content)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return (cons mli (cons ml [])))
end)) units)
(fun files =>
let files := Stdlib.List.concat files in
Lwt._return files))).
Definition write_dir
(dir : string) (hash : option Tezos_crypto.Protocol_hash.t)
(p : Tezos_base.Protocol.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
op_gtgteq (create_files dir (components p))
(fun _files =>
to_file dir hash (Some (expected_env p))
(List.map
(fun function_parameter =>
let '{| name := name |} := function_parameter in
Stdlib.String.capitalize_ascii name) (components p))).
src/lib_clic/unix/scriptable.ml 7 errors
open Error_monad
type output_format = Rows of {separator : string; escape : [`No | `OCaml]}
let rows separator escape = Rows {separator; escape}
let tsv = rows "\t" `No
let csv = rows "," `OCaml
let clic_arg () =
let open Clic in
arg
~doc:"Make the output script-friendly"
~long:"for-script"
~placeholder:"FORMAT"
(parameter (fun _ spec ->
match String.lowercase_ascii spec with
| "tsv" ->
return tsv
| "csv" ->
return csv
| other ->
failwith
"Cannot recognize format %S, please try 'TSV' or 'CSV'"
other))
let fprintf_lwt chan fmt =
Format.kasprintf
(fun s ->
protect (fun () -> Lwt_io.write chan s >>= fun () -> return_unit))
fmt
let output ?(channel = Lwt_io.stdout) how_option ~for_human ~for_script =
match how_option with
| None ->
for_human ()
| Some (Rows {separator; escape}) ->
let open Format in
iter_s
(fun row ->
fprintf_lwt
channel
"%a@."
(pp_print_list
~pp_sep:(fun fmt () -> pp_print_string fmt separator)
(fun fmt cell ->
match escape with
| `OCaml ->
fprintf fmt "%S" cell
| `No ->
pp_print_string fmt cell))
row)
(for_script ())
>>=? fun () ->
protect (fun () -> Lwt_io.flush channel >>= fun () -> return_unit)
let output_for_human how_option for_human =
output how_option ~for_human ~for_script:(fun () -> [])
let output_row ?channel how_option ~for_human ~for_script =
output ?channel how_option ~for_human ~for_script:(fun () -> [for_script ()])
src/lib_clic/unix/scriptable.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Inductive output_format : Type :=
| Rows : string -> variant -> output_format.
Definition rows (separator : string) (escape : variant) : output_format :=
Rows {| separator := separator; escape := escape |}.
Definition tsv : output_format :=
rows " " % string
(* ❌ Variants not supported *)
variant.
Definition csv : output_format :=
rows "," % string
(* ❌ Variants not supported *)
variant.
Definition clic_arg {A : Type} (function_parameter : unit)
: Tezos_clic.Clic.arg (option output_format) A :=
let 'tt := function_parameter in
arg "Make the output script-friendly" % string None "for-script" % string
"FORMAT" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun spec =>
match Stdlib.String.lowercase_ascii spec with
| "tsv" % string => _return tsv
| "csv" % string => _return csv
| other =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot recognize format " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
", please try 'TSV' or 'CSV'" % string
CamlinternalFormatBasics.End_of_format)))
"Cannot recognize format %S, please try 'TSV' or 'CSV'" % string)
other
end)).
Definition fprintf_lwt {A : Type}
(chan : Lwt_io.output_channel)
(fmt :
Stdlib.format4 A Stdlib.Format.formatter unit
(Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))) : A :=
Format.kasprintf
(fun s =>
protect None None
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_io.write chan s)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))) fmt.
Definition output (op_staroptstar : option Lwt_io.output_channel)
: (option output_format) ->
(unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) ->
(unit -> list (list string)) ->
Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
let channel :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Lwt_io.stdout
end in
fun how_option =>
fun for_human =>
fun for_script =>
match how_option with
| None => for_human tt
| Some (Rows {| separator := separator; escape := escape |}) =>
op_gtgteqquestion
(iter_s
(fun row =>
fprintf_lwt channel
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)) "%a@." % string)
(pp_print_list
(Some
(fun fmt =>
fun function_parameter =>
let 'tt := function_parameter in
pp_print_string fmt separator))
(fun fmt =>
fun cell =>
match escape with
| OCaml =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)
"%S" % string) cell
| No => pp_print_string fmt cell
end)) row) (for_script tt))
(fun function_parameter =>
let 'tt := function_parameter in
protect None None
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_io.flush channel)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
end.
Definition output_for_human
(how_option : option output_format)
(for_human : unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
output None how_option for_human
(fun function_parameter =>
let 'tt := function_parameter in
[]).
Definition output_row
(channel : option Lwt_io.output_channel) (how_option : option output_format)
(for_human : unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
(for_script : unit -> list string)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
output channel how_option for_human
(fun function_parameter =>
let 'tt := function_parameter in
cons (for_script tt) []).
src/lib_client_base/client_aliases.ml 192 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Tezos Command line interface - Local Storage for Configuration *)
open Lwt.Infix
open Clic
module type Entity = sig
type t
val encoding : t Data_encoding.t
val of_source : string -> t tzresult Lwt.t
val to_source : t -> string tzresult Lwt.t
val name : string
end
module type Alias = sig
type t
type fresh_param
val load : #Client_context.wallet -> (string * t) list tzresult Lwt.t
val set : #Client_context.wallet -> (string * t) list -> unit tzresult Lwt.t
val find : #Client_context.wallet -> string -> t tzresult Lwt.t
val find_opt : #Client_context.wallet -> string -> t option tzresult Lwt.t
val rev_find : #Client_context.wallet -> t -> string option tzresult Lwt.t
val name : #Client_context.wallet -> t -> string tzresult Lwt.t
val mem : #Client_context.wallet -> string -> bool tzresult Lwt.t
val add :
force:bool -> #Client_context.wallet -> string -> t -> unit tzresult Lwt.t
val del : #Client_context.wallet -> string -> unit tzresult Lwt.t
val update : #Client_context.wallet -> string -> t -> unit tzresult Lwt.t
val of_source : string -> t tzresult Lwt.t
val to_source : t -> string tzresult Lwt.t
val alias_parameter :
unit -> (string * t, #Client_context.wallet) Clic.parameter
val alias_param :
?name:string ->
?desc:string ->
('a, (#Client_context.wallet as 'b)) Clic.params ->
(string * t -> 'a, 'b) Clic.params
val fresh_alias_param :
?name:string ->
?desc:string ->
('a, (< .. > as 'obj)) Clic.params ->
(fresh_param -> 'a, 'obj) Clic.params
val force_switch : unit -> (bool, _) arg
val of_fresh :
#Client_context.wallet -> bool -> fresh_param -> string tzresult Lwt.t
val source_param :
?name:string ->
?desc:string ->
('a, (#Client_context.wallet as 'obj)) Clic.params ->
(t -> 'a, 'obj) Clic.params
val source_arg :
?long:string ->
?placeholder:string ->
?doc:string ->
unit ->
(t option, (#Client_context.wallet as 'obj)) Clic.arg
val autocomplete : #Client_context.wallet -> string list tzresult Lwt.t
end
module Alias (Entity : Entity) = struct
open Client_context
let wallet_encoding : (string * Entity.t) list Data_encoding.encoding =
let open Data_encoding in
list (obj2 (req "name" string) (req "value" Entity.encoding))
let load (wallet : #wallet) =
wallet#load Entity.name ~default:[] wallet_encoding
let set (wallet : #wallet) entries =
wallet#write Entity.name entries wallet_encoding
let autocomplete wallet =
load wallet
>>= function
| Error _ -> return_nil | Ok list -> return (List.map fst list)
let find_opt (wallet : #wallet) name =
load wallet
>>=? fun list ->
try return_some (List.assoc name list) with Not_found -> return_none
let find (wallet : #wallet) name =
load wallet
>>=? fun list ->
try return (List.assoc name list)
with Not_found -> failwith "no %s alias named %s" Entity.name name
let rev_find (wallet : #wallet) v =
load wallet
>>=? fun list ->
try return_some (List.find (fun (_, v') -> v = v') list |> fst)
with Not_found -> return_none
let mem (wallet : #wallet) name =
load wallet
>>=? fun list ->
try
ignore (List.assoc name list) ;
return_true
with Not_found -> return_false
let add ~force (wallet : #wallet) name value =
let keep = ref false in
load wallet
>>=? fun list ->
( if force then return_unit
else
iter_s
(fun (n, v) ->
if n = name && v = value then (
keep := true ;
return_unit )
else if n = name && v <> value then
failwith
"another %s is already aliased as %s, use --force to update"
Entity.name
n
else if n <> name && v = value then
failwith
"this %s is already aliased as %s, use --force to insert \
duplicate"
Entity.name
n
else return_unit)
list )
>>=? fun () ->
let list = List.filter (fun (n, _) -> n <> name) list in
let list = (name, value) :: list in
if !keep then return_unit
else wallet#write Entity.name list wallet_encoding
let del (wallet : #wallet) name =
load wallet
>>=? fun list ->
let list = List.filter (fun (n, _) -> n <> name) list in
wallet#write Entity.name list wallet_encoding
let update (wallet : #wallet) name value =
load wallet
>>=? fun list ->
let list =
List.map (fun (n, v) -> (n, if n = name then value else v)) list
in
wallet#write Entity.name list wallet_encoding
include Entity
let alias_parameter () =
parameter ~autocomplete (fun cctxt s ->
find cctxt s >>=? fun v -> return (s, v))
let alias_param ?(name = "name")
?(desc = "existing " ^ Entity.name ^ " alias") next =
param ~name ~desc (alias_parameter ()) next
type fresh_param = Fresh of string
let of_fresh (wallet : #wallet) force (Fresh s) =
load wallet
>>=? fun list ->
( if force then return_unit
else
iter_s
(fun (n, v) ->
if n = s then
Entity.to_source v
>>=? fun value ->
failwith
"@[<v 2>The %s alias %s already exists.@,\
The current value is %s.@,\
Use --force to update@]"
Entity.name
n
value
else return_unit)
list )
>>=? fun () -> return s
let fresh_alias_param ?(name = "new")
?(desc = "new " ^ Entity.name ^ " alias") next =
param
~name
~desc
(parameter (fun (_ : < .. >) s -> return @@ Fresh s))
next
let parse_source_string cctxt s =
match String.split ~limit:1 ':' s with
| ["alias"; alias] ->
find cctxt alias
| ["text"; text] ->
of_source text
| ["file"; path] ->
cctxt#read_file path >>=? of_source
| _ -> (
find cctxt s
>>= function
| Ok v ->
return v
| Error a_errs -> (
cctxt#read_file s >>=? of_source
>>= function
| Ok v ->
return v
| Error r_errs -> (
of_source s
>>= function
| Ok v ->
return v
| Error s_errs ->
let all_errs = List.flatten [a_errs; r_errs; s_errs] in
Lwt.return_error all_errs ) ) )
let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next =
let desc =
Format.asprintf
"%s\n\
Can be a %s name, a file or a raw %s literal. If the parameter is \
not the name of an existing %s, the client will look for a file \
containing a %s, and if it does not exist, the argument will be read \
as a raw %s.\n\
Use 'alias:name', 'file:path' or 'text:literal' to disable autodetect."
desc
Entity.name
Entity.name
Entity.name
Entity.name
Entity.name
in
param ~name ~desc (parameter parse_source_string) next
let source_arg ?(long = "source " ^ Entity.name) ?(placeholder = "src")
?(doc = "") () =
let doc =
Format.asprintf
"%s\n\
Can be a %s name, a file or a raw %s literal. If the parameter is \
not the name of an existing %s, the client will look for a file \
containing a %s, and if it does not exist, the argument will be read \
as a raw %s.\n\
Use 'alias:name', 'file:path' or 'text:literal' to disable autodetect."
doc
Entity.name
Entity.name
Entity.name
Entity.name
Entity.name
in
arg ~long ~placeholder ~doc (parameter parse_source_string)
let force_switch () =
Clic.switch
~long:"force"
~short:'f'
~doc:("overwrite existing " ^ Entity.name)
()
let name (wallet : #wallet) d =
rev_find wallet d
>>=? function None -> Entity.to_source d | Some name -> return name
end
src/lib_client_base/client_aliases.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
Import Clic.
Module Entity.
Record signature {t : Type} := {
t := t;
encoding : Tezos_base__TzPervasives.Data_encoding.t t;
of_source : string -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
to_source : t -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
name : string;
}.
Arguments signature : clear implicits.
End Entity.
Module Alias.
Record signature {t fresh_param : Type} := {
t := t;
fresh_param := fresh_param;
load : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> Lwt.t (Tezos_base__TzPervasives.tzresult (list (string * t)));
set : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) ->
(list (string * t)) -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
find : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
find_opt : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult (option t));
rev_find : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult (option string));
name : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
mem : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult bool);
add : forall {_ a : Type}, bool ->
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> string -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
del : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
update : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> string -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
of_source : string -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
to_source : t -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
alias_parameter : forall {_ a : Type}, unit ->
Tezos_base__TzPervasives.Clic.parameter (string * t)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _);
alias_param : forall {a b : Type}, (option string) ->
(option string) ->
(Tezos_base__TzPervasives.Clic.params a
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
b))))) * b)) ->
Tezos_base__TzPervasives.Clic.params ((string * t) -> a)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a))
* b))))) * b);
fresh_alias_param : forall {a obj : Type}, (option string) ->
(option string) ->
(Tezos_base__TzPervasives.Clic.params a (obj)) ->
Tezos_base__TzPervasives.Clic.params (fresh_param -> a) (obj);
force_switch : forall {_ : Type}, unit ->
Tezos_base__TzPervasives.Clic.arg bool _;
of_fresh : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) ->
bool -> fresh_param -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
source_param : forall {a obj : Type}, (option string) ->
(option string) ->
(Tezos_base__TzPervasives.Clic.params a
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
obj))))) * obj)) ->
Tezos_base__TzPervasives.Clic.params (t -> a)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a))
* obj))))) * obj);
source_arg : forall {a obj : Type}, (option string) ->
(option string) ->
(option string) ->
unit ->
Tezos_base__TzPervasives.Clic.arg (option t)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) *
(a)) * obj))))) * obj);
autocomplete : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
* _) -> Lwt.t (Tezos_base__TzPervasives.tzresult (list string));
}.
Arguments signature : clear implicits.
End Alias.
(* ❌ Functors are not handled. *)
functor
src/lib_client_base/client_confirmations.ml 130 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let in_block operation_hash operations =
let exception Found of int * int in
try
List.iteri
(fun i ops ->
List.iteri
(fun j op ->
if Operation_hash.equal operation_hash op then raise (Found (i, j)))
ops)
operations ;
None
with Found (i, j) -> Some (i, j)
type operation_status =
| Confirmed of (Block_hash.t * int * int)
| Pending
| Still_not_found
let wait_for_operation_inclusion (ctxt : #Client_context.full) ~chain
?(predecessors = 10) ?(confirmations = 1) ?branch operation_hash =
let exception WrapError of error list in
let exception Outdated of Operation_hash.t in
(* Table of known blocks:
- None: if neither the block or its predecessors contains the operation
- (Some ((hash, i, j), n)):
if the `hash` contains the operation in list `i` at position `j`
and if `hash` denotes the `n-th` predecessors of the block. *)
let blocks : ((Block_hash.t * int * int) * int) option Block_hash.Table.t =
Block_hash.Table.create confirmations
in
(* Fetch _all_ the 'unknown' predecessors af a block. *)
let fetch_predecessors (hash, header) =
let rec loop acc (_hash, header) =
let predecessor = header.Block_header.predecessor in
if Block_hash.Table.mem blocks predecessor then return acc
else
Chain_services.Blocks.Header.shell_header
ctxt
~chain
~block:(`Hash (predecessor, 0))
()
>>=? fun shell ->
let block = (predecessor, shell) in
loop (block :: acc) block
in
loop [(hash, header.Block_header.shell)] (hash, header.shell)
>>= function
| Ok blocks ->
Lwt.return blocks
| Error err ->
ctxt#warning
"Error while fetching block (ignored): %a"
pp_print_error
err
>>= fun () ->
(* Will be retried when a new head arrives *)
Lwt.return_nil
in
(* Check whether a block as enough confirmations. This function
assumes that the block predecessor has been processed already. *)
let process hash header =
let block = `Hash (hash, 0) in
let predecessor = header.Tezos_base.Block_header.predecessor in
match Block_hash.Table.find blocks predecessor with
| Some (block_with_op, n) ->
ctxt#answer
"Operation received %d confirmations as of block: %a"
(n + 1)
Block_hash.pp
hash
>>= fun () ->
Block_hash.Table.add blocks hash (Some (block_with_op, n + 1)) ;
if n + 1 < confirmations then return Pending
else return (Confirmed block_with_op)
| None -> (
Shell_services.Blocks.Operation_hashes.operation_hashes
ctxt
~chain
~block
()
>>=? fun operations ->
match in_block operation_hash operations with
| None ->
Block_hash.Table.add blocks hash None ;
return Still_not_found
| Some (i, j) ->
ctxt#answer
"Operation found in block: %a (pass: %d, offset: %d)"
Block_hash.pp
hash
i
j
>>= fun () ->
Block_hash.Table.add blocks hash (Some ((hash, i, j), 0)) ;
if confirmations <= 0 then return (Confirmed (hash, i, j))
else return Pending )
in
(* Checks if the given branch is considered alive.*)
let check_branch_alive () =
match branch with
| Some branch_hash -> (
Shell_services.Blocks.live_blocks ctxt ~chain ~block:(`Head 0) ()
>>= function
| Ok live_blocks ->
if Block_hash.Set.mem branch_hash live_blocks then Lwt.return_unit
else
ctxt#error
"The operation %a is outdated and may never be included in \
the chain.@,\
We recommand to use an external block explorer."
Operation_hash.pp
operation_hash
>>= fun () -> Lwt.fail (Outdated operation_hash)
| Error err ->
Lwt.fail (WrapError err) )
| None ->
Lwt.return_unit
in
Shell_services.Monitor.heads ctxt chain
>>=? fun (stream, stop) ->
Lwt_stream.get stream
>>= function
| None ->
assert false
| Some (head, _) ->
let rec loop n =
if n >= 0 then
(*Search for the operation in the n head predecessors*)
let block = `Hash (head, n) in
Shell_services.Blocks.hash ctxt ~chain ~block ()
>>=? fun hash ->
Shell_services.Blocks.Header.shell_header ctxt ~chain ~block ()
>>=? fun shell ->
process hash shell
>>=? function
| Confirmed block ->
stop () ; return block
| Pending | Still_not_found ->
loop (n - 1)
else
(*Search for the operation in new heads*)
Lwt.catch
(fun () ->
(*Fetching potential unknown blocks from potential new heads*)
let stream = Lwt_stream.map_list_s fetch_predecessors stream in
Lwt_stream.find_s
(fun (hash, header) ->
process hash header
>>= function
| Ok Pending ->
Lwt.return_false
| Ok Still_not_found ->
check_branch_alive () >>= fun () -> Lwt.return_false
| Ok (Confirmed _) ->
Lwt.return_true
| Error err ->
Lwt.fail (WrapError err))
stream
>>= return)
(function
| WrapError e -> Lwt.return_error e | exn -> Lwt.fail exn)
>>=? function
| None ->
failwith "..."
| Some (hash, _) -> (
stop () ;
match Block_hash.Table.find_opt blocks hash with
| None | Some None ->
assert false
| Some (Some (hash, _)) ->
return hash )
in
( match branch with
| Some branch_hash ->
Shell_services.Blocks.Header.shell_header
ctxt
~chain
~block:(`Hash (branch_hash, 0))
()
>>=? fun branch_header ->
let branch_level = branch_header.Block_header.level in
Shell_services.Blocks.Header.shell_header
ctxt
~chain
~block:(`Hash (head, 0))
()
>>=? fun head_shell ->
let head_level = head_shell.Block_header.level in
return Int32.(to_int (sub head_level branch_level))
| None ->
return predecessors )
>>=? fun block_hook ->
Block_services.Empty.hash
ctxt
~chain
~block:(`Hash (head, block_hook + 1))
()
>>=? fun oldest ->
Block_hash.Table.add blocks oldest None ;
loop block_hook
let lookup_operation_in_previous_block ctxt chain operation_hash i =
Block_services.Empty.hash ctxt ~block:(`Head i) ()
>>=? fun block ->
Shell_services.Blocks.Operation_hashes.operation_hashes
ctxt
~chain
~block:(`Hash (block, 0))
()
>>=? fun operations ->
match in_block operation_hash operations with
| None ->
return_none
| Some (a, b) ->
return_some (block, a, b)
let lookup_operation_in_previous_blocks (ctxt : #Client_context.full) ~chain
~predecessors operation_hash =
let rec loop i =
if i = predecessors + 1 then return_none
else
lookup_operation_in_previous_block ctxt chain operation_hash i
>>=? function
| None -> loop (i + 1) | Some (block, a, b) -> return_some (block, a, b)
in
loop 0
let wait_for_bootstrapped (ctxt : #Client_context.full) =
let display = ref false in
Lwt.async (fun () ->
ctxt#sleep 0.3
>>= fun () ->
if not !display then (
ctxt#answer
"Waiting for the node to be bootstrapped before injection..."
>>= fun () ->
display := true ;
Lwt.return_unit )
else Lwt.return_unit) ;
Monitor_services.bootstrapped ctxt
>>=? fun (stream, _stop) ->
Lwt_stream.iter_s
(fun (hash, time) ->
if !display then
ctxt#message
"Current head: %a (timestamp: %a, validation: %a)"
Block_hash.pp_short
hash
Time.System.pp_hum
(Time.System.of_protocol_exn time)
Time.System.pp_hum
(ctxt#now ())
else Lwt.return_unit)
stream
>>= fun () ->
display := true ;
ctxt#answer "Node is bootstrapped, ready for injecting operations."
>>= fun () -> return_unit
src/lib_client_base/client_confirmations.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition in_block
(operation_hash : Tezos_base__TzPervasives.Operation_hash.t)
(operations : list (list Tezos_base__TzPervasives.Operation_hash.t))
: option (Z * Z) :=
(* ❌ Let of exception is not handled *)
let_exception.
Inductive operation_status : Type :=
| Confirmed : (Tezos_base__TzPervasives.Block_hash.t * Z * Z) ->
operation_status
| Pending : operation_status
| Still_not_found : operation_status.
Definition wait_for_operation_inclusion {F G I a b i o p q : Type}
(ctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) (chain : Tezos_shell_services__Block_services.chain)
(op_staroptstar : option Z)
: (option Z) ->
(option Tezos_base__TzPervasives.Block_hash.Set.elt) ->
Tezos_base__TzPervasives.Operation_hash.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Block_hash.t * Z * Z)) :=
let predecessors :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 10
end in
fun op_staroptstar =>
let confirmations :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 1
end in
fun branch =>
fun operation_hash =>
(* ❌ Let of exception is not handled *)
let_exception.
Definition lookup_operation_in_previous_block {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(chain : Tezos_shell_services__Block_services.chain)
(operation_hash : Tezos_base__TzPervasives.Operation_hash.t) (i : Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option (Tezos_base__TzPervasives.Block_hash.t * Z * Z))) :=
op_gtgteqquestion
(Block_services.Empty.hash ctxt None
(Some
(* ❌ Variants not supported *)
variant) tt)
(fun block =>
op_gtgteqquestion
(Shell_services.Blocks.Operation_hashes.operation_hashes ctxt
(Some chain)
(Some
(* ❌ Variants not supported *)
variant) tt)
(fun operations =>
match in_block operation_hash operations with
| None => return_none
| Some (a, b) => return_some (block, a, b)
end)).
Definition lookup_operation_in_previous_blocks {F G I a b i o p q : Type}
(ctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) (chain : Tezos_shell_services__Block_services.chain)
(predecessors : Z)
(operation_hash : Tezos_base__TzPervasives.Operation_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option (Tezos_base__TzPervasives.Block_hash.t * Z * Z))) :=
let fix loop (i : Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option (Tezos_base__TzPervasives.Block_hash.t * Z * Z))) :=
if equiv_decb i (Z.add predecessors 1) then
return_none
else
op_gtgteqquestion
(lookup_operation_in_previous_block ctxt chain operation_hash i)
(fun function_parameter =>
match function_parameter with
| None => loop (Z.add i 1)
| Some (block, a, b) => return_some (block, a, b)
end) in
loop 0.
Definition wait_for_bootstrapped {F G I a b i o p q : Type}
(ctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let display := Stdlib.ref false in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(* ❌ Float constant 0.3 is approximated by the integer 0 *)
0)
(fun function_parameter =>
let 'tt := function_parameter in
if negb (Stdlib.op_exclamation display) then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Waiting for the node to be bootstrapped before injection..."
% string CamlinternalFormatBasics.End_of_format)
"Waiting for the node to be bootstrapped before injection..."
% string))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq display true in
Lwt.return_unit)
else
Lwt.return_unit)) in
op_gtgteqquestion (Monitor_services.bootstrapped ctxt)
(fun function_parameter =>
let '(stream, _stop) := function_parameter in
op_gtgteq
(Lwt_stream.iter_s
(fun function_parameter =>
let '(hash, time) := function_parameter in
if Stdlib.op_exclamation display then
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Current head: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (timestamp: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", validation: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))))
"Current head: %a (timestamp: %a, validation: %a)" % string)
Block_hash.pp_short hash Time.System.pp_hum
(Time.System.of_protocol_exn time) Time.System.pp_hum
((* ❌ Sending method message is not handled *)
send tt)
else
Lwt.return_unit) stream)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq display true in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Node is bootstrapped, ready for injecting operations." %
string CamlinternalFormatBasics.End_of_format)
"Node is bootstrapped, ready for injecting operations." % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))).
src/lib_client_base/client_context.ml 26 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type ('a, 'b) lwt_format = ('a, Format.formatter, unit, 'b Lwt.t) format4
class type printer =
object
method error : ('a, 'b) lwt_format -> 'a
method warning : ('a, unit) lwt_format -> 'a
method message : ('a, unit) lwt_format -> 'a
method answer : ('a, unit) lwt_format -> 'a
method log : string -> ('a, unit) lwt_format -> 'a
end
class type prompter =
object
method prompt : ('a, string tzresult) lwt_format -> 'a
method prompt_password : ('a, Bigstring.t tzresult) lwt_format -> 'a
end
class type io =
object
inherit printer
inherit prompter
end
class simple_printer log =
let message x = Format.kasprintf (fun msg -> log "stdout" msg) x in
object
method error : type a b. (a, b) lwt_format -> a =
Format.kasprintf (fun msg -> Lwt.fail (Failure msg))
method warning : type a. (a, unit) lwt_format -> a =
Format.kasprintf (fun msg -> log "stderr" msg)
method message : type a. (a, unit) lwt_format -> a = message
method answer : type a. (a, unit) lwt_format -> a = message
method log : type a. string -> (a, unit) lwt_format -> a =
fun name -> Format.kasprintf (fun msg -> log name msg)
end
class type wallet =
object
method load_passwords : string Lwt_stream.t option
method read_file : string -> string tzresult Lwt.t
method with_lock : (unit -> 'a Lwt.t) -> 'a Lwt.t
method load :
string -> default:'a -> 'a Data_encoding.encoding -> 'a tzresult Lwt.t
method write :
string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t
end
class type chain =
object
method chain : Shell_services.chain
end
class type block =
object
method block : Shell_services.block
method confirmations : int option
end
class type io_wallet =
object
inherit printer
inherit prompter
inherit wallet
end
class type io_rpcs =
object
inherit printer
inherit prompter
inherit RPC_context.json
end
class type ui =
object
method sleep : float -> unit Lwt.t
method now : unit -> Ptime.t
end
class type full =
object
inherit printer
inherit prompter
inherit wallet
inherit RPC_context.json
inherit chain
inherit block
inherit ui
end
class proxy_context (obj : full) =
object
method load_passwords = obj#load_passwords
method read_file = obj#read_file
method base = obj#base
method chain = obj#chain
method block = obj#block
method confirmations = obj#confirmations
method answer : type a. (a, unit) lwt_format -> a = obj#answer
method call_service
: 'm 'p 'q 'i 'o.
(([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p ->
'q -> 'i -> 'o tzresult Lwt.t =
obj#call_service
method call_streamed_service
: 'm 'p 'q 'i 'o.
(([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t ->
on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q -> 'i ->
(unit -> unit) tzresult Lwt.t =
obj#call_streamed_service
method error : type a b. (a, b) lwt_format -> a = obj#error
method generic_json_call = obj#generic_json_call
method with_lock : type a. (unit -> a Lwt.t) -> a Lwt.t = obj#with_lock
method load : type a.
string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t =
obj#load
method log : type a. string -> (a, unit) lwt_format -> a = obj#log
method message : type a. (a, unit) lwt_format -> a = obj#message
method warning : type a. (a, unit) lwt_format -> a = obj#warning
method write : type a.
string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t =
obj#write
method prompt : type a. (a, string tzresult) lwt_format -> a = obj#prompt
method prompt_password : type a. (a, Bigstring.t tzresult) lwt_format -> a
=
obj#prompt_password
method sleep : float -> unit Lwt.t = obj#sleep
method now : unit -> Ptime.t = obj#now
end
let log _ _ = Lwt.return_unit
let null_printer : #printer = new simple_printer log
src/lib_client_base/client_context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition lwt_format (a b : Type) :=
Stdlib.format4 a Stdlib.Format.formatter unit (Lwt.t b).
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class` not handled. *)
class
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class` not handled. *)
class
Definition log {A B : Type} (function_parameter : A) : B -> Lwt.t unit :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit.
Definition null_printer {a b : Type}
: ((((lwt_format a b) -> a) * (a * b)) *
((((lwt_format a unit) -> a) * (a)) *
((((lwt_format a unit) -> a) * (a)) *
((((lwt_format a unit) -> a) * (a)) *
(((string -> (lwt_format a unit) -> a) * (a)) * nil))))) * nil :=
(* ❌ Creation of new objects is not handled *)
new log.
src/lib_client_base/client_keys.ml 113 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type error += Unregistered_key_scheme of string
type error += Invalid_uri of Uri.t
let () =
register_error_kind
`Permanent
~id:"cli.unregistered_key_scheme"
~title:"Unregistered key scheme"
~description:
"A key has been provided with an unregistered scheme (no corresponding \
plugin)"
~pp:(fun ppf s ->
Format.fprintf ppf "No matching plugin for key scheme %s" s)
Data_encoding.(obj1 (req "value" string))
(function Unregistered_key_scheme s -> Some s | _ -> None)
(fun s -> Unregistered_key_scheme s) ;
register_error_kind
`Permanent
~id:"cli.key.invalid_uri"
~title:"Invalid key uri"
~description:"A key has been provided with an invalid uri."
~pp:(fun ppf s -> Format.fprintf ppf "Cannot parse the key uri: %s" s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_uri s -> Some (Uri.to_string s) | _ -> None)
(fun s -> Invalid_uri (Uri.of_string s))
module Public_key_hash = struct
include Client_aliases.Alias (struct
type t = Signature.Public_key_hash.t
let encoding = Signature.Public_key_hash.encoding
let of_source s = Lwt.return (Signature.Public_key_hash.of_b58check s)
let to_source p = return (Signature.Public_key_hash.to_b58check p)
let name = "public key hash"
end)
end
module Logging = struct
let tag = Tag.def ~doc:"Identity" "pk_alias" Format.pp_print_text
end
let uri_encoding = Data_encoding.(conv Uri.to_string Uri.of_string string)
type pk_uri = Uri.t
let make_pk_uri (x : Uri.t) : pk_uri =
match Uri.scheme x with
| None ->
Pervasives.failwith "PK_URI needs a scheme"
| Some _ ->
x
type sk_uri = Uri.t
let make_sk_uri (x : Uri.t) : sk_uri =
match Uri.scheme x with
| None ->
Pervasives.failwith "SK_URI needs a scheme"
| Some _ ->
x
let pk_uri_parameter () =
Clic.parameter (fun _ s ->
try return (make_pk_uri @@ Uri.of_string s)
with Failure s -> failwith "Error while parsing URI: %s" s)
let pk_uri_param ?name ?desc params =
let name = Option.unopt ~default:"uri" name in
let desc =
Option.unopt
~default:
"public key\n\
Varies from one scheme to the other.\n\
Use command `list signing schemes` for more information."
desc
in
Clic.param ~name ~desc (pk_uri_parameter ()) params
let sk_uri_parameter () =
Clic.parameter (fun _ s ->
try return (make_sk_uri @@ Uri.of_string s)
with Failure s -> failwith "Error while parsing URI: %s" s)
let sk_uri_param ?name ?desc params =
let name = Option.unopt ~default:"uri" name in
let desc =
Option.unopt
~default:
"secret key\n\
Varies from one scheme to the other.\n\
Use command `list signing schemes` for more information."
desc
in
Clic.param ~name ~desc (sk_uri_parameter ()) params
module Secret_key = Client_aliases.Alias (struct
let name = "secret_key"
type t = Uri.t
let of_source s = return (Uri.of_string s)
let to_source t = return (Uri.to_string t)
let encoding = uri_encoding
end)
module Public_key = Client_aliases.Alias (struct
let name = "public_key"
type t = Uri.t * Signature.Public_key.t option
let of_source s = return (Uri.of_string s, None)
let to_source (t, _) = return (Uri.to_string t)
let encoding =
let open Data_encoding in
union
[ case
Json_only
~title:"Locator_only"
uri_encoding
(function (uri, None) -> Some uri | (_, Some _) -> None)
(fun uri -> (uri, None));
case
Json_only
~title:"Locator_and_full_key"
(obj2
(req "locator" uri_encoding)
(req "key" Signature.Public_key.encoding))
(function (uri, Some key) -> Some (uri, key) | (_, None) -> None)
(fun (uri, key) -> (uri, Some key)) ]
end)
module type SIGNER = sig
val scheme : string
val title : string
val description : string
val neuterize : sk_uri -> pk_uri tzresult Lwt.t
val import_secret_key :
io:Client_context.io_wallet ->
pk_uri ->
(Signature.Public_key_hash.t * Signature.Public_key.t option) tzresult
Lwt.t
val public_key : pk_uri -> Signature.Public_key.t tzresult Lwt.t
val public_key_hash :
pk_uri ->
(Signature.Public_key_hash.t * Signature.Public_key.t option) tzresult
Lwt.t
val sign :
?watermark:Signature.watermark ->
sk_uri ->
Bytes.t ->
Signature.t tzresult Lwt.t
val deterministic_nonce : sk_uri -> Bytes.t -> Bigstring.t tzresult Lwt.t
val deterministic_nonce_hash : sk_uri -> Bytes.t -> Bytes.t tzresult Lwt.t
val supports_deterministic_nonces : sk_uri -> bool tzresult Lwt.t
end
let signers_table : (string, (module SIGNER)) Hashtbl.t = Hashtbl.create 13
let register_signer signer =
let module Signer = (val signer : SIGNER) in
Hashtbl.replace signers_table Signer.scheme signer
let find_signer_for_key ~scheme =
match Hashtbl.find_opt signers_table scheme with
| None ->
fail (Unregistered_key_scheme scheme)
| Some signer ->
return signer
let registered_signers () : (string * (module SIGNER)) list =
Hashtbl.fold (fun k v acc -> (k, v) :: acc) signers_table []
type error += Signature_mismatch of sk_uri
let () =
register_error_kind
`Permanent
~id:"cli.signature_mismatch"
~title:"Signature mismatch"
~description:"The signer produced an invalid signature"
~pp:(fun ppf sk ->
Format.fprintf
ppf
"The signer for %a produced an invalid signature"
Uri.pp_hum
sk)
Data_encoding.(obj1 (req "locator" uri_encoding))
(function Signature_mismatch sk -> Some sk | _ -> None)
(fun sk -> Signature_mismatch sk)
let with_scheme_signer (uri : Uri.t) (f : (module SIGNER) -> 'a) : 'a =
match Uri.scheme uri with
| None ->
assert false
| Some scheme ->
find_signer_for_key ~scheme >>=? fun signer -> f signer
let neuterize sk_uri =
with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
Signer.neuterize sk_uri)
let public_key pk_uri =
with_scheme_signer pk_uri (fun (module Signer : SIGNER) ->
Signer.public_key pk_uri)
let public_key_hash pk_uri =
with_scheme_signer pk_uri (fun (module Signer : SIGNER) ->
Signer.public_key_hash pk_uri)
let import_secret_key ~io pk_uri =
with_scheme_signer pk_uri (fun (module Signer : SIGNER) ->
Signer.import_secret_key ~io pk_uri)
let sign cctxt ?watermark sk_uri buf =
with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
Signer.sign ?watermark sk_uri buf
>>=? fun signature ->
Signer.neuterize sk_uri
>>=? fun pk_uri ->
Secret_key.rev_find cctxt sk_uri
>>=? (function
| None ->
public_key pk_uri
| Some name -> (
Public_key.find cctxt name
>>=? function
| (_, None) ->
public_key pk_uri
>>=? fun pk ->
Public_key.update cctxt name (pk_uri, Some pk)
>>=? fun () -> return pk
| (_, Some pubkey) ->
return pubkey ))
>>=? fun pubkey ->
fail_unless
(Signature.check ?watermark pubkey signature buf)
(Signature_mismatch sk_uri)
>>=? fun () -> return signature)
let append cctxt ?watermark loc buf =
sign cctxt ?watermark loc buf
>>|? fun signature -> Signature.concat buf signature
let check ?watermark pk_uri signature buf =
public_key pk_uri
>>=? fun pk -> return (Signature.check ?watermark pk signature buf)
let deterministic_nonce sk_uri data =
with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
Signer.deterministic_nonce sk_uri data)
let deterministic_nonce_hash sk_uri data =
with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
Signer.deterministic_nonce_hash sk_uri data)
let supports_deterministic_nonces sk_uri =
with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
Signer.supports_deterministic_nonces sk_uri)
let register_key cctxt ?(force = false) (public_key_hash, pk_uri, sk_uri)
?public_key name =
Public_key.add ~force cctxt name (pk_uri, public_key)
>>=? fun () ->
Secret_key.add ~force cctxt name sk_uri
>>=? fun () ->
Public_key_hash.add ~force cctxt name public_key_hash
>>=? fun () -> return_unit
let raw_get_key (cctxt : #Client_context.wallet) pkh =
Public_key_hash.rev_find cctxt pkh
>>=? (function
| None ->
failwith "no keys for the source contract manager"
| Some n ->
Secret_key.find_opt cctxt n
>>=? fun sk_uri ->
Public_key.find_opt cctxt n
>>=? (function
| None ->
return_none
| Some (_, Some pk) ->
return_some pk
| Some (pk_uri, None) ->
public_key pk_uri
>>=? fun pk ->
Public_key.update cctxt n (pk_uri, Some pk)
>>=? fun () -> return_some pk)
>>=? fun pk -> return (n, pk, sk_uri))
>>= function
| (Ok (_, None, None) | Error _) as initial_result -> (
(* try to lookup for a remote key *)
find_signer_for_key ~scheme:"remote"
>>=? (fun signer ->
let module Signer = (val signer : SIGNER) in
let path = Signature.Public_key_hash.to_b58check pkh in
let uri = Uri.make ~scheme:Signer.scheme ~path () in
Signer.public_key uri
>>=? fun pk -> return (path, Some pk, Some uri))
>>= function
| Error _ ->
Lwt.return initial_result
| Ok _ as success ->
Lwt.return success )
| Ok _ as success ->
Lwt.return success
let get_key cctxt pkh =
raw_get_key cctxt pkh
>>=? function
| (pkh, Some pk, Some sk) ->
return (pkh, pk, sk)
| (_pkh, _pk, None) ->
failwith "Unknown secret key for %a" Signature.Public_key_hash.pp pkh
| (_pkh, None, _sk) ->
failwith "Unknown public key for %a" Signature.Public_key_hash.pp pkh
let get_public_key cctxt pkh =
raw_get_key cctxt pkh
>>=? function
| (pkh, Some pk, _sk) ->
return (pkh, pk)
| (_pkh, None, _sk) ->
failwith "Unknown public key for %a" Signature.Public_key_hash.pp pkh
let get_keys (cctxt : #Client_context.wallet) =
Secret_key.load cctxt
>>=? fun sks ->
Lwt_list.filter_map_s
(fun (name, sk_uri) ->
Public_key_hash.find cctxt name
>>=? (fun pkh ->
Public_key.find cctxt name
>>=? (function
| (_, Some pk) ->
return pk
| (pk_uri, None) ->
public_key pk_uri
>>=? fun pk ->
Public_key.update cctxt name (pk_uri, Some pk)
>>=? fun () -> return pk)
>>=? fun pk -> return (name, pkh, pk, sk_uri))
>>= function Ok r -> Lwt.return_some r | Error _ -> Lwt.return_none)
sks
>>= fun keys -> return keys
let list_keys cctxt =
Public_key_hash.load cctxt
>>=? fun l ->
map_s
(fun (name, pkh) ->
raw_get_key cctxt pkh
>>= function
| Ok (_name, pk, sk_uri) ->
return (name, pkh, pk, sk_uri)
| Error _ ->
return (name, pkh, None, None))
l
let alias_keys cctxt name =
Public_key_hash.find cctxt name
>>=? fun pkh ->
raw_get_key cctxt pkh
>>= function
| Ok (_name, pk, sk_uri) ->
return_some (pkh, pk, sk_uri)
| Error _ ->
return_none
let force_switch () =
Clic.switch ~long:"force" ~short:'f' ~doc:"overwrite existing keys" ()
src/lib_client_base/client_keys.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Module Public_key_hash.
(* ❌ Structure item `include` not handled. *)
include
End Public_key_hash.
Module Logging.
Definition tag : Tezos_base__TzPervasives.Tag.def string :=
Tag.def (Some "Identity" % string) "pk_alias" % string Format.pp_print_text.
End Logging.
Definition uri_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Uri.t :=
conv Uri.to_string Uri.of_string None string.
Definition pk_uri := Uri.t.
Definition make_pk_uri (x : Uri.t) : pk_uri :=
match Uri.scheme x with
| None => Pervasives.failwith "PK_URI needs a scheme" % string
| Some _ => x
end.
Definition sk_uri := Uri.t.
Definition make_sk_uri (x : Uri.t) : sk_uri :=
match Uri.scheme x with
| None => Pervasives.failwith "SK_URI needs a scheme" % string
| Some _ => x
end.
Definition pk_uri_parameter {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter pk_uri A :=
let 'tt := function_parameter in
Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try (_return (apply make_pk_uri (Uri.of_string s)))).
Definition pk_uri_param {A B : Type}
(name : option string) (desc : option string)
(params : Tezos_base__TzPervasives.Clic.params A B)
: Tezos_base__TzPervasives.Clic.params (pk_uri -> A) B :=
let name := Option.unopt "uri" % string name in
let desc :=
Option.unopt
"public key
Varies from one scheme to the other.
Use command `list signing schemes` for more information."
% string desc in
Clic.param name desc (pk_uri_parameter tt) params.
Definition sk_uri_parameter {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter sk_uri A :=
let 'tt := function_parameter in
Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try (_return (apply make_sk_uri (Uri.of_string s)))).
Definition sk_uri_param {A B : Type}
(name : option string) (desc : option string)
(params : Tezos_base__TzPervasives.Clic.params A B)
: Tezos_base__TzPervasives.Clic.params (sk_uri -> A) B :=
let name := Option.unopt "uri" % string name in
let desc :=
Option.unopt
"secret key
Varies from one scheme to the other.
Use command `list signing schemes` for more information."
% string desc in
Clic.param name desc (sk_uri_parameter tt) params.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Module SIGNER.
Record signature := {
scheme : string;
title : string;
description : string;
neuterize : sk_uri -> Lwt.t (Tezos_base__TzPervasives.tzresult pk_uri);
import_secret_key : Tezos_client_base.Client_context.io_wallet ->
pk_uri ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Signature.Public_key_hash.t *
(option Tezos_base__TzPervasives.Signature.Public_key.t)));
public_key : pk_uri ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.Public_key.t);
public_key_hash : pk_uri ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Signature.Public_key_hash.t *
(option Tezos_base__TzPervasives.Signature.Public_key.t)));
sign : (option Tezos_base__TzPervasives.Signature.watermark) ->
sk_uri ->
Stdlib.Bytes.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.t);
deterministic_nonce : sk_uri ->
Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t);
deterministic_nonce_hash : sk_uri ->
Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t);
supports_deterministic_nonces : sk_uri ->
Lwt.t (Tezos_base__TzPervasives.tzresult bool);
}.
End SIGNER.
Definition signers_table
: Stdlib.Hashtbl.t string {_ : unit & SIGNER.signature } :=
Hashtbl.create None 13.
Definition register_signer (signer : {_ : unit & SIGNER.signature }) : unit :=
let Signer := projT2 signer in
Hashtbl.replace signers_table Signer.(SIGNER.scheme) signer.
Definition find_signer_for_key (scheme : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult {_ : unit & SIGNER.signature }) :=
match Hashtbl.find_opt signers_table scheme with
| None => fail (Tezos_base__TzPervasives.Unregistered_key_scheme scheme)
| Some signer => _return signer
end.
Definition registered_signers (function_parameter : unit)
: list (string * {_ : unit & SIGNER.signature }) :=
let 'tt := function_parameter in
Hashtbl.fold (fun k => fun v => fun acc => cons (k, v) acc) signers_table [].
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition with_scheme_signer {A : Type}
(uri : Uri.t)
(f :
{_ : unit & SIGNER.signature } ->
Lwt.t (Tezos_base__TzPervasives.tzresult A))
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
match Uri.scheme uri with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some scheme =>
op_gtgteqquestion (find_signer_for_key scheme) (fun signer => f signer)
end.
Definition neuterize (sk_uri : sk_uri)
: Lwt.t (Tezos_base__TzPervasives.tzresult pk_uri) :=
with_scheme_signer sk_uri
(fun Signer =>
let Signer := projT2 Signer in
Signer.(SIGNER.neuterize) sk_uri).
Definition public_key (pk_uri : pk_uri)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.Public_key.t) :=
with_scheme_signer pk_uri
(fun Signer =>
let Signer := projT2 Signer in
Signer.(SIGNER.public_key) pk_uri).
Definition public_key_hash (pk_uri : pk_uri)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Signature.Public_key_hash.t *
(option Tezos_base__TzPervasives.Signature.Public_key.t))) :=
with_scheme_signer pk_uri
(fun Signer =>
let Signer := projT2 Signer in
Signer.(SIGNER.public_key_hash) pk_uri).
Definition import_secret_key
(io : Tezos_client_base.Client_context.io_wallet) (pk_uri : pk_uri)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Signature.Public_key_hash.t *
(option Tezos_base__TzPervasives.Signature.Public_key.t))) :=
with_scheme_signer pk_uri
(fun Signer =>
let Signer := projT2 Signer in
Signer.(SIGNER.import_secret_key) io pk_uri).
Definition sign {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (watermark : option Tezos_base__TzPervasives.Signature.watermark)
(sk_uri : sk_uri) (buf : Stdlib.Bytes.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
with_scheme_signer sk_uri
(fun Signer =>
let Signer := projT2 Signer in
op_gtgteqquestion (Signer.(SIGNER.sign) watermark sk_uri buf)
(fun signature =>
op_gtgteqquestion (Signer.(SIGNER.neuterize) sk_uri)
(fun pk_uri =>
op_gtgteqquestion
(op_gtgteqquestion (Secret_key.rev_find cctxt sk_uri)
(fun function_parameter =>
match function_parameter with
| None => public_key pk_uri
| Some name =>
op_gtgteqquestion (Public_key.find cctxt name)
(fun function_parameter =>
match function_parameter with
| (_, None) =>
op_gtgteqquestion (public_key pk_uri)
(fun pk =>
op_gtgteqquestion
(Public_key.update cctxt name
(pk_uri, (Some pk)))
(fun function_parameter =>
let 'tt := function_parameter in
_return pk))
| (_, Some pubkey) => _return pubkey
end)
end))
(fun pubkey =>
op_gtgteqquestion
(fail_unless
(Signature.check watermark pubkey signature buf)
(Tezos_base__TzPervasives.Signature_mismatch sk_uri))
(fun function_parameter =>
let 'tt := function_parameter in
_return signature))))).
Definition append {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (watermark : option Tezos_base__TzPervasives.Signature.watermark)
(loc : sk_uri) (buf : Stdlib.Bytes.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
op_gtgtpipequestion (sign cctxt watermark loc buf)
(fun signature => Signature.concat buf signature).
Definition check
(watermark : option Tezos_base__TzPervasives.Signature.watermark)
(pk_uri : pk_uri) (signature : Tezos_base__TzPervasives.Signature.t)
(buf : Stdlib.Bytes.t) : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
op_gtgteqquestion (public_key pk_uri)
(fun pk => _return (Signature.check watermark pk signature buf)).
Definition deterministic_nonce (sk_uri : sk_uri) (data : Stdlib.Bytes.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
with_scheme_signer sk_uri
(fun Signer =>
let Signer := projT2 Signer in
Signer.(SIGNER.deterministic_nonce) sk_uri data).
Definition deterministic_nonce_hash (sk_uri : sk_uri) (data : Stdlib.Bytes.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
with_scheme_signer sk_uri
(fun Signer =>
let Signer := projT2 Signer in
Signer.(SIGNER.deterministic_nonce_hash) sk_uri data).
Definition supports_deterministic_nonces (sk_uri : sk_uri)
: Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
with_scheme_signer sk_uri
(fun Signer =>
let Signer := projT2 Signer in
Signer.(SIGNER.supports_deterministic_nonces) sk_uri).
Definition register_key {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (op_staroptstar : option bool)
: (Public_key_hash.t * Uri.t * Secret_key.t) ->
(option Tezos_base__TzPervasives.Signature.Public_key.t) ->
string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let force :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun function_parameter =>
let '(public_key_hash, pk_uri, sk_uri) := function_parameter in
fun public_key =>
fun name =>
op_gtgteqquestion (Public_key.add force cctxt name (pk_uri, public_key))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Secret_key.add force cctxt name sk_uri)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Public_key_hash.add force cctxt name public_key_hash)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))).
Definition raw_get_key {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (pkh : Public_key_hash.t)
: Lwt.t
(sum
(string * (option Tezos_base__TzPervasives.Signature.Public_key.t) *
(option Secret_key.t)) Tezos_base__TzPervasives.trace) :=
op_gtgteq
(op_gtgteqquestion (Public_key_hash.rev_find cctxt pkh)
(fun function_parameter =>
match function_parameter with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"no keys for the source contract manager" % string
CamlinternalFormatBasics.End_of_format)
"no keys for the source contract manager" % string)
| Some n =>
op_gtgteqquestion (Secret_key.find_opt cctxt n)
(fun sk_uri =>
op_gtgteqquestion
(op_gtgteqquestion (Public_key.find_opt cctxt n)
(fun function_parameter =>
match function_parameter with
| None => return_none
| Some (_, Some pk) => return_some pk
| Some (pk_uri, None) =>
op_gtgteqquestion (public_key pk_uri)
(fun pk =>
op_gtgteqquestion
(Public_key.update cctxt n (pk_uri, (Some pk)))
(fun function_parameter =>
let 'tt := function_parameter in
return_some pk))
end)) (fun pk => _return (n, pk, sk_uri)))
end))
(fun function_parameter =>
match function_parameter with
| (Stdlib.Ok (_, None, None) | Stdlib.Error _) as initial_result =>
op_gtgteq
(op_gtgteqquestion (find_signer_for_key "remote" % string)
(fun signer =>
let Signer := projT2 signer in
let path := Signature.Public_key_hash.to_b58check pkh in
let uri :=
Uri.make (Some Signer.(SIGNER.scheme)) None None None
(Some path) None None tt in
op_gtgteqquestion (Signer.(SIGNER.public_key) uri)
(fun pk => _return (path, (Some pk), (Some uri)))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ => Lwt._return initial_result
| (Stdlib.Ok _) as success => Lwt._return success
end)
| (Stdlib.Ok _) as success => Lwt._return success
end).
Definition get_key {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (pkh : Public_key_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(string * Tezos_base__TzPervasives.Signature.Public_key.t * Secret_key.t)) :=
op_gtgteqquestion (raw_get_key cctxt pkh)
(fun function_parameter =>
match function_parameter with
| (pkh, Some pk, Some sk) => _return (pkh, pk, sk)
| (_pkh, _pk, None) =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown secret key for " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Unknown secret key for %a" % string) Signature.Public_key_hash.pp
pkh
| (_pkh, None, _sk) =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown public key for " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Unknown public key for %a" % string) Signature.Public_key_hash.pp
pkh
end).
Definition get_public_key {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (pkh : Public_key_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(string * Tezos_base__TzPervasives.Signature.Public_key.t)) :=
op_gtgteqquestion (raw_get_key cctxt pkh)
(fun function_parameter =>
match function_parameter with
| (pkh, Some pk, _sk) => _return (pkh, pk)
| (_pkh, None, _sk) =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown public key for " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Unknown public key for %a" % string) Signature.Public_key_hash.pp
pkh
end).
Definition get_keys {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(string * Public_key_hash.t *
Tezos_base__TzPervasives.Signature.Public_key.t * Secret_key.t))) :=
op_gtgteqquestion (Secret_key.load cctxt)
(fun sks =>
op_gtgteq
(Lwt_list.filter_map_s
(fun function_parameter =>
let '(name, sk_uri) := function_parameter in
op_gtgteq
(op_gtgteqquestion (Public_key_hash.find cctxt name)
(fun pkh =>
op_gtgteqquestion
(op_gtgteqquestion (Public_key.find cctxt name)
(fun function_parameter =>
match function_parameter with
| (_, Some pk) => _return pk
| (pk_uri, None) =>
op_gtgteqquestion (public_key pk_uri)
(fun pk =>
op_gtgteqquestion
(Public_key.update cctxt name
(pk_uri, (Some pk)))
(fun function_parameter =>
let 'tt := function_parameter in
_return pk))
end)) (fun pk => _return (name, pkh, pk, sk_uri))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok r => Lwt.return_some r
| Stdlib.Error _ => Lwt.return_none
end)) sks) (fun keys => _return keys)).
Definition list_keys {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(string * Public_key_hash.t *
(option Tezos_base__TzPervasives.Signature.Public_key.t) *
(option Secret_key.t)))) :=
op_gtgteqquestion (Public_key_hash.load cctxt)
(fun l =>
map_s
(fun function_parameter =>
let '(name, pkh) := function_parameter in
op_gtgteq (raw_get_key cctxt pkh)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok (_name, pk, sk_uri) => _return (name, pkh, pk, sk_uri)
| Stdlib.Error _ => _return (name, pkh, None, None)
end)) l).
Definition alias_keys {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (name : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option
(Public_key_hash.t *
(option Tezos_base__TzPervasives.Signature.Public_key.t) *
(option Secret_key.t)))) :=
op_gtgteqquestion (Public_key_hash.find cctxt name)
(fun pkh =>
op_gtgteq (raw_get_key cctxt pkh)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok (_name, pk, sk_uri) => return_some (pkh, pk, sk_uri)
| Stdlib.Error _ => return_none
end)).
Definition force_switch {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg bool A :=
let 'tt := function_parameter in
Clic.switch "overwrite existing keys" % string (Some "f" % char)
"force" % string tt.
src/lib_client_base_unix/client_config.ml 323 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Tezos Command line interface - Configuration and Arguments Parsing *)
type error += Invalid_chain_argument of string
type error += Invalid_block_argument of string
type error += Invalid_protocol_argument of string
type error += Invalid_port_arg of string
type error += Invalid_remote_signer_argument of string
type error += Invalid_wait_arg of string
let () =
register_error_kind
`Branch
~id:"badChainArgument"
~title:"Bad Chain Argument"
~description:"Chain argument could not be parsed"
~pp:(fun ppf s ->
Format.fprintf ppf "Value %s is not a value chain reference." s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_chain_argument s -> Some s | _ -> None)
(fun s -> Invalid_chain_argument s) ;
register_error_kind
`Branch
~id:"badBlockArgument"
~title:"Bad Block Argument"
~description:"Block argument could not be parsed"
~pp:(fun ppf s ->
Format.fprintf ppf "Value %s is not a value block reference." s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_block_argument s -> Some s | _ -> None)
(fun s -> Invalid_block_argument s) ;
register_error_kind
`Branch
~id:"badProtocolArgument"
~title:"Bad Protocol Argument"
~description:"Protocol argument could not be parsed"
~pp:(fun ppf s ->
Format.fprintf
ppf
"Value %s does not correspond to any known protocol."
s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_protocol_argument s -> Some s | _ -> None)
(fun s -> Invalid_protocol_argument s) ;
register_error_kind
`Branch
~id:"invalidPortArgument"
~title:"Bad Port Argument"
~description:"Port argument could not be parsed"
~pp:(fun ppf s -> Format.fprintf ppf "Value %s is not a valid TCP port." s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_port_arg s -> Some s | _ -> None)
(fun s -> Invalid_port_arg s) ;
register_error_kind
`Branch
~id:"invalid_remote_signer_argument"
~title:"Unexpected URI of remote signer"
~description:"The remote signer argument could not be parsed"
~pp:(fun ppf s -> Format.fprintf ppf "Value '%s' is not a valid URI." s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_remote_signer_argument s -> Some s | _ -> None)
(fun s -> Invalid_remote_signer_argument s) ;
register_error_kind
`Branch
~id:"invalidWaitArgument"
~title:"Bad Wait Argument"
~description:"Wait argument could not be parsed"
~pp:(fun ppf s ->
Format.fprintf
ppf
"Value %s is not a valid number of confirmation, nor 'none'."
s)
Data_encoding.(obj1 (req "value" string))
(function Invalid_wait_arg s -> Some s | _ -> None)
(fun s -> Invalid_wait_arg s)
let home = try Sys.getenv "HOME" with Not_found -> "/root"
let default_base_dir = Filename.concat home ".tezos-client"
let default_chain = `Main
let default_block = `Head 0
let ( // ) = Filename.concat
module Cfg_file = struct
type t = {
base_dir : string;
node_addr : string;
node_port : int;
tls : bool;
web_port : int;
remote_signer : Uri.t option;
confirmations : int option;
password_filename : string option;
}
let default =
{
base_dir = default_base_dir;
node_addr = "localhost";
node_port = 8732;
tls = false;
web_port = 8080;
remote_signer = None;
confirmations = Some 0;
password_filename = None;
}
open Data_encoding
let encoding =
conv
(fun { base_dir;
node_addr;
node_port;
tls;
web_port;
remote_signer;
confirmations;
password_filename } ->
( base_dir,
Some node_addr,
Some node_port,
Some tls,
Some web_port,
remote_signer,
confirmations,
password_filename ))
(fun ( base_dir,
node_addr,
node_port,
tls,
web_port,
remote_signer,
confirmations,
password_filename ) ->
let node_addr = Option.unopt ~default:default.node_addr node_addr in
let node_port = Option.unopt ~default:default.node_port node_port in
let tls = Option.unopt ~default:default.tls tls in
let web_port = Option.unopt ~default:default.web_port web_port in
{
base_dir;
node_addr;
node_port;
tls;
web_port;
remote_signer;
confirmations;
password_filename;
})
(obj8
(req "base_dir" string)
(opt "node_addr" string)
(opt "node_port" int16)
(opt "tls" bool)
(opt "web_port" int16)
(opt "remote_signer" RPC_encoding.uri_encoding)
(opt "confirmations" int8)
(opt "password_filename" string))
let from_json json = Data_encoding.Json.destruct encoding json
let read fp =
Lwt_utils_unix.Json.read_file fp >>=? fun json -> return (from_json json)
let write out cfg =
Lwt_utils_unix.Json.write_file
out
(Data_encoding.Json.construct encoding cfg)
end
type cli_args = {
chain : Chain_services.chain;
block : Shell_services.block;
confirmations : int option;
password_filename : string option;
protocol : Protocol_hash.t option;
print_timings : bool;
log_requests : bool;
}
let default_cli_args =
{
chain = default_chain;
block = default_block;
confirmations = Some 0;
password_filename = None;
protocol = None;
print_timings = false;
log_requests = false;
}
open Clic
let string_parameter () : (string, #Client_context.full) parameter =
parameter (fun _ x -> return x)
let chain_parameter () =
parameter (fun _ chain ->
match Chain_services.parse_chain chain with
| Error _ ->
fail (Invalid_chain_argument chain)
| Ok chain ->
return chain)
let block_parameter () =
parameter (fun _ block ->
match Block_services.parse_block block with
| Error _ ->
fail (Invalid_block_argument block)
| Ok block ->
return block)
let wait_parameter () =
parameter (fun _ wait ->
match wait with
| "no" | "none" ->
return_none
| _ -> (
try
let w = int_of_string wait in
if 0 <= w then return_some w else fail (Invalid_wait_arg wait)
with _ -> fail (Invalid_wait_arg wait) ))
let protocol_parameter () =
parameter (fun _ arg ->
try
let (hash, _commands) =
List.find
(fun (hash, _commands) ->
String.has_prefix ~prefix:arg (Protocol_hash.to_b58check hash))
(Client_commands.get_versions ())
in
return_some hash
with Not_found -> fail (Invalid_protocol_argument arg))
(* Command-line only args (not in config file) *)
let base_dir_arg () =
arg
~long:"base-dir"
~short:'d'
~placeholder:"path"
~doc:
( "client data directory\n\
The directory where the Tezos client will store all its data.\n\
By default: '" ^ default_base_dir ^ "'." )
(string_parameter ())
let config_file_arg () =
arg
~long:"config-file"
~short:'c'
~placeholder:"path"
~doc:"configuration file"
(string_parameter ())
let timings_switch () =
switch ~long:"timings" ~short:'t' ~doc:"show RPC request times" ()
let chain_arg () =
default_arg
~long:"chain"
~placeholder:"hash|tag"
~doc:
"chain on which to apply contextual commands (possible tags are 'main' \
and 'test')"
~default:(Chain_services.to_string default_cli_args.chain)
(chain_parameter ())
let block_arg () =
default_arg
~long:"block"
~short:'b'
~placeholder:"hash|tag"
~doc:
"block on which to apply contextual commands (possible tags are 'head' \
and 'genesis')"
~default:(Block_services.to_string default_cli_args.block)
(block_parameter ())
let wait_arg () =
arg
~long:"wait"
~short:'w'
~placeholder:"none|<int>"
~doc:
"how many confirmation blocks before to consider an operation as included"
(wait_parameter ())
let protocol_arg () =
arg
~long:"protocol"
~short:'p'
~placeholder:"hash"
~doc:"use commands of a specific protocol"
(protocol_parameter ())
let log_requests_switch () =
switch ~long:"log-requests" ~short:'l' ~doc:"log all requests to the node" ()
(* Command-line args which can be set in config file as well *)
let addr_arg () =
arg
~long:"addr"
~short:'A'
~placeholder:"IP addr|host"
~doc:"IP address of the node"
(string_parameter ())
let port_arg () =
arg
~long:"port"
~short:'P'
~placeholder:"number"
~doc:"RPC port of the node"
(parameter (fun _ x ->
try return (int_of_string x)
with Failure _ -> fail (Invalid_port_arg x)))
let tls_switch () =
switch ~long:"tls" ~short:'S' ~doc:"use TLS to connect to node." ()
let remote_signer_arg () =
arg
~long:"remote-signer"
~short:'R'
~placeholder:"uri"
~doc:"URI of the remote signer"
(parameter (fun _ x -> Tezos_signer_backends_unix.Remote.parse_base_uri x))
let password_filename_arg () =
arg
~long:"password-filename"
~short:'f'
~placeholder:"filename"
~doc:"path to the password filename"
(string_parameter ())
let read_config_file config_file =
Lwt_utils_unix.Json.read_file config_file
>>=? fun cfg_json ->
try return @@ Cfg_file.from_json cfg_json
with exn ->
failwith
"Can't parse the configuration file: %s@,%a"
config_file
(fun ppf exn -> Json_encoding.print_error ppf exn)
exn
let default_config_file_name = "config"
let commands config_file cfg =
let open Clic in
let group =
{
Clic.name = "config";
title = "Commands for editing and viewing the client's config file";
}
in
[ command
~group
~desc:"Show the config file."
no_options
(fixed ["config"; "show"])
(fun () (cctxt : #Client_context.full) ->
let pp_cfg ppf cfg =
Format.fprintf
ppf
"%a"
Data_encoding.Json.pp
(Data_encoding.Json.construct Cfg_file.encoding cfg)
in
if not @@ Sys.file_exists config_file then
cctxt#warning
"@[<v 2>Warning: no config file at %s,@,\
displaying the default configuration.@]"
config_file
>>= fun () -> cctxt#warning "%a@," pp_cfg Cfg_file.default >>= return
else
read_config_file config_file
>>=? fun cfg -> cctxt#message "%a@," pp_cfg cfg >>= return);
command
~group
~desc:"Reset the config file to the factory defaults."
no_options
(fixed ["config"; "reset"])
(fun () _cctxt -> Cfg_file.(write config_file default));
command
~group
~desc:
"Update the config based on the current cli values.\n\
Loads the current configuration (default or as specified with \
`-config-file`), applies alterations from other command line \
arguments (such as the node's address, etc.), and overwrites the \
updated configuration file."
no_options
(fixed ["config"; "update"])
(fun () _cctxt -> Cfg_file.(write config_file cfg));
command
~group
~desc:
"Create a config file based on the current CLI values.\n\
If the `-file` option is not passed, this will initialize the \
default config file, based on default parameters, altered by other \
command line options (such as the node's address, etc.).\n\
Otherwise, it will create a new config file, based on the default \
parameters (or the the ones specified with `-config-file`), altered \
by other command line options.\n\
The command will always fail if the file already exists."
(args1
(default_arg
~long:"output"
~short:'o'
~placeholder:"path"
~doc:"path at which to create the file"
~default:(cfg.base_dir // default_config_file_name)
(parameter (fun _ctx str -> return str))))
(fixed ["config"; "init"])
(fun config_file _cctxt ->
if not (Sys.file_exists config_file) then
Cfg_file.(write config_file cfg)
(* Should be default or command would have failed *)
else failwith "Config file already exists at location") ]
let global_options () =
args13
(base_dir_arg ())
(config_file_arg ())
(timings_switch ())
(chain_arg ())
(block_arg ())
(wait_arg ())
(protocol_arg ())
(log_requests_switch ())
(addr_arg ())
(port_arg ())
(tls_switch ())
(remote_signer_arg ())
(password_filename_arg ())
type parsed_config_args = {
parsed_config_file : Cfg_file.t option;
parsed_args : cli_args option;
config_commands : Client_context.full command list;
base_dir : string option;
require_auth : bool;
password_filename : string option;
}
let default_parsed_config_args =
{
parsed_config_file = None;
parsed_args = None;
config_commands = [];
base_dir = None;
require_auth = false;
password_filename = None;
}
let parse_config_args (ctx : #Client_context.full) argv =
parse_global_options (global_options ()) ctx argv
>>=? fun ( ( base_dir,
config_file,
timings,
chain,
block,
confirmations,
protocol,
log_requests,
node_addr,
node_port,
tls,
remote_signer,
password_filename ),
remaining ) ->
( match base_dir with
| None ->
let base_dir = default_base_dir in
unless (Sys.file_exists base_dir) (fun () ->
Lwt_utils_unix.create_dir base_dir >>= return)
>>=? fun () -> return base_dir
| Some dir ->
if not (Sys.file_exists dir) then
failwith
"Specified -base-dir does not exist. Please create the directory \
and try again."
else if Sys.is_directory dir then return dir
else failwith "Specified -base-dir must be a directory" )
>>=? fun base_dir ->
( match config_file with
| None ->
return @@ (base_dir // default_config_file_name)
| Some config_file ->
if Sys.file_exists config_file then return config_file
else
failwith
"Config file specified in option does not exist. Use `client config \
init` to create one." )
>>=? fun config_file ->
let config_dir = Filename.dirname config_file in
let protocol = match protocol with None -> None | Some p -> p in
( if not (Sys.file_exists config_file) then
return {Cfg_file.default with base_dir}
else read_config_file config_file )
>>=? fun cfg ->
let tls = cfg.tls || tls in
let node_addr = Option.unopt ~default:cfg.node_addr node_addr in
let node_port = Option.unopt ~default:cfg.node_port node_port in
Tezos_signer_backends_unix.Remote.read_base_uri_from_env ()
>>=? fun remote_signer_env ->
let remote_signer =
Option.first_some
remote_signer
(Option.first_some remote_signer_env cfg.remote_signer)
in
let confirmations = Option.unopt ~default:cfg.confirmations confirmations in
let cfg =
{
cfg with
tls;
node_port;
node_addr;
remote_signer;
confirmations;
password_filename;
}
in
if Sys.file_exists base_dir && not (Sys.is_directory base_dir) then (
Format.eprintf "%s is not a directory.@." base_dir ;
exit 1 ) ;
if Sys.file_exists config_dir && not (Sys.is_directory config_dir) then (
Format.eprintf "%s is not a directory.@." config_dir ;
exit 1 ) ;
Lwt_utils_unix.create_dir config_dir
>>= fun () ->
return
( {
default_parsed_config_args with
parsed_config_file = Some cfg;
parsed_args =
Some
{
chain;
block;
confirmations;
print_timings = timings;
log_requests;
password_filename;
protocol;
};
config_commands = commands config_file cfg;
},
remaining )
type t =
string option
* string option
* bool
* Shell_services.chain
* Shell_services.block
* int option option
* Protocol_hash.t option option
* bool
* string option
* int option
* bool
* Uri.t option
* string option
module type Remote_params = sig
val authenticate :
Signature.public_key_hash list -> Bytes.t -> Signature.t tzresult Lwt.t
val logger : RPC_client_unix.logger
end
let other_registrations : (_ -> (module Remote_params) -> _) option =
Some
(fun parsed_config_file (module Remote_params) ->
Option.iter parsed_config_file.Cfg_file.remote_signer ~f:(fun signer ->
Client_keys.register_signer
( module Tezos_signer_backends_unix.Remote.Make
(RPC_client_unix)
(struct
let default = signer
include Remote_params
end) )))
let clic_commands ~base_dir:_ ~config_commands ~builtin_commands
~other_commands ~require_auth:_ =
config_commands @ builtin_commands @ other_commands
let logger = None
src/lib_client_base_unix/client_config.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition home : string :=
(* ❌ Try-with are not handled *)
try (Sys.getenv "HOME" % string).
Definition default_base_dir : string :=
Filename.concat home ".tezos-client" % string.
Definition default_chain : variant :=
(* ❌ Variants not supported *)
variant.
Definition default_block : variant :=
(* ❌ Variants not supported *)
variant.
Definition op_divdiv : string -> string -> string := Filename.concat.
Module Cfg_file.
Record t := {
base_dir : string;
node_addr : string;
node_port : Z;
tls : bool;
web_port : Z;
remote_signer : option Uri.t;
confirmations : option Z;
password_filename : option string }.
Definition default : t :=
{| base_dir := default_base_dir; node_addr := "localhost" % string;
node_port := 8732; tls := false; web_port := 8080; remote_signer := None;
confirmations := Some 0; password_filename := None |}.
Import Data_encoding.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
conv
(fun function_parameter =>
let '{|
base_dir := base_dir;
node_addr := node_addr;
node_port := node_port;
tls := tls;
web_port := web_port;
remote_signer := remote_signer;
confirmations := confirmations;
password_filename := password_filename
|} := function_parameter in
(base_dir, (Some node_addr), (Some node_port), (Some tls),
(Some web_port), remote_signer, confirmations, password_filename))
(fun function_parameter =>
let
'(base_dir, node_addr, node_port, tls, web_port, remote_signer,
confirmations, password_filename) := function_parameter in
let node_addr := Option.unopt (node_addr default) node_addr in
let node_port := Option.unopt (node_port default) node_port in
let tls := Option.unopt (tls default) tls in
let web_port := Option.unopt (web_port default) web_port in
{| base_dir := base_dir; node_addr := node_addr; node_port := node_port;
tls := tls; web_port := web_port; remote_signer := remote_signer;
confirmations := confirmations; password_filename := password_filename
|}) None
(obj8 (req None None "base_dir" % string string)
(opt None None "node_addr" % string string)
(opt None None "node_port" % string int16)
(opt None None "tls" % string bool)
(opt None None "web_port" % string int16)
(opt None None "remote_signer" % string RPC_encoding.uri_encoding)
(opt None None "confirmations" % string int8)
(opt None None "password_filename" % string string)).
Definition from_json (json : Tezos_base__TzPervasives.Data_encoding.Json.json)
: t := Data_encoding.Json.destruct encoding json.
Definition read (fp : string) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
op_gtgteqquestion (Lwt_utils_unix.Json.read_file fp)
(fun json => _return (from_json json)).
Definition write (out : string) (cfg : t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
Lwt_utils_unix.Json.write_file out
(Data_encoding.Json.construct encoding cfg).
End Cfg_file.
Record cli_args := {
chain : Tezos_shell_services.Chain_services.chain;
block : Tezos_shell_services.Shell_services.block;
confirmations : option Z;
password_filename : option string;
protocol : option Tezos_base__TzPervasives.Protocol_hash.t;
print_timings : bool;
log_requests : bool }.
Definition default_cli_args : cli_args :=
{| chain := default_chain; block := default_block; confirmations := Some 0;
password_filename := None; protocol := None; print_timings := false;
log_requests := false |}.
Import Clic.
Definition string_parameter {F G I a b i o p q : Type}
(function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter string
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
let 'tt := function_parameter in
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x => _return x).
Definition chain_parameter {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter
Tezos_shell_services.Chain_services.chain A :=
let 'tt := function_parameter in
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun chain =>
match Chain_services.parse_chain chain with
| Stdlib.Error _ =>
fail (Tezos_base__TzPervasives.Invalid_chain_argument chain)
| Stdlib.Ok chain => _return chain
end).
Definition block_parameter {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter
Tezos_shell_services.Block_services.block A :=
let 'tt := function_parameter in
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun block =>
match Block_services.parse_block block with
| Stdlib.Error _ =>
fail (Tezos_base__TzPervasives.Invalid_block_argument block)
| Stdlib.Ok block => _return block
end).
Definition wait_parameter {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter (option Z) A :=
let 'tt := function_parameter in
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun wait =>
match wait with
| "no" % string | "none" % string => return_none
| _ =>
(* ❌ Try-with are not handled *)
try
(let w := OCaml.Stdlib.int_of_string wait in
if OCaml.Stdlib.le 0 w then
return_some w
else
fail (Tezos_base__TzPervasives.Invalid_wait_arg wait))
end).
Definition protocol_parameter {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter
(option Tezos_base__TzPervasives.Protocol_hash.t) A :=
let 'tt := function_parameter in
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun arg =>
(* ❌ Try-with are not handled *)
try
(let '(hash, _commands) :=
List.find
(fun function_parameter =>
let '(hash, _commands) := function_parameter in
String.has_prefix arg (Protocol_hash.to_b58check hash))
(Client_commands.get_versions tt) in
return_some hash)).
Definition base_dir_arg {F G I a b i o p q : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option string)
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
let 'tt := function_parameter in
arg
(String.append
"client data directory
The directory where the Tezos client will store all its data.
By default: '"
% string (String.append default_base_dir "'." % string))
(Some "d" % char) "base-dir" % string "path" % string (string_parameter tt).
Definition config_file_arg {F G I a b i o p q : Type}
(function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option string)
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
let 'tt := function_parameter in
arg "configuration file" % string (Some "c" % char) "config-file" % string
"path" % string (string_parameter tt).
Definition timings_switch {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg bool A :=
let 'tt := function_parameter in
switch "show RPC request times" % string (Some "t" % char) "timings" % string
tt.
Definition chain_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg Tezos_shell_services.Chain_services.chain
A :=
let 'tt := function_parameter in
default_arg
"chain on which to apply contextual commands (possible tags are 'main' and 'test')"
% string None "chain" % string "hash|tag" % string
(Chain_services.to_string (chain default_cli_args)) (chain_parameter tt).
Definition block_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg Tezos_shell_services.Block_services.block
A :=
let 'tt := function_parameter in
default_arg
"block on which to apply contextual commands (possible tags are 'head' and 'genesis')"
% string (Some "b" % char) "block" % string "hash|tag" % string
(Block_services.to_string (block default_cli_args)) (block_parameter tt).
Definition wait_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option (option Z)) A :=
let 'tt := function_parameter in
arg
"how many confirmation blocks before to consider an operation as included" %
string (Some "w" % char) "wait" % string "none|<int>" % string
(wait_parameter tt).
Definition protocol_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg
(option (option Tezos_base__TzPervasives.Protocol_hash.t)) A :=
let 'tt := function_parameter in
arg "use commands of a specific protocol" % string (Some "p" % char)
"protocol" % string "hash" % string (protocol_parameter tt).
Definition log_requests_switch {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg bool A :=
let 'tt := function_parameter in
switch "log all requests to the node" % string (Some "l" % char)
"log-requests" % string tt.
Definition addr_arg {F G I a b i o p q : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option string)
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
let 'tt := function_parameter in
arg "IP address of the node" % string (Some "A" % char) "addr" % string
"IP addr|host" % string (string_parameter tt).
Definition port_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option Z) A :=
let 'tt := function_parameter in
arg "RPC port of the node" % string (Some "P" % char) "port" % string
"number" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x =>
(* ❌ Try-with are not handled *)
try (_return (OCaml.Stdlib.int_of_string x)))).
Definition tls_switch {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg bool A :=
let 'tt := function_parameter in
switch "use TLS to connect to node." % string (Some "S" % char) "tls" % string
tt.
Definition remote_signer_arg {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option Uri.t) A :=
let 'tt := function_parameter in
arg "URI of the remote signer" % string (Some "R" % char)
"remote-signer" % string "uri" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x => Tezos_signer_backends_unix.Remote.parse_base_uri x)).
Definition password_filename_arg {F G I a b i o p q : Type}
(function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg (option string)
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
let 'tt := function_parameter in
arg "path to the password filename" % string (Some "f" % char)
"password-filename" % string "filename" % string (string_parameter tt).
Definition read_config_file (config_file : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult Cfg_file.t) :=
op_gtgteqquestion (Lwt_utils_unix.Json.read_file config_file)
(fun cfg_json =>
(* ❌ Try-with are not handled *)
try (apply _return (Cfg_file.from_json cfg_json))).
Definition default_config_file_name : string := "config" % string.
Definition commands {F G I a b i o p q : Type}
(config_file : string) (cfg : Cfg_file.t)
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) :=
let group :=
{| Clic.name := "config" % string;
Clic.title :=
"Commands for editing and viewing the client's config file" % string |}
in
cons
(command (Some group) "Show the config file." % string no_options
(fixed (cons "config" % string (cons "show" % string [])))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
let pp_cfg (ppf : Stdlib.Format.formatter) (cfg : Cfg_file.t)
: unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Data_encoding.Json.pp
(Data_encoding.Json.construct Cfg_file.encoding cfg) in
if apply negb (Sys.file_exists config_file) then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Warning: no config file at " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "," % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"displaying the default configuration." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 2>Warning: no config file at %s,@,displaying the default configuration.@]"
% string) config_file)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format))
"%a@," % string) pp_cfg Cfg_file.default) _return)
else
op_gtgteqquestion (read_config_file config_file)
(fun cfg =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format))
"%a@," % string) pp_cfg cfg) _return)))
(cons
(command (Some group)
"Reset the config file to the factory defaults." % string no_options
(fixed (cons "config" % string (cons "reset" % string [])))
(fun function_parameter =>
let 'tt := function_parameter in
fun _cctxt => write config_file default))
(cons
(command (Some group)
"Update the config based on the current cli values.
Loads the current configuration (default or as specified with `-config-file`), applies alterations from other command line arguments (such as the node's address, etc.), and overwrites the updated configuration file."
% string no_options
(fixed (cons "config" % string (cons "update" % string [])))
(fun function_parameter =>
let 'tt := function_parameter in
fun _cctxt => write config_file cfg))
(cons
(command (Some group)
"Create a config file based on the current CLI values.
If the `-file` option is not passed, this will initialize the default config file, based on default parameters, altered by other command line options (such as the node's address, etc.).
Otherwise, it will create a new config file, based on the default parameters (or the the ones specified with `-config-file`), altered by other command line options.
The command will always fail if the file already exists."
% string
(args1
(default_arg "path at which to create the file" % string
(Some "o" % char) "output" % string "path" % string
(op_divdiv (base_dir cfg) default_config_file_name)
(parameter None (fun _ctx => fun str => _return str))))
(fixed (cons "config" % string (cons "init" % string [])))
(fun config_file =>
fun _cctxt =>
if negb (Sys.file_exists config_file) then
write config_file cfg
else
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Config file already exists at location" % string
CamlinternalFormatBasics.End_of_format)
"Config file already exists at location" % string))) []))).
Definition global_options {F G I a b i o p q : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.options
((option string) * (option string) * bool *
Tezos_shell_services.Chain_services.chain *
Tezos_shell_services.Block_services.block * (option (option Z)) *
(option (option Tezos_base__TzPervasives.Protocol_hash.t)) * bool *
(option string) * (option Z) * bool * (option Uri.t) * (option string))
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
let 'tt := function_parameter in
args13 (base_dir_arg tt) (config_file_arg tt) (timings_switch tt)
(chain_arg tt) (block_arg tt) (wait_arg tt) (protocol_arg tt)
(log_requests_switch tt) (addr_arg tt) (port_arg tt) (tls_switch tt)
(remote_signer_arg tt) (password_filename_arg tt).
Record parsed_config_args := {
parsed_config_file : option Cfg_file.t;
parsed_args : option cli_args;
config_commands :
list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full);
base_dir : option string;
require_auth : bool;
password_filename : option string }.
Definition default_parsed_config_args : parsed_config_args :=
{| parsed_config_file := None; parsed_args := None; config_commands := [];
base_dir := None; require_auth := false; password_filename := None |}.
Definition parse_config_args {F G I a b i o p q : Type}
(ctx :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) (argv : list string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult (parsed_config_args * (list string))) :=
op_gtgteqquestion (parse_global_options (global_options tt) ctx argv)
(fun function_parameter =>
let
'((base_dir, config_file, timings, chain, block, confirmations,
protocol, log_requests, node_addr, node_port, tls, remote_signer,
password_filename), remaining) := function_parameter in
op_gtgteqquestion
match base_dir with
| None =>
let base_dir := default_base_dir in
op_gtgteqquestion
(unless (Sys.file_exists base_dir)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_utils_unix.create_dir None base_dir) _return))
(fun function_parameter =>
let 'tt := function_parameter in
_return base_dir)
| Some dir =>
if negb (Sys.file_exists dir) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Specified -base-dir does not exist. Please create the directory and try again."
% string CamlinternalFormatBasics.End_of_format)
"Specified -base-dir does not exist. Please create the directory and try again."
% string)
else
if Sys.is_directory dir then
_return dir
else
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Specified -base-dir must be a directory" % string
CamlinternalFormatBasics.End_of_format)
"Specified -base-dir must be a directory" % string)
end
(fun base_dir =>
op_gtgteqquestion
match config_file with
| None =>
apply _return (op_divdiv base_dir default_config_file_name)
| Some config_file =>
if Sys.file_exists config_file then
_return config_file
else
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Config file specified in option does not exist. Use `client config init` to create one."
% string CamlinternalFormatBasics.End_of_format)
"Config file specified in option does not exist. Use `client config init` to create one."
% string)
end
(fun config_file =>
let config_dir := Filename.dirname config_file in
let protocol :=
match protocol with
| None => None
| Some p => p
end in
op_gtgteqquestion
(if negb (Sys.file_exists config_file) then
_return
(* ❌ Record substitution not handled *)
record_substitution
else
read_config_file config_file)
(fun cfg =>
let tls := orb (tls cfg) tls in
let node_addr := Option.unopt (node_addr cfg) node_addr in
let node_port := Option.unopt (node_port cfg) node_port in
op_gtgteqquestion
(Tezos_signer_backends_unix.Remote.read_base_uri_from_env tt)
(fun remote_signer_env =>
let remote_signer :=
Option.first_some remote_signer
(Option.first_some remote_signer_env
(remote_signer cfg)) in
let confirmations :=
Option.unopt (confirmations cfg) confirmations in
let cfg :=
(* ❌ Record substitution not handled *)
record_substitution in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
andb (Sys.file_exists base_dir)
(negb (Sys.is_directory base_dir)) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" is not a directory." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))
"%s is not a directory.@." % string) base_dir in
Stdlib.exit 1
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
andb (Sys.file_exists config_dir)
(negb (Sys.is_directory config_dir)) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" is not a directory." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))
"%s is not a directory.@." % string) config_dir
in
Stdlib.exit 1
else
tt in
op_gtgteq (Lwt_utils_unix.create_dir None config_dir)
(fun function_parameter =>
let 'tt := function_parameter in
_return
((* ❌ Record substitution not handled *)
record_substitution, remaining))))))).
Definition t :=
(option string) * (option string) * bool *
Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block * (option (option Z)) *
(option (option Tezos_base__TzPervasives.Protocol_hash.t)) * bool *
(option string) * (option Z) * bool * (option Uri.t) * (option string).
Module Remote_params.
Record signature := {
authenticate : (list Tezos_base__TzPervasives.Signature.public_key_hash) ->
Stdlib.Bytes.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.t);
logger : Tezos_rpc_http_client_unix.RPC_client_unix.logger;
}.
End Remote_params.
Definition other_registrations
: option (Cfg_file.t -> {_ : unit & Remote_params.signature } -> unit) :=
Some
(fun parsed_config_file =>
fun Remote_params =>
let Remote_params := projT2 Remote_params in
Option.iter
(fun signer =>
Client_keys.register_signer
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application)
(Cfg_file.remote_signer parsed_config_file)).
Definition clic_commands {A B C : Type} (function_parameter : A)
: (list B) -> (list B) -> (list B) -> C -> list B :=
let '_ := function_parameter in
fun config_commands =>
fun builtin_commands =>
fun other_commands =>
fun function_parameter =>
let '_ := function_parameter in
OCaml.Stdlib.app config_commands
(OCaml.Stdlib.app builtin_commands other_commands).
Definition logger {A : Type} : option A := None.
src/lib_client_base_unix/client_context_unix.ml 6 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make_semantic (struct
let name = "client.context.unix"
end)
class unix_wallet ~base_dir ~password_filename : Client_context.wallet =
object (self)
method load_passwords =
match password_filename with
| None ->
None
| Some filename ->
if Sys.file_exists filename then Some (Lwt_io.lines_of_file filename)
else None
method read_file path =
Lwt.catch
(fun () ->
Lwt_io.(with_file ~mode:Input path read)
>>= fun content -> return content)
(fun exn -> failwith "cannot read file (%s)" (Printexc.to_string exn))
method private filename alias_name =
Filename.concat
base_dir
(String.map (function ' ' -> '_' | c -> c) alias_name ^ "s")
method with_lock : type a. (unit -> a Lwt.t) -> a Lwt.t =
fun f ->
let unlock fd =
let fd = Lwt_unix.unix_file_descr fd in
Unix.lockf fd Unix.F_ULOCK 0 ;
Unix.close fd
in
let lock () =
Lwt_unix.openfile
(Filename.concat base_dir "wallet_lock")
Lwt_unix.[O_CREAT; O_WRONLY]
0o644
>>= fun fd ->
Lwt_unix.lockf fd Unix.F_LOCK 0
>>= fun () ->
let sighandler =
Lwt_unix.on_signal Sys.sigint (fun _s -> unlock fd)
in
Lwt.return (fd, sighandler)
in
lock ()
>>= fun (fd, sh) ->
(* catch might be useless if f always uses the error monad *)
Lwt.catch f (function e -> Lwt.return (unlock fd ; raise e))
>>= fun res ->
Lwt.return (unlock fd)
>>= fun () ->
Lwt_unix.disable_signal_handler sh ;
Lwt.return res
method load : type a.
string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t =
fun alias_name ~default encoding ->
let filename = self#filename alias_name in
if not (Sys.file_exists filename) then return default
else
Lwt_utils_unix.Json.read_file filename
|> generic_trace "could not read the %s alias file" alias_name
>>=? fun json ->
match Data_encoding.Json.destruct encoding json with
| exception e ->
failwith
"did not understand the %s alias file %s : %s"
alias_name
filename
(Printexc.to_string e)
| data ->
return data
method write : type a.
string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t =
fun alias_name list encoding ->
Lwt.catch
(fun () ->
Lwt_utils_unix.create_dir base_dir
>>= fun () ->
let filename = self#filename alias_name in
let json = Data_encoding.Json.construct encoding list in
Lwt_utils_unix.Json.write_file filename json)
(fun exn -> Lwt.return (error_exn exn))
|> generic_trace "could not write the %s alias file." alias_name
end
class unix_prompter : Client_context.prompter =
object
method prompt : type a. (a, string tzresult) Client_context.lwt_format -> a
=
Format.kasprintf (fun msg ->
print_string msg ;
let line = read_line () in
return line)
method prompt_password : type a.
(a, Bigstring.t tzresult) Client_context.lwt_format -> a =
Format.kasprintf (fun msg ->
print_string msg ;
let line = Lwt_utils_unix.getpass () in
return (Bigstring.of_string line))
end
class unix_logger ~base_dir : Client_context.printer =
let startup = Format.asprintf "%a" Time.System.pp_hum (Systime_os.now ()) in
let log channel msg =
match channel with
| "stdout" ->
print_endline msg ; Lwt.return_unit
| "stderr" ->
prerr_endline msg ; Lwt.return_unit
| log ->
let ( // ) = Filename.concat in
Lwt_utils_unix.create_dir (base_dir // "logs" // log)
>>= fun () ->
Lwt_io.with_file
~flags:Unix.[O_APPEND; O_CREAT; O_WRONLY]
~mode:Lwt_io.Output
(base_dir // "logs" // log // startup)
(fun chan -> Lwt_io.write chan msg)
in
object
inherit Client_context.simple_printer log
end
class unix_ui : Client_context.ui =
object
method sleep f = Lwt_unix.sleep f
method now = Tezos_stdlib_unix.Systime_os.now
end
class unix_full ~base_dir ~chain ~block ~confirmations ~password_filename
~rpc_config : Client_context.full =
object
inherit unix_logger ~base_dir
inherit unix_prompter
inherit unix_wallet ~base_dir ~password_filename
inherit RPC_client_unix.http_ctxt rpc_config Media_type.all_media_types
inherit unix_ui
method chain = chain
method block = block
method confirmations = confirmations
end
src/lib_client_base_unix/client_context_unix.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include (* ❌ Structure item `class` not handled. *) class (* ❌ Structure item `class` not handled. *) class (* ❌ Structure item `class` not handled. *) class (* ❌ Structure item `class` not handled. *) class (* ❌ Structure item `class` not handled. *) class
src/lib_client_base_unix/client_main_run.ml 114 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Tezos Command line interface - Main Program *)
open Client_context_unix
let builtin_commands =
let open Clic in
[ command
~desc:"List the protocol versions that this client understands."
no_options
(fixed ["list"; "understood"; "protocols"])
(fun () (cctxt : #Client_context.full) ->
Lwt_list.iter_s
(fun (ver, _) -> cctxt#message "%a" Protocol_hash.pp_short ver)
(Client_commands.get_versions ())
>>= fun () -> return_unit) ]
module type M = sig
type t
val global_options : unit -> (t, Client_context_unix.unix_full) Clic.options
val parse_config_args :
#Tezos_client_base.Client_context.full ->
string list ->
(Client_config.parsed_config_args * string list) tzresult Lwt.t
val default_chain : Chain_services.chain
val default_block : [> `Head of int]
val default_base_dir : string
val other_registrations :
(Client_config.Cfg_file.t -> (module Client_config.Remote_params) -> unit)
option
val clic_commands :
base_dir:string ->
config_commands:Tezos_client_base.Client_context.full Clic.command list ->
builtin_commands:Tezos_client_base.Client_context.full Clic.command list ->
other_commands:Tezos_client_base.Client_context.full Clic.command list ->
require_auth:bool ->
Tezos_client_base.Client_context.full Clic.command list
val logger : RPC_client_unix.logger option
end
(* Main (lwt) entry *)
let main (module C : M) ~select_commands =
let global_options = C.global_options () in
let executable_name = Filename.basename Sys.executable_name in
let (original_args, autocomplete) =
(* for shell aliases *)
let rec move_autocomplete_token_upfront acc = function
| "bash_autocomplete" :: prev_arg :: cur_arg :: script :: args ->
let args = List.rev acc @ args in
(args, Some (prev_arg, cur_arg, script))
| x :: rest ->
move_autocomplete_token_upfront (x :: acc) rest
| [] ->
(List.rev acc, None)
in
match Array.to_list Sys.argv with
| _ :: args ->
move_autocomplete_token_upfront [] args
| [] ->
([], None)
in
Random.self_init () ;
ignore
Clic.(
setup_formatter
Format.std_formatter
(if Unix.isatty Unix.stdout then Ansi else Plain)
Short) ;
ignore
Clic.(
setup_formatter
Format.err_formatter
(if Unix.isatty Unix.stderr then Ansi else Plain)
Short) ;
Internal_event_unix.init ()
>>= fun () ->
Lwt.catch
(fun () ->
C.parse_config_args
(new unix_full
~chain:C.default_chain
~block:C.default_block
~confirmations:None
~password_filename:None
~base_dir:C.default_base_dir
~rpc_config:RPC_client_unix.default_config)
original_args
>>=? (fun (parsed, remaining) ->
let parsed_config_file = parsed.Client_config.parsed_config_file
and parsed_args = parsed.Client_config.parsed_args
and config_commands = parsed.Client_config.config_commands in
let base_dir : string =
match parsed.Client_config.base_dir with
| Some p ->
p
| None -> (
match parsed_config_file with
| None ->
C.default_base_dir
| Some p ->
p.Client_config.Cfg_file.base_dir )
and require_auth = parsed.Client_config.require_auth in
let rpc_config =
let rpc_config : RPC_client_unix.config =
match parsed_config_file with
| None ->
RPC_client_unix.default_config
| Some parsed_config_file ->
{
RPC_client_unix.default_config with
host =
parsed_config_file.Client_config.Cfg_file.node_addr;
port =
parsed_config_file.Client_config.Cfg_file.node_port;
tls = parsed_config_file.Client_config.Cfg_file.tls;
}
in
match parsed_args with
| Some parsed_args ->
if parsed_args.Client_config.print_timings then
let gettimeofday = Unix.gettimeofday in
{
rpc_config with
logger =
RPC_client_unix.timings_logger
~gettimeofday
Format.err_formatter;
}
else if parsed_args.Client_config.log_requests then
{
rpc_config with
logger =
RPC_client_unix.full_logger Format.err_formatter;
}
else rpc_config
| None ->
rpc_config
in
let client_config =
new unix_full
~chain:
( match parsed_args with
| Some p ->
p.Client_config.chain
| None ->
Client_config.default_chain )
~block:
( match parsed_args with
| Some p ->
p.Client_config.block
| None ->
Client_config.default_block )
~confirmations:
( match parsed_args with
| Some p ->
p.Client_config.confirmations
| None ->
None )
~password_filename:
( match parsed_args with
| Some p ->
p.Client_config.password_filename
| None ->
None )
~base_dir
~rpc_config
in
let module Remote_params = struct
let authenticate pkhs payload =
Client_keys.list_keys client_config
>>=? fun keys ->
match
List.filter_map
(function
| (_, known_pkh, _, Some known_sk_uri)
when List.exists
(fun pkh ->
Signature.Public_key_hash.equal pkh known_pkh)
pkhs ->
Some known_sk_uri
| _ ->
None)
keys
with
| sk_uri :: _ ->
Client_keys.sign client_config sk_uri payload
| [] ->
failwith
"remote signer expects authentication signature, but \
no authorized key was found in the wallet"
let logger =
(* overriding the logger we might already have with the one from
module C *)
match C.logger with
| Some logger ->
logger
| None ->
rpc_config.logger
end in
let module Http =
Tezos_signer_backends.Http.Make
(RPC_client_unix)
(Remote_params)
in
let module Https =
Tezos_signer_backends.Https.Make
(RPC_client_unix)
(Remote_params)
in
let module Socket =
Tezos_signer_backends_unix.Socket.Make (Remote_params) in
Client_keys.register_signer
( module Tezos_signer_backends.Encrypted.Make (struct
let cctxt = (client_config :> Client_context.prompter)
end) ) ;
Client_keys.register_signer
(module Tezos_signer_backends.Unencrypted) ;
Client_keys.register_signer
(module Tezos_signer_backends_unix.Ledger.Signer_implementation) ;
Client_keys.register_signer (module Socket.Unix) ;
Client_keys.register_signer (module Socket.Tcp) ;
Client_keys.register_signer (module Http) ;
Client_keys.register_signer (module Https) ;
( match parsed_config_file with
| None ->
()
| Some parsed_config_file -> (
match C.other_registrations with
| Some r ->
r parsed_config_file (module Remote_params)
| None ->
() ) ) ;
( match parsed_args with
| Some parsed_args ->
select_commands
(client_config :> RPC_client_unix.http_ctxt)
parsed_args
| None ->
return_nil )
>>=? fun other_commands ->
let commands =
Clic.add_manual
~executable_name
~global_options
(if Unix.isatty Unix.stdout then Clic.Ansi else Clic.Plain)
Format.std_formatter
(C.clic_commands
~base_dir
~config_commands
~builtin_commands
~other_commands
~require_auth)
in
match autocomplete with
| Some (prev_arg, cur_arg, script) ->
Clic.autocompletion
~script
~cur_arg
~prev_arg
~args:original_args
~global_options
commands
client_config
>>=? fun completions ->
List.iter print_endline completions ;
return_unit
| None ->
Clic.dispatch commands client_config remaining)
>>= function
| Ok () ->
Lwt.return 0
| Error [Clic.Help command] ->
Clic.usage
Format.std_formatter
~executable_name
~global_options
(match command with None -> [] | Some c -> [c]) ;
Lwt.return 0
| Error errs ->
Clic.pp_cli_errors
Format.err_formatter
~executable_name
~global_options
~default:Error_monad.pp
errs ;
Lwt.return 1)
(function
| Client_commands.Version_not_found ->
Format.eprintf
"@{<error>@{<title>Fatal error@}@} unknown protocol version.@." ;
Lwt.return 1
| Failure message ->
Format.eprintf
"@{<error>@{<title>Fatal error@}@}@. @[<h 0>%a@]@."
Format.pp_print_text
message ;
Lwt.return 1
| exn ->
Format.printf
"@{<error>@{<title>Fatal error@}@}@. @[<h 0>%a@]@."
Format.pp_print_text
(Printexc.to_string exn) ;
Lwt.return 1)
>>= fun retcode ->
Format.pp_print_flush Format.err_formatter () ;
Format.pp_print_flush Format.std_formatter () ;
Internal_event_unix.close () >>= fun () -> Lwt.return retcode
(* Where all the user friendliness starts *)
let run ?log (module M : M)
~(select_commands :
RPC_client_unix.http_ctxt ->
Client_config.cli_args ->
Client_context.full Clic.command list tzresult Lwt.t) =
Lwt_exit.exit_on ?log Sys.sigint ;
Lwt_exit.exit_on ?log Sys.sigterm ;
Pervasives.exit @@ Lwt_main.run @@ Lwt_exit.wrap_promise
@@ main (module M) ~select_commands
src/lib_client_base_unix/client_main_run.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Client_context_unix.
Definition builtin_commands {F G a b i o p q : Type}
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * nil)))))))))))))))))))))
* nil)) :=
cons
(command None
"List the protocol versions that this client understands." % string
no_options
(fixed
(cons "list" % string
(cons "understood" % string (cons "protocols" % string []))))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteq
(Lwt_list.iter_s
(fun function_parameter =>
let '(ver, _) := function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Protocol_hash.pp_short ver) (Client_commands.get_versions tt))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))) [].
Module M.
Record signature {t : Type} := {
t := t;
global_options : unit ->
Tezos_base__TzPervasives.Clic.options t
Tezos_client_base_unix.Client_context_unix.unix_full;
parse_config_args : forall {_ a b i o p q variant : Type}, (((Z ->
Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (_ * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (_ * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * _)))))))))))))))))))))
* _) ->
(list string) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_client_base_unix.Client_config.parsed_config_args *
(list string)));
default_chain : Tezos_shell_services.Chain_services.chain;
default_block : forall {variant : Type}, variant;
default_base_dir : string;
other_registrations : option
(Tezos_client_base_unix.Client_config.Cfg_file.t ->
{_ : unit &
Tezos_client_base_unix.Client_config.Remote_params.signature } -> unit);
clic_commands : string ->
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full)) ->
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full)) ->
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full)) ->
bool ->
list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full);
logger : option Tezos_rpc_http_client_unix.RPC_client_unix.logger;
}.
Arguments signature : clear implicits.
End M.
Definition main (C : {t : _ & M.signature t})
: (Tezos_rpc_http_client_unix.RPC_client_unix.http_ctxt ->
Tezos_client_base_unix.Client_config.cli_args ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full)))) -> Lwt.t Z :=
let C := projT2 C in
fun select_commands =>
let global_options := C.(M.global_options) tt in
let executable_name := Filename.basename Sys.executable_name in
let '(original_args, autocomplete) :=
let fix move_autocomplete_token_upfront
(acc : list string) (function_parameter : list string)
: (list string) * (option (string * string * string)) :=
match function_parameter with
|
cons "bash_autocomplete" % string
(cons prev_arg (cons cur_arg (cons script args))) =>
let args := OCaml.Stdlib.app (List.rev acc) args in
(args, (Some (prev_arg, cur_arg, script)))
| cons x rest => move_autocomplete_token_upfront (cons x acc) rest
| [] => ((List.rev acc), None)
end in
match Array.to_list Sys.argv with
| cons _ args => move_autocomplete_token_upfront [] args
| [] => ([], None)
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Random.self_init tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.ignore
(setup_formatter Format.std_formatter
(if Unix.isatty Unix.stdout then
Tezos_base__TzPervasives.Clic.Ansi
else
Tezos_base__TzPervasives.Clic.Plain)
Tezos_base__TzPervasives.Clic.Short) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.ignore
(setup_formatter Format.err_formatter
(if Unix.isatty Unix.stderr then
Tezos_base__TzPervasives.Clic.Ansi
else
Tezos_base__TzPervasives.Clic.Plain)
Tezos_base__TzPervasives.Clic.Short) in
op_gtgteq (Internal_event_unix.init None None tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtgteqquestion
(C.(M.parse_config_args)
((* ❌ Creation of new objects is not handled *)
new C.(M.default_base_dir) C.(M.default_chain)
C.(M.default_block) None None
RPC_client_unix.default_config) original_args)
(fun function_parameter =>
let '(parsed, remaining) := function_parameter in
let parsed_config_file
: option Tezos_client_base_unix.Client_config.Cfg_file.t :=
Client_config.parsed_config_file parsed
with parsed_args
: option Tezos_client_base_unix.Client_config.cli_args :=
Client_config.parsed_args parsed
with config_commands
: list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full) :=
Client_config.config_commands parsed in
let base_dir : string :=
match Client_config.base_dir parsed with
| Some p => p
| None =>
match parsed_config_file with
| None => C.(M.default_base_dir)
| Some p => Client_config.Cfg_file.base_dir p
end
end
with require_auth : bool :=
Client_config.require_auth parsed in
let rpc_config :=
let rpc_config :=
match parsed_config_file with
| None => RPC_client_unix.default_config
| Some parsed_config_file =>
(* ❌ Record substitution not handled *)
record_substitution
end in
match parsed_args with
| Some parsed_args =>
if Client_config.print_timings parsed_args then
let gettimeofday := Unix.gettimeofday in
(* ❌ Record substitution not handled *)
record_substitution
else
if Client_config.log_requests parsed_args then
(* ❌ Record substitution not handled *)
record_substitution
else
rpc_config
| None => rpc_config
end in
let client_config :=
(* ❌ Creation of new objects is not handled *)
new base_dir
match parsed_args with
| Some p => Client_config.chain p
| None => Client_config.default_chain
end
match parsed_args with
| Some p => Client_config.block p
| None => Client_config.default_block
end
match parsed_args with
| Some p => Client_config.confirmations p
| None => None
end
match parsed_args with
| Some p => Client_config.password_filename p
| None => None
end rpc_config in
let Remote_params :=
existT _ unit
{|
(* ❌ This kind of definition of value for first-class modules is not handled *)
Tezos_client_base_unix__Client_config.Remote_params.authenticate :=
unhandled;
Tezos_client_base_unix__Client_config.Remote_params.logger :=
match C.(M.logger) with
| Some logger => logger
| None => logger rpc_config
end
|} in
let Http :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
let Https :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
let Socket :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Client_keys.register_signer
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Client_keys.register_signer
Tezos_signer_backends.Unencrypted in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Client_keys.register_signer
Tezos_signer_backends_unix.Ledger.Signer_implementation
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Client_keys.register_signer Socket.Unix in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Client_keys.register_signer Socket.Tcp in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Client_keys.register_signer Http in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Client_keys.register_signer Https in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match parsed_config_file with
| None => tt
| Some parsed_config_file =>
match C.(M.other_registrations) with
| Some r => r parsed_config_file Remote_params
| None => tt
end
end in
op_gtgteqquestion
match parsed_args with
| Some parsed_args =>
select_commands client_config parsed_args
| None => return_nil
end
(fun other_commands =>
let commands :=
Clic.add_manual executable_name global_options
(if Unix.isatty Unix.stdout then
Tezos_base__TzPervasives.Clic.Ansi
else
Tezos_base__TzPervasives.Clic.Plain)
Format.std_formatter
(C.(M.clic_commands) base_dir config_commands
builtin_commands other_commands require_auth) in
match autocomplete with
| Some (prev_arg, cur_arg, script) =>
op_gtgteqquestion
(Clic.autocompletion script cur_arg prev_arg
original_args global_options commands
client_config)
(fun completions =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter OCaml.Stdlib.print_endline completions
in
return_unit)
| None => Clic.dispatch commands client_config remaining
end)))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt._return 0
|
Stdlib.Error
(cons (Tezos_error_monad.Error_monad.Help command) []) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Clic.usage Format.std_formatter executable_name
global_options
match command with
| None => []
| Some c => cons c []
end in
Lwt._return 0
| Stdlib.Error errs =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Clic.pp_cli_errors Format.err_formatter executable_name
global_options Error_monad.pp errs in
Lwt._return 1
end))
(fun function_parameter =>
match function_parameter with
| Version_not_found =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<error>" % string
CamlinternalFormatBasics.End_of_format)
"<error>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<title>" % string
CamlinternalFormatBasics.End_of_format)
"<title>" % string))
(CamlinternalFormatBasics.String_literal
"Fatal error" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.String_literal
" unknown protocol version." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))
"@{<error>@{<title>Fatal error@}@} unknown protocol version.@."
% string) in
Lwt._return 1
| OCaml.Failure message =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<error>" % string
CamlinternalFormatBasics.End_of_format)
"<error>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<title>" % string
CamlinternalFormatBasics.End_of_format)
"<title>" % string))
(CamlinternalFormatBasics.String_literal
"Fatal error" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<h 0>" % string
CamlinternalFormatBasics.End_of_format)
"<h 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))))
"@{<error>@{<title>Fatal error@}@}@. @[<h 0>%a@]@." %
string) Format.pp_print_text message in
Lwt._return 1
| exn =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<error>" % string
CamlinternalFormatBasics.End_of_format)
"<error>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<title>" % string
CamlinternalFormatBasics.End_of_format)
"<title>" % string))
(CamlinternalFormatBasics.String_literal
"Fatal error" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<h 0>" % string
CamlinternalFormatBasics.End_of_format)
"<h 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))))
"@{<error>@{<title>Fatal error@}@}@. @[<h 0>%a@]@." %
string) Format.pp_print_text (Printexc.to_string exn) in
Lwt._return 1
end))
(fun retcode =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_flush Format.err_formatter tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_flush Format.std_formatter tt in
op_gtgteq (Internal_event_unix.close tt)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return retcode))).
Definition run {A : Type}
(log : option (string -> unit)) (M : {t : _ & M.signature t})
: (Tezos_rpc_http_client_unix.RPC_client_unix.http_ctxt ->
Tezos_client_base_unix.Client_config.cli_args ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full)))) -> A :=
let M := projT2 M in
fun select_commands =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_exit.exit_on log Sys.sigint in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_exit.exit_on log Sys.sigterm in
apply Pervasives.exit
(apply Lwt_main.run (apply Lwt_exit.wrap_promise (main M select_commands))).
src/lib_client_commands/client_admin_commands.ml 40 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let block_param ~name ~desc t =
Clic.param
~name
~desc
(Clic.parameter (fun _ str -> Lwt.return (Block_hash.of_b58check str)))
t
let commands () =
let open Clic in
let group =
{
name = "admin";
title = "Commands to perform privileged operations on the node";
}
in
[ command
~group
~desc:"Make the node forget its decision of rejecting blocks."
no_options
( prefixes ["unmark"; "invalid"]
@@ seq_of_param
(block_param
~name:"block"
~desc:"blocks to remove from invalid list") )
(fun () blocks (cctxt : #Client_context.full) ->
iter_s
(fun block ->
Shell_services.Invalid_blocks.delete cctxt block
>>=? fun () ->
cctxt#message
"Block %a no longer marked invalid."
Block_hash.pp
block
>>= fun () -> return_unit)
blocks);
command
~group
~desc:"Make the node forget every decision of rejecting blocks."
no_options
(prefixes ["unmark"; "all"; "invalid"; "blocks"] @@ stop)
(fun () (cctxt : #Client_context.full) ->
Shell_services.Invalid_blocks.list cctxt ()
>>=? fun invalid_blocks ->
iter_s
(fun {Chain_services.hash; _} ->
Shell_services.Invalid_blocks.delete cctxt hash
>>=? fun () ->
cctxt#message
"Block %a no longer marked invalid."
Block_hash.pp_short
hash
>>= fun () -> return_unit)
invalid_blocks);
command
~group
~desc:
"Retrieve the current checkpoint and display it in a format \
compatible with node argument `--checkpoint`."
no_options
(fixed ["show"; "current"; "checkpoint"])
(fun () (cctxt : #Client_context.full) ->
Shell_services.Chain.checkpoint cctxt ~chain:cctxt#chain ()
>>=? fun (block_header, save_point, caboose, history_mode) ->
cctxt#message
"@[<v 0>Checkpoint: %s@,\
Checkpoint level: %ld@,\
History mode: %a@,\
Save point level: %ld@,\
Caboose level: %ld@]"
(Block_header.to_b58check block_header)
block_header.shell.level
History_mode.pp
history_mode
save_point
caboose
>>= fun () -> return ()) ]
src/lib_client_commands/client_admin_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition block_param {A B : Type}
(name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
: Tezos_base__TzPervasives.Clic.params
(Tezos_base__TzPervasives.Block_hash.t -> A) B :=
Clic.param name desc
(Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun str => Lwt._return (Block_hash.of_b58check str))) t.
Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) :=
let 'tt := function_parameter in
let group :=
{| name := "admin" % string;
title := "Commands to perform privileged operations on the node" % string
|} in
cons
(command (Some group)
"Make the node forget its decision of rejecting blocks." % string
no_options
(apply (prefixes (cons "unmark" % string (cons "invalid" % string [])))
(seq_of_param
(block_param "block" % string
"blocks to remove from invalid list" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
fun blocks =>
fun cctxt =>
iter_s
(fun block =>
op_gtgteqquestion
(Shell_services.Invalid_blocks.delete cctxt None block)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" no longer marked invalid." % string
CamlinternalFormatBasics.End_of_format)))
"Block %a no longer marked invalid." % string)
Block_hash.pp block)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))) blocks))
(cons
(command (Some group)
"Make the node forget every decision of rejecting blocks." % string
no_options
(apply
(prefixes
(cons "unmark" % string
(cons "all" % string
(cons "invalid" % string (cons "blocks" % string []))))) stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion (Shell_services.Invalid_blocks.list cctxt None tt)
(fun invalid_blocks =>
iter_s
(fun function_parameter =>
let '{| Chain_services.hash := hash |} := function_parameter
in
op_gtgteqquestion
(Shell_services.Invalid_blocks.delete cctxt None hash)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" no longer marked invalid." % string
CamlinternalFormatBasics.End_of_format)))
"Block %a no longer marked invalid." % string)
Block_hash.pp_short hash)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))) invalid_blocks)))
(cons
(command (Some group)
"Retrieve the current checkpoint and display it in a format compatible with node argument `--checkpoint`."
% string no_options
(fixed
(cons "show" % string
(cons "current" % string (cons "checkpoint" % string []))))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion
(Shell_services.Chain.checkpoint cctxt
(Some
(* ❌ Sending method message is not handled *)
send) tt)
(fun function_parameter =>
let '(block_header, save_point, caboose, history_mode) :=
function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Checkpoint: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0
0)
(CamlinternalFormatBasics.String_literal
"Checkpoint level: " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"History mode: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Save point level: " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Caboose level: " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))))
"@[<v 0>Checkpoint: %s@,Checkpoint level: %ld@,History mode: %a@,Save point level: %ld@,Caboose level: %ld@]"
% string) (Block_header.to_b58check block_header)
(level (shell block_header)) History_mode.pp history_mode
save_point caboose)
(fun function_parameter =>
let 'tt := function_parameter in
_return tt)))) [])).
src/lib_client_commands/client_commands.ml 13 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Client_context
type command = full Clic.command
type network = [`Mainnet | `Alphanet | `Zeronet | `Sandbox]
exception Version_not_found
let versions = Protocol_hash.Table.create 7
let get_versions () =
Protocol_hash.Table.fold (fun k c acc -> (k, c) :: acc) versions []
let register name commands =
let previous =
try Protocol_hash.Table.find versions name
with Not_found -> fun (_network : network option) -> ([] : command list)
in
Protocol_hash.Table.replace versions name (fun (network : network option) ->
commands network @ previous network)
let commands_for_version version =
try Protocol_hash.Table.find versions version
with Not_found -> raise Version_not_found
src/lib_client_commands/client_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Client_context.
Definition command :=
Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full.
Definition network := variant.
(* ❌ The definition of exceptions is not handled. *)
exception
Definition versions
: Tezos_base__TzPervasives.Protocol_hash.Table.t
((option network) -> list command) := Protocol_hash.Table.create 7.
Definition get_versions (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Protocol_hash.Table.key *
((option network) -> list command)) :=
let 'tt := function_parameter in
Protocol_hash.Table.fold (fun k => fun c => fun acc => cons (k, c) acc)
versions [].
Definition register
(name : Tezos_base__TzPervasives.Protocol_hash.Table.key)
(commands : (option network) -> list command) : unit :=
let previous :=
(* ❌ Try-with are not handled *)
try (Protocol_hash.Table.find versions name) in
Protocol_hash.Table.replace versions name
(fun network => OCaml.Stdlib.app (commands network) (previous network)).
Definition commands_for_version
(version : Tezos_base__TzPervasives.Protocol_hash.Table.key)
: (option network) -> list command :=
(* ❌ Try-with are not handled *)
try (Protocol_hash.Table.find versions version).
src/lib_client_commands/client_event_logging_commands.ml 92 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let group =
Clic.
{
name = "event-logging-framework";
title = "Commands to inspect the event-logging framework";
}
let date_parameter option_name build =
let open Clic in
parameter (fun _ s ->
let problem fmt = Printf.ksprintf invalid_arg fmt in
try
if String.length s <> 8 then problem "date should be `YYYYMMDD`" ;
String.iteri
(fun idx -> function '0' .. '9' -> () | other ->
problem "character %d is not a digit: '%c'." idx other)
s ;
let month = int_of_string (String.sub s 4 2) - 1 in
if month < 0 then problem "The month cannot be '00'" ;
if month > 11 then problem "The month cannot be more than '12'" ;
let day = int_of_string (String.sub s 6 2) in
if day > 31 then problem "The month cannot be more than '31'" ;
let t =
let tm =
Unix.
{
tm_sec = 0;
tm_min = 0;
tm_hour = 0;
tm_mday = day;
tm_mon = month;
tm_year = int_of_string (String.sub s 0 4) - 1900;
tm_wday = 0;
tm_yday = 0;
tm_isdst = false;
}
in
Unix.mktime tm |> fst
in
return (build t)
with
| Invalid_argument e ->
failwith "In `%s %S`, %s" option_name s e
| e ->
failwith "Exn: %a" pp_exn e)
let flat_pp pp o =
Format.(
asprintf
"%a"
(fun fmt () ->
pp_set_margin fmt 2_000_000 ;
pp fmt o)
())
let commands () =
let open Clic in
let command ~desc = command ~group ~desc in
[ command
~desc:"Query the events from an event sink."
(args7
(arg
~doc:"Filter on event names"
~long:"names"
~placeholder:"LIST"
(parameter (fun _ s ->
try return (String.split_on_char ',' s)
with _ -> failwith "List of names cannot be parsed")))
(arg
~doc:"Filter on event sections (use '_' for no-section)"
~long:"sections"
~placeholder:"LIST"
(parameter (fun _ s ->
try
return
( String.split_on_char ',' s
|> List.map (function "_" -> None | other -> Some other)
)
with _ -> failwith "List of sections cannot be parsed")))
(arg
~doc:"Filter out events before DATE"
~long:"since"
~placeholder:"DATE"
(date_parameter "--since" (fun s -> `Date (`Ge, s))))
(arg
~doc:"Filter out events after DATE"
~long:"until"
~placeholder:"DATE"
(date_parameter "--until" (fun s -> `Date (`Le, s))))
(switch
~doc:"Display events as JSON instead of pretty-printing them"
~long:"as-json"
())
(switch ~doc:"Try to display unknown events" ~long:"dump-unknown" ())
(Scriptable.clic_arg ()))
( prefixes ["query"; "events"; "from"]
@@ param
~name:"Sink-Name"
~desc:"The URI of the SINK to query"
(parameter (fun _ s ->
try return (Uri.of_string s)
with _ -> failwith "Uri cannot be parsed"))
@@ stop )
(fun ( only_names,
only_sections,
since,
until,
as_json,
dump_unknown,
scriptable )
uri
(cctxt : #Client_context.full) ->
let open Tezos_stdlib_unix in
match Uri.scheme uri with
| None | Some "unix-files" -> (
let script_row kind date evname data () =
[kind; date; evname; data]
in
Scriptable.output_for_human scriptable (fun () ->
cctxt#message "### Events" >>= fun () -> return_unit)
>>=? fun () ->
let on_unknown =
if not dump_unknown then None
else
Some
(fun path ->
Scriptable.output_row
scriptable
~for_human:(fun () ->
cctxt#message "Unknown: %s" path
>>= fun () ->
Lwt_stream.iter_s
(fun line -> cctxt#message " |%s" line)
(Lwt_io.lines_of_file path)
>>= fun () -> return_unit)
~for_script:(script_row "unknown-event" "-" "-" path))
in
let time_query =
match (since, until) with
| (None, None) ->
None
| (Some a, None) | (None, Some a) ->
Some a
| (Some a, Some b) ->
Some (`And (a, b))
in
File_event_sink.Query.fold
?only_names
?on_unknown
?only_sections
?time_query
uri
~init:()
~f:(fun () ~time_stamp ev ->
let o = Internal_event.Generic.explode_event ev in
let time_string time_value =
let open Unix in
let tm = gmtime time_value in
Printf.sprintf
"%04d%02d%02d-%02d%02d%02d-%04d"
(1900 + tm.tm_year)
(tm.tm_mon + 1)
tm.tm_mday
tm.tm_hour
tm.tm_min
tm.tm_sec
( (time_value -. floor time_value) *. 10_000.
|> int_of_float )
in
let pp fmt o =
if as_json then Data_encoding.Json.pp fmt o#json
else o#pp fmt ()
in
Scriptable.output_row
scriptable
~for_human:(fun () ->
cctxt#message
"@[<2>* [%s %s]@ %a@]"
(time_string time_stamp)
o#name
pp
o
>>= fun () -> return_unit)
~for_script:(fun () ->
let text = flat_pp pp o in
script_row "event" (time_string time_stamp) o#name text ()))
>>=? function
| ([], ()) ->
return_unit
| (errors_and_warnings, ()) ->
let open Format in
Scriptable.output
scriptable
~for_human:(fun () ->
cctxt#message
"### Some things were not perfect:@.@[<2>%a@]"
(pp_print_list
~pp_sep:(fun fmt () -> fprintf fmt "@.")
(fun fmt item ->
fprintf
fmt
"* %a"
File_event_sink.Query.Report.pp
item))
errors_and_warnings
>>= fun () -> return_unit)
~for_script:(fun () ->
let make_row e =
let text = flat_pp File_event_sink.Query.Report.pp e in
let tag =
match e with
| `Error _ ->
"error"
| `Warning _ ->
"warning"
in
script_row tag "-" "-" text ()
in
List.map make_row errors_and_warnings) )
| Some other ->
cctxt#message "URI scheme %S not handled as of now." other
>>= fun () -> return_unit);
command
~desc:
"Display configuration/state information about the internal-event \
logging framework."
no_options
(prefixes ["show"; "event-logging"] @@ stop)
(fun () (cctxt : #Client_context.full) ->
let pp_event_definitions fmt schs =
let open Format in
pp_open_box fmt 0 ;
pp_print_list
~pp_sep:(fun fmt () -> fprintf fmt "@;")
(fun fmt obj_schema ->
pp_open_box fmt 2 ;
fprintf fmt "* `%s`:@ " obj_schema#name ;
pp_print_text fmt obj_schema#doc ;
pp_close_box fmt ())
fmt
schs ;
pp_close_box fmt ()
in
cctxt#message
"Event logging framework:@.Sinks state:@ %a@.Events registered:@ %a"
Internal_event.All_sinks.pp_state
()
pp_event_definitions
Internal_event.(
All_definitions.get () |> List.map Generic.json_schema)
>>= fun () -> return_unit);
command
~desc:"Output the JSON schema of an internal-event."
no_options
( prefixes ["output"; "schema"; "of"]
@@ param
~name:"Event-Name"
~desc:"Name of the event"
(parameter (fun _ s -> return s))
@@ prefix "to"
@@ param
~name:"File-path"
~desc:"Path to a JSON file"
(parameter (fun _ s -> return s))
@@ stop )
(fun () event path (cctxt : #Client_context.full) ->
let open Internal_event in
match All_definitions.find (( = ) event) with
| None ->
failwith "Event %S not found" event
| Some ev ->
let o = Generic.json_schema ev in
Lwt_io.with_file ~mode:Lwt_io.output path (fun chan ->
let v = Format.asprintf "%a" Json_schema.pp o#schema in
Lwt_io.write chan v)
>>= fun () ->
cctxt#message "Wrote schema of %s to %s" event path
>>= fun () -> return_unit) ]
src/lib_client_commands/client_event_logging_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| name := "event-logging-framework" % string;
title := "Commands to inspect the event-logging framework" % string |}.
Definition date_parameter {A B : Type} (option_name : string) (build : Z -> A)
: Tezos_base__TzPervasives.Clic.parameter A B :=
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
let problem {C D : Type} (fmt : Stdlib.format4 C unit string D) : C :=
Printf.ksprintf OCaml.Stdlib.invalid_arg fmt in
(* ❌ Try-with are not handled *)
try
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ :=
if nequiv_decb (String.length s) 8 then
problem
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"date should be `YYYYMMDD`" % string
CamlinternalFormatBasics.End_of_format)
"date should be `YYYYMMDD`" % string)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
String.iteri
(fun idx =>
fun function_parameter =>
match function_parameter with
|
"0" % char |
"1" % char |
"2" % char |
"3" % char |
"4" % char |
"5" % char |
"6" % char |
"7" % char | "8" % char | "9" % char => tt
| other =>
problem
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"character " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" is not a digit: '" % string
(CamlinternalFormatBasics.Char
(CamlinternalFormatBasics.String_literal
"'." % string
CamlinternalFormatBasics.End_of_format)))))
"character %d is not a digit: '%c'." % string) idx other
end) s in
let month := Z.sub (OCaml.Stdlib.int_of_string (String.sub s 4 2)) 1
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt month 0 then
problem
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The month cannot be '00'" % string
CamlinternalFormatBasics.End_of_format)
"The month cannot be '00'" % string)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt month 11 then
problem
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The month cannot be more than '12'" % string
CamlinternalFormatBasics.End_of_format)
"The month cannot be more than '12'" % string)
else
tt in
let day := OCaml.Stdlib.int_of_string (String.sub s 6 2) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt day 31 then
problem
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The month cannot be more than '31'" % string
CamlinternalFormatBasics.End_of_format)
"The month cannot be more than '31'" % string)
else
tt in
let t :=
let tm :=
{| tm_sec := 0; tm_min := 0; tm_hour := 0; tm_mday := day;
tm_mon := month;
tm_year :=
Z.sub (OCaml.Stdlib.int_of_string (String.sub s 0 4)) 1900;
tm_wday := 0; tm_yday := 0; tm_isdst := false |} in
OCaml.Stdlib.reverse_apply (Unix.mktime tm) fst in
_return (build t))).
Definition flat_pp {A : Type}
(pp : Stdlib.Format.formatter -> A -> unit) (o : A) : string :=
asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string)
(fun fmt =>
fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_set_margin fmt 2000000 in
pp fmt o) tt.
Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) :=
let 'tt := function_parameter in
let command {J K L : Type} (desc : string)
: (Tezos_base__TzPervasives.Clic.options J K) ->
(Tezos_base__TzPervasives.Clic.params L K) ->
(J -> L) -> Tezos_base__TzPervasives.Clic.command K :=
command (Some group) desc in
cons
(command "Query the events from an event sink." % string
(args7
(arg "Filter on event names" % string None "names" % string
"LIST" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try (_return (String.split_on_char "," % char s)))))
(arg "Filter on event sections (use '_' for no-section)" % string None
"sections" % string "LIST" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try
(_return
(OCaml.Stdlib.reverse_apply
(String.split_on_char "," % char s)
(List.map
(fun function_parameter =>
match function_parameter with
| "_" % string => None
| other => Some other
end)))))))
(arg "Filter out events before DATE" % string None "since" % string
"DATE" % string
(date_parameter "--since" % string
(fun s =>
(* ❌ Variants not supported *)
variant)))
(arg "Filter out events after DATE" % string None "until" % string
"DATE" % string
(date_parameter "--until" % string
(fun s =>
(* ❌ Variants not supported *)
variant)))
(switch
"Display events as JSON instead of pretty-printing them" % string None
"as-json" % string tt)
(switch "Try to display unknown events" % string None
"dump-unknown" % string tt) (Scriptable.clic_arg tt))
(apply
(prefixes
(cons "query" % string
(cons "events" % string (cons "from" % string []))))
(apply
(param "Sink-Name" % string "The URI of the SINK to query" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try (_return (Uri.of_string s))))) stop))
(fun function_parameter =>
let
'(only_names, only_sections, since, until, as_json, dump_unknown,
scriptable) := function_parameter in
fun uri =>
fun cctxt =>
match Uri.scheme uri with
| None | Some "unix-files" % string =>
let script_row {J : Type}
(kind : J) (date : J) (evname : J) (data : J)
(function_parameter : unit) : list J :=
let 'tt := function_parameter in
cons kind (cons date (cons evname (cons data []))) in
op_gtgteqquestion
(Scriptable.output_for_human scriptable
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"### Events" % string
CamlinternalFormatBasics.End_of_format)
"### Events" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(fun function_parameter =>
let 'tt := function_parameter in
let on_unknown :=
if negb dump_unknown then
None
else
Some
(fun path =>
Scriptable.output_row None scriptable
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Unknown: %s" % string) path)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_stream.iter_s
(fun line =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" |" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
" |%s" % string) line)
(Lwt_io.lines_of_file path))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(script_row "unknown-event" % string "-" % string
"-" % string path)) in
let time_query :=
match (since, until) with
| (None, None) => None
| (Some a, None) | (None, Some a) => Some a
| (Some a, Some b) =>
Some
(* ❌ Variants not supported *)
variant
end in
op_gtgteqquestion
(File_event_sink.Query.fold on_unknown only_sections
only_names time_query uri tt
(fun function_parameter =>
let 'tt := function_parameter in
fun time_stamp =>
fun ev =>
let o := Internal_event.Generic.explode_event ev in
let time_string (time_value : Z) : string :=
let tm := gmtime time_value in
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 4)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
"-" % char
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros
2)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
"-" % char
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros
4)
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)))))))))
"%04d%02d%02d-%02d%02d%02d-%04d" % string)
(Z.add 1900 (tm_year tm)) (Z.add (tm_mon tm) 1)
(tm_mday tm) (tm_hour tm) (tm_min tm)
(tm_sec tm)
(OCaml.Stdlib.reverse_apply
(Stdlib.op_starpoint
(Stdlib.op_minuspoint time_value
(Stdlib.floor time_value))
(* ❌ Float constant 10_000. is approximated by the integer 10000 *)
10000) Stdlib.int_of_float) in
let pp {J : Type}
(fmt : Stdlib.Format.formatter) (o :
(Tezos_data_encoding.Data_encoding.Json.json *
((Stdlib.Format.formatter -> unit -> unit) * J)))
: unit :=
if as_json then
Data_encoding.Json.pp fmt
(* ❌ Sending method message is not handled *)
send
else
(* ❌ Sending method message is not handled *)
send fmt tt in
Scriptable.output_row None scriptable
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<2>" % string
CamlinternalFormatBasics.End_of_format)
"<2>" % string))
(CamlinternalFormatBasics.String_literal
"* [" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
" " % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"]" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[<2>* [%s %s]@ %a@]" % string)
(time_string time_stamp)
(* ❌ Sending method message is not handled *)
send pp o)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))
(fun function_parameter =>
let 'tt := function_parameter in
let text := flat_pp pp o in
script_row "event" % string
(time_string time_stamp)
(* ❌ Sending method message is not handled *)
send text tt)))
(fun function_parameter =>
match function_parameter with
| ([], tt) => return_unit
| (errors_and_warnings, tt) =>
Scriptable.output None scriptable
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"### Some things were not perfect:" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<2>" % string
CamlinternalFormatBasics.End_of_format)
"<2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"### Some things were not perfect:@.@[<2>%a@]"
% string)
(pp_print_list
(Some
(fun fmt =>
fun function_parameter =>
let 'tt := function_parameter in
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)
"@." % string)))
(fun fmt =>
fun item =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"* " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"* %a" % string)
File_event_sink.Query.Report.pp item))
errors_and_warnings)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))
(fun function_parameter =>
let 'tt := function_parameter in
let make_row
(e :
Tezos_stdlib_unix.File_event_sink.Query.Report.item)
: list string :=
let text :=
flat_pp File_event_sink.Query.Report.pp e in
let tag :=
match e with
| Error _ => "error" % string
| Warning _ => "warning" % string
end in
script_row tag "-" % string "-" % string text tt
in
List.map make_row errors_and_warnings)
end))
| Some other =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"URI scheme " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" not handled as of now." % string
CamlinternalFormatBasics.End_of_format)))
"URI scheme %S not handled as of now." % string) other)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end))
(cons
(command
"Display configuration/state information about the internal-event logging framework."
% string no_options
(apply
(prefixes (cons "show" % string (cons "event-logging" % string [])))
stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
let pp_event_definitions {J : Type}
(fmt : Stdlib.Format.formatter) (schs :
list ((string * (string * J)))) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_open_box fmt 0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
pp_print_list
(Some
(fun fmt =>
fun function_parameter =>
let 'tt := function_parameter in
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@;" % string 1 0)
CamlinternalFormatBasics.End_of_format)
"@;" % string)))
(fun fmt =>
fun obj_schema =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_open_box fmt 2 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"* `" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"`:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
CamlinternalFormatBasics.End_of_format))))
"* `%s`:@ " % string)
(* ❌ Sending method message is not handled *)
send in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
pp_print_text fmt
(* ❌ Sending method message is not handled *)
send in
pp_close_box fmt tt) fmt schs in
pp_close_box fmt tt in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Event logging framework:" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
"Sinks state:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
"Events registered:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string
1 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))))))))
"Event logging framework:@.Sinks state:@ %a@.Events registered:@ %a"
% string) Internal_event.All_sinks.pp_state tt
pp_event_definitions
(OCaml.Stdlib.reverse_apply (All_definitions.get tt)
(List.map Generic.json_schema)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(cons
(command "Output the JSON schema of an internal-event." % string
no_options
(apply
(prefixes
(cons "output" % string
(cons "schema" % string (cons "of" % string []))))
(apply
(param "Event-Name" % string "Name of the event" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s)))
(apply (prefix "to" % string)
(apply
(param "File-path" % string "Path to a JSON file" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s))) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun event =>
fun path =>
fun cctxt =>
match All_definitions.find (equiv_decb event) with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Event " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" not found" % string
CamlinternalFormatBasics.End_of_format)))
"Event %S not found" % string) event
| Some ev =>
let o := Generic.json_schema ev in
op_gtgteq
(Lwt_io.with_file None None None Lwt_io.output path
(fun chan =>
let v :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Json_schema.pp
(* ❌ Sending method message is not handled *)
send in
Lwt_io.write chan v))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Wrote schema of " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" to " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"Wrote schema of %s to %s" % string) event path)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))
end)) [])).
src/lib_client_commands/client_helpers_commands.ml 82 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let unique_switch =
Clic.switch
~long:"unique"
~short:'u'
~doc:"Fail when there is more than one possible completion."
()
let commands () =
Clic.
[ command
~desc:
"Autocomplete a prefix of Base58Check-encoded hash.\n\
This actually works only for blocks, operations, public key and \
contract identifiers."
(args1 unique_switch)
( prefixes ["complete"]
@@ string ~name:"prefix" ~desc:"the prefix of the hash to complete"
@@ stop )
(fun unique prefix (cctxt : #Client_context.full) ->
Shell_services.Blocks.Helpers.complete
cctxt
~chain:cctxt#chain
~block:cctxt#block
prefix
>>=? fun completions ->
match completions with
| [] ->
Pervasives.exit 3
| _ :: _ :: _ when unique ->
Pervasives.exit 3
| completions ->
List.iter print_endline completions ;
return_unit);
command
~desc:"Wait for the node to be bootstrapped."
no_options
(prefixes ["bootstrapped"] @@ stop)
(fun () (cctxt : #Client_context.full) ->
Monitor_services.bootstrapped cctxt
>>=? fun (stream, _) ->
Lwt_stream.iter_s
(fun (hash, time) ->
cctxt#message
"Current head: %a (timestamp: %a, validation: %a)"
Block_hash.pp_short
hash
Time.System.pp_hum
(Time.System.of_protocol_exn time)
Time.System.pp_hum
(Tezos_stdlib_unix.Systime_os.now ()))
stream
>>= fun () -> cctxt#answer "Bootstrapped." >>= fun () -> return_unit)
]
src/lib_client_commands/client_helpers_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition unique_switch {F G I a b i o p q : Type}
: Tezos_base__TzPervasives.Clic.arg bool
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
Clic.switch "Fail when there is more than one possible completion." % string
(Some "u" % char) "unique" % string tt.
Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) :=
let 'tt := function_parameter in
cons
(command None
"Autocomplete a prefix of Base58Check-encoded hash.
This actually works only for blocks, operations, public key and contract identifiers."
% string (args1 unique_switch)
(apply (prefixes (cons "complete" % string []))
(apply
(string "prefix" % string
"the prefix of the hash to complete" % string) stop))
(fun unique =>
fun prefix =>
fun cctxt =>
op_gtgteqquestion
(Shell_services.Blocks.Helpers.complete cctxt
(Some
(* ❌ Sending method message is not handled *)
send)
(Some
(* ❌ Sending method message is not handled *)
send) prefix)
(fun completions =>
match completions with
| [] => Pervasives.exit 3
| cons _ (cons _ _) => Pervasives.exit 3
| completions =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter OCaml.Stdlib.print_endline completions in
return_unit
end)))
(cons
(command None "Wait for the node to be bootstrapped." % string no_options
(apply (prefixes (cons "bootstrapped" % string [])) stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion (Monitor_services.bootstrapped cctxt)
(fun function_parameter =>
let '(stream, _) := function_parameter in
op_gtgteq
(Lwt_stream.iter_s
(fun function_parameter =>
let '(hash, time) := function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Current head: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (timestamp: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", validation: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))))))
"Current head: %a (timestamp: %a, validation: %a)" %
string) Block_hash.pp_short hash Time.System.pp_hum
(Time.System.of_protocol_exn time) Time.System.pp_hum
(Tezos_stdlib_unix.Systime_os.now tt)) stream)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Bootstrapped." % string
CamlinternalFormatBasics.End_of_format)
"Bootstrapped." % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))) []).
src/lib_client_commands/client_keys_commands.ml 168 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Client_keys
let group =
{
Clic.name = "keys";
title = "Commands for managing the wallet of cryptographic keys";
}
let algo_param () =
Clic.parameter
~autocomplete:(fun _ -> return ["ed25519"; "secp256k1"; "p256"])
(fun _ name ->
match name with
| "ed25519" ->
return Signature.Ed25519
| "secp256k1" ->
return Signature.Secp256k1
| "p256" ->
return Signature.P256
| name ->
failwith
"Unknown signature algorithm (%s). Available: 'ed25519', \
'secp256k1' or 'p256'"
name)
let sig_algo_arg =
Clic.default_arg
~doc:"use custom signature algorithm"
~long:"sig"
~short:'s'
~placeholder:"ed25519|secp256k1|p256"
~default:"ed25519"
(algo_param ())
let gen_keys_containing ?(encrypted = false) ?(prefix = false) ?(force = false)
~containing ~name (cctxt : #Client_context.io_wallet) =
let unrepresentable =
List.filter
(fun s ->
not @@ Base58.Alphabet.all_in_alphabet Base58.Alphabet.bitcoin s)
containing
in
let good_initial_char = "KLMNPQRSTUVWXYZabcdefghi" in
let bad_initial_char = "123456789ABCDEFGHJjkmnopqrstuvwxyz" in
match unrepresentable with
| _ :: _ ->
cctxt#error
"@[<v 0>The following words can't be written in the key alphabet: %a.@,\
Valid characters: %a@,\
Extra restriction for the first character: %s@]"
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf ", ")
(fun ppf s -> Format.fprintf ppf "'%s'" s))
unrepresentable
Base58.Alphabet.pp
Base58.Alphabet.bitcoin
good_initial_char
| [] -> (
let unrepresentable =
List.filter
(fun s -> prefix && String.contains bad_initial_char s.[0])
containing
in
match unrepresentable with
| _ :: _ ->
cctxt#error
"@[<v 0>The following words don't respect the first character \
restriction: %a.@,\
Valid characters: %a@,\
Extra restriction for the first character: %s@]"
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf ", ")
(fun ppf s -> Format.fprintf ppf "'%s'" s))
unrepresentable
Base58.Alphabet.pp
Base58.Alphabet.bitcoin
good_initial_char
| [] ->
Public_key_hash.mem cctxt name
>>=? fun name_exists ->
if name_exists && not force then
cctxt#warning
"Key for name '%s' already exists. Use --force to update."
name
>>= return
else
cctxt#warning
"This process uses a brute force search and may take a long \
time to find a key."
>>= fun () ->
let matches =
if prefix then
let containing_tz1 = List.map (( ^ ) "tz1") containing in
fun key ->
List.exists
(fun containing ->
String.sub key 0 (String.length containing) = containing)
containing_tz1
else
let re = Re.Str.regexp (String.concat "\\|" containing) in
fun key ->
try
ignore (Re.Str.search_forward re key 0) ;
true
with Not_found -> false
in
let rec loop attempts =
let (public_key_hash, public_key, secret_key) =
Signature.generate_key ()
in
let hash =
Signature.Public_key_hash.to_b58check
@@ Signature.Public_key.hash public_key
in
if matches hash then
let pk_uri =
Tezos_signer_backends.Unencrypted.make_pk public_key
in
( if encrypted then
Tezos_signer_backends.Encrypted.encrypt cctxt secret_key
else
return (Tezos_signer_backends.Unencrypted.make_sk secret_key)
)
>>=? fun sk_uri ->
register_key
cctxt
~force
(public_key_hash, pk_uri, sk_uri)
name
>>=? fun () -> return hash
else
( if attempts mod 25_000 = 0 then
cctxt#message
"Tried %d keys without finding a match"
attempts
else Lwt.return_unit )
>>= fun () ->
Lwt_unix.yield () >>= fun () -> loop (attempts + 1)
in
loop 1
>>=? fun key_hash ->
cctxt#message "Generated '%s' under the name '%s'." key_hash name
>>= fun () -> return_unit )
let rec input_fundraiser_params (cctxt : #Client_context.io_wallet) =
let rec get_boolean_answer (cctxt : #Client_context.io_wallet) ~default ~msg
=
let prompt = if default then "(Y/n/q)" else "(y/N/q)" in
cctxt#prompt "%s %s: " msg prompt
>>=? fun gen ->
match (default, String.lowercase_ascii gen) with
| (default, "") ->
return default
| (_, "y") ->
return_true
| (_, "n") ->
return_false
| (_, "q") ->
failwith "Exit by user request."
| _ ->
get_boolean_answer cctxt ~msg ~default
in
cctxt#prompt "Enter the e-mail used for the paper wallet: "
>>=? fun email ->
let rec loop_words acc i =
if i > 14 then return (List.rev acc)
else
cctxt#prompt_password "Enter word %d: " i
>>=? fun word ->
match Bip39.index_of_word (Bigstring.to_string word) with
| None ->
loop_words acc i
| Some wordidx ->
loop_words (wordidx :: acc) (succ i)
in
loop_words [] 0
>>=? fun words ->
match Bip39.of_indices words with
| None ->
assert false
| Some t -> (
cctxt#prompt_password "Enter the password used for the paper wallet: "
>>=? fun password ->
(* TODO: unicode normalization (NFKD)... *)
let passphrase = Bigstring.(concat "" [of_string email; password]) in
let sk = Bip39.to_seed ~passphrase t in
let sk = Bigstring.sub_bytes sk 0 32 in
let sk : Signature.Secret_key.t =
Ed25519
(Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk)
in
let pk = Signature.Secret_key.to_public_key sk in
let pkh = Signature.Public_key.hash pk in
let msg =
Format.asprintf
"Your public Tezos address is %a is that correct?"
Signature.Public_key_hash.pp
pkh
in
get_boolean_answer cctxt ~msg ~default:true
>>=? function
| true -> return sk | false -> input_fundraiser_params cctxt )
let commands version : Client_context.full Clic.command list =
let open Clic in
let encrypted_switch () =
if
List.exists
(fun (scheme, _) -> scheme = Tezos_signer_backends.Unencrypted.scheme)
(Client_keys.registered_signers ())
then Clic.switch ~long:"encrypted" ~doc:"Encrypt the key on-disk" ()
else Clic.constant true
in
let show_private_switch =
switch ~long:"show-secret" ~short:'S' ~doc:"show the private key" ()
in
[ command
~group
~desc:
"List supported signing schemes.\n\
Signing schemes are identifiers for signer modules: the built-in \
signing routines, a hardware wallet, an external agent, etc.\n\
Each signer has its own format for describing secret keys, such a \
raw secret key for the default `unencrypted` scheme, the path on a \
hardware security module, an alias for an external agent, etc.\n\
This command gives the list of signer modules that this version of \
the tezos client supports."
no_options
(fixed ["list"; "signing"; "schemes"])
(fun () (cctxt : Client_context.full) ->
let signers =
List.sort
(fun (ka, _) (kb, _) -> String.compare ka kb)
(registered_signers ())
in
Lwt_list.iter_s
(fun (n, (module S : SIGNER)) ->
cctxt#message
"@[<v 2>Scheme `%s`: %s@,@[<hov 0>%a@]@]"
n
S.title
Format.pp_print_text
S.description)
signers
>>= return);
( match version with
| Some `Mainnet ->
command
~group
~desc:"Generate a pair of keys."
(args2 (Secret_key.force_switch ()) sig_algo_arg)
(prefixes ["gen"; "keys"] @@ Secret_key.fresh_alias_param @@ stop)
(fun (force, algo) name (cctxt : Client_context.full) ->
Secret_key.of_fresh cctxt force name
>>=? fun name ->
let (pkh, pk, sk) = Signature.generate_key ~algo () in
let pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in
Tezos_signer_backends.Encrypted.encrypt cctxt sk
>>=? fun sk_uri ->
register_key cctxt ~force (pkh, pk_uri, sk_uri) name)
| _ ->
command
~group
~desc:"Generate a pair of keys."
(args3
(Secret_key.force_switch ())
sig_algo_arg
(encrypted_switch ()))
(prefixes ["gen"; "keys"] @@ Secret_key.fresh_alias_param @@ stop)
(fun (force, algo, encrypted) name (cctxt : Client_context.full) ->
Secret_key.of_fresh cctxt force name
>>=? fun name ->
let (pkh, pk, sk) = Signature.generate_key ~algo () in
let pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in
( if encrypted then Tezos_signer_backends.Encrypted.encrypt cctxt sk
else return (Tezos_signer_backends.Unencrypted.make_sk sk) )
>>=? fun sk_uri ->
register_key cctxt ~force (pkh, pk_uri, sk_uri) name) );
( match version with
| Some `Mainnet ->
command
~group
~desc:"Generate keys including the given string."
(args2
(switch
~long:"prefix"
~short:'P'
~doc:"the key must begin with tz1[word]"
())
(force_switch ()))
( prefixes ["gen"; "vanity"; "keys"]
@@ Public_key_hash.fresh_alias_param @@ prefix "matching"
@@ seq_of_param
@@ string
~name:"words"
~desc:"string key must contain one of these words" )
(fun (prefix, force) name containing (cctxt : Client_context.full) ->
Public_key_hash.of_fresh cctxt force name
>>=? fun name ->
gen_keys_containing
~encrypted:true
~force
~prefix
~containing
~name
cctxt)
| _ ->
command
~group
~desc:"Generate keys including the given string."
(args3
(switch
~long:"prefix"
~short:'P'
~doc:"the key must begin with tz1[word]"
())
(force_switch ())
(encrypted_switch ()))
( prefixes ["gen"; "vanity"; "keys"]
@@ Public_key_hash.fresh_alias_param @@ prefix "matching"
@@ seq_of_param
@@ string
~name:"words"
~desc:"string key must contain one of these words" )
(fun (prefix, force, encrypted)
name
containing
(cctxt : Client_context.full) ->
Public_key_hash.of_fresh cctxt force name
>>=? fun name ->
gen_keys_containing
~encrypted
~force
~prefix
~containing
~name
cctxt) );
command
~group
~desc:"Encrypt an unencrypted secret key."
no_options
(prefixes ["encrypt"; "secret"; "key"] @@ stop)
(fun () (cctxt : Client_context.full) ->
cctxt#prompt_password "Enter unencrypted secret key: "
>>=? fun sk_uri ->
let sk_uri = Uri.of_string (Bigstring.to_string sk_uri) in
( match Uri.scheme sk_uri with
| None | Some "unencrypted" ->
return_unit
| _ ->
failwith
"This command can only be used with the \"unencrypted\" scheme"
)
>>=? fun () ->
Lwt.return (Signature.Secret_key.of_b58check (Uri.path sk_uri))
>>=? fun sk ->
Tezos_signer_backends.Encrypted.encrypt cctxt sk
>>=? fun sk_uri ->
cctxt#message "Encrypted secret key %a" Uri.pp_hum (sk_uri :> Uri.t)
>>= fun () -> return_unit);
command
~group
~desc:"Add a secret key to the wallet."
(args1 (Secret_key.force_switch ()))
( prefix "import"
@@ prefixes ["secret"; "key"]
@@ Secret_key.fresh_alias_param @@ Client_keys.sk_uri_param @@ stop )
(fun force name sk_uri (cctxt : Client_context.full) ->
Secret_key.of_fresh cctxt force name
>>=? fun name ->
Client_keys.neuterize sk_uri
>>=? fun pk_uri ->
Public_key.find_opt cctxt name
>>=? (function
| None ->
return_unit
| Some (pk_uri_found, _) ->
fail_unless
(pk_uri = pk_uri_found || force)
(failure
"public and secret keys '%s' don't correspond, please \
don't use --force"
name))
>>=? fun () ->
Client_keys.import_secret_key
~io:(cctxt :> Client_context.io_wallet)
pk_uri
>>=? fun (pkh, public_key) ->
cctxt#message
"Tezos address added: %a"
Signature.Public_key_hash.pp
pkh
>>= fun () ->
register_key cctxt ~force (pkh, pk_uri, sk_uri) ?public_key name) ]
@ ( if version <> Some `Mainnet then []
else
[ command
~group
~desc:"Add a fundraiser secret key to the wallet."
(args1 (Secret_key.force_switch ()))
( prefix "import"
@@ prefixes ["fundraiser"; "secret"; "key"]
@@ Secret_key.fresh_alias_param @@ stop )
(fun force name (cctxt : Client_context.full) ->
Secret_key.of_fresh cctxt force name
>>=? fun name ->
input_fundraiser_params cctxt
>>=? fun sk ->
Tezos_signer_backends.Encrypted.encrypt cctxt sk
>>=? fun sk_uri ->
Client_keys.neuterize sk_uri
>>=? fun pk_uri ->
Public_key.find_opt cctxt name
>>=? (function
| None ->
return_unit
| Some (pk_uri_found, _) ->
fail_unless
(pk_uri = pk_uri_found || force)
(failure
"public and secret keys '%s' don't correspond, \
please don't use --force"
name))
>>=? fun () ->
Client_keys.public_key_hash pk_uri
>>=? fun (pkh, _public_key) ->
register_key cctxt ~force (pkh, pk_uri, sk_uri) name) ] )
@ [ command
~group
~desc:"Add a public key to the wallet."
(args1 (Public_key.force_switch ()))
( prefix "import"
@@ prefixes ["public"; "key"]
@@ Public_key.fresh_alias_param @@ Client_keys.pk_uri_param @@ stop )
(fun force name pk_uri (cctxt : Client_context.full) ->
Public_key.of_fresh cctxt force name
>>=? fun name ->
Client_keys.public_key_hash pk_uri
>>=? fun (pkh, public_key) ->
Public_key_hash.add ~force cctxt name pkh
>>=? fun () ->
cctxt#message
"Tezos address added: %a"
Signature.Public_key_hash.pp
pkh
>>= fun () -> Public_key.add ~force cctxt name (pk_uri, public_key));
command
~group
~desc:"Add an address to the wallet."
(args1 (Public_key.force_switch ()))
( prefixes ["add"; "address"]
@@ Public_key_hash.fresh_alias_param @@ Public_key_hash.source_param
@@ stop )
(fun force name hash cctxt ->
Public_key_hash.of_fresh cctxt force name
>>=? fun name -> Public_key_hash.add ~force cctxt name hash);
command
~group
~desc:"List all addresses and associated keys."
no_options
(fixed ["list"; "known"; "addresses"])
(fun () (cctxt : #Client_context.full) ->
list_keys cctxt
>>=? fun l ->
iter_s
(fun (name, pkh, pk, sk) ->
Public_key_hash.to_source pkh
>>=? fun v ->
( match (pk, sk) with
| (None, None) ->
cctxt#message "%s: %s" name v
| (_, Some uri) ->
let scheme =
Option.unopt ~default:"unencrypted"
@@ Uri.scheme (uri : sk_uri :> Uri.t)
in
cctxt#message "%s: %s (%s sk known)" name v scheme
| (Some _, _) ->
cctxt#message "%s: %s (pk known)" name v )
>>= fun () -> return_unit)
l);
command
~group
~desc:"Show the keys associated with an implicit account."
(args1 show_private_switch)
(prefixes ["show"; "address"] @@ Public_key_hash.alias_param @@ stop)
(fun show_private (name, _) (cctxt : #Client_context.full) ->
alias_keys cctxt name
>>=? fun key_info ->
match key_info with
| None ->
cctxt#message "No keys found for address"
>>= fun () -> return_unit
| Some (pkh, pk, skloc) -> (
cctxt#message "Hash: %a" Signature.Public_key_hash.pp pkh
>>= fun () ->
match pk with
| None ->
return_unit
| Some pk ->
cctxt#message "Public Key: %a" Signature.Public_key.pp pk
>>= fun () ->
if show_private then
match skloc with
| None ->
return_unit
| Some skloc ->
Secret_key.to_source skloc
>>=? fun skloc ->
cctxt#message "Secret Key: %s" skloc
>>= fun () -> return_unit
else return_unit ));
command
~group
~desc:"Forget one address."
(args1
(Clic.switch
~long:"force"
~short:'f'
~doc:"delete associated keys when present"
()))
(prefixes ["forget"; "address"] @@ Public_key_hash.alias_param @@ stop)
(fun force (name, _pkh) (cctxt : Client_context.full) ->
Secret_key.mem cctxt name
>>=? fun has_secret_key ->
Public_key.mem cctxt name
>>=? fun has_public_key ->
fail_when
((not force) && (has_secret_key || has_public_key))
(failure
"secret or public key present for %s, use --force to delete"
name)
>>=? fun () ->
Secret_key.del cctxt name
>>=? fun () ->
Public_key.del cctxt name
>>=? fun () -> Public_key_hash.del cctxt name);
command
~group
~desc:"Forget the entire wallet of keys."
(args1
(Clic.switch
~long:"force"
~short:'f'
~doc:"you got to use the force for that"
()))
(fixed ["forget"; "all"; "keys"])
(fun force (cctxt : Client_context.full) ->
fail_unless
force
(failure "this can only be used with option --force")
>>=? fun () ->
Public_key.set cctxt []
>>=? fun () ->
Secret_key.set cctxt [] >>=? fun () -> Public_key_hash.set cctxt []);
command
~group
~desc:"Compute deterministic nonce."
no_options
( prefixes ["generate"; "nonce"; "for"]
@@ Public_key_hash.alias_param
@@ prefixes ["from"]
@@ string
~name:"data"
~desc:"string from which to deterministically generate the nonce"
@@ stop )
(fun () (name, _pkh) data (cctxt : Client_context.full) ->
let data = Bytes.of_string data in
Secret_key.mem cctxt name
>>=? fun sk_present ->
fail_unless sk_present (failure "secret key not present for %s" name)
>>=? fun () ->
Secret_key.find cctxt name
>>=? fun sk_uri ->
Client_keys.deterministic_nonce sk_uri data
>>=? fun nonce ->
cctxt#message "%a" Hex.pp (Hex.of_bytes (Bigstring.to_bytes nonce))
>>= fun () -> return_unit);
command
~group
~desc:"Compute deterministic nonce hash."
no_options
( prefixes ["generate"; "nonce"; "hash"; "for"]
@@ Public_key_hash.alias_param
@@ prefixes ["from"]
@@ string
~name:"data"
~desc:
"string from which to deterministically generate the nonce hash"
@@ stop )
(fun () (name, _pkh) data (cctxt : Client_context.full) ->
let data = Bytes.of_string data in
Secret_key.mem cctxt name
>>=? fun sk_present ->
fail_unless sk_present (failure "secret key not present for %s" name)
>>=? fun () ->
Secret_key.find cctxt name
>>=? fun sk_uri ->
Client_keys.deterministic_nonce_hash sk_uri data
>>=? fun nonce_hash ->
cctxt#message "%a" Hex.pp (Hex.of_bytes nonce_hash)
>>= fun () -> return_unit) ]
src/lib_client_commands/client_keys_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Client_keys.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "keys" % string;
Clic.title :=
"Commands for managing the wallet of cryptographic keys" % string |}.
Definition algo_param {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter
Tezos_base__TzPervasives.Signature.algo A :=
let 'tt := function_parameter in
Clic.parameter
(Some
(fun function_parameter =>
let '_ := function_parameter in
_return
(cons "ed25519" % string
(cons "secp256k1" % string (cons "p256" % string [])))))
(fun function_parameter =>
let '_ := function_parameter in
fun name =>
match name with
| "ed25519" % string =>
_return Tezos_base__TzPervasives.Signature.Ed25519
| "secp256k1" % string =>
_return Tezos_base__TzPervasives.Signature.Secp256k1
| "p256" % string => _return Tezos_base__TzPervasives.Signature.P256
| name =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown signature algorithm (" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"). Available: 'ed25519', 'secp256k1' or 'p256'" % string
CamlinternalFormatBasics.End_of_format)))
"Unknown signature algorithm (%s). Available: 'ed25519', 'secp256k1' or 'p256'"
% string) name
end).
Definition sig_algo_arg
: Tezos_base__TzPervasives.Clic.arg Tezos_base__TzPervasives.Signature.algo
Tezos_client_base.Client_context.full :=
Clic.default_arg "use custom signature algorithm" % string (Some "s" % char)
"sig" % string "ed25519|secp256k1|p256" % string "ed25519" % string
(algo_param tt).
Definition gen_keys_containing {C a b : Type} (op_staroptstar : option bool)
: (option bool) ->
(option bool) ->
(list string) ->
string ->
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit)
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit)
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) * C)))))))))))) * C) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let encrypted :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun op_staroptstar =>
let prefix :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun op_staroptstar =>
let force :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun containing =>
fun name =>
fun cctxt =>
let unrepresentable :=
List.filter
(fun s =>
apply negb
(Base58.Alphabet.all_in_alphabet Base58.Alphabet.bitcoin s))
containing in
let good_initial_char := "KLMNPQRSTUVWXYZabcdefghi" % string in
let bad_initial_char :=
"123456789ABCDEFGHJjkmnopqrstuvwxyz" % string in
match unrepresentable with
| cons _ _ =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"The following words can't be written in the key alphabet: "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Valid characters: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string
0 0)
(CamlinternalFormatBasics.String_literal
"Extra restriction for the first character: "
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))
"@[<v 0>The following words can't be written in the key alphabet: %a.@,Valid characters: %a@,Extra restriction for the first character: %s@]"
% string)
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
", " % string
CamlinternalFormatBasics.End_of_format)
", " % string)))
(fun ppf =>
fun s =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "'" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "'" % char
CamlinternalFormatBasics.End_of_format)))
"'%s'" % string) s)) unrepresentable
Base58.Alphabet.pp Base58.Alphabet.bitcoin good_initial_char
| [] =>
let unrepresentable :=
List.filter
(fun s =>
andb prefix
(String.contains bad_initial_char (String.get s 0)))
containing in
match unrepresentable with
| cons _ _ =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"The following words don't respect the first character restriction: "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Valid characters: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Extra restriction for the first character: "
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))
"@[<v 0>The following words don't respect the first character restriction: %a.@,Valid characters: %a@,Extra restriction for the first character: %s@]"
% string)
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
", " % string
CamlinternalFormatBasics.End_of_format)
", " % string)))
(fun ppf =>
fun s =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "'" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))
"'%s'" % string) s)) unrepresentable
Base58.Alphabet.pp Base58.Alphabet.bitcoin good_initial_char
| [] =>
op_gtgteqquestion (Public_key_hash.mem cctxt name)
(fun name_exists =>
if andb name_exists (negb force) then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Key for name '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"' already exists. Use --force to update." %
string
CamlinternalFormatBasics.End_of_format)))
"Key for name '%s' already exists. Use --force to update."
% string) name) _return
else
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This process uses a brute force search and may take a long time to find a key."
% string CamlinternalFormatBasics.End_of_format)
"This process uses a brute force search and may take a long time to find a key."
% string))
(fun function_parameter =>
let 'tt := function_parameter in
let matches :=
if prefix then
let containing_tz1 :=
List.map (String.append "tz1" % string)
containing in
fun key =>
List._exists
(fun containing =>
equiv_decb
(String.sub key 0
(String.length containing)) containing)
containing_tz1
else
let re :=
Re.Str.regexp
(String.concat "\|" % string containing) in
fun key =>
(* ❌ Try-with are not handled *)
try
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ :=
OCaml.Stdlib.ignore
(Re.Str.search_forward re key 0) in
true) in
let fix loop (attempts : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
let '(public_key_hash, public_key, secret_key) :=
Signature.generate_key None None tt in
let hash :=
apply Signature.Public_key_hash.to_b58check
(Signature.Public_key.hash public_key) in
if matches hash then
let pk_uri :=
Tezos_signer_backends.Unencrypted.make_pk
public_key in
op_gtgteqquestion
(if encrypted then
Tezos_signer_backends.Encrypted.encrypt cctxt
secret_key
else
_return
(Tezos_signer_backends.Unencrypted.make_sk
secret_key))
(fun sk_uri =>
op_gtgteqquestion
(register_key cctxt (Some force)
(public_key_hash, pk_uri, sk_uri) None
name)
(fun function_parameter =>
let 'tt := function_parameter in
_return hash))
else
op_gtgteq
(if equiv_decb (Z.modulo attempts 25000) 0 then
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Tried " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" keys without finding a match" %
string
CamlinternalFormatBasics.End_of_format)))
"Tried %d keys without finding a match" %
string) attempts
else
Lwt.return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_unix.yield tt)
(fun function_parameter =>
let 'tt := function_parameter in
loop (Z.add attempts 1))) in
op_gtgteqquestion (loop 1)
(fun key_hash =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Generated '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"' under the name '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"'." % string
CamlinternalFormatBasics.End_of_format)))))
"Generated '%s' under the name '%s'." %
string) key_hash name)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
end
end.
Fixpoint input_fundraiser_params {C a b : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
(a * b)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a) * (a))
*
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit)
-> a) * (a)) * C)))))))))))) * C)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.Secret_key.t) :=
let fix get_boolean_answer {D : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
(a * b)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a) * (a))
*
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit)
-> a) * (a)) * D)))))))))))) * D) (default : bool)
(msg : string) : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
let prompt :=
if default then
"(Y/n/q)" % string
else
"(y/N/q)" % string in
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ": " % string
CamlinternalFormatBasics.End_of_format)))) "%s %s: " % string)
msg prompt)
(fun gen =>
match (default, (String.lowercase_ascii gen)) with
| (default, "" % string) => _return default
| (_, "y" % string) => return_true
| (_, "n" % string) => return_false
| (_, "q" % string) =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Exit by user request." % string
CamlinternalFormatBasics.End_of_format)
"Exit by user request." % string)
| _ => get_boolean_answer cctxt default msg
end) in
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Enter the e-mail used for the paper wallet: " % string
CamlinternalFormatBasics.End_of_format)
"Enter the e-mail used for the paper wallet: " % string))
(fun email =>
let fix loop_words (acc : list Z) (i : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult (list Z)) :=
if OCaml.Stdlib.gt i 14 then
_return (List.rev acc)
else
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Enter word " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ": " % string
CamlinternalFormatBasics.End_of_format)))
"Enter word %d: " % string) i)
(fun word =>
match Bip39.index_of_word (Bigstring.to_string word) with
| None => loop_words acc i
| Some wordidx => loop_words (cons wordidx acc) (Z.succ i)
end) in
op_gtgteqquestion (loop_words [] 0)
(fun words =>
match Bip39.of_indices words with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some t =>
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Enter the password used for the paper wallet: " % string
CamlinternalFormatBasics.End_of_format)
"Enter the password used for the paper wallet: " % string))
(fun password =>
let passphrase :=
concat "" % string (cons (of_string email) (cons password []))
in
let sk := Bip39.to_seed (Some passphrase) t in
let sk := Bigstring.sub_bytes sk 0 32 in
let sk :=
Tezos_crypto__Signature.Ed25519
(Data_encoding.Binary.of_bytes_exn
Ed25519.Secret_key.encoding sk) in
let pk := Signature.Secret_key.to_public_key sk in
let pkh := Signature.Public_key.hash pk in
let msg :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Your public Tezos address is " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is that correct?" % string
CamlinternalFormatBasics.End_of_format)))
"Your public Tezos address is %a is that correct?" %
string) Signature.Public_key_hash.pp pkh in
op_gtgteqquestion (get_boolean_answer cctxt true msg)
(fun function_parameter =>
match function_parameter with
| true => _return sk
| false => input_fundraiser_params cctxt
end))
end)).
Definition commands (version : option variant)
: list
(Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
let encrypted_switch {A : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.arg bool A :=
let 'tt := function_parameter in
if
List._exists
(fun function_parameter =>
let '(scheme, _) := function_parameter in
equiv_decb scheme Tezos_signer_backends.Unencrypted.scheme)
(Client_keys.registered_signers tt) then
Clic.switch "Encrypt the key on-disk" % string None "encrypted" % string
tt
else
Clic.constant true in
let show_private_switch :=
switch "show the private key" % string (Some "S" % char)
"show-secret" % string tt in
OCaml.Stdlib.app
(cons
(command (Some group)
"List supported signing schemes.
Signing schemes are identifiers for signer modules: the built-in signing routines, a hardware wallet, an external agent, etc.
Each signer has its own format for describing secret keys, such a raw secret key for the default `unencrypted` scheme, the path on a hardware security module, an alias for an external agent, etc.
This command gives the list of signer modules that this version of the tezos client supports."
% string no_options
(fixed
(cons "list" % string
(cons "signing" % string (cons "schemes" % string []))))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
let signers :=
List.sort
(fun function_parameter =>
let '(ka, _) := function_parameter in
fun function_parameter =>
let '(kb, _) := function_parameter in
String.compare ka kb) (registered_signers tt) in
op_gtgteq
(Lwt_list.iter_s
(fun function_parameter =>
let '(n, _ as S) := function_parameter in
let S := projT2 S in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Scheme `" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"`: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string
0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 0>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))
"@[<v 2>Scheme `%s`: %s@,@[<hov 0>%a@]@]" % string) n
S.(Tezos_client_base.Client_keys.SIGNER.title)
Format.pp_print_text
S.(Tezos_client_base.Client_keys.SIGNER.description))
signers) _return))
(cons
match version with
| Some Mainnet =>
command (Some group) "Generate a pair of keys." % string
(args2 (Secret_key.force_switch tt) sig_algo_arg)
(apply (prefixes (cons "gen" % string (cons "keys" % string [])))
(apply
(let arg := Secret_key.fresh_alias_param in
fun eta => arg None None eta) stop))
(fun function_parameter =>
let '(force, algo) := function_parameter in
fun name =>
fun cctxt =>
op_gtgteqquestion (Secret_key.of_fresh cctxt force name)
(fun name =>
let '(pkh, pk, sk) :=
Signature.generate_key (Some algo) None tt in
let pk_uri := Tezos_signer_backends.Unencrypted.make_pk pk
in
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.encrypt cctxt sk)
(fun sk_uri =>
register_key cctxt (Some force) (pkh, pk_uri, sk_uri)
None name)))
| _ =>
command (Some group) "Generate a pair of keys." % string
(args3 (Secret_key.force_switch tt) sig_algo_arg
(encrypted_switch tt))
(apply (prefixes (cons "gen" % string (cons "keys" % string [])))
(apply
(let arg := Secret_key.fresh_alias_param in
fun eta => arg None None eta) stop))
(fun function_parameter =>
let '(force, algo, encrypted) := function_parameter in
fun name =>
fun cctxt =>
op_gtgteqquestion (Secret_key.of_fresh cctxt force name)
(fun name =>
let '(pkh, pk, sk) :=
Signature.generate_key (Some algo) None tt in
let pk_uri := Tezos_signer_backends.Unencrypted.make_pk pk
in
op_gtgteqquestion
(if encrypted then
Tezos_signer_backends.Encrypted.encrypt cctxt sk
else
_return (Tezos_signer_backends.Unencrypted.make_sk sk))
(fun sk_uri =>
register_key cctxt (Some force) (pkh, pk_uri, sk_uri)
None name)))
end
(cons
match version with
| Some Mainnet =>
command (Some group)
"Generate keys including the given string." % string
(args2
(switch "the key must begin with tz1[word]" % string
(Some "P" % char) "prefix" % string tt) (force_switch tt))
(apply
(prefixes
(cons "gen" % string
(cons "vanity" % string (cons "keys" % string []))))
(apply
(let arg := Public_key_hash.fresh_alias_param in
fun eta => arg None None eta)
(apply (prefix "matching" % string)
(apply seq_of_param
(string "words" % string
"string key must contain one of these words" % string)))))
(fun function_parameter =>
let '(prefix, force) := function_parameter in
fun name =>
fun containing =>
fun cctxt =>
op_gtgteqquestion
(Public_key_hash.of_fresh cctxt force name)
(fun name =>
gen_keys_containing (Some true) (Some prefix)
(Some force) containing name cctxt))
| _ =>
command (Some group)
"Generate keys including the given string." % string
(args3
(switch "the key must begin with tz1[word]" % string
(Some "P" % char) "prefix" % string tt) (force_switch tt)
(encrypted_switch tt))
(apply
(prefixes
(cons "gen" % string
(cons "vanity" % string (cons "keys" % string []))))
(apply
(let arg := Public_key_hash.fresh_alias_param in
fun eta => arg None None eta)
(apply (prefix "matching" % string)
(apply seq_of_param
(string "words" % string
"string key must contain one of these words" % string)))))
(fun function_parameter =>
let '(prefix, force, encrypted) := function_parameter in
fun name =>
fun containing =>
fun cctxt =>
op_gtgteqquestion
(Public_key_hash.of_fresh cctxt force name)
(fun name =>
gen_keys_containing (Some encrypted) (Some prefix)
(Some force) containing name cctxt))
end
(cons
(command (Some group) "Encrypt an unencrypted secret key." % string
no_options
(apply
(prefixes
(cons "encrypt" % string
(cons "secret" % string (cons "key" % string [])))) stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Enter unencrypted secret key: " % string
CamlinternalFormatBasics.End_of_format)
"Enter unencrypted secret key: " % string))
(fun sk_uri =>
let sk_uri := Uri.of_string (Bigstring.to_string sk_uri)
in
op_gtgteqquestion
match Uri.scheme sk_uri with
| None | Some "unencrypted" % string => return_unit
| _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This command can only be used with the ""unencrypted"" scheme"
% string
CamlinternalFormatBasics.End_of_format)
"This command can only be used with the ""unencrypted"" scheme"
% string)
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt._return
(Signature.Secret_key.of_b58check
(Uri.path sk_uri)))
(fun sk =>
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.encrypt cctxt
sk)
(fun sk_uri =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Encrypted secret key " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Encrypted secret key %a" % string)
Uri.pp_hum sk_uri)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))))))
(cons
(command (Some group) "Add a secret key to the wallet." % string
(args1 (Secret_key.force_switch tt))
(apply (prefix "import" % string)
(apply
(prefixes (cons "secret" % string (cons "key" % string [])))
(apply
(let arg := Secret_key.fresh_alias_param in
fun eta => arg None None eta)
(apply
(let arg := Client_keys.sk_uri_param in
fun eta => arg None None eta) stop))))
(fun force =>
fun name =>
fun sk_uri =>
fun cctxt =>
op_gtgteqquestion (Secret_key.of_fresh cctxt force name)
(fun name =>
op_gtgteqquestion (Client_keys.neuterize sk_uri)
(fun pk_uri =>
op_gtgteqquestion
(op_gtgteqquestion
(Public_key.find_opt cctxt name)
(fun function_parameter =>
match function_parameter with
| None => return_unit
| Some (pk_uri_found, _) =>
fail_unless
(orb (equiv_decb pk_uri pk_uri_found)
force)
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"public and secret keys '" %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"' don't correspond, please don't use --force"
% string
CamlinternalFormatBasics.End_of_format)))
"public and secret keys '%s' don't correspond, please don't use --force"
% string) name)
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_keys.import_secret_key cctxt
pk_uri)
(fun function_parameter =>
let '(pkh, public_key) :=
function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Tezos address added: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Tezos address added: %a" % string)
Signature.Public_key_hash.pp pkh)
(fun function_parameter =>
let 'tt := function_parameter in
register_key cctxt (Some force)
(pkh, pk_uri, sk_uri) public_key
name))))))) [])))))
(OCaml.Stdlib.app
(if
nequiv_decb version
(Some
(* ❌ Variants not supported *)
variant) then
[]
else
cons
(command (Some group)
"Add a fundraiser secret key to the wallet." % string
(args1 (Secret_key.force_switch tt))
(apply (prefix "import" % string)
(apply
(prefixes
(cons "fundraiser" % string
(cons "secret" % string (cons "key" % string []))))
(apply
(let arg := Secret_key.fresh_alias_param in
fun eta => arg None None eta) stop)))
(fun force =>
fun name =>
fun cctxt =>
op_gtgteqquestion (Secret_key.of_fresh cctxt force name)
(fun name =>
op_gtgteqquestion (input_fundraiser_params cctxt)
(fun sk =>
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.encrypt cctxt sk)
(fun sk_uri =>
op_gtgteqquestion (Client_keys.neuterize sk_uri)
(fun pk_uri =>
op_gtgteqquestion
(op_gtgteqquestion
(Public_key.find_opt cctxt name)
(fun function_parameter =>
match function_parameter with
| None => return_unit
| Some (pk_uri_found, _) =>
fail_unless
(orb
(equiv_decb pk_uri pk_uri_found)
force)
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"public and secret keys '" %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"' don't correspond, please don't use --force"
% string
CamlinternalFormatBasics.End_of_format)))
"public and secret keys '%s' don't correspond, please don't use --force"
% string) name)
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_keys.public_key_hash pk_uri)
(fun function_parameter =>
let '(pkh, _public_key) :=
function_parameter in
register_key cctxt (Some force)
(pkh, pk_uri, sk_uri) None name))))))))
[])
(cons
(command (Some group) "Add a public key to the wallet." % string
(args1 (Public_key.force_switch tt))
(apply (prefix "import" % string)
(apply (prefixes (cons "public" % string (cons "key" % string [])))
(apply
(let arg := Public_key.fresh_alias_param in
fun eta => arg None None eta)
(apply
(let arg := Client_keys.pk_uri_param in
fun eta => arg None None eta) stop))))
(fun force =>
fun name =>
fun pk_uri =>
fun cctxt =>
op_gtgteqquestion (Public_key.of_fresh cctxt force name)
(fun name =>
op_gtgteqquestion (Client_keys.public_key_hash pk_uri)
(fun function_parameter =>
let '(pkh, public_key) := function_parameter in
op_gtgteqquestion
(Public_key_hash.add force cctxt name pkh)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Tezos address added: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Tezos address added: %a" % string)
Signature.Public_key_hash.pp pkh)
(fun function_parameter =>
let 'tt := function_parameter in
Public_key.add force cctxt name
(pk_uri, public_key)))))))
(cons
(command (Some group) "Add an address to the wallet." % string
(args1 (Public_key.force_switch tt))
(apply (prefixes (cons "add" % string (cons "address" % string [])))
(apply
(let arg := Public_key_hash.fresh_alias_param in
fun eta => arg None None eta)
(apply
(let arg := Public_key_hash.source_param in
fun eta => arg None None eta) stop)))
(fun force =>
fun name =>
fun hash =>
fun cctxt =>
op_gtgteqquestion
(Public_key_hash.of_fresh cctxt force name)
(fun name => Public_key_hash.add force cctxt name hash)))
(cons
(command (Some group)
"List all addresses and associated keys." % string no_options
(fixed
(cons "list" % string
(cons "known" % string (cons "addresses" % string []))))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion (list_keys cctxt)
(fun l =>
iter_s
(fun function_parameter =>
let '(name, pkh, pk, sk) := function_parameter in
op_gtgteqquestion (Public_key_hash.to_source pkh)
(fun v =>
op_gtgteq
match (pk, sk) with
| (None, None) =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"%s: %s" % string) name v
| (_, Some uri) =>
let scheme :=
apply (Option.unopt "unencrypted" % string)
(Uri.scheme uri) in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" sk known)" % string
CamlinternalFormatBasics.End_of_format))))))
"%s: %s (%s sk known)" % string) name v
scheme
| (Some _, _) =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (pk known)" % string
CamlinternalFormatBasics.End_of_format))))
"%s: %s (pk known)" % string) name v
end
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))) l)))
(cons
(command (Some group)
"Show the keys associated with an implicit account." % string
(args1 show_private_switch)
(apply
(prefixes (cons "show" % string (cons "address" % string [])))
(apply
(let arg := Public_key_hash.alias_param in
fun eta => arg None None eta) stop))
(fun show_private =>
fun function_parameter =>
let '(name, _) := function_parameter in
fun cctxt =>
op_gtgteqquestion (alias_keys cctxt name)
(fun key_info =>
match key_info with
| None =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No keys found for address" % string
CamlinternalFormatBasics.End_of_format)
"No keys found for address" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Some (pkh, pk, skloc) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Hash: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Hash: %a" % string)
Signature.Public_key_hash.pp pkh)
(fun function_parameter =>
let 'tt := function_parameter in
match pk with
| None => return_unit
| Some pk =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Public Key: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Public Key: %a" % string)
Signature.Public_key.pp pk)
(fun function_parameter =>
let 'tt := function_parameter in
if show_private then
match skloc with
| None => return_unit
| Some skloc =>
op_gtgteqquestion
(Secret_key.to_source skloc)
(fun skloc =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Secret Key: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Secret Key: %s" % string)
skloc)
(fun function_parameter =>
let 'tt := function_parameter
in
return_unit))
end
else
return_unit)
end)
end)))
(cons
(command (Some group) "Forget one address." % string
(args1
(Clic.switch "delete associated keys when present" % string
(Some "f" % char) "force" % string tt))
(apply
(prefixes
(cons "forget" % string (cons "address" % string [])))
(apply
(let arg := Public_key_hash.alias_param in
fun eta => arg None None eta) stop))
(fun force =>
fun function_parameter =>
let '(name, _pkh) := function_parameter in
fun cctxt =>
op_gtgteqquestion (Secret_key.mem cctxt name)
(fun has_secret_key =>
op_gtgteqquestion (Public_key.mem cctxt name)
(fun has_public_key =>
op_gtgteqquestion
(fail_when
(andb (negb force)
(orb has_secret_key has_public_key))
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"secret or public key present for " %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
", use --force to delete" % string
CamlinternalFormatBasics.End_of_format)))
"secret or public key present for %s, use --force to delete"
% string) name))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Secret_key.del cctxt name)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Public_key.del cctxt name)
(fun function_parameter =>
let 'tt := function_parameter in
Public_key_hash.del cctxt name)))))))
(cons
(command (Some group)
"Forget the entire wallet of keys." % string
(args1
(Clic.switch "you got to use the force for that" % string
(Some "f" % char) "force" % string tt))
(fixed
(cons "forget" % string
(cons "all" % string (cons "keys" % string []))))
(fun force =>
fun cctxt =>
op_gtgteqquestion
(fail_unless force
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"this can only be used with option --force" %
string
CamlinternalFormatBasics.End_of_format)
"this can only be used with option --force" %
string)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Public_key.set cctxt [])
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Secret_key.set cctxt [])
(fun function_parameter =>
let 'tt := function_parameter in
Public_key_hash.set cctxt [])))))
(cons
(command (Some group)
"Compute deterministic nonce." % string no_options
(apply
(prefixes
(cons "generate" % string
(cons "nonce" % string (cons "for" % string []))))
(apply
(let arg := Public_key_hash.alias_param in
fun eta => arg None None eta)
(apply (prefixes (cons "from" % string []))
(apply
(string "data" % string
"string from which to deterministically generate the nonce"
% string) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(name, _pkh) := function_parameter in
fun data =>
fun cctxt =>
let data := Stdlib.Bytes.of_string data in
op_gtgteqquestion (Secret_key.mem cctxt name)
(fun sk_present =>
op_gtgteqquestion
(fail_unless sk_present
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"secret key not present for " %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"secret key not present for %s" %
string) name))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Secret_key.find cctxt name)
(fun sk_uri =>
op_gtgteqquestion
(Client_keys.deterministic_nonce
sk_uri data)
(fun nonce =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Hex.pp
(Hex.of_bytes None
(Bigstring.to_bytes nonce)))
(fun function_parameter =>
let 'tt := function_parameter
in
return_unit)))))))
(cons
(command (Some group)
"Compute deterministic nonce hash." % string no_options
(apply
(prefixes
(cons "generate" % string
(cons "nonce" % string
(cons "hash" % string (cons "for" % string [])))))
(apply
(let arg := Public_key_hash.alias_param in
fun eta => arg None None eta)
(apply (prefixes (cons "from" % string []))
(apply
(string "data" % string
"string from which to deterministically generate the nonce hash"
% string) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(name, _pkh) := function_parameter in
fun data =>
fun cctxt =>
let data := Stdlib.Bytes.of_string data in
op_gtgteqquestion (Secret_key.mem cctxt name)
(fun sk_present =>
op_gtgteqquestion
(fail_unless sk_present
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"secret key not present for " %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"secret key not present for %s" %
string) name))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Secret_key.find cctxt name)
(fun sk_uri =>
op_gtgteqquestion
(Client_keys.deterministic_nonce_hash
sk_uri data)
(fun nonce_hash =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Hex.pp
(Hex.of_bytes None
nonce_hash))
(fun function_parameter =>
let 'tt :=
function_parameter in
return_unit))))))) []))))))))).
src/lib_client_commands/client_p2p_commands.ml 235 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let group =
{
Clic.name = "p2p";
title = "Commands for monitoring and controlling p2p-layer state";
}
let pp_connection_info ppf conn =
P2p_connection.Info.pp (fun _ _ -> ()) ppf conn
let addr_parameter =
let open Clic in
param
~name:"address"
~desc:"<IPv4>:PORT or <IPV6>:PORT address (PORT defaults to 9732)."
(parameter (fun _ x ->
return (P2p_point.Id.of_string_exn ~default_port:9732 x)))
let p2p_peer_id_param ~name ~desc t =
Clic.param
~name
~desc
(Clic.parameter (fun _ str -> Lwt.return (P2p_peer.Id.of_b58check str)))
t
let commands () =
let open Clic in
[ command
~group
~desc:"show global network status"
no_options
(prefixes ["p2p"; "stat"] stop)
(fun () (cctxt : #Client_context.full) ->
Shell_services.P2p.stat cctxt
>>=? fun stat ->
Shell_services.P2p.Connections.list cctxt
>>=? fun conns ->
Shell_services.P2p.Peers.list cctxt
>>=? fun peers ->
Shell_services.P2p.Points.list cctxt
>>=? fun points ->
cctxt#message "GLOBAL STATS"
>>= fun () ->
cctxt#message " %a" P2p_stat.pp stat
>>= fun () ->
cctxt#message "CONNECTIONS"
>>= fun () ->
let (incoming, outgoing) =
List.partition (fun c -> c.P2p_connection.Info.incoming) conns
in
Lwt_list.iter_s
(fun conn -> cctxt#message " %a" pp_connection_info conn)
incoming
>>= fun () ->
Lwt_list.iter_s
(fun conn -> cctxt#message " %a" pp_connection_info conn)
outgoing
>>= fun () ->
cctxt#message "KNOWN PEERS"
>>= fun () ->
Lwt_list.iter_s
(fun (p, pi) ->
cctxt#message
" %a %.0f %a %a %s"
P2p_peer.State.pp_digram
pi.P2p_peer.Info.state
pi.score
P2p_peer.Id.pp
p
P2p_stat.pp
pi.stat
(if pi.trusted then "â
" else " "))
peers
>>= fun () ->
cctxt#message "KNOWN POINTS"
>>= fun () ->
Lwt_list.iter_s
(fun (p, pi) ->
match pi.P2p_point.Info.state with
| Running peer_id ->
cctxt#message
" %a %a %a %s"
P2p_point.State.pp_digram
pi.state
P2p_point.Id.pp
p
P2p_peer.Id.pp
peer_id
(if pi.trusted then "â
" else " ")
| _ -> (
match pi.last_seen with
| Some (peer_id, ts) ->
cctxt#message
" %a %a (last seen: %a %a) %s"
P2p_point.State.pp_digram
pi.state
P2p_point.Id.pp
p
P2p_peer.Id.pp
peer_id
Time.System.pp_hum
ts
(if pi.trusted then "â
" else " ")
| None ->
cctxt#message
" %a %a %s"
P2p_point.State.pp_digram
pi.state
P2p_point.Id.pp
p
(if pi.trusted then "â
" else " ") ))
points
>>= fun () -> return_unit);
command
~group
~desc:"Connect to a new point."
no_options
(prefixes ["connect"; "address"] @@ addr_parameter @@ stop)
(fun () (address, port) (cctxt : #Client_context.full) ->
let timeout = Time.System.Span.of_seconds_exn 10. in
P2p_services.connect cctxt ~timeout (address, port)
>>= function
| Ok () ->
cctxt#message
"Connection to %a:%d established."
P2p_addr.pp
address
port
>>= fun () -> return_unit
| Error (Tezos_p2p.P2p_errors.Pending_connection :: _) ->
cctxt#warning "Already connecting to peer %a" P2p_addr.pp address
>>= fun () -> return_unit
| Error (Tezos_p2p.P2p_errors.Connected :: _) ->
cctxt#warning "Already connected to peer %a" P2p_addr.pp address
>>= fun () -> return_unit
| Error _ as e ->
Lwt.return e);
command
~group
~desc:"Kick a peer."
no_options
( prefixes ["kick"; "peer"]
@@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
@@ stop )
(fun () peer (cctxt : #Client_context.full) ->
P2p_services.Connections.kick cctxt peer
>>=? fun () ->
cctxt#message "Connection to %a interrupted." P2p_peer.Id.pp peer
>>= fun () -> return_unit);
command
~group
~desc:
"Add an IP address and all its ports to the blacklist and kicks it. \
Remove the address from the whitelist if it was previously in it."
no_options
(prefixes ["ban"; "address"] @@ addr_parameter @@ stop)
(fun () (address, _port) (cctxt : #Client_context.full) ->
P2p_services.Points.ban cctxt (address, 0)
>>=? fun () ->
cctxt#message "Address %a:* is now banned." P2p_addr.pp address
>>= fun () -> return_unit);
command
~group
~desc:"Remove an IP address and all its ports from the blacklist."
no_options
(prefixes ["unban"; "address"] @@ addr_parameter @@ stop)
(fun () (address, _port) (cctxt : #Client_context.full) ->
P2p_services.Points.unban cctxt (address, 0)
>>=? fun () ->
cctxt#message "Address %a:* is now unbanned." P2p_addr.pp address
>>= fun () -> return_unit);
command
~group
~desc:
"Add an IP address to the whitelist. Remove the address from the \
blacklist if it was previously in it."
no_options
(prefixes ["trust"; "address"] @@ addr_parameter @@ stop)
(fun () (address, port) (cctxt : #Client_context.full) ->
P2p_services.Points.trust cctxt (address, port)
>>=? fun () ->
cctxt#message "Address %a:%d is now trusted." P2p_addr.pp address port
>>= fun () -> return_unit);
command
~group
~desc:"Removes an IP address from the whitelist."
no_options
(prefixes ["untrust"; "address"] @@ addr_parameter @@ stop)
(fun () (address, port) (cctxt : #Client_context.full) ->
P2p_services.Points.untrust cctxt (address, port)
>>=? fun () ->
cctxt#message
"Address %a:%d is now untrusted."
P2p_addr.pp
address
port
>>= fun () -> return_unit);
command
~group
~desc:"Check if an IP address is banned."
no_options
(prefixes ["is"; "address"; "banned"] @@ addr_parameter @@ stop)
(fun () (address, port) (cctxt : #Client_context.full) ->
P2p_services.Points.banned cctxt (address, port)
>>=? fun banned ->
cctxt#message
"The given ip address is %s"
(if banned then "banned" else "not banned")
>>= fun () -> return_unit);
command
~group
~desc:"Check if a peer ID is banned."
no_options
( prefixes ["is"; "peer"; "banned"]
@@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
@@ stop )
(fun () peer (cctxt : #Client_context.full) ->
P2p_services.Peers.banned cctxt peer
>>=? fun banned ->
cctxt#message
"The given peer ID is %s"
(if banned then "banned" else "not banned")
>>= fun () -> return_unit);
command
~group
~desc:
"Add a peer ID to the blacklist and kicks it. Remove the peer ID from \
the blacklist if was previously in it."
no_options
( prefixes ["ban"; "peer"]
@@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
@@ stop )
(fun () peer (cctxt : #Client_context.full) ->
P2p_services.Peers.ban cctxt peer
>>=? fun () ->
cctxt#message "The peer %a is now banned." P2p_peer.Id.pp_short peer
>>= fun () -> return_unit);
command
~group
~desc:"Removes a peer ID from the blacklist."
no_options
( prefixes ["unban"; "peer"]
@@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
@@ stop )
(fun () peer (cctxt : #Client_context.full) ->
P2p_services.Peers.unban cctxt peer
>>=? fun () ->
cctxt#message "The peer %a is now unbanned." P2p_peer.Id.pp_short peer
>>= fun () -> return_unit);
command
~group
~desc:
"Add a peer ID to the whitelist. Remove the peer ID from the \
blacklist if it was previously in it."
no_options
( prefixes ["trust"; "peer"]
@@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
@@ stop )
(fun () peer (cctxt : #Client_context.full) ->
P2p_services.Peers.trust cctxt peer
>>=? fun () ->
cctxt#message "The peer %a is now trusted." P2p_peer.Id.pp_short peer
>>= fun () -> return_unit);
command
~group
~desc:"Remove a peer ID from the whitelist."
no_options
( prefixes ["untrust"; "peer"]
@@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
@@ stop )
(fun () peer (cctxt : #Client_context.full) ->
P2p_services.Peers.untrust cctxt peer
>>=? fun () ->
cctxt#message "The peer %a is now untrusted." P2p_peer.Id.pp_short peer
>>= fun () -> return_unit);
command
~group
~desc:"Clear all access control rules."
no_options
(prefixes ["clear"; "acls"] @@ stop)
(fun () (cctxt : #Client_context.full) ->
P2p_services.ACL.clear cctxt ()
>>=? fun () ->
cctxt#message "The access control rules are now cleared."
>>= fun () -> return_unit) ]
src/lib_client_commands/client_p2p_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "p2p" % string;
Clic.title :=
"Commands for monitoring and controlling p2p-layer state" % string |}.
Definition pp_connection_info {A : Type}
(ppf : Stdlib.Format.formatter)
(conn : Tezos_base__TzPervasives.P2p_connection.Info.t A) : unit :=
P2p_connection.Info.pp
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
tt) ppf conn.
Definition addr_parameter {F G I a b i o p q : Type}
: (Tezos_base__TzPervasives.Clic.params
((((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) ->
Tezos_base__TzPervasives.Clic.params
(Tezos_base__TzPervasives.P2p_point.Id.t ->
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) :=
param "address" % string
"<IPv4>:PORT or <IPV6>:PORT address (PORT defaults to 9732)." % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x => _return (P2p_point.Id.of_string_exn (Some 9732) x))).
Definition p2p_peer_id_param {A B : Type}
(name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
: Tezos_base__TzPervasives.Clic.params
(Tezos_base__TzPervasives.P2p_peer.Id.t -> A) B :=
Clic.param name desc
(Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun str => Lwt._return (P2p_peer.Id.of_b58check str))) t.
Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
(((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I)) :=
let 'tt := function_parameter in
cons
(command (Some group) "show global network status" % string no_options
(prefixes (cons "p2p" % string (cons "stat" % string [])) stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion (Shell_services.P2p.stat cctxt)
(fun stat =>
op_gtgteqquestion (Shell_services.P2p.Connections.list cctxt)
(fun conns =>
op_gtgteqquestion (Shell_services.P2p.Peers.list None cctxt)
(fun peers =>
op_gtgteqquestion
(Shell_services.P2p.Points.list None cctxt)
(fun points =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"GLOBAL STATS" % string
CamlinternalFormatBasics.End_of_format)
"GLOBAL STATS" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
" %a" % string) P2p_stat.pp stat)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"CONNECTIONS" % string
CamlinternalFormatBasics.End_of_format)
"CONNECTIONS" % string))
(fun function_parameter =>
let 'tt := function_parameter in
let '(incoming, outgoing) :=
List.partition
(fun c =>
P2p_connection.Info.incoming c)
conns in
op_gtgteq
(Lwt_list.iter_s
(fun conn =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
" %a" % string)
pp_connection_info conn) incoming)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_list.iter_s
(fun conn =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
" %a" % string)
pp_connection_info conn)
outgoing)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"KNOWN PEERS" % string
CamlinternalFormatBasics.End_of_format)
"KNOWN PEERS" % string))
(fun function_parameter =>
let 'tt := function_parameter
in
op_gtgteq
(Lwt_list.iter_s
(fun function_parameter =>
let '(p, pi) :=
function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Float
CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision
0)
(CamlinternalFormatBasics.Char_literal
" " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" " %
char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" "
%
char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))))))))
" %a %.0f %a %a %s"
% string)
P2p_peer.State.pp_digram
(P2p_peer.Info.state
pi) (score pi)
P2p_peer.Id.pp p
P2p_stat.pp (stat pi)
(if trusted pi then
"★" % string
else
" " % string)) peers)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"KNOWN POINTS" %
string
CamlinternalFormatBasics.End_of_format)
"KNOWN POINTS" %
string))
(fun function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(Lwt_list.iter_s
(fun
function_parameter
=>
let '(p, pi) :=
function_parameter
in
match
P2p_point.Info.state
pi with
|
Tezos_base__P2p_point.State.Running
peer_id =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" "
%
char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" "
%
char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))))))
" %a %a %a %s"
% string)
P2p_point.State.pp_digram
(state pi)
P2p_point.Id.pp
p
P2p_peer.Id.pp
peer_id
(if
trusted pi
then
"★" %
string
else
" " %
string)
| _ =>
match
last_seen pi
with
|
Some
(peer_id,
ts) =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (last seen: "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" "
%
char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
") "
%
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))))))))
" %a %a (last seen: %a %a) %s"
%
string)
P2p_point.State.pp_digram
(state pi)
P2p_point.Id.pp
p
P2p_peer.Id.pp
peer_id
Time.System.pp_hum
ts
(if
trusted
pi
then
"★" %
string
else
" " %
string)
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" "
%
char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))))
" %a %a %s"
%
string)
P2p_point.State.pp_digram
(state pi)
P2p_point.Id.pp
p
(if
trusted
pi
then
"★" %
string
else
" " %
string)
end
end) points)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
return_unit)))))))))))))))
(cons
(command (Some group) "Connect to a new point." % string no_options
(apply (prefixes (cons "connect" % string (cons "address" % string [])))
(apply addr_parameter stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(address, port) := function_parameter in
fun cctxt =>
let timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 10. is approximated by the integer 10 *)
10 in
op_gtgteq (P2p_services.connect cctxt timeout (address, port))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Connection to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" established." % string
CamlinternalFormatBasics.End_of_format)))))
"Connection to %a:%d established." % string)
P2p_addr.pp address port)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
|
Stdlib.Error
(cons Tezos_base__TzPervasives.Pending_connection _) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Already connecting to peer " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Already connecting to peer %a" % string) P2p_addr.pp
address)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error (cons Tezos_base__TzPervasives.Connected _) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Already connected to peer " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Already connected to peer %a" % string) P2p_addr.pp
address)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| (Stdlib.Error _) as e => Lwt._return e
end)))
(cons
(command (Some group) "Kick a peer." % string no_options
(apply (prefixes (cons "kick" % string (cons "peer" % string [])))
(apply
(p2p_peer_id_param "peer" % string
"peer network identity" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun peer =>
fun cctxt =>
op_gtgteqquestion
(P2p_services.Connections.kick cctxt None peer)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Connection to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" interrupted." % string
CamlinternalFormatBasics.End_of_format)))
"Connection to %a interrupted." % string)
P2p_peer.Id.pp peer)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Add an IP address and all its ports to the blacklist and kicks it. Remove the address from the whitelist if it was previously in it."
% string no_options
(apply (prefixes (cons "ban" % string (cons "address" % string [])))
(apply addr_parameter stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(address, _port) := function_parameter in
fun cctxt =>
op_gtgteqquestion (P2p_services.Points.ban cctxt (address, 0))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Address " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
":* is now banned." % string
CamlinternalFormatBasics.End_of_format)))
"Address %a:* is now banned." % string) P2p_addr.pp
address)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Remove an IP address and all its ports from the blacklist." %
string no_options
(apply
(prefixes (cons "unban" % string (cons "address" % string [])))
(apply addr_parameter stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(address, _port) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(P2p_services.Points.unban cctxt (address, 0))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Address " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
":* is now unbanned." % string
CamlinternalFormatBasics.End_of_format)))
"Address %a:* is now unbanned." % string)
P2p_addr.pp address)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Add an IP address to the whitelist. Remove the address from the blacklist if it was previously in it."
% string no_options
(apply
(prefixes (cons "trust" % string (cons "address" % string [])))
(apply addr_parameter stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(address, port) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(P2p_services.Points.trust cctxt (address, port))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Address " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
":" % char
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" is now trusted." % string
CamlinternalFormatBasics.End_of_format)))))
"Address %a:%d is now trusted." % string)
P2p_addr.pp address port)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Removes an IP address from the whitelist." % string
no_options
(apply
(prefixes
(cons "untrust" % string (cons "address" % string [])))
(apply addr_parameter stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(address, port) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(P2p_services.Points.untrust cctxt (address, port))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Address " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
":" % char
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" is now untrusted." % string
CamlinternalFormatBasics.End_of_format)))))
"Address %a:%d is now untrusted." % string)
P2p_addr.pp address port)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Check if an IP address is banned." % string no_options
(apply
(prefixes
(cons "is" % string
(cons "address" % string (cons "banned" % string []))))
(apply addr_parameter stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(address, port) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(P2p_services.Points.banned cctxt (address, port))
(fun banned =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The given ip address is " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"The given ip address is %s" % string)
(if banned then
"banned" % string
else
"not banned" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Check if a peer ID is banned." % string no_options
(apply
(prefixes
(cons "is" % string
(cons "peer" % string (cons "banned" % string []))))
(apply
(p2p_peer_id_param "peer" % string
"peer network identity" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun peer =>
fun cctxt =>
op_gtgteqquestion
(P2p_services.Peers.banned cctxt peer)
(fun banned =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The given peer ID is " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"The given peer ID is %s" % string)
(if banned then
"banned" % string
else
"not banned" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Add a peer ID to the blacklist and kicks it. Remove the peer ID from the blacklist if was previously in it."
% string no_options
(apply
(prefixes
(cons "ban" % string (cons "peer" % string [])))
(apply
(p2p_peer_id_param "peer" % string
"peer network identity" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun peer =>
fun cctxt =>
op_gtgteqquestion
(P2p_services.Peers.ban cctxt peer)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is now banned." % string
CamlinternalFormatBasics.End_of_format)))
"The peer %a is now banned." % string)
P2p_peer.Id.pp_short peer)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Removes a peer ID from the blacklist." % string
no_options
(apply
(prefixes
(cons "unban" % string (cons "peer" % string [])))
(apply
(p2p_peer_id_param "peer" % string
"peer network identity" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun peer =>
fun cctxt =>
op_gtgteqquestion
(P2p_services.Peers.unban cctxt peer)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is now unbanned." % string
CamlinternalFormatBasics.End_of_format)))
"The peer %a is now unbanned." %
string) P2p_peer.Id.pp_short peer)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Add a peer ID to the whitelist. Remove the peer ID from the blacklist if it was previously in it."
% string no_options
(apply
(prefixes
(cons "trust" % string (cons "peer" % string [])))
(apply
(p2p_peer_id_param "peer" % string
"peer network identity" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun peer =>
fun cctxt =>
op_gtgteqquestion
(P2p_services.Peers.trust cctxt peer)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is now trusted." % string
CamlinternalFormatBasics.End_of_format)))
"The peer %a is now trusted." %
string) P2p_peer.Id.pp_short peer)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Remove a peer ID from the whitelist." % string
no_options
(apply
(prefixes
(cons "untrust" % string
(cons "peer" % string [])))
(apply
(p2p_peer_id_param "peer" % string
"peer network identity" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun peer =>
fun cctxt =>
op_gtgteqquestion
(P2p_services.Peers.untrust cctxt peer)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is now untrusted." %
string
CamlinternalFormatBasics.End_of_format)))
"The peer %a is now untrusted." %
string) P2p_peer.Id.pp_short
peer)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Clear all access control rules." % string
no_options
(apply
(prefixes
(cons "clear" % string
(cons "acls" % string []))) stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion
(P2p_services.ACL.clear cctxt tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The access control rules are now cleared."
% string
CamlinternalFormatBasics.End_of_format)
"The access control rules are now cleared."
% string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))) []))))))))))))).
src/lib_client_commands/client_report_commands.ml 8 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Commands used to introspect the node's state *)
let print_invalid_blocks ppf (b : Shell_services.Chain.invalid_block) =
Format.fprintf
ppf
"@[<v 2>Hash: %a@ Level: %ld@ %a@]"
Block_hash.pp
b.hash
b.level
pp_print_error
b.errors
let commands () =
let open Clic in
let group =
{name = "report"; title = "Commands to report the node's status"}
in
let output_arg =
default_arg
~doc:"write to a file"
~long:"output"
~short:'o'
~placeholder:"path"
~default:"-"
(parameter (fun _ ->
function
| "-" ->
return Format.std_formatter
| file ->
let ppf = Format.formatter_of_out_channel (open_out file) in
ignore Clic.(setup_formatter ppf Plain Full) ;
return ppf))
in
[ command
~group
~desc:"The last heads that have been considered by the node."
(args1 output_arg)
(fixed ["list"; "heads"])
(fun ppf cctxt ->
Shell_services.Blocks.list cctxt ()
>>=? fun heads ->
Format.fprintf
ppf
"@[<v>%a@]@."
(Format.pp_print_list Block_hash.pp)
(List.concat heads) ;
return_unit);
command
~group
~desc:"The blocks that have been marked invalid by the node."
(args1 output_arg)
(fixed ["list"; "rejected"; "blocks"])
(fun ppf cctxt ->
Shell_services.Invalid_blocks.list cctxt ()
>>=? function
| [] ->
Format.fprintf ppf "No invalid blocks.@." ;
return_unit
| _ :: _ as invalid ->
Format.fprintf
ppf
"@[<v>%a@]@."
(Format.pp_print_list print_invalid_blocks)
invalid ;
return_unit) ]
src/lib_client_commands/client_report_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition print_invalid_blocks
(ppf : Stdlib.Format.formatter)
(b : Tezos_shell_services.Shell_services.Chain.invalid_block) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Hash: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "Level: " % string
(CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[<v 2>Hash: %a@ Level: %ld@ %a@]" % string) Block_hash.pp (hash b)
(level b) pp_print_error (errors b).
Definition commands {E F i o p q : Type} (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
(((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)) :=
let 'tt := function_parameter in
let group :=
{| name := "report" % string;
title := "Commands to report the node's status" % string |} in
let output_arg :=
default_arg "write to a file" % string (Some "o" % char) "output" % string
"path" % string "-" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
match function_parameter with
| "-" % string => _return Format.std_formatter
| file =>
let ppf := Format.formatter_of_out_channel (Stdlib.open_out file)
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.ignore
(setup_formatter ppf Tezos_base__TzPervasives.Clic.Plain
Tezos_base__TzPervasives.Clic.Full) in
_return ppf
end)) in
cons
(command (Some group)
"The last heads that have been considered by the node." % string
(args1 output_arg)
(fixed (cons "list" % string (cons "heads" % string [])))
(fun ppf =>
fun cctxt =>
op_gtgteqquestion
(Shell_services.Blocks.list cctxt None None None None tt)
(fun heads =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v>" % string
CamlinternalFormatBasics.End_of_format)
"<v>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"@[<v>%a@]@." % string)
(Format.pp_print_list None Block_hash.pp) (List.concat heads)
in
return_unit)))
(cons
(command (Some group)
"The blocks that have been marked invalid by the node." % string
(args1 output_arg)
(fixed
(cons "list" % string
(cons "rejected" % string (cons "blocks" % string []))))
(fun ppf =>
fun cctxt =>
op_gtgteqquestion (Shell_services.Invalid_blocks.list cctxt None tt)
(fun function_parameter =>
match function_parameter with
| [] =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No invalid blocks." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))
"No invalid blocks.@." % string) in
return_unit
| (cons _ _) as invalid =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v>" % string
CamlinternalFormatBasics.End_of_format)
"<v>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"@[<v>%a@]@." % string)
(Format.pp_print_list None print_invalid_blocks) invalid
in
return_unit
end))) []).
src/lib_crypto/blake2B.ml 8 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
(*-- Type specific Hash builder ---------------------------------------------*)
module type Name = sig
val name : string
val title : string
val size : int option
end
module type PrefixedName = sig
include Name
val b58check_prefix : string
end
module Make_minimal (K : Name) = struct
open Blake2
type t = Blake2b.hash
include K
let size = match K.size with None -> 32 | Some x -> x
let of_string_opt s =
if String.length s <> size then None
else Some (Blake2b.Hash (Bytes.of_string s))
let of_string s =
match of_string_opt s with
| None ->
generic_error
"%s.of_string: wrong string size (%d)"
K.name
(String.length s)
| Some h ->
Ok h
let of_string_exn s =
match of_string_opt s with
| None ->
Format.kasprintf
invalid_arg
"%s.of_string: wrong string size (%d)"
K.name
(String.length s)
| Some h ->
h
let to_string (Blake2b.Hash h) = Bytes.to_string h
let of_hex s = of_string (Hex.to_string s)
let of_hex_opt s = of_string_opt (Hex.to_string s)
let of_hex_exn s = of_string_exn (Hex.to_string s)
let to_hex s = Hex.of_string (to_string s)
let pp ppf h =
let (`Hex h) = to_hex h in
Format.pp_print_string ppf h
let pp_short ppf h =
let (`Hex h) = to_hex h in
Format.pp_print_string ppf (String.sub h 0 8)
let of_bytes_opt b =
if Bytes.length b <> size then None else Some (Blake2b.Hash b)
let of_bytes_exn b =
match of_bytes_opt b with
| None ->
let msg =
Printf.sprintf
"%s.of_bytes: wrong string size (%d)"
K.name
(Bytes.length b)
in
raise (Invalid_argument msg)
| Some h ->
h
let of_bytes s =
match of_bytes_opt s with
| Some x ->
Ok x
| None ->
generic_error "Failed to deserialize a hash (%s)" K.name
let to_bytes (Blake2b.Hash h) = h
let hash_bytes ?key l =
let state = Blake2b.init ?key size in
List.iter (fun b -> Blake2b.update state b) l ;
Blake2b.final state
let hash_string ?key l =
let key = Option.map ~f:Bytes.of_string key in
let state = Blake2b.init ?key size in
List.iter (fun s -> Blake2b.update state (Bytes.of_string s)) l ;
Blake2b.final state
let path_length = 6
(** Converts [key] to hex thus doubling its size then splits it into a list of
length [path_length] where each element is one byte, or two characters,
except the last one which contains the rest. *)
let to_path key l =
let (`Hex key) = to_hex key in
String.sub key 0 2 :: String.sub key 2 2 :: String.sub key 4 2
:: String.sub key 6 2 :: String.sub key 8 2
:: String.sub key 10 ((size * 2) - 10)
:: l
let of_path path =
let path = String.concat "" path in
of_hex_opt (`Hex path)
let of_path_exn path =
let path = String.concat "" path in
of_hex_exn (`Hex path)
let prefix_path p =
let (`Hex p) = Hex.of_string p in
let len = String.length p in
let p1 = if len >= 2 then String.sub p 0 2 else ""
and p2 = if len >= 4 then String.sub p 2 2 else ""
and p3 = if len >= 6 then String.sub p 4 2 else ""
and p4 = if len >= 8 then String.sub p 6 2 else ""
and p5 = if len >= 10 then String.sub p 8 2 else ""
and p6 =
if len > 10 then String.sub p 10 (min (len - 10) ((size * 2) - 10))
else ""
in
[p1; p2; p3; p4; p5; p6]
let zero = of_hex_exn (`Hex (String.make (size * 2) '0'))
include Compare.Make (struct
type nonrec t = t
let compare (Blake2b.Hash h1) (Blake2b.Hash h2) = Bytes.compare h1 h2
end)
end
module Make (R : sig
val register_encoding :
prefix:string ->
length:int ->
to_raw:('a -> string) ->
of_raw:(string -> 'a option) ->
wrap:('a -> Base58.data) ->
'a Base58.encoding
end)
(K : PrefixedName) =
struct
include Make_minimal (K)
(* Serializers *)
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let hash =
if Compare.Int.(size >= 8) then fun h ->
Int64.to_int (TzEndian.get_int64 (to_bytes h) 0)
else if Compare.Int.(size >= 4) then fun h ->
Int32.to_int (TzEndian.get_int32 (to_bytes h) 0)
else fun h ->
let r = ref 0 in
let h = to_bytes h in
for i = 0 to size - 1 do
r := TzEndian.get_uint8 h i + (8 * !r)
done ;
!r
type Base58.data += Data of t
let b58check_encoding =
R.register_encoding
~prefix:K.b58check_prefix
~length:size
~wrap:(fun s -> Data s)
~of_raw:of_string_opt
~to_raw:to_string
include Helpers.Make (struct
type nonrec t = t
let title = title
let name = name
let b58check_encoding = b58check_encoding
let raw_encoding = raw_encoding
let compare = compare
let equal = equal
let hash = hash
end)
end
module Generic_Merkle_tree (H : sig
type t
type elt
val empty : t
val leaf : elt -> t
val node : t -> t -> t
end) =
struct
let rec step a n =
let m = (n + 1) / 2 in
for i = 0 to m - 1 do
a.(i) <- H.node a.(2 * i) a.((2 * i) + 1)
done ;
a.(m) <- H.node a.(n) a.(n) ;
if m = 1 then a.(0)
else if m mod 2 = 0 then step a m
else (
a.(m + 1) <- a.(m) ;
step a (m + 1) )
let empty = H.empty
let compute xs =
match xs with
| [] ->
H.empty
| [x] ->
H.leaf x
| _ :: _ :: _ ->
let last = TzList.last_exn xs in
let n = List.length xs in
let a = Array.make (n + 1) (H.leaf last) in
List.iteri (fun i x -> a.(i) <- H.leaf x) xs ;
step a n
type path = Left of path * H.t | Right of H.t * path | Op
let rec step_path a n p j =
let m = (n + 1) / 2 in
let p =
if j mod 2 = 0 then Left (p, a.(j + 1)) else Right (a.(j - 1), p)
in
for i = 0 to m - 1 do
a.(i) <- H.node a.(2 * i) a.((2 * i) + 1)
done ;
a.(m) <- H.node a.(n) a.(n) ;
if m = 1 then p
else if m mod 2 = 0 then step_path a m p (j / 2)
else (
a.(m + 1) <- a.(m) ;
step_path a (m + 1) p (j / 2) )
let compute_path xs i =
match xs with
| [] ->
invalid_arg "compute_path"
| [_] ->
Op
| _ :: _ :: _ ->
let last = TzList.last_exn xs in
let n = List.length xs in
if i < 0 || n <= i then invalid_arg "compute_path" ;
let a = Array.make (n + 1) (H.leaf last) in
List.iteri (fun i x -> a.(i) <- H.leaf x) xs ;
step_path a n Op i
let rec check_path p h =
match p with
| Op ->
(H.leaf h, 1, 0)
| Left (p, r) ->
let (l, s, pos) = check_path p h in
(H.node l r, s * 2, pos)
| Right (l, p) ->
let (r, s, pos) = check_path p h in
(H.node l r, s * 2, pos + s)
let check_path p h =
let (h, _, pos) = check_path p h in
(h, pos)
end
let rec log2 x = if x <= 1 then 0 else 1 + log2 ((x + 1) / 2)
module Make_merkle_tree (R : sig
val register_encoding :
prefix:string ->
length:int ->
to_raw:('a -> string) ->
of_raw:(string -> 'a option) ->
wrap:('a -> Base58.data) ->
'a Base58.encoding
end)
(K : PrefixedName) (Contents : sig
type t
val to_bytes : t -> Bytes.t
end) =
struct
include Make (R) (K)
type elt = Contents.t
let elt_bytes = Contents.to_bytes
let empty = hash_bytes []
include Generic_Merkle_tree (struct
type nonrec t = t
type nonrec elt = elt
let empty = empty
let leaf x = hash_bytes [Contents.to_bytes x]
let node x y = hash_bytes [to_bytes x; to_bytes y]
end)
let path_encoding =
let open Data_encoding in
mu "path" (fun path_encoding ->
union
[ case
(Tag 240)
~title:"Left"
(obj2 (req "path" path_encoding) (req "right" encoding))
(function Left (p, r) -> Some (p, r) | _ -> None)
(fun (p, r) -> Left (p, r));
case
(Tag 15)
~title:"Right"
(obj2 (req "left" encoding) (req "path" path_encoding))
(function Right (r, p) -> Some (r, p) | _ -> None)
(fun (r, p) -> Right (r, p));
case
(Tag 0)
~title:"Op"
unit
(function Op -> Some () | _ -> None)
(fun () -> Op) ])
let bounded_path_encoding ?max_length () =
match max_length with
| None ->
path_encoding
| Some max_length ->
let max_depth = log2 max_length in
Data_encoding.check_size ((max_depth * (size + 1)) + 1) path_encoding
end
include Make_minimal (struct
let name = "Generic_hash"
let title = ""
let size = None
end)
let pp ppf h =
let (`Hex h) = to_hex h in
Format.pp_print_string ppf h
let pp_short ppf h =
let (`Hex h) = to_hex h in
Format.pp_print_string ppf (String.sub h 0 8)
src/lib_crypto/blake2B.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Module Name.
Record signature := {
name : string;
title : string;
size : option Z;
}.
End Name.
Module PrefixedName.
Record signature := {
include;
b58check_prefix : string;
}.
End PrefixedName.
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
Fixpoint log2 (x : Z) : Z :=
if OCaml.Stdlib.le x 1 then
0
else
Z.add 1 (log2 (Z.div (Z.add x 1) 2)).
(* ❌ Functors are not handled. *)
functor
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (h : Blake2.Blake2b.hash)
: unit :=
let 'Hex h := to_hex h in
Format.pp_print_string ppf h.
Definition pp_short (ppf : Stdlib.Format.formatter) (h : Blake2.Blake2b.hash)
: unit :=
let 'Hex h := to_hex h in
Format.pp_print_string ppf (Stdlib.String.sub h 0 8).
src/lib_crypto/block_hash.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Blake2B.Make
(Base58)
(struct
let name = "block_hash"
let title = "A block identifier"
let b58check_prefix = Base58.Prefix.block_hash
let size = None
end)
module Logging = struct
let tag = Tag.def ~doc:"Block Hash" "block_hash" pp_short
let predecessor_tag =
Tag.def ~doc:"Block Predecessor Hash" "predecessor_hash" pp_short
end
let () = Base58.check_encoded_prefix b58check_encoding "B" 51
src/lib_crypto/block_hash.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Module Logging.
Definition tag : Tezos_stdlib.Tag.def t :=
Tag.def (Some "Block Hash" % string) "block_hash" % string pp_short.
Definition predecessor_tag : Tezos_stdlib.Tag.def t :=
Tag.def (Some "Block Predecessor Hash" % string) "predecessor_hash" % string
pp_short.
End Logging.
src/lib_crypto/chain_id.ml 10 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
type t = string
let name = "Chain_id"
let title = "Network identifier"
let extract bh = Bytes.sub_string (Block_hash.to_bytes bh) 0 4
let hash_bytes ?key l = extract (Block_hash.hash_bytes ?key l)
let hash_string ?key l = extract (Block_hash.hash_string ?key l)
let size = 4
let of_string_opt s = if String.length s <> size then None else Some s
let of_string s =
match of_string_opt s with
| None ->
generic_error
"%s.of_string: wrong string size (%d)"
name
(String.length s)
| Some h ->
Ok h
let of_string_exn s =
match of_string_opt s with
| None ->
Format.kasprintf
invalid_arg
"%s.of_string_exn: wrong string size (%d)"
name
(String.length s)
| Some h ->
h
let to_string s = s
let of_hex s = of_string (Hex.to_string s)
let of_hex_opt s = of_string_opt (Hex.to_string s)
let of_hex_exn s = of_string_exn (Hex.to_string s)
let to_hex s = Hex.of_string (to_string s)
let of_bytes_opt b =
if Bytes.length b <> size then None else Some (Bytes.to_string b)
let of_bytes_exn b =
match of_bytes_opt b with
| None ->
let msg =
Printf.sprintf
"%s.of_bytes: wrong string size (%d)"
name
(Bytes.length b)
in
raise (Invalid_argument msg)
| Some h ->
h
let of_bytes s =
match of_bytes_opt s with
| Some x ->
Ok x
| None ->
generic_error "Failed to deserialize a hash (%s)" name
let to_bytes = Bytes.of_string
let path_length = 1
let to_path key l =
let (`Hex h) = to_hex key in
h :: l
let of_path path =
let path = String.concat "" path in
of_hex_opt (`Hex path)
let of_path_exn path =
let path = String.concat "" path in
of_hex_exn (`Hex path)
let prefix_path p =
let (`Hex p) = Hex.of_string p in
[p]
let zero = of_hex_exn (`Hex (String.make (size * 2) '0'))
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.chain_id
~length:size
~wrap:(fun s -> Data s)
~of_raw:of_string_opt
~to_raw:to_string
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let hash h = Int32.to_int (TzEndian.get_int32 (to_bytes h) 0)
let of_block_hash bh = hash_bytes [Block_hash.to_bytes bh]
include Compare.Make (struct
type nonrec t = t
let compare = String.compare
end)
include Helpers.Make (struct
type nonrec t = t
let title = title
let name = name
let b58check_encoding = b58check_encoding
let raw_encoding = raw_encoding
let compare = compare
let equal = equal
let hash = hash
end)
src/lib_crypto/chain_id.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Definition t := string.
Definition name : string := "Chain_id" % string.
Definition title : string := "Network identifier" % string.
Definition extract (bh : Tezos_crypto.Block_hash.t) : string :=
Stdlib.Bytes.sub_string (Block_hash.to_bytes bh) 0 4.
Definition hash_bytes (key : option Stdlib.Bytes.t) (l : list Stdlib.Bytes.t)
: string := extract (Block_hash.hash_bytes key l).
Definition hash_string (key : option string) (l : list string) : string :=
extract (Block_hash.hash_string key l).
Definition size : Z := 4.
Definition of_string_opt (s : string) : option string :=
if nequiv_decb (OCaml.String.length s) size then
None
else
Some s.
Definition of_string (s : string)
: Tezos_error_monad.Error_monad.tzresult string :=
match of_string_opt s with
| None =>
generic_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
".of_string: wrong string size (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))
"%s.of_string: wrong string size (%d)" % string) name
(OCaml.String.length s)
| Some h => Stdlib.Ok h
end.
Definition of_string_exn (s : string) : string :=
match of_string_opt s with
| None =>
Format.kasprintf OCaml.Stdlib.invalid_arg
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
".of_string_exn: wrong string size (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))
"%s.of_string_exn: wrong string size (%d)" % string) name
(OCaml.String.length s)
| Some h => h
end.
Definition to_string {A : Type} (s : A) : A := s.
Definition of_hex (s : Hex.t) : Tezos_error_monad.Error_monad.tzresult string :=
of_string (Hex.to_string s).
Definition of_hex_opt (s : Hex.t) : option string :=
of_string_opt (Hex.to_string s).
Definition of_hex_exn (s : Hex.t) : string := of_string_exn (Hex.to_string s).
Definition to_hex (s : string) : Hex.t := Hex.of_string None (to_string s).
Definition of_bytes_opt (b : string) : option string :=
if nequiv_decb (String.length b) size then
None
else
Some (Stdlib.Bytes.to_string b).
Definition of_bytes_exn (b : string) : string :=
match of_bytes_opt b with
| None =>
let msg :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
".of_bytes: wrong string size (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))
"%s.of_bytes: wrong string size (%d)" % string) name (String.length b)
in
Stdlib.raise (OCaml.Invalid_argument msg)
| Some h => h
end.
Definition of_bytes (s : string)
: sum string Tezos_error_monad.Error_monad.trace :=
match of_bytes_opt s with
| Some x => Stdlib.Ok x
| None =>
generic_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to deserialize a hash (" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"Failed to deserialize a hash (%s)" % string) name
end.
Definition to_bytes : string -> string := Stdlib.Bytes.of_string.
Definition path_length : Z := 1.
Definition to_path (key : string) (l : list string) : list string :=
let 'Hex h := to_hex key in
cons h l.
Definition of_path (path : list string) : option string :=
let path := Stdlib.String.concat "" % string path in
of_hex_opt
(* ❌ Variants not supported *)
variant.
Definition of_path_exn (path : list string) : string :=
let path := Stdlib.String.concat "" % string path in
of_hex_exn
(* ❌ Variants not supported *)
variant.
Definition prefix_path (p : string) : list string :=
let 'Hex p := Hex.of_string None p in
cons p [].
Definition zero : string :=
of_hex_exn
(* ❌ Variants not supported *)
variant.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
Base58.register_encoding Base58.Prefix.chain_id size to_string of_string_opt
(fun s => Tezos_crypto.Base58.Data s).
Definition raw_encoding : Tezos_data_encoding.Data_encoding.encoding string :=
conv to_bytes of_bytes_exn None (Fixed.bytes size).
Definition hash (h : string) : Z :=
Int32.to_int (TzEndian.get_int32 (to_bytes h) 0).
Definition of_block_hash (bh : Tezos_crypto.Block_hash.t) : string :=
hash_bytes None (cons (Block_hash.to_bytes bh) []).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
src/lib_crypto/context_hash.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Blake2B.Make
(Base58)
(struct
let name = "Context_hash"
let title = "A hash of context"
let b58check_prefix = Base58.Prefix.context_hash
let size = None
end)
let () = Base58.check_encoded_prefix b58check_encoding "Co" 52
src/lib_crypto/context_hash.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/lib_crypto/crypto_box.ml 15 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Tezos - X25519/XSalsa20-Poly1305 cryptography *)
open Hacl
type secret_key = secret Box.key
type public_key = public Box.key
type channel_key = Box.combined Box.key
type nonce = Bigstring.t
type target = Z.t
module Secretbox = struct
include Secretbox
let box_noalloc key nonce msg = box ~key ~nonce ~msg ~cmsg:msg
let box_open_noalloc key nonce cmsg = box_open ~key ~nonce ~cmsg ~msg:cmsg
let box key msg nonce =
let msglen = Bytes.length msg in
let cmsg = Bigstring.make (msglen + zerobytes) '\x00' in
Bigstring.blit_of_bytes msg 0 cmsg zerobytes msglen ;
box ~key ~nonce ~msg:cmsg ~cmsg ;
Bigstring.sub cmsg boxzerobytes (msglen + zerobytes - boxzerobytes)
let box_open key cmsg nonce =
let cmsglen = Bigstring.length cmsg in
let msg = Bigstring.make (cmsglen + boxzerobytes) '\x00' in
Bigstring.blit cmsg 0 msg boxzerobytes cmsglen ;
match box_open ~key ~nonce ~cmsg:msg ~msg with
| false ->
None
| true ->
Some (Bigstring.sub_bytes msg zerobytes (cmsglen - boxzerobytes))
end
module Public_key_hash =
Blake2B.Make
(Base58)
(struct
let name = "Crypto_box.Public_key_hash"
let title = "A Cryptobox public key ID"
let b58check_prefix = Base58.Prefix.cryptobox_public_key_hash
let size = Some 16
end)
let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "id" 30
let hash pk =
Public_key_hash.hash_bytes [Bigstring.to_bytes (Box.unsafe_to_bytes pk)]
let zerobytes = Box.zerobytes
let boxzerobytes = Box.boxzerobytes
let random_keypair () =
let (pk, sk) = Box.keypair () in
(sk, pk, hash pk)
let zero_nonce = Bigstring.make Nonce.bytes '\x00'
let random_nonce = Nonce.gen
let increment_nonce = Nonce.increment
let generate_nonce bytes_list =
let hash = Blake2B.hash_bytes bytes_list in
let s = Bigstring.of_bytes (Blake2B.to_bytes hash) in
Nonce.of_bytes_exn @@ Bigstring.sub s 0 Nonce.bytes
let init_to_resp_seed = Bytes.of_string "Init -> Resp"
let resp_to_init_seed = Bytes.of_string "Resp -> Init"
let generate_nonces ~incoming ~sent_msg ~recv_msg =
let ((init_msg, resp_msg, false) | (resp_msg, init_msg, true)) =
(sent_msg, recv_msg, incoming)
in
let nonce_init_to_resp =
generate_nonce [init_msg; resp_msg; init_to_resp_seed]
in
let nonce_resp_to_init =
generate_nonce [init_msg; resp_msg; resp_to_init_seed]
in
if incoming then (nonce_init_to_resp, nonce_resp_to_init)
else (nonce_resp_to_init, nonce_init_to_resp)
let precompute sk pk = Box.dh pk sk
let fast_box_noalloc k nonce bmsg =
let msg = Bigstring.of_bytes bmsg in
Box.box ~k ~nonce ~msg ~cmsg:msg ;
Bigstring.blit_to_bytes msg 0 bmsg 0 (Bytes.length bmsg)
let fast_box_open_noalloc k nonce bcmsg =
let cmsg = Bigstring.of_bytes bcmsg in
if Box.box_open ~k ~nonce ~cmsg ~msg:cmsg then (
Bigstring.blit_to_bytes cmsg 0 bcmsg 0 (Bytes.length bcmsg) ;
true )
else false
let fast_box k msg nonce =
let msglen = Bigstring.length msg in
let cmsg = Bigstring.make (msglen + zerobytes) '\x00' in
Bigstring.blit msg 0 cmsg zerobytes msglen ;
Box.box ~k ~nonce ~msg:cmsg ~cmsg ;
cmsg
let fast_box_open k cmsg nonce =
let cmsglen = Bigstring.length cmsg in
let msg = Bigstring.make cmsglen '\x00' in
match Box.box_open ~k ~nonce ~cmsg ~msg with
| false ->
None
| true ->
Some (Bigstring.sub msg zerobytes (cmsglen - zerobytes))
let compare_target hash target =
let hash = Z.of_bits (Blake2B.to_string hash) in
Z.compare hash target <= 0
let make_target f =
if f < 0. || 256. < f then invalid_arg "Cryptobox.target_of_float" ;
let (frac, shift) = modf f in
let shift = int_of_float shift in
let m =
Z.of_int64
@@
if frac = 0. then Int64.(pred (shift_left 1L 54))
else Int64.of_float (2. ** (54. -. frac))
in
if shift < 202 then
Z.logor
(Z.shift_left m (202 - shift))
(Z.pred @@ Z.shift_left Z.one (202 - shift))
else Z.shift_right m (shift - 202)
let default_target = make_target 24.
let check_proof_of_work pk nonce target =
let hash =
Blake2B.hash_bytes
[Bigstring.to_bytes (Box.unsafe_to_bytes pk); Bigstring.to_bytes nonce]
in
compare_target hash target
let generate_proof_of_work ?max pk target =
let may_interupt =
match max with
| None ->
fun _ -> ()
| Some max ->
fun cpt -> if max < cpt then raise Not_found
in
let rec loop nonce cpt =
may_interupt cpt ;
if check_proof_of_work pk nonce target then nonce
else loop (Nonce.increment nonce) (cpt + 1)
in
loop (random_nonce ()) 0
let public_key_to_bytes pk = Bigstring.to_bytes (Box.unsafe_to_bytes pk)
let public_key_of_bytes buf = Box.unsafe_pk_of_bytes (Bigstring.of_bytes buf)
let public_key_size = Box.pkbytes
let secret_key_to_bytes sk = Bigstring.to_bytes (Box.unsafe_to_bytes sk)
let secret_key_of_bytes buf = Box.unsafe_sk_of_bytes (Bigstring.of_bytes buf)
let secret_key_size = Box.skbytes
let nonce_size = Nonce.bytes
let public_key_encoding =
let open Data_encoding in
conv public_key_to_bytes public_key_of_bytes (Fixed.bytes public_key_size)
let secret_key_encoding =
let open Data_encoding in
conv secret_key_to_bytes secret_key_of_bytes (Fixed.bytes secret_key_size)
let nonce_encoding =
let open Data_encoding in
conv Bigstring.to_bytes Bigstring.of_bytes (Fixed.bytes nonce_size)
let neuterize : secret_key -> public_key = Box.neuterize
let equal : public_key -> public_key -> bool = Box.equal
let pp_pk ppf pk = Hex.pp ppf (Hex.of_bytes (public_key_to_bytes pk))
src/lib_crypto/crypto_box.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Hacl.
Definition secret_key := Hacl.Box.key Hacl.secret.
Definition public_key := Hacl.Box.key Hacl.public.
Definition channel_key := Hacl.Box.key Hacl.Box.combined.
Definition nonce := Bigstring.t.
Definition target := Z.t.
Module Secretbox.
(* ❌ Structure item `include` not handled. *)
include
Definition box_noalloc (key : key) (nonce : Bigstring.t) (msg : Bigstring.t)
: unit := box key nonce msg msg.
Definition box_open_noalloc
(key : key) (nonce : Bigstring.t) (cmsg : Bigstring.t) : bool :=
box_open key nonce cmsg cmsg.
Definition box (key : key) (msg : Stdlib.Bytes.t) (nonce : Bigstring.t)
: Bigstring.t :=
let msglen := String.length msg in
let cmsg := Bigstring.make (Z.add msglen zerobytes) "000" % char in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit_of_bytes msg 0 cmsg zerobytes msglen in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := box key nonce cmsg cmsg in
Bigstring.sub cmsg boxzerobytes
(Z.sub (Z.add msglen zerobytes) boxzerobytes).
Definition box_open (key : key) (cmsg : Bigstring.t) (nonce : Bigstring.t)
: option Stdlib.Bytes.t :=
let cmsglen := Bigstring.length cmsg in
let msg := Bigstring.make (Z.add cmsglen boxzerobytes) "000" % char in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit cmsg 0 msg boxzerobytes cmsglen in
match box_open key nonce msg msg with
| false => None
| true =>
Some (Bigstring.sub_bytes msg zerobytes (Z.sub cmsglen boxzerobytes))
end.
End Secretbox.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition hash {A : Type} (pk : Hacl.Box.key A)
: Public_key_hash.(Tezos_crypto__S.HASH.t) :=
Public_key_hash.(Tezos_crypto__S.HASH.hash_bytes) None
(cons (Bigstring.to_bytes (Box.unsafe_to_bytes pk)) []).
Definition zerobytes : Z := Box.zerobytes.
Definition boxzerobytes : Z := Box.boxzerobytes.
Definition random_keypair (function_parameter : unit)
: (Hacl.Box.key Hacl.secret) * (Hacl.Box.key Hacl.public) *
Public_key_hash.(Tezos_crypto__S.HASH.t) :=
let 'tt := function_parameter in
let '(pk, sk) := Box.keypair tt in
(sk, pk, (hash pk)).
Definition zero_nonce : Bigstring.t := Bigstring.make Nonce.bytes "000" % char.
Definition random_nonce : unit -> Hacl.Nonce.t := Nonce.gen.
Definition increment_nonce : (option Z) -> Hacl.Nonce.t -> Hacl.Nonce.t :=
Nonce.increment.
Definition generate_nonce (bytes_list : list Stdlib.Bytes.t) : Hacl.Nonce.t :=
let hash := Blake2B.hash_bytes None bytes_list in
let s := Bigstring.of_bytes (Blake2B.to_bytes hash) in
apply Nonce.of_bytes_exn (Bigstring.sub s 0 Nonce.bytes).
Definition init_to_resp_seed : string :=
Stdlib.Bytes.of_string "Init -> Resp" % string.
Definition resp_to_init_seed : string :=
Stdlib.Bytes.of_string "Resp -> Init" % string.
Definition generate_nonces
(incoming : bool) (sent_msg : Stdlib.Bytes.t) (recv_msg : Stdlib.Bytes.t)
: Hacl.Nonce.t * Hacl.Nonce.t :=
let '(init_msg, resp_msg, false) | (resp_msg, init_msg, true) :=
(sent_msg, recv_msg, incoming) in
let nonce_init_to_resp :=
generate_nonce (cons init_msg (cons resp_msg (cons init_to_resp_seed [])))
in
let nonce_resp_to_init :=
generate_nonce (cons init_msg (cons resp_msg (cons resp_to_init_seed [])))
in
if incoming then
(nonce_init_to_resp, nonce_resp_to_init)
else
(nonce_resp_to_init, nonce_init_to_resp).
Definition precompute
(sk : Hacl.Box.key Hacl.secret) (pk : Hacl.Box.key Hacl.public)
: Hacl.Box.key Hacl.Box.combined := Box.dh pk sk.
Definition fast_box_noalloc
(k : Hacl.Box.key Hacl.Box.combined) (nonce : Bigstring.t)
(bmsg : Stdlib.Bytes.t) : unit :=
let msg := Bigstring.of_bytes bmsg in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Box.box k nonce msg msg in
Bigstring.blit_to_bytes msg 0 bmsg 0 (String.length bmsg).
Definition fast_box_open_noalloc
(k : Hacl.Box.key Hacl.Box.combined) (nonce : Bigstring.t)
(bcmsg : Stdlib.Bytes.t) : bool :=
let cmsg := Bigstring.of_bytes bcmsg in
if Box.box_open k nonce cmsg cmsg then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit_to_bytes cmsg 0 bcmsg 0 (String.length bcmsg) in
true
else
false.
Definition fast_box
(k : Hacl.Box.key Hacl.Box.combined) (msg : Bigstring.t) (nonce : Bigstring.t)
: Bigstring.t :=
let msglen := Bigstring.length msg in
let cmsg := Bigstring.make (Z.add msglen zerobytes) "000" % char in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit msg 0 cmsg zerobytes msglen in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Box.box k nonce cmsg cmsg in
cmsg.
Definition fast_box_open
(k : Hacl.Box.key Hacl.Box.combined) (cmsg : Bigstring.t)
(nonce : Bigstring.t) : option Bigstring.t :=
let cmsglen := Bigstring.length cmsg in
let msg := Bigstring.make cmsglen "000" % char in
match Box.box_open k nonce cmsg msg with
| false => None
| true => Some (Bigstring.sub msg zerobytes (Z.sub cmsglen zerobytes))
end.
Definition compare_target (hash : Tezos_crypto.Blake2B.t) (target : Z.t)
: bool :=
let hash := Z.of_bits (Blake2B.to_string hash) in
OCaml.Stdlib.le (Z.compare hash target) 0.
Definition make_target (f : Z) : Z.t :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
orb
(OCaml.Stdlib.lt f
(* ❌ Float constant 0. is approximated by the integer 0 *)
0)
(OCaml.Stdlib.lt
(* ❌ Float constant 256. is approximated by the integer 256 *)
256 f) then
OCaml.Stdlib.invalid_arg "Cryptobox.target_of_float" % string
else
tt in
let '(frac, shift) := Stdlib.modf f in
let shift := Stdlib.int_of_float shift in
let m :=
apply Z.of_int64
(if
equiv_decb frac
(* ❌ Float constant 0. is approximated by the integer 0 *)
0 then
pred
(shift_left
(* ❌ Constant of type int64 is converted to int *)
1 54)
else
Int64.of_float
(Stdlib.op_starstar
(* ❌ Float constant 2. is approximated by the integer 2 *)
2
(Stdlib.op_minuspoint
(* ❌ Float constant 54. is approximated by the integer 54 *)
54 frac))) in
if OCaml.Stdlib.lt shift 202 then
Z.logor (Z.shift_left m (Z.sub 202 shift))
(apply Z.pred (Z.shift_left Z.one (Z.sub 202 shift)))
else
Z.shift_right m (Z.sub shift 202).
Definition default_target : Z.t :=
make_target
(* ❌ Float constant 24. is approximated by the integer 24 *)
24.
Definition check_proof_of_work {A : Type}
(pk : Hacl.Box.key A) (nonce : Bigstring.t) (target : Z.t) : bool :=
let hash :=
Blake2B.hash_bytes None
(cons (Bigstring.to_bytes (Box.unsafe_to_bytes pk))
(cons (Bigstring.to_bytes nonce) [])) in
compare_target hash target.
Definition generate_proof_of_work {A : Type}
(max : option Z) (pk : Hacl.Box.key A) (target : Z.t) : Bigstring.t :=
let may_interupt :=
match max with
| None =>
fun function_parameter =>
let '_ := function_parameter in
tt
| Some max =>
fun cpt =>
if OCaml.Stdlib.lt max cpt then
Stdlib.raise OCaml.Not_found
else
tt
end in
let fix loop (nonce : Bigstring.t) (cpt : Z) : Bigstring.t :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := may_interupt cpt in
if check_proof_of_work pk nonce target then
nonce
else
loop (Nonce.increment None nonce) (Z.add cpt 1) in
loop (random_nonce tt) 0.
Definition public_key_to_bytes {A : Type} (pk : Hacl.Box.key A)
: Stdlib.Bytes.t := Bigstring.to_bytes (Box.unsafe_to_bytes pk).
Definition public_key_of_bytes (buf : Stdlib.Bytes.t)
: Hacl.Box.key Hacl.public := Box.unsafe_pk_of_bytes (Bigstring.of_bytes buf).
Definition public_key_size : Z := Box.pkbytes.
Definition secret_key_to_bytes {A : Type} (sk : Hacl.Box.key A)
: Stdlib.Bytes.t := Bigstring.to_bytes (Box.unsafe_to_bytes sk).
Definition secret_key_of_bytes (buf : Stdlib.Bytes.t)
: Hacl.Box.key Hacl.secret := Box.unsafe_sk_of_bytes (Bigstring.of_bytes buf).
Definition secret_key_size : Z := Box.skbytes.
Definition nonce_size : Z := Nonce.bytes.
Definition public_key_encoding
: Tezos_data_encoding.Data_encoding.encoding (Hacl.Box.key Hacl.public) :=
conv public_key_to_bytes public_key_of_bytes None
(Fixed.bytes public_key_size).
Definition secret_key_encoding
: Tezos_data_encoding.Data_encoding.encoding (Hacl.Box.key Hacl.secret) :=
conv secret_key_to_bytes secret_key_of_bytes None
(Fixed.bytes secret_key_size).
Definition nonce_encoding
: Tezos_data_encoding.Data_encoding.encoding Bigstring.t :=
conv Bigstring.to_bytes Bigstring.of_bytes None (Fixed.bytes nonce_size).
Definition neuterize : secret_key -> public_key := Box.neuterize.
Definition equal : public_key -> public_key -> bool := Box.equal.
Definition pp_pk {A : Type}
(ppf : Stdlib.Format.formatter) (pk : Hacl.Box.key A) : unit :=
Hex.pp ppf (Hex.of_bytes None (public_key_to_bytes pk)).
src/lib_crypto/ed25519.ml 33 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
module Public_key_hash = struct
include Blake2B.Make
(Base58)
(struct
let name = "Ed25519.Public_key_hash"
let title = "An Ed25519 public key hash"
let b58check_prefix = Base58.Prefix.ed25519_public_key_hash
let size = Some 20
end)
module Logging = struct
let tag = Tag.def ~doc:title name pp
end
end
let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz1" 36
open Hacl
module Public_key = struct
type t = public Sign.key
let name = "Ed25519.Public_key"
let title = "Ed25519 public key"
let to_string s = Bigstring.to_string (Sign.unsafe_to_bytes s)
let of_string_opt s =
if String.length s < Sign.pkbytes then None
else
let pk = Bigstring.create Sign.pkbytes in
Bigstring.blit_of_string s 0 pk 0 Sign.pkbytes ;
Some (Sign.unsafe_pk_of_bytes pk)
let to_bytes pk = Bigstring.to_bytes (Sign.unsafe_to_bytes pk)
let of_bytes_opt buf =
let buflen = Bytes.length buf in
if buflen < Sign.pkbytes then None
else
let pk = Bigstring.create Sign.pkbytes in
Bigstring.blit_of_bytes buf 0 pk 0 Sign.pkbytes ;
Some (Sign.unsafe_pk_of_bytes pk)
let size = Sign.pkbytes
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.ed25519_public_key
~length:size
~to_raw:to_string
~of_raw:of_string_opt
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "edpk" 54
let hash v =
Public_key_hash.hash_bytes [Bigstring.to_bytes (Sign.unsafe_to_bytes v)]
include Compare.Make (struct
type nonrec t = t
let compare a b =
Bigstring.compare (Sign.unsafe_to_bytes a) (Sign.unsafe_to_bytes b)
end)
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end
module Secret_key = struct
type t = secret Sign.key
let name = "Ed25519.Secret_key"
let title = "An Ed25519 secret key"
let size = Sign.skbytes
let to_bigstring sk = Sign.unsafe_to_bytes sk
let to_bytes sk = Bigstring.to_bytes (to_bigstring sk)
let of_bytes_opt s =
if Bytes.length s > 64 then None
else
let sk = Bigstring.create Sign.skbytes in
Bigstring.blit_of_bytes s 0 sk 0 Sign.skbytes ;
Some (Sign.unsafe_sk_of_bytes sk)
let to_string s = Bytes.to_string (to_bytes s)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
let to_public_key = Sign.neuterize
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.ed25519_seed
~length:size
~to_raw:(fun sk -> Bigstring.to_string (Sign.unsafe_to_bytes sk))
~of_raw:(fun buf ->
if String.length buf <> Sign.skbytes then None
else Some (Sign.unsafe_sk_of_bytes (Bigstring.of_string buf)))
~wrap:(fun sk -> Data sk)
(* Legacy NaCl secret key encoding. Used to store both sk and pk. *)
let secret_key_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.ed25519_secret_key
~length:Sign.(skbytes + pkbytes)
~to_raw:(fun sk ->
let pk = Sign.neuterize sk in
let buf = Bigstring.create Sign.(skbytes + pkbytes) in
Sign.blit_to_bytes sk buf ;
Sign.blit_to_bytes pk ~pos:Sign.skbytes buf ;
Bigstring.to_string buf)
~of_raw:(fun buf ->
if String.length buf <> Sign.(skbytes + pkbytes) then None
else
let sk = Bigstring.create Sign.skbytes in
Bigstring.blit_of_string buf 0 sk 0 Sign.skbytes ;
Some (Sign.unsafe_sk_of_bytes sk))
~wrap:(fun x -> Data x)
let of_b58check_opt s =
match Base58.simple_decode b58check_encoding s with
| Some x ->
Some x
| None ->
Base58.simple_decode secret_key_encoding s
let of_b58check_exn s =
match of_b58check_opt s with
| Some x ->
x
| None ->
Format.kasprintf Pervasives.failwith "Unexpected data (%s)" name
let of_b58check s =
match of_b58check_opt s with
| Some x ->
Ok x
| None ->
generic_error "Failed to read a b58check_encoding data (%s): %S" name s
let to_b58check s = Base58.simple_encode b58check_encoding s
let to_short_b58check s =
String.sub
(to_b58check s)
0
(10 + String.length (Base58.prefix b58check_encoding))
let () =
Base58.check_encoded_prefix b58check_encoding "edsk" 54 ;
Base58.check_encoded_prefix secret_key_encoding "edsk" 98
include Compare.Make (struct
type nonrec t = t
let compare a b =
Bigstring.compare (Sign.unsafe_to_bytes a) (Sign.unsafe_to_bytes b)
end)
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end
type t = Bigstring.t
type watermark = Bytes.t
let name = "Ed25519"
let title = "An Ed25519 signature"
let size = Sign.bytes
let of_bytes_opt s =
if Bytes.length s = size then Some (Bigstring.of_bytes s) else None
let to_bytes x = Bigstring.to_bytes x
let to_string s = Bytes.to_string (to_bytes s)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.ed25519_signature
~length:size
~to_raw:Bigstring.to_string
~of_raw:(fun s -> Some (Bigstring.of_string s))
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "edsig" 99
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
let zero = Bigstring.make size '\000'
let sign ?watermark sk msg =
let msg =
Blake2B.to_bytes @@ Blake2B.hash_bytes
@@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
in
let signature = Bigstring.create Sign.bytes in
Sign.sign ~sk ~msg:(Bigstring.of_bytes msg) ~signature ;
signature
let check ?watermark pk signature msg =
let msg =
Blake2B.to_bytes @@ Blake2B.hash_bytes
@@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
in
Sign.verify ~pk ~signature ~msg:(Bigstring.of_bytes msg)
let generate_key ?seed () =
match seed with
| None ->
let (pk, sk) = Sign.keypair () in
(Public_key.hash pk, pk, sk)
| Some seed ->
let seedlen = Bigstring.length seed in
if seedlen < Sign.skbytes then
invalid_arg
(Printf.sprintf
"Ed25519.generate_key: seed must be at least %d bytes long (got \
%d)"
Sign.skbytes
seedlen) ;
let sk = Bigstring.create Sign.skbytes in
Bigstring.blit seed 0 sk 0 Sign.skbytes ;
let sk = Sign.unsafe_sk_of_bytes sk in
let pk = Sign.neuterize sk in
(Public_key.hash pk, pk, sk)
let deterministic_nonce sk msg =
let msg = Bigstring.of_bytes msg in
let key = Secret_key.to_bigstring sk in
Hash.SHA256.HMAC.digest ~key ~msg
let deterministic_nonce_hash sk msg =
Blake2B.to_bytes
(Blake2B.hash_bytes [Bigstring.to_bytes (deterministic_nonce sk msg)])
include Compare.Make (struct
type nonrec t = t
let compare = Bigstring.compare
end)
src/lib_crypto/ed25519.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Module Public_key_hash.
(* ❌ Structure item `include` not handled. *)
include
Module Logging.
Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp.
End Logging.
End Public_key_hash.
Import Hacl.
Module Public_key.
Definition t := Hacl.Sign.key Hacl.public.
Definition name : string := "Ed25519.Public_key" % string.
Definition title : string := "Ed25519 public key" % string.
Definition to_string {A : Type} (s : Hacl.Sign.key A) : string :=
Bigstring.to_string (Sign.unsafe_to_bytes s).
Definition of_string_opt (s : string) : option (Hacl.Sign.key Hacl.public) :=
if OCaml.Stdlib.lt (OCaml.String.length s) Sign.pkbytes then
None
else
let pk := Bigstring.create Sign.pkbytes in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit_of_string s 0 pk 0 Sign.pkbytes in
Some (Sign.unsafe_pk_of_bytes pk).
Definition to_bytes {A : Type} (pk : Hacl.Sign.key A) : Stdlib.Bytes.t :=
Bigstring.to_bytes (Sign.unsafe_to_bytes pk).
Definition of_bytes_opt (buf : Stdlib.Bytes.t)
: option (Hacl.Sign.key Hacl.public) :=
let buflen := String.length buf in
if OCaml.Stdlib.lt buflen Sign.pkbytes then
None
else
let pk := Bigstring.create Sign.pkbytes in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit_of_bytes buf 0 pk 0 Sign.pkbytes in
Some (Sign.unsafe_pk_of_bytes pk).
Definition size : Z := Sign.pkbytes.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
Base58.register_encoding Base58.Prefix.ed25519_public_key size to_string
of_string_opt (fun x => Tezos_crypto.Base58.Data x).
Definition hash {A : Type} (v : Hacl.Sign.key A) : Public_key_hash.t :=
Public_key_hash.hash_bytes None
(cons (Bigstring.to_bytes (Sign.unsafe_to_bytes v)) []).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Public_key.
Module Secret_key.
Definition t := Hacl.Sign.key Hacl.secret.
Definition name : string := "Ed25519.Secret_key" % string.
Definition title : string := "An Ed25519 secret key" % string.
Definition size : Z := Sign.skbytes.
Definition to_bigstring {A : Type} (sk : Hacl.Sign.key A) : Bigstring.t :=
Sign.unsafe_to_bytes sk.
Definition to_bytes {A : Type} (sk : Hacl.Sign.key A) : Stdlib.Bytes.t :=
Bigstring.to_bytes (to_bigstring sk).
Definition of_bytes_opt (s : Stdlib.Bytes.t)
: option (Hacl.Sign.key Hacl.secret) :=
if OCaml.Stdlib.gt (String.length s) 64 then
None
else
let sk := Bigstring.create Sign.skbytes in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit_of_bytes s 0 sk 0 Sign.skbytes in
Some (Sign.unsafe_sk_of_bytes sk).
Definition to_string {A : Type} (s : Hacl.Sign.key A) : string :=
Stdlib.Bytes.to_string (to_bytes s).
Definition of_string_opt (s : string) : option (Hacl.Sign.key Hacl.secret) :=
of_bytes_opt (Stdlib.Bytes.of_string s).
Definition to_public_key {A : Type}
: (Hacl.Sign.key A) -> Hacl.Sign.key Hacl.public := Sign.neuterize.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
Base58.register_encoding Base58.Prefix.ed25519_seed size
(fun sk => Bigstring.to_string (Sign.unsafe_to_bytes sk))
(fun buf =>
if nequiv_decb (OCaml.String.length buf) Sign.skbytes then
None
else
Some (Sign.unsafe_sk_of_bytes (Bigstring.of_string buf)))
(fun sk => Tezos_crypto.Base58.Data sk).
Definition secret_key_encoding : Tezos_crypto.Base58.encoding t :=
Base58.register_encoding Base58.Prefix.ed25519_secret_key
(Z.add skbytes pkbytes)
(fun sk =>
let pk := Sign.neuterize sk in
let buf := Bigstring.create (Z.add skbytes pkbytes) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sign.blit_to_bytes sk None buf in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sign.blit_to_bytes pk (Some Sign.skbytes) buf in
Bigstring.to_string buf)
(fun buf =>
if nequiv_decb (OCaml.String.length buf) (Z.add skbytes pkbytes) then
None
else
let sk := Bigstring.create Sign.skbytes in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit_of_string buf 0 sk 0 Sign.skbytes in
Some (Sign.unsafe_sk_of_bytes sk))
(fun x => Tezos_crypto.Base58.Data x).
Definition of_b58check_opt (s : string) : option t :=
match Base58.simple_decode None b58check_encoding s with
| Some x => Some x
| None => Base58.simple_decode None secret_key_encoding s
end.
Definition of_b58check_exn (s : string) : t :=
match of_b58check_opt s with
| Some x => x
| None =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Unexpected data (" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"Unexpected data (%s)" % string) name
end.
Definition of_b58check (s : string)
: sum t Tezos_error_monad.Error_monad.trace :=
match of_b58check_opt s with
| Some x => Stdlib.Ok x
| None =>
generic_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to read a b58check_encoding data (" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal "): " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"Failed to read a b58check_encoding data (%s): %S" % string) name s
end.
Definition to_b58check (s : t) : string :=
Base58.simple_encode None b58check_encoding s.
Definition to_short_b58check (s : t) : string :=
Stdlib.String.sub (to_b58check s) 0
(Z.add 10 (OCaml.String.length (Base58.prefix b58check_encoding))).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Secret_key.
Definition t := Bigstring.t.
Definition watermark := Stdlib.Bytes.t.
Definition name : string := "Ed25519" % string.
Definition title : string := "An Ed25519 signature" % string.
Definition size : Z := Sign.bytes.
Definition of_bytes_opt (s : Stdlib.Bytes.t) : option Bigstring.t :=
if equiv_decb (String.length s) size then
Some (Bigstring.of_bytes s)
else
None.
Definition to_bytes (x : Bigstring.t) : Stdlib.Bytes.t := Bigstring.to_bytes x.
Definition to_string (s : Bigstring.t) : string :=
Stdlib.Bytes.to_string (to_bytes s).
Definition of_string_opt (s : string) : option Bigstring.t :=
of_bytes_opt (Stdlib.Bytes.of_string s).
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding : Tezos_crypto.Base58.encoding Bigstring.t :=
Base58.register_encoding Base58.Prefix.ed25519_signature size
Bigstring.to_string (fun s => Some (Bigstring.of_string s))
(fun x => Tezos_crypto.Base58.Data x).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
Definition zero : Bigstring.t := Bigstring.make size "000" % char.
Definition sign
(watermark : option Stdlib.Bytes.t) (sk : Hacl.Sign.key Hacl.secret)
(msg : Stdlib.Bytes.t) : Bigstring.t :=
let msg :=
apply Blake2B.to_bytes
(apply
(let arg := Blake2B.hash_bytes in
fun eta => arg None eta)
match watermark with
| None => cons msg []
| Some prefix => cons prefix (cons msg [])
end) in
let signature := Bigstring.create Sign.bytes in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sign.sign sk (Bigstring.of_bytes msg) signature in
signature.
Definition check
(watermark : option Stdlib.Bytes.t) (pk : Hacl.Sign.key Hacl.public)
(signature : Bigstring.t) (msg : Stdlib.Bytes.t) : bool :=
let msg :=
apply Blake2B.to_bytes
(apply
(let arg := Blake2B.hash_bytes in
fun eta => arg None eta)
match watermark with
| None => cons msg []
| Some prefix => cons prefix (cons msg [])
end) in
Sign.verify pk (Bigstring.of_bytes msg) signature.
Definition generate_key (seed : option Bigstring.t) (function_parameter : unit)
: Public_key_hash.t * (Hacl.Sign.key Hacl.public) *
(Hacl.Sign.key Hacl.secret) :=
let 'tt := function_parameter in
match seed with
| None =>
let '(pk, sk) := Sign.keypair tt in
((Public_key.hash pk), pk, sk)
| Some seed =>
let seedlen := Bigstring.length seed in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt seedlen Sign.skbytes then
OCaml.Stdlib.invalid_arg
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Ed25519.generate_key: seed must be at least " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" bytes long (got " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"Ed25519.generate_key: seed must be at least %d bytes long (got %d)"
% string) Sign.skbytes seedlen)
else
tt in
let sk := Bigstring.create Sign.skbytes in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bigstring.blit seed 0 sk 0 Sign.skbytes in
let sk := Sign.unsafe_sk_of_bytes sk in
let pk := Sign.neuterize sk in
((Public_key.hash pk), pk, sk)
end.
Definition deterministic_nonce {A : Type}
(sk : Hacl.Sign.key A) (msg : Stdlib.Bytes.t) : Bigstring.t :=
let msg := Bigstring.of_bytes msg in
let key := Secret_key.to_bigstring sk in
Hash.SHA256.HMAC.digest key msg.
Definition deterministic_nonce_hash {A : Type}
(sk : Hacl.Sign.key A) (msg : Stdlib.Bytes.t) : Stdlib.Bytes.t :=
Blake2B.to_bytes
(Blake2B.hash_bytes None
(cons (Bigstring.to_bytes (deterministic_nonce sk msg)) [])).
(* ❌ Structure item `include` not handled. *)
include
src/lib_crypto/helpers.ml 5 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
module MakeRaw (H : sig
type t
val name : string
val of_bytes_opt : Bytes.t -> t option
val to_string : t -> string
val of_string_opt : string -> t option
end) =
struct
let of_bytes_exn s =
match H.of_bytes_opt s with
| None ->
Format.kasprintf invalid_arg "of_bytes_exn (%s)" H.name
| Some pk ->
pk
let of_bytes s =
match H.of_bytes_opt s with
| None ->
generic_error "of_bytes (%s)" H.name
| Some pk ->
Ok pk
let of_string_exn s =
match H.of_string_opt s with
| None ->
Format.kasprintf invalid_arg "of_string_exn (%s)" H.name
| Some pk ->
pk
let of_string s =
match H.of_string_opt s with
| None ->
generic_error "of_string (%s)" H.name
| Some pk ->
Ok pk
let to_hex s = Hex.of_string (H.to_string s)
let of_hex_opt s = H.of_string_opt (Hex.to_string s)
let of_hex_exn s =
match H.of_string_opt (Hex.to_string s) with
| Some x ->
x
| None ->
Format.kasprintf invalid_arg "of_hex_exn (%s)" H.name
let of_hex s =
match of_hex_opt s with
| None ->
generic_error "of_hex (%s)" H.name
| Some pk ->
ok pk
end
module MakeB58 (H : sig
type t
val name : string
val b58check_encoding : t Base58.encoding
end) =
struct
let of_b58check_opt s = Base58.simple_decode H.b58check_encoding s
let of_b58check_exn s =
match of_b58check_opt s with
| Some x ->
x
| None ->
Format.kasprintf Pervasives.failwith "Unexpected data (%s)" H.name
let of_b58check s =
match of_b58check_opt s with
| Some x ->
Ok x
| None ->
generic_error
"Failed to read a b58check_encoding data (%s): %S"
H.name
s
let to_b58check s = Base58.simple_encode H.b58check_encoding s
let to_short_b58check s =
String.sub
(to_b58check s)
0
(10 + String.length (Base58.prefix H.b58check_encoding))
end
module MakeEncoder (H : sig
type t
val title : string
val name : string
val to_b58check : t -> string
val to_short_b58check : t -> string
val of_b58check : string -> t tzresult
val of_b58check_exn : string -> t
val of_b58check_opt : string -> t option
val raw_encoding : t Data_encoding.t
end) =
struct
let pp ppf t = Format.pp_print_string ppf (H.to_b58check t)
let pp_short ppf t = Format.pp_print_string ppf (H.to_short_b58check t)
let encoding =
let open Data_encoding in
splitted
~binary:(obj1 (req H.name H.raw_encoding))
~json:
( def H.name ~title:(H.title ^ " (Base58Check-encoded)")
@@ conv
H.to_b58check
(Data_encoding.Json.wrap_error H.of_b58check_exn)
string )
let of_b58check = H.of_b58check
let rpc_arg =
RPC_arg.make
~name:H.name
~descr:(Format.asprintf "%s (Base58Check-encoded)" H.name)
~destruct:(fun s ->
match H.of_b58check_opt s with
| None ->
Error
(Format.asprintf
"failed to decode Base58Check-encoded data (%s): %S"
H.name
s)
| Some v ->
Ok v)
~construct:H.to_b58check
()
end
module MakeIterator (H : sig
type t
val encoding : t Data_encoding.t
val compare : t -> t -> int
val equal : t -> t -> bool
val hash : t -> int
end) =
struct
module Set = struct
include Set.Make (struct
type t = H.t
let compare = H.compare
end)
exception Found of elt
let random_elt s =
let n = Random.int (cardinal s) in
try
ignore
( fold
(fun x i ->
if i = n then raise (Found x) ;
i + 1)
s
0
: int ) ;
assert false
with Found x -> x
let encoding =
Data_encoding.conv
elements
(fun l -> List.fold_left (fun m x -> add x m) empty l)
Data_encoding.(list H.encoding)
end
module Table = struct
include Hashtbl.Make (struct
type t = H.t
let hash = H.hash
let equal = H.equal
end)
let encoding arg_encoding =
Data_encoding.conv
(fun h -> fold (fun k v l -> (k, v) :: l) h [])
(fun l ->
let h = create (List.length l) in
List.iter (fun (k, v) -> add h k v) l ;
h)
Data_encoding.(list (tup2 H.encoding arg_encoding))
end
module Map = struct
include Map.Make (struct
type t = H.t
let compare = H.compare
end)
let encoding arg_encoding =
Data_encoding.conv
bindings
(fun l -> List.fold_left (fun m (k, v) -> add k v m) empty l)
Data_encoding.(list (tup2 H.encoding arg_encoding))
end
module Error_table = struct
include Error_table.Make (Table)
end
module WeakRingTable = struct
include WeakRingTable.Make (struct
type t = H.t
let hash = H.hash
let equal = H.equal
end)
let encoding arg_encoding =
Data_encoding.conv
(fun h -> fold (fun k v l -> (k, v) :: l) h [])
(fun l ->
let h = create (List.length l) in
List.iter (fun (k, v) -> add h k v) l ;
h)
Data_encoding.(list (tup2 H.encoding arg_encoding))
end
end
module Make (H : sig
type t
val title : string
val name : string
val b58check_encoding : t Base58.encoding
val raw_encoding : t Data_encoding.t
val compare : t -> t -> int
val equal : t -> t -> bool
val hash : t -> int
end) =
struct
include MakeB58 (H)
include MakeEncoder (struct
include H
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
end)
include MakeIterator (struct
include H
let encoding = encoding
end)
end
src/lib_crypto/helpers.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. Import Error_monad. (* ❌ Functors are not handled. *) functor (* ❌ Functors are not handled. *) functor (* ❌ Functors are not handled. *) functor (* ❌ Functors are not handled. *) functor (* ❌ Functors are not handled. *) functor
src/lib_crypto/operation_hash.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Blake2B.Make
(Base58)
(struct
let name = "Operation_hash"
let title = "A Tezos operation ID"
let b58check_prefix = Base58.Prefix.operation_hash
let size = None
end)
let () = Base58.check_encoded_prefix b58check_encoding "o" 51
module Logging = struct
let tag = Tag.def ~doc:title name pp
end
src/lib_crypto/operation_hash.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include Module Logging. Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp. End Logging.
src/lib_crypto/operation_list_hash.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Blake2B.Make_merkle_tree
(Base58)
(struct
let name = "Operation_list_hash"
let title = "A list of operations"
let b58check_prefix = Base58.Prefix.operation_list_hash
let size = None
end)
(Operation_hash)
let () = Base58.check_encoded_prefix b58check_encoding "Lo" 52
src/lib_crypto/operation_list_hash.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/lib_crypto/operation_list_list_hash.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Blake2B.Make_merkle_tree
(Base58)
(struct
let name = "Operation_list_list_hash"
let title = "A list of list of operations"
let b58check_prefix = Base58.Prefix.operation_list_list_hash
let size = None
end)
(Operation_list_hash)
let () = Base58.check_encoded_prefix b58check_encoding "LLo" 53
src/lib_crypto/operation_list_list_hash.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/lib_crypto/p256.ml 24 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Public_key_hash = struct
include Blake2B.Make
(Base58)
(struct
let name = "P256.Public_key_hash"
let title = "A P256 public key hash"
let b58check_prefix = Base58.Prefix.p256_public_key_hash
let size = Some 20
end)
module Logging = struct
let tag = Tag.def ~doc:title name pp
end
end
let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz3" 36
open Uecc
module Public_key = struct
type t = (secp256r1, public) key
let name = "P256.Public_key"
let title = "A P256 public key"
let to_bigstring = to_bytes ~compress:true
let to_bytes b = Bigstring.to_bytes (to_bigstring b)
let to_string s = Bytes.to_string (to_bytes s)
let of_bytes_opt b = pk_of_bytes secp256r1 (Bigstring.of_bytes b)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
let size = compressed_size secp256r1
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.p256_public_key
~length:size
~to_raw:to_string
~of_raw:of_string_opt
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "p2pk" 55
let hash v = Public_key_hash.hash_bytes [to_bytes v]
include Compare.Make (struct
type nonrec t = t
let compare a b = Bytes.compare (to_bytes a) (to_bytes b)
end)
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end
module Secret_key = struct
type t = (secp256r1, secret) key
let name = "P256.Secret_key"
let title = "A P256 secret key"
let size = sk_size secp256r1
let of_bytes_opt buf =
Option.map ~f:fst (sk_of_bytes secp256r1 (Bigstring.of_bytes buf))
let to_bigstring = to_bytes ~compress:true
let to_bytes t = Bigstring.to_bytes (to_bigstring t)
let to_string s = Bytes.to_string (to_bytes s)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
let to_public_key = neuterize
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.p256_secret_key
~length:size
~to_raw:to_string
~of_raw:of_string_opt
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "p2sk" 54
include Compare.Make (struct
type nonrec t = t
let compare a b = Bytes.compare (to_bytes a) (to_bytes b)
end)
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end
type t = Bigstring.t
type watermark = Bytes.t
let name = "P256"
let title = "A P256 signature"
let size = pk_size secp256r1
let of_bytes_opt s =
if Bytes.length s = size then Some (Bigstring.of_bytes s) else None
let to_bytes s = Bigstring.to_bytes s
let to_string s = Bytes.to_string (to_bytes s)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.p256_signature
~length:size
~to_raw:to_string
~of_raw:of_string_opt
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "p2sig" 98
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
let zero = of_bytes_exn (Bytes.make size '\000')
let sign ?watermark sk msg =
let msg =
Blake2B.to_bytes @@ Blake2B.hash_bytes
@@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
in
match sign sk (Bigstring.of_bytes msg) with
| None ->
(* Will never happen in practice. This can only happen in case
of RNG error. *)
invalid_arg "P256.sign: internal error"
| Some signature ->
signature
let check ?watermark public_key signature msg =
let msg =
Blake2B.to_bytes @@ Blake2B.hash_bytes
@@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
in
verify public_key ~msg:(Bigstring.of_bytes msg) ~signature
let generate_key ?(seed = Hacl.Rand.gen 32) () =
let seedlen = Bigstring.length seed in
if seedlen < 32 then
invalid_arg
(Printf.sprintf
"P256.generate_key: seed must be at least 32 bytes long (was %d)"
seedlen) ;
match sk_of_bytes secp256r1 seed with
| None ->
invalid_arg "P256.generate_key: invalid seed (very rare!)"
| Some (sk, pk) ->
let pkh = Public_key.hash pk in
(pkh, pk, sk)
let deterministic_nonce sk msg =
let msg = Bigstring.of_bytes msg in
let key = Secret_key.to_bigstring sk in
Hacl.Hash.SHA256.HMAC.digest ~key ~msg
let deterministic_nonce_hash sk msg =
let nonce = deterministic_nonce sk msg in
Blake2B.to_bytes (Blake2B.hash_bytes [Bigstring.to_bytes nonce])
include Compare.Make (struct
type nonrec t = t
let compare = Bigstring.compare
end)
src/lib_crypto/p256.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Public_key_hash.
(* ❌ Structure item `include` not handled. *)
include
Module Logging.
Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp.
End Logging.
End Public_key_hash.
Import Uecc.
Module Public_key.
Definition t := Uecc.key Uecc.secp256r1 Uecc.public.
Definition name : string := "P256.Public_key" % string.
Definition title : string := "A P256 public key" % string.
Definition to_bigstring
: (Uecc.key Uecc.secp256r1 Uecc.public) -> Bigstring.t :=
to_bytes (Some true).
Definition to_bytes (b : Uecc.key Uecc.secp256r1 Uecc.public)
: Stdlib.Bytes.t := Bigstring.to_bytes (to_bigstring b).
Definition to_string (s : Uecc.key Uecc.secp256r1 Uecc.public) : string :=
Stdlib.Bytes.to_string (to_bytes s).
Definition of_bytes_opt (b : Stdlib.Bytes.t)
: option (Uecc.key Uecc.secp256r1 Uecc.public) :=
pk_of_bytes secp256r1 (Bigstring.of_bytes b).
Definition of_string_opt (s : string)
: option (Uecc.key Uecc.secp256r1 Uecc.public) :=
of_bytes_opt (Stdlib.Bytes.of_string s).
Definition size : Z := compressed_size secp256r1.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
Base58.register_encoding Base58.Prefix.p256_public_key size to_string
of_string_opt (fun x => Tezos_crypto.Base58.Data x).
Definition hash (v : Uecc.key Uecc.secp256r1 Uecc.public)
: Public_key_hash.t :=
Public_key_hash.hash_bytes None (cons (to_bytes v) []).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Public_key.
Module Secret_key.
Definition t := Uecc.key Uecc.secp256r1 Uecc.secret.
Definition name : string := "P256.Secret_key" % string.
Definition title : string := "A P256 secret key" % string.
Definition size : Z := sk_size secp256r1.
Definition of_bytes_opt (buf : Stdlib.Bytes.t)
: option (Uecc.key Uecc.secp256r1 Uecc.secret) :=
Option.map fst (sk_of_bytes secp256r1 (Bigstring.of_bytes buf)).
Definition to_bigstring
: (Uecc.key Uecc.secp256r1 Uecc.secret) -> Bigstring.t :=
to_bytes (Some true).
Definition to_bytes (t : Uecc.key Uecc.secp256r1 Uecc.secret)
: Stdlib.Bytes.t := Bigstring.to_bytes (to_bigstring t).
Definition to_string (s : Uecc.key Uecc.secp256r1 Uecc.secret) : string :=
Stdlib.Bytes.to_string (to_bytes s).
Definition of_string_opt (s : string)
: option (Uecc.key Uecc.secp256r1 Uecc.secret) :=
of_bytes_opt (Stdlib.Bytes.of_string s).
Definition to_public_key {A B : Type}
: (Uecc.key A B) -> Uecc.key A Uecc.public := neuterize.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
Base58.register_encoding Base58.Prefix.p256_secret_key size to_string
of_string_opt (fun x => Tezos_crypto.Base58.Data x).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Secret_key.
Definition t := Bigstring.t.
Definition watermark := Stdlib.Bytes.t.
Definition name : string := "P256" % string.
Definition title : string := "A P256 signature" % string.
Definition size : Z := pk_size secp256r1.
Definition of_bytes_opt (s : Stdlib.Bytes.t) : option Bigstring.t :=
if equiv_decb (String.length s) size then
Some (Bigstring.of_bytes s)
else
None.
Definition to_bytes (s : Bigstring.t) : Stdlib.Bytes.t := Bigstring.to_bytes s.
Definition to_string (s : Bigstring.t) : string :=
Stdlib.Bytes.to_string (to_bytes s).
Definition of_string_opt (s : string) : option Bigstring.t :=
of_bytes_opt (Stdlib.Bytes.of_string s).
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding : Tezos_crypto.Base58.encoding Bigstring.t :=
Base58.register_encoding Base58.Prefix.p256_signature size to_string
of_string_opt (fun x => Tezos_crypto.Base58.Data x).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
Definition zero : t := of_bytes_exn (Stdlib.Bytes.make size "000" % char).
Definition sign {A : Type}
(watermark : option Stdlib.Bytes.t) (sk : Uecc.key A Uecc.secret)
(msg : Stdlib.Bytes.t) : Bigstring.t :=
let msg :=
apply Blake2B.to_bytes
(apply
(let arg := Blake2B.hash_bytes in
fun eta => arg None eta)
match watermark with
| None => cons msg []
| Some prefix => cons prefix (cons msg [])
end) in
match sign sk (Bigstring.of_bytes msg) with
| None => OCaml.Stdlib.invalid_arg "P256.sign: internal error" % string
| Some signature => signature
end.
Definition check {A : Type}
(watermark : option Stdlib.Bytes.t) (public_key : Uecc.key A Uecc.public)
(signature : Bigstring.t) (msg : Stdlib.Bytes.t) : bool :=
let msg :=
apply Blake2B.to_bytes
(apply
(let arg := Blake2B.hash_bytes in
fun eta => arg None eta)
match watermark with
| None => cons msg []
| Some prefix => cons prefix (cons msg [])
end) in
verify public_key (Bigstring.of_bytes msg) signature.
Definition generate_key (op_staroptstar : option Bigstring.t)
: unit ->
Public_key_hash.t * (Uecc.key Uecc.secp256r1 Uecc.public) *
(Uecc.key Uecc.secp256r1 Uecc.secret) :=
let seed :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Hacl.Rand.gen 32
end in
fun function_parameter =>
let 'tt := function_parameter in
let seedlen := Bigstring.length seed in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt seedlen 32 then
OCaml.Stdlib.invalid_arg
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"P256.generate_key: seed must be at least 32 bytes long (was " %
string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"P256.generate_key: seed must be at least 32 bytes long (was %d)"
% string) seedlen)
else
tt in
match sk_of_bytes secp256r1 seed with
| None =>
OCaml.Stdlib.invalid_arg
"P256.generate_key: invalid seed (very rare!)" % string
| Some (sk, pk) =>
let pkh := Public_key.hash pk in
(pkh, pk, sk)
end.
Definition deterministic_nonce
(sk : Uecc.key Uecc.secp256r1 Uecc.secret) (msg : Stdlib.Bytes.t)
: Bigstring.t :=
let msg := Bigstring.of_bytes msg in
let key := Secret_key.to_bigstring sk in
Hacl.Hash.SHA256.HMAC.digest key msg.
Definition deterministic_nonce_hash
(sk : Uecc.key Uecc.secp256r1 Uecc.secret) (msg : Stdlib.Bytes.t)
: Stdlib.Bytes.t :=
let nonce := deterministic_nonce sk msg in
Blake2B.to_bytes
(Blake2B.hash_bytes None (cons (Bigstring.to_bytes nonce) [])).
(* ❌ Structure item `include` not handled. *)
include
src/lib_crypto/protocol_hash.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Blake2B.Make
(Base58)
(struct
let name = "Protocol_hash"
let title = "A Tezos protocol ID"
let b58check_prefix = Base58.Prefix.protocol_hash
let size = None
end)
let () = Base58.check_encoded_prefix b58check_encoding "P" 51
module Logging = struct
let tag = Tag.def ~doc:title name pp
end
src/lib_crypto/protocol_hash.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include Module Logging. Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp. End Logging.
src/lib_crypto/pvss_secp256k1.ml 56 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Secp256k1_group
module G : Pvss.CYCLIC_GROUP = struct
module Z_m = struct
include Group.Scalar
let n = Group.order
let ( + ) = Group.Scalar.add
let ( * ) = Group.Scalar.mul
let ( - ) = Group.Scalar.sub
let ( = ) = Group.Scalar.equal
let inv = Group.Scalar.inverse
end
include Group
let name = "secp256k1"
(* This pvss algorithm assumes the public keys of the participants receiving
shares are based on g2, so we set g2 to Group.g to match regular Secp256k1
public keys.
*)
let g1 = Group.h
let g2 = Group.g
(* We use a multiplicative notation in the pvss module, but
secp256k1 usually uses an additive notation. *)
let ( * ) = Group.(( + ))
let pow x n = Group.mul n x
let of_bits b = try Some (Group.of_bits_exn b) with _ -> None
end
include Pvss.MakePvss (G)
src/lib_crypto/pvss_secp256k1.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Secp256k1_group.
Module G.
Module Z_m.
(* ❌ Structure item `include` not handled. *)
include
Definition n : Z.t := Group.order.
Definition op_plus
: Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
Tezos_crypto.Secp256k1_group.Group.Scalar.t := Group.Scalar.add.
Definition op_star
: Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
Tezos_crypto.Secp256k1_group.Group.Scalar.t := Group.Scalar.mul.
Definition op_minus
: Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
Tezos_crypto.Secp256k1_group.Group.Scalar.t := Group.Scalar.sub.
Definition op_eq
: Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
Tezos_crypto.Secp256k1_group.Group.Scalar.t -> bool :=
Group.Scalar.equal.
Definition inv
: Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
option Tezos_crypto.Secp256k1_group.Group.Scalar.t :=
Group.Scalar.inverse.
End Z_m.
(* ❌ Structure item `include` not handled. *)
include
Definition name : string := "secp256k1" % string.
Definition g1 : Tezos_crypto.Secp256k1_group.Group.t := Group.h.
Definition g2 : Tezos_crypto.Secp256k1_group.Group.t := Group.g.
Definition op_star
: Tezos_crypto.Secp256k1_group.Group.t ->
Tezos_crypto.Secp256k1_group.Group.t ->
Tezos_crypto.Secp256k1_group.Group.t := op_plus.
Definition pow
(x : Tezos_crypto.Secp256k1_group.Group.t)
(n : Tezos_crypto.Secp256k1_group.Group.Scalar.t)
: Tezos_crypto.Secp256k1_group.Group.t := Group.mul n x.
Definition of_bits (b : string)
: option Tezos_crypto.Secp256k1_group.Group.t :=
(* ❌ Try-with are not handled *)
try (Some (Group.of_bits_exn b)).
End G.
(* ❌ Structure item `include` not handled. *)
include
src/lib_crypto/rand.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let generate len = Bigstring.to_bytes (Hacl.Rand.gen len)
let generate_into ?(pos = 0) ?len buf =
let buflen = Bytes.length buf in
let len = match len with Some len -> len | None -> buflen - pos in
if pos < 0 || len < 0 || pos + len > buflen then
invalid_arg
(Printf.sprintf
"Rand.generate_into: invalid slice (pos=%d len=%d)"
pos
len) ;
let rand = Hacl.Rand.gen len in
Bigstring.blit_to_bytes rand 0 buf pos len
src/lib_crypto/rand.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition generate (len : Z) : Stdlib.Bytes.t :=
Bigstring.to_bytes (Hacl.Rand.gen len).
Definition generate_into (op_staroptstar : option Z)
: (option Z) -> Stdlib.Bytes.t -> unit :=
let pos :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 0
end in
fun len =>
fun buf =>
let buflen := String.length buf in
let len :=
match len with
| Some len => len
| None => Z.sub buflen pos
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
orb (OCaml.Stdlib.lt pos 0)
(orb (OCaml.Stdlib.lt len 0)
(OCaml.Stdlib.gt (Z.add pos len) buflen)) then
OCaml.Stdlib.invalid_arg
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Rand.generate_into: invalid slice (pos=" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " len=" % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"Rand.generate_into: invalid slice (pos=%d len=%d)" % string)
pos len)
else
tt in
let rand := Hacl.Rand.gen len in
Bigstring.blit_to_bytes rand 0 buf pos len.
src/lib_crypto/s.ml 31 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
(** {2 Hash Types} *)
(** The signature of an abstract hash type, as produced by functor
{!Make_Blake2B}. The {!t} type is abstracted for separating the
various kinds of hashes in the system at typing time. Each type is
equipped with functions to use it as is of as keys in the database
or in memory sets and maps. *)
module type MINIMAL_HASH = sig
type t
val name : string
val title : string
val pp : Format.formatter -> t -> unit
val pp_short : Format.formatter -> t -> unit
include Compare.S with type t := t
val hash_bytes : ?key:Bytes.t -> Bytes.t list -> t
val hash_string : ?key:string -> string list -> t
val zero : t
end
module type RAW_DATA = sig
type t
val size : int (* in bytes *)
val to_hex : t -> Hex.t
val of_hex : Hex.t -> t tzresult
val of_hex_opt : Hex.t -> t option
val of_hex_exn : Hex.t -> t
val to_string : t -> string
val of_string : string -> t tzresult
val of_string_opt : string -> t option
val of_string_exn : string -> t
val to_bytes : t -> Bytes.t
val of_bytes : Bytes.t -> t tzresult
val of_bytes_opt : Bytes.t -> t option
val of_bytes_exn : Bytes.t -> t
end
module type B58_DATA = sig
type t
val to_b58check : t -> string
val to_short_b58check : t -> string
val of_b58check : string -> t tzresult
val of_b58check_exn : string -> t
val of_b58check_opt : string -> t option
type Base58.data += Data of t
val b58check_encoding : t Base58.encoding
end
module type ENCODER = sig
type t
val encoding : t Data_encoding.t
val rpc_arg : t RPC_arg.t
end
module type PVSS = sig
type proof
module Clear_share : sig
type t
end
module Commitment : sig
type t
end
module Encrypted_share : sig
type t
end
module Public_key : sig
type t
include B58_DATA with type t := t
include ENCODER with type t := t
end
end
module type INDEXES = sig
type t
val hash : t -> int
val to_path : t -> string list -> string list
val of_path : string list -> t option
val of_path_exn : string list -> t
val prefix_path : string -> string list
val path_length : int
module Set : sig
include Set.S with type elt = t
val random_elt : t -> elt
val encoding : t Data_encoding.t
end
module Map : sig
include Map.S with type key = t
val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
end
module Table : sig
include Hashtbl.S with type key = t
val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
end
module Error_table : sig
include Error_table.S with type key = t
end
module WeakRingTable : sig
include WeakRingTable.S with type key = t
val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
end
end
module type HASH = sig
include MINIMAL_HASH
include RAW_DATA with type t := t
include B58_DATA with type t := t
include ENCODER with type t := t
include INDEXES with type t := t
end
module type MERKLE_TREE = sig
type elt
val elt_bytes : elt -> Bytes.t
include HASH
val compute : elt list -> t
val empty : t
type path = Left of path * t | Right of t * path | Op
val path_encoding : path Data_encoding.t
val bounded_path_encoding : ?max_length:int -> unit -> path Data_encoding.t
val compute_path : elt list -> int -> path
val check_path : path -> elt -> t * int
end
module type SIGNATURE = sig
module Public_key_hash : sig
type t
val pp : Format.formatter -> t -> unit
val pp_short : Format.formatter -> t -> unit
include Compare.S with type t := t
include RAW_DATA with type t := t
include B58_DATA with type t := t
include ENCODER with type t := t
include INDEXES with type t := t
val zero : t
module Logging : sig
val tag : t Tag.def
end
end
module Public_key : sig
type t
val pp : Format.formatter -> t -> unit
include Compare.S with type t := t
include B58_DATA with type t := t
include ENCODER with type t := t
val hash : t -> Public_key_hash.t
end
module Secret_key : sig
type t
val pp : Format.formatter -> t -> unit
include Compare.S with type t := t
include B58_DATA with type t := t
include ENCODER with type t := t
val to_public_key : t -> Public_key.t
end
type t
val pp : Format.formatter -> t -> unit
include Compare.S with type t := t
include B58_DATA with type t := t
include ENCODER with type t := t
val zero : t
type watermark
val sign : ?watermark:watermark -> Secret_key.t -> Bytes.t -> t
val check : ?watermark:watermark -> Public_key.t -> t -> Bytes.t -> bool
val generate_key :
?seed:Bigstring.t ->
unit ->
Public_key_hash.t * Public_key.t * Secret_key.t
val deterministic_nonce : Secret_key.t -> Bytes.t -> Bigstring.t
val deterministic_nonce_hash : Secret_key.t -> Bytes.t -> Bytes.t
end
src/lib_crypto/s.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Module MINIMAL_HASH.
Record signature {t : Type} := {
t := t;
name : string;
title : string;
pp : Stdlib.Format.formatter -> t -> unit;
pp_short : Stdlib.Format.formatter -> t -> unit;
include;
hash_bytes : (option Stdlib.Bytes.t) -> (list Stdlib.Bytes.t) -> t;
hash_string : (option string) -> (list string) -> t;
zero : t;
}.
Arguments signature : clear implicits.
End MINIMAL_HASH.
Module RAW_DATA.
Record signature {t : Type} := {
t := t;
size : Z;
to_hex : t -> Hex.t;
of_hex : Hex.t -> Tezos_error_monad.Error_monad.tzresult t;
of_hex_opt : Hex.t -> option t;
of_hex_exn : Hex.t -> t;
to_string : t -> string;
of_string : string -> Tezos_error_monad.Error_monad.tzresult t;
of_string_opt : string -> option t;
of_string_exn : string -> t;
to_bytes : t -> Stdlib.Bytes.t;
of_bytes : Stdlib.Bytes.t -> Tezos_error_monad.Error_monad.tzresult t;
of_bytes_opt : Stdlib.Bytes.t -> option t;
of_bytes_exn : Stdlib.Bytes.t -> t;
}.
Arguments signature : clear implicits.
End RAW_DATA.
Module B58_DATA.
Record signature {t : Type} := {
t := t;
to_b58check : t -> string;
to_short_b58check : t -> string;
of_b58check : string -> Tezos_error_monad.Error_monad.tzresult t;
of_b58check_exn : string -> t;
of_b58check_opt : string -> option t;
extensible_type;
b58check_encoding : Tezos_crypto.Base58.encoding t;
}.
Arguments signature : clear implicits.
End B58_DATA.
Module ENCODER.
Record signature {t : Type} := {
t := t;
encoding : Tezos_data_encoding.Data_encoding.t t;
rpc_arg : Tezos_rpc.RPC_arg.t t;
}.
Arguments signature : clear implicits.
End ENCODER.
Module PVSS.
Record signature {proof Clear_share_t Commitment_t Encrypted_share_t
Public_key_t : Type} := {
proof := proof;
Clear_share : signature;
Commitment : signature;
Encrypted_share : signature;
Public_key : signature;
}.
Arguments signature : clear implicits.
End PVSS.
Module INDEXES.
Record signature {t Set_t Map_t Table_t Error_table_t WeakRingTable_t : Type}
:= {
t := t;
hash : t -> Z;
to_path : t -> (list string) -> list string;
of_path : (list string) -> option t;
of_path_exn : (list string) -> t;
prefix_path : string -> list string;
path_length : Z;
Set : signature;
Map : signature;
Table : signature;
Error_table : signature;
WeakRingTable : signature;
}.
Arguments signature : clear implicits.
End INDEXES.
Module HASH.
Record signature {t Set_t Map_t Table_t Error_table_t WeakRingTable_t : Type}
:= {
include;
include;
include;
include;
include;
}.
Arguments signature : clear implicits.
End HASH.
Module MERKLE_TREE.
Record signature {elt t Set_t Map_t Table_t Error_table_t WeakRingTable_t path
: Type} := {
elt := elt;
elt_bytes : elt -> Stdlib.Bytes.t;
include;
compute : (list elt) -> t;
empty : t;
path := path;
path_encoding : Tezos_data_encoding.Data_encoding.t path;
bounded_path_encoding : (option Z) ->
unit -> Tezos_data_encoding.Data_encoding.t path;
compute_path : (list elt) -> Z -> path;
check_path : path -> elt -> t * Z;
}.
Arguments signature : clear implicits.
End MERKLE_TREE.
Module SIGNATURE.
Record signature {Public_key_hash_t Public_key_hash_Set_t
Public_key_hash_Map_t Public_key_hash_Table_t Public_key_hash_Error_table_t
Public_key_hash_WeakRingTable_t Public_key_t Secret_key_t t watermark :
Type} := {
Public_key_hash : signature;
Public_key : signature;
Secret_key : signature;
t := t;
pp : Stdlib.Format.formatter -> t -> unit;
include;
include;
include;
zero : t;
watermark := watermark;
sign : (option watermark) -> Secret_key.t -> Stdlib.Bytes.t -> t;
check : (option watermark) -> Public_key.t -> t -> Stdlib.Bytes.t -> bool;
generate_key : (option Bigstring.t) ->
unit -> Public_key_hash.t * Public_key.t * Secret_key.t;
deterministic_nonce : Secret_key.t -> Stdlib.Bytes.t -> Bigstring.t;
deterministic_nonce_hash : Secret_key.t -> Stdlib.Bytes.t -> Stdlib.Bytes.t;
}.
Arguments signature : clear implicits.
End SIGNATURE.
src/lib_crypto/secp256k1.ml 90 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Public_key_hash = struct
include Blake2B.Make
(Base58)
(struct
let name = "Secp256k1.Public_key_hash"
let title = "A Secp256k1 public key hash"
let b58check_prefix = Base58.Prefix.secp256k1_public_key_hash
let size = Some 20
end)
module Logging = struct
let tag = Tag.def ~doc:title name pp
end
end
let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz2" 36
open Libsecp256k1.External
let context =
let ctx = Context.create () in
match Context.randomize ctx (Hacl.Rand.gen 32) with
| false ->
failwith "Secp256k1 context randomization failed. Aborting."
| true ->
ctx
module Public_key = struct
type t = Key.public Key.t
let name = "Secp256k1.Public_key"
let title = "A Secp256k1 public key"
let to_bytes pk = Bigstring.to_bytes (Key.to_bytes context pk)
let of_bytes_opt s =
try Some (Key.read_pk_exn context (Bigstring.of_bytes s)) with _ -> None
let to_string s = Bytes.to_string (to_bytes s)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
let size = Key.compressed_pk_bytes
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.secp256k1_public_key
~length:size
~to_raw:to_string
~of_raw:of_string_opt
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "sppk" 55
let hash v = Public_key_hash.hash_bytes [to_bytes v]
include Compare.Make (struct
type nonrec t = t
let compare a b = Bytes.compare (to_bytes a) (to_bytes b)
end)
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end
module Secret_key = struct
type t = Key.secret Key.t
let name = "Secp256k1.Secret_key"
let title = "A Secp256k1 secret key"
let size = Key.secret_bytes
let of_bytes_opt s =
match Key.read_sk context (Bigstring.of_bytes s) with
| Ok x ->
Some x
| _ ->
None
let to_bigstring = Key.to_bytes context
let to_bytes x = Bigstring.to_bytes (to_bigstring x)
let to_string s = Bytes.to_string (to_bytes s)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
let to_public_key key = Key.neuterize_exn context key
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.secp256k1_secret_key
~length:size
~to_raw:to_string
~of_raw:of_string_opt
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "spsk" 54
include Compare.Make (struct
type nonrec t = t
let compare a b = Bigstring.compare (Key.buffer a) (Key.buffer b)
end)
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end
type t = Sign.plain Sign.t
type watermark = Bytes.t
let name = "Secp256k1"
let title = "A Secp256k1 signature"
let size = Sign.plain_bytes
let of_bytes_opt s =
match Sign.read context (Bigstring.of_bytes s) with
| Ok s ->
Some s
| Error _ ->
None
let to_bytes t = Bigstring.to_bytes (Sign.to_bytes ~der:false context t)
let to_string s = Bytes.to_string (to_bytes s)
let of_string_opt s = of_bytes_opt (Bytes.of_string s)
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.secp256k1_signature
~length:size
~to_raw:to_string
~of_raw:of_string_opt
~wrap:(fun x -> Data x)
let () = Base58.check_encoded_prefix b58check_encoding "spsig1" 99
include Compare.Make (struct
type nonrec t = t
let compare a b = Bigstring.compare (Sign.buffer a) (Sign.buffer b)
end)
include Helpers.MakeRaw (struct
type nonrec t = t
let name = name
let of_bytes_opt = of_bytes_opt
let of_string_opt = of_string_opt
let to_string = to_string
end)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding =
let open Data_encoding in
conv to_bytes of_bytes_exn (Fixed.bytes size)
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
end)
let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
let zero = of_bytes_exn (Bytes.make size '\000')
let sign ?watermark sk msg =
let msg =
Blake2B.to_bytes @@ Blake2B.hash_bytes
@@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
in
Sign.sign_exn context ~sk (Bigstring.of_bytes msg)
let check ?watermark public_key signature msg =
let msg =
Blake2B.to_bytes @@ Blake2B.hash_bytes
@@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
in
Sign.verify_exn
context
~pk:public_key
~msg:(Bigstring.of_bytes msg)
~signature
let generate_key ?(seed = Hacl.Rand.gen 32) () =
let sk = Key.read_sk_exn context seed in
let pk = Key.neuterize_exn context sk in
let pkh = Public_key.hash pk in
(pkh, pk, sk)
let deterministic_nonce sk msg =
let msg = Bigstring.of_bytes msg in
let key = Secret_key.to_bigstring sk in
Hacl.Hash.SHA256.HMAC.digest ~key ~msg
let deterministic_nonce_hash sk msg =
let nonce = deterministic_nonce sk msg in
Blake2B.to_bytes (Blake2B.hash_bytes [Bigstring.to_bytes nonce])
src/lib_crypto/secp256k1.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Public_key_hash.
(* ❌ Structure item `include` not handled. *)
include
Module Logging.
Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp.
End Logging.
End Public_key_hash.
Import Libsecp256k1.External.
Definition context : Libsecp256k1.External.Context.t :=
let ctx := Context.create None None tt in
match Context.randomize ctx (Hacl.Rand.gen 32) with
| false =>
OCaml.Stdlib.failwith
"Secp256k1 context randomization failed. Aborting." % string
| true => ctx
end.
Module Public_key.
Definition t := Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public.
Definition name : string := "Secp256k1.Public_key" % string.
Definition title : string := "A Secp256k1 public key" % string.
Definition to_bytes {A : Type} (pk : Libsecp256k1.External.Key.t A)
: Stdlib.Bytes.t := Bigstring.to_bytes (Key.to_bytes None context pk).
Definition of_bytes_opt (s : Stdlib.Bytes.t)
: option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) :=
(* ❌ Try-with are not handled *)
try (Some (Key.read_pk_exn context (Bigstring.of_bytes s))).
Definition to_string {A : Type} (s : Libsecp256k1.External.Key.t A)
: string := Stdlib.Bytes.to_string (to_bytes s).
Definition of_string_opt (s : string)
: option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) :=
of_bytes_opt (Stdlib.Bytes.of_string s).
Definition size : Z := Key.compressed_pk_bytes.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding
: Tezos_crypto.Base58.encoding
(Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) :=
Base58.register_encoding Base58.Prefix.secp256k1_public_key size to_string
of_string_opt (fun x => Tezos_crypto.Base58.Data x).
Definition hash {A : Type} (v : Libsecp256k1.External.Key.t A)
: Public_key_hash.t :=
Public_key_hash.hash_bytes None (cons (to_bytes v) []).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Public_key.
Module Secret_key.
Definition t := Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret.
Definition name : string := "Secp256k1.Secret_key" % string.
Definition title : string := "A Secp256k1 secret key" % string.
Definition size : Z := Key.secret_bytes.
Definition of_bytes_opt (s : Stdlib.Bytes.t)
: option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
match Key.read_sk context (Bigstring.of_bytes s) with
| Stdlib.Ok x => Some x
| _ => None
end.
Definition to_bigstring
: (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) ->
Bigstring.t := Key.to_bytes None context.
Definition to_bytes
(x : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
: Stdlib.Bytes.t := Bigstring.to_bytes (to_bigstring x).
Definition to_string
(s : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
: string := Stdlib.Bytes.to_string (to_bytes s).
Definition of_string_opt (s : string)
: option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
of_bytes_opt (Stdlib.Bytes.of_string s).
Definition to_public_key {A : Type} (key : Libsecp256k1.External.Key.t A)
: Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public :=
Key.neuterize_exn context key.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding
: Tezos_crypto.Base58.encoding
(Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
Base58.register_encoding Base58.Prefix.secp256k1_secret_key size to_string
of_string_opt (fun x => Tezos_crypto.Base58.Data x).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Secret_key.
Definition t := Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain.
Definition watermark := Stdlib.Bytes.t.
Definition name : string := "Secp256k1" % string.
Definition title : string := "A Secp256k1 signature" % string.
Definition size : Z := Sign.plain_bytes.
Definition of_bytes_opt (s : Stdlib.Bytes.t)
: option (Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain) :=
match Sign.read context (Bigstring.of_bytes s) with
| Stdlib.Ok s => Some s
| Stdlib.Error _ => None
end.
Definition to_bytes {A : Type} (t : Libsecp256k1.External.Sign.t A)
: Stdlib.Bytes.t := Bigstring.to_bytes (Sign.to_bytes (Some false) context t).
Definition to_string {A : Type} (s : Libsecp256k1.External.Sign.t A) : string :=
Stdlib.Bytes.to_string (to_bytes s).
Definition of_string_opt (s : string)
: option (Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain) :=
of_bytes_opt (Stdlib.Bytes.of_string s).
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition b58check_encoding
: Tezos_crypto.Base58.encoding
(Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain) :=
Base58.register_encoding Base58.Prefix.secp256k1_signature size to_string
of_string_opt (fun x => Tezos_crypto.Base58.Data x).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
Definition zero : t := of_bytes_exn (Stdlib.Bytes.make size "000" % char).
Definition sign
(watermark : option Stdlib.Bytes.t)
(sk : Libsecp256k1__External.Key.t Libsecp256k1__External.Key.secret)
(msg : Stdlib.Bytes.t)
: Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain :=
let msg :=
apply Blake2B.to_bytes
(apply
(let arg := Blake2B.hash_bytes in
fun eta => arg None eta)
match watermark with
| None => cons msg []
| Some prefix => cons prefix (cons msg [])
end) in
Sign.sign_exn context sk (Bigstring.of_bytes msg).
Definition check {A : Type}
(watermark : option Stdlib.Bytes.t)
(public_key : Libsecp256k1__External.Key.t Libsecp256k1__External.Key.public)
(signature : Libsecp256k1.External.Sign.t A) (msg : Stdlib.Bytes.t) : bool :=
let msg :=
apply Blake2B.to_bytes
(apply
(let arg := Blake2B.hash_bytes in
fun eta => arg None eta)
match watermark with
| None => cons msg []
| Some prefix => cons prefix (cons msg [])
end) in
Sign.verify_exn context public_key (Bigstring.of_bytes msg) signature.
Definition generate_key (op_staroptstar : option Bigstring.t)
: unit ->
Public_key_hash.t *
(Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) *
(Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
let seed :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Hacl.Rand.gen 32
end in
fun function_parameter =>
let 'tt := function_parameter in
let sk := Key.read_sk_exn context seed in
let pk := Key.neuterize_exn context sk in
let pkh := Public_key.hash pk in
(pkh, pk, sk).
Definition deterministic_nonce
(sk : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
(msg : Stdlib.Bytes.t) : Bigstring.t :=
let msg := Bigstring.of_bytes msg in
let key := Secret_key.to_bigstring sk in
Hacl.Hash.SHA256.HMAC.digest key msg.
Definition deterministic_nonce_hash
(sk : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
(msg : Stdlib.Bytes.t) : Stdlib.Bytes.t :=
let nonce := deterministic_nonce sk msg in
Blake2B.to_bytes
(Blake2B.hash_bytes None (cons (Bigstring.to_bytes nonce) [])).
src/lib_crypto/secp256k1_group.ml 91 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Sp = Libsecp256k1.Internal
module type SCALAR_SIG = sig
type t
include S.B58_DATA with type t := t
include S.ENCODER with type t := t
val zero : t
val one : t
val of_Z : Z.t -> t
val to_Z : t -> Z.t
val of_int : int -> t
val add : t -> t -> t
val mul : t -> t -> t
val negate : t -> t
val sub : t -> t -> t
val of_bits_exn : string -> t
val to_bits : t -> string
val inverse : t -> t option
val pow : t -> Z.t -> t
val equal : t -> t -> bool
end
module Group : sig
val order : Z.t
module Scalar : SCALAR_SIG
type t
include S.B58_DATA with type t := t
include S.ENCODER with type t := t
val e : t
val g : t
val h : t
val of_coordinates : x:Z.t -> y:Z.t -> t
val of_bits_exn : string -> t
val to_bits : t -> string
val mul : Scalar.t -> t -> t
val ( + ) : t -> t -> t
val ( - ) : t -> t -> t
val ( = ) : t -> t -> bool
end = struct
let order =
Z.of_string_base
16
"FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141"
let string_rev s =
let len = String.length s in
String.init len (fun i -> s.[len - 1 - i])
let b32_of_Z z =
let cs = Cstruct.create 32 in
let bits = Z.to_bits z in
let length = min 32 (String.length bits) in
let bits = String.sub bits 0 length in
let bits = string_rev bits in
Cstruct.blit_from_string bits 0 cs (32 - length) length ;
cs
let z_of_b32 b = b |> Cstruct.to_string |> string_rev |> Z.of_bits
module Scalar : SCALAR_SIG with type t = Sp.Scalar.t = struct
type t = Sp.Scalar.t
let zero = Sp.Scalar.zero ()
let one = Sp.Scalar.one ()
let equal x y = Sp.Scalar.equal x y
let of_Z z =
let z = Z.erem z order in
let r = Sp.Scalar.const () in
let cs = b32_of_Z z in
let _ = Sp.Scalar.set_b32 r cs in
r
let to_Z s =
let cs = Cstruct.create 32 in
Sp.Scalar.get_b32 cs s ; cs |> z_of_b32
let of_int i = i |> Z.of_int |> of_Z
let pow t n = Z.powm (to_Z t) n order |> of_Z
let add x y =
let r = Sp.Scalar.const () in
let _ = Sp.Scalar.add r x y in
r
let mul x y =
let r = Sp.Scalar.const () in
Sp.Scalar.mul r x y ; r
let negate x =
let r = Sp.Scalar.const () in
Sp.Scalar.negate r x ; r
let sub x y = add x (negate y)
let of_bits_exn bits =
let r = Sp.Scalar.const () in
(* trim to 32 bytes *)
let cs = Cstruct.create 32 in
Cstruct.blit_from_string bits 0 cs 0 (min (String.length bits) 32) ;
(* ignore overflow condition, it's always 0 based on the c-code *)
let _ = Sp.Scalar.set_b32 r cs in
r
(* TODO, check that we are less than the order *)
let to_bits x =
let c = Cstruct.create 32 in
Sp.Scalar.get_b32 c x ; Cstruct.to_string c
let inverse x =
if x = zero then None
else
let r = Sp.Scalar.const () in
Sp.Scalar.inverse r x ; Some r
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.secp256k1_scalar
~length:32
~to_raw:to_bits
~of_raw:(fun s -> try Some (of_bits_exn s) with _ -> None)
~wrap:(fun x -> Data x)
let title = "Secp256k1_group.Scalar"
let name = "Anscalar for the secp256k1 group"
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding = Data_encoding.(conv to_bits of_bits_exn string)
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
end)
end
type t = Sp.Group.Jacobian.t
(* type ge = Sp.Group.ge *)
let field_of_Z z =
let fe = Sp.Field.const () in
let cs = b32_of_Z z in
let _ = Sp.Field.set_b32 fe cs in
fe
let group_of_jacobian j =
let r = Sp.Group.of_fields () in
Sp.Group.Jacobian.get_ge r j ;
r
let jacobian_of_group g =
let j = Sp.Group.Jacobian.of_fields () in
Sp.Group.Jacobian.set_ge j g ;
j
let of_coordinates ~x ~y =
Sp.Group.of_fields ~x:(field_of_Z x) ~y:(field_of_Z y) ()
|> jacobian_of_group
let e = Sp.Group.Jacobian.of_fields ~infinity:true ()
let g =
let gx =
Z.of_string
"55066263022277343669578718895168534326250603453777594175500187360389116729240"
and gy =
Z.of_string
"32670510020758816978083085130507043184471273380659243275938904335757337482424"
in
of_coordinates ~x:gx ~y:gy
(* To obtain the second generator, take the sha256 hash of the decimal representation of g1_y
python -c "import hashlib;print int(hashlib.sha256('32670510020758816978083085130507043184471273380659243275938904335757337482424').hexdigest(),16)"
*)
let h =
let hx =
Z.of_string
"54850469061264194188802857211425616972714231399857248865148107587305936171824"
and hy =
Z.of_string
"6558914719042992724977242403721980463337660510165027616783569279181206179101"
in
of_coordinates ~x:hx ~y:hy
let ( + ) x y =
let r = Sp.Group.Jacobian.of_fields () in
Sp.Group.Jacobian.add_var r x y ;
r
let ( - ) x y =
let neg_y = Sp.Group.Jacobian.of_fields () in
Sp.Group.Jacobian.neg neg_y y ;
x + neg_y
let ( = ) x y = Sp.Group.Jacobian.is_infinity (x - y)
let mul s g =
let r = Sp.Group.Jacobian.of_fields () in
Sp.Group.Jacobian.mul r (group_of_jacobian g) s ;
r
let to_bits j =
let x = group_of_jacobian j and buf = Cstruct.create 33 in
let cs = Sp.Group.to_pubkey ~compress:true buf x in
Cstruct.to_string cs
let of_bits_exn bits =
let buf = Cstruct.of_string bits and x = Sp.Group.of_fields () in
Sp.Group.from_pubkey x buf ; x |> jacobian_of_group
module Encoding = struct
type Base58.data += Data of t
let title = "Secp256k1_group.Group"
let name = "An element of secp256k1"
let b58check_encoding =
Base58.register_encoding
~prefix:Base58.Prefix.secp256k1_element
~length:33
~to_raw:to_bits
~of_raw:(fun s -> try Some (of_bits_exn s) with _ -> None)
~wrap:(fun x -> Data x)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding = Data_encoding.(conv to_bits of_bits_exn string)
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
end)
end
include Encoding
end
src/lib_crypto/secp256k1_group.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ This kind of module is not handled. *)
unhandled_module
Module SCALAR_SIG.
Record signature {t : Type} := {
t := t;
include;
include;
zero : t;
one : t;
of_Z : Z.t -> t;
to_Z : t -> Z.t;
of_int : Z -> t;
add : t -> t -> t;
mul : t -> t -> t;
negate : t -> t;
sub : t -> t -> t;
of_bits_exn : string -> t;
to_bits : t -> string;
inverse : t -> option t;
pow : t -> Z.t -> t;
equal : t -> t -> bool;
}.
Arguments signature : clear implicits.
End SCALAR_SIG.
Module Group.
Definition order : Z.t :=
Z.of_string_base 16
"FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141" %
string.
Definition string_rev (s : string) : string :=
let len := OCaml.String.length s in
Stdlib.String.init len
(fun i => Stdlib.String.get s (Z.sub (Z.sub len 1) i)).
Definition b32_of_Z (z : Z.t) : Cstruct.t :=
let cs := Cstruct.create 32 in
let bits := Z.to_bits z in
let length := OCaml.Stdlib.min 32 (OCaml.String.length bits) in
let bits := Stdlib.String.sub bits 0 length in
let bits := string_rev bits in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Cstruct.blit_from_string bits 0 cs (Z.sub 32 length) length in
cs.
Definition z_of_b32 (b : Cstruct.t) : Z.t :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply b Cstruct.to_string) string_rev) Z.of_bits.
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition t := Sp.Group.Jacobian.t.
Definition field_of_Z (z : Z.t) : Sp.Field.t :=
let fe := Sp.Field.const None None None None None None None None tt in
let cs := b32_of_Z z in
let '_ := Sp.Field.set_b32 fe cs in
fe.
Definition group_of_jacobian (j : Sp.Group.Jacobian.t) : Sp.Group.t :=
let r := Sp.Group.of_fields None None None tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sp.Group.Jacobian.get_ge r j in
r.
Definition jacobian_of_group (g : Libsecp256k1__Internal.Group.ge)
: Sp.Group.Jacobian.t :=
let j := Sp.Group.Jacobian.of_fields None None None None tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sp.Group.Jacobian.set_ge j g in
j.
Definition of_coordinates (x : Z.t) (y : Z.t) : Sp.Group.Jacobian.t :=
OCaml.Stdlib.reverse_apply
(Sp.Group.of_fields (Some (field_of_Z x)) (Some (field_of_Z y)) None tt)
jacobian_of_group.
Definition e : Sp.Group.Jacobian.t :=
Sp.Group.Jacobian.of_fields None None None (Some true) tt.
Definition g : Sp.Group.Jacobian.t :=
let gx : Z.t :=
Z.of_string
"55066263022277343669578718895168534326250603453777594175500187360389116729240"
% string
with gy : Z.t :=
Z.of_string
"32670510020758816978083085130507043184471273380659243275938904335757337482424"
% string in
of_coordinates gx gy.
Definition h : Sp.Group.Jacobian.t :=
let hx : Z.t :=
Z.of_string
"54850469061264194188802857211425616972714231399857248865148107587305936171824"
% string
with hy : Z.t :=
Z.of_string
"6558914719042992724977242403721980463337660510165027616783569279181206179101"
% string in
of_coordinates hx hy.
Definition op_plus (x : Sp.Group.Jacobian.t) (y : Sp.Group.Jacobian.t)
: Sp.Group.Jacobian.t :=
let r := Sp.Group.Jacobian.of_fields None None None None tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sp.Group.Jacobian.add_var None r x y in
r.
Definition op_minus (x : Sp.Group.Jacobian.t) (y : Sp.Group.Jacobian.t)
: Sp.Group.Jacobian.t :=
let neg_y := Sp.Group.Jacobian.of_fields None None None None tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sp.Group.Jacobian.neg neg_y y in
op_plus x neg_y.
Definition op_eq (x : Sp.Group.Jacobian.t) (y : Sp.Group.Jacobian.t) : bool :=
Sp.Group.Jacobian.is_infinity (op_minus x y).
Definition mul (s : Libsecp256k1__Internal.Scalar.t) (g : Sp.Group.Jacobian.t)
: Sp.Group.Jacobian.t :=
let r := Sp.Group.Jacobian.of_fields None None None None tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sp.Group.Jacobian.mul r (group_of_jacobian g) s in
r.
Definition to_bits (j : Sp.Group.Jacobian.t) : string :=
let x : Sp.Group.t :=
group_of_jacobian j
with buf : Cstruct.t :=
Cstruct.create 33 in
let cs := Sp.Group.to_pubkey (Some true) buf x in
Cstruct.to_string cs.
Definition of_bits_exn (bits : string) : Sp.Group.Jacobian.t :=
let buf : Cstruct.t :=
Cstruct.of_string None None None bits
with x : Sp.Group.t :=
Sp.Group.of_fields None None None tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Sp.Group.from_pubkey x buf in
OCaml.Stdlib.reverse_apply x jacobian_of_group.
Module Encoding.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition title : string := "Secp256k1_group.Group" % string.
Definition name : string := "An element of secp256k1" % string.
Definition b58check_encoding
: Tezos_crypto.Base58.encoding Sp.Group.Jacobian.t :=
Base58.register_encoding Base58.Prefix.secp256k1_element 33 to_bits
(fun s =>
(* ❌ Try-with are not handled *)
try (Some (of_bits_exn s))) (fun x => Tezos_crypto.Base58.Data x).
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
End Encoding.
(* ❌ Structure item `include` not handled. *)
include
End Group.
src/lib_crypto/test/roundtrips.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let test_rt_opt name testable enc dec input =
try
let roundtripped = dec (enc input) in
Alcotest.check (Alcotest.option testable) name (Some input) roundtripped
with exc ->
Alcotest.failf
"%s failed for %a: exception whilst decoding: %s"
name
(Alcotest.pp testable)
input
(Printexc.to_string exc)
let test_decode_opt_safe name testable dec encoded =
match dec encoded with
| Some _ | None ->
()
| exception exc ->
Alcotest.failf
"%s failed for %a: exception whilst decoding: %s"
name
(Alcotest.pp testable)
encoded
(Printexc.to_string exc)
let test_decode_opt_fail name testable dec encoded =
try
let decoded = dec encoded in
Alcotest.check (Alcotest.option testable) name None decoded
with exc ->
Alcotest.failf
"%s failed: exception whilst decoding: %s"
name
(Printexc.to_string exc)
src/lib_crypto/test/roundtrips.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition test_rt_opt {A B C D E F : Type}
(name : A) (testable : B) (enc : C -> D) (dec : D -> E) (input : C) : F :=
(* ❌ Try-with are not handled *)
try
(let roundtripped := dec (enc input) in
op_startypeminuserrorstar (op_startypeminuserrorstar testable) name
(Some input) roundtripped).
Definition test_decode_opt_safe {A B C D : Type}
(name : A) (testable : B) (dec : C -> option D) (encoded : C) : unit :=
let 'Some _ | None := dec encoded in
tt.
Definition test_decode_opt_fail {A B C D E : Type}
(name : A) (testable : B) (dec : C -> D) (encoded : C) : E :=
(* ❌ Try-with are not handled *)
try
(let decoded := dec encoded in
op_startypeminuserrorstar (op_startypeminuserrorstar testable) name None
decoded).
src/lib_crypto/test/test_base58.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let test_roundtrip_safe input =
Roundtrips.test_rt_opt
"safe base58"
Alcotest.string
Base58.safe_encode
Base58.safe_decode
input
let test_roundtrip_raw input =
Roundtrips.test_rt_opt
"raw base58"
Alcotest.string
Base58.raw_encode
Base58.raw_decode
input
let inputs =
[ "abc";
string_of_int max_int;
"0";
"00";
"000";
"0000";
"0000000000000000";
String.make 64 '0';
"1";
"11";
"111";
"1111";
String.make 2048 '0';
"2";
"22";
"5";
"Z";
String.make 2048 'Z';
"z";
"zz";
"zzzzzzzz";
String.make 2048 'z';
(*loads of ascii characters: codes between 32 and 126 *)
String.init 1000 (fun i -> Char.chr (32 + (i mod (126 - 32))));
"" ]
let test_roundtrip_safes () = List.iter test_roundtrip_safe inputs
let test_roundtrip_raws () = List.iter test_roundtrip_raw inputs
let test_safety input =
Roundtrips.test_decode_opt_safe
"safe base58"
Alcotest.string
Base58.safe_decode
input
let test_safetys () = List.iter test_safety inputs
let tests =
[ ("safe decoding", `Quick, test_safetys);
("safe encoding/decoding", `Quick, test_roundtrip_safes);
("raw encoding/decoding", `Quick, test_roundtrip_raws) ]
let () = Alcotest.run "tezos-crypto" [("base58", tests)]
src/lib_crypto/test/test_base58.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition test_roundtrip_safe {A B : Type} (input : A) : B :=
op_startypeminuserrorstar "safe base58" % string op_startypeminuserrorstar
Base58.safe_encode Base58.safe_decode input.
Definition test_roundtrip_raw {A B : Type} (input : A) : B :=
op_startypeminuserrorstar "raw base58" % string op_startypeminuserrorstar
Base58.raw_encode Base58.raw_decode input.
Definition inputs : list string :=
cons "abc" % string
(cons (OCaml.Stdlib.string_of_int Stdlib.max_int)
(cons "0" % string
(cons "00" % string
(cons "000" % string
(cons "0000" % string
(cons "0000000000000000" % string
(cons (Stdlib.String.make 64 "0" % char)
(cons "1" % string
(cons "11" % string
(cons "111" % string
(cons "1111" % string
(cons (Stdlib.String.make 2048 "0" % char)
(cons "2" % string
(cons "22" % string
(cons "5" % string
(cons "Z" % string
(cons (Stdlib.String.make 2048 "Z" % char)
(cons "z" % string
(cons "zz" % string
(cons "zzzzzzzz" % string
(cons
(Stdlib.String.make 2048
"z" % char)
(cons
(Stdlib.String.init 1000
(fun i =>
Char.chr
(Z.add 32
(Z.modulo i
(Z.sub 126 32)))))
(cons "" % string []))))))))))))))))))))))).
Definition test_roundtrip_safes (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Stdlib.List.iter test_roundtrip_safe inputs.
Definition test_roundtrip_raws (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Stdlib.List.iter test_roundtrip_raw inputs.
Definition test_safety {A B : Type} (input : A) : B :=
op_startypeminuserrorstar "safe base58" % string op_startypeminuserrorstar
Base58.safe_decode input.
Definition test_safetys (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Stdlib.List.iter test_safety inputs.
Definition tests : list (string * variant * (unit -> unit)) :=
cons
("safe decoding" % string,
(* ❌ Variants not supported *)
variant, test_safetys)
(cons
("safe encoding/decoding" % string,
(* ❌ Variants not supported *)
variant, test_roundtrip_safes)
(cons
("raw encoding/decoding" % string,
(* ❌ Variants not supported *)
variant, test_roundtrip_raws) [])).
src/lib_crypto/test/test_blake2b.ml 7 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let test_hashed_roundtrip name enc dec input =
(* this wrapper to start with hashing *)
Roundtrips.test_rt_opt
name
(Alcotest.testable
(fun fmt (input, _) -> Format.fprintf fmt "%s" input)
(fun (_, hashed) (_, decoded) -> hashed = decoded))
(fun (_, hashed) -> enc hashed)
(fun encoded ->
match dec encoded with
| None ->
None
| Some decoded ->
Some (input, decoded))
(input, Blake2B.hash_string [input])
let test_roundtrip_hex input =
test_hashed_roundtrip "Hex" Blake2B.to_hex Blake2B.of_hex_opt input
let test_roundtrip_string input =
test_hashed_roundtrip "String" Blake2B.to_string Blake2B.of_string_opt input
let inputs =
[ "abc";
string_of_int max_int;
"0";
"00";
String.make 64 '0';
(*loads of ascii characters: codes between 32 and 126 *)
String.init 1000 (fun i -> Char.chr (32 + (i mod (126 - 32))));
"" ]
let test_roundtrip_hexs () = List.iter test_roundtrip_hex inputs
let test_roundtrip_strings () = List.iter test_roundtrip_string inputs
let tests =
[ ("hash hex/dehex", `Quick, test_roundtrip_hexs);
("hash print/parse", `Quick, test_roundtrip_strings) ]
let () = Alcotest.run "tezos-crypto" [("blake2b", tests)]
src/lib_crypto/test/test_blake2b.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition test_hashed_roundtrip {A B C D E F : Type}
(name : A) (enc : B -> C) (dec : D -> option E) (input : string) : F :=
op_startypeminuserrorstar name
(op_startypeminuserrorstar
(fun fmt =>
fun function_parameter =>
let '(input, _) := function_parameter in
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) input)
(fun function_parameter =>
let '(_, hashed) := function_parameter in
fun function_parameter =>
let '(_, decoded) := function_parameter in
equiv_decb hashed decoded))
(fun function_parameter =>
let '(_, hashed) := function_parameter in
enc hashed)
(fun encoded =>
match dec encoded with
| None => None
| Some decoded => Some (input, decoded)
end) (input, (Blake2B.hash_string None (cons input []))).
Definition test_roundtrip_hex {A : Type} (input : string) : A :=
test_hashed_roundtrip "Hex" % string Blake2B.to_hex Blake2B.of_hex_opt input.
Definition test_roundtrip_string {A : Type} (input : string) : A :=
test_hashed_roundtrip "String" % string Blake2B.to_string
Blake2B.of_string_opt input.
Definition inputs : list string :=
cons "abc" % string
(cons (OCaml.Stdlib.string_of_int Stdlib.max_int)
(cons "0" % string
(cons "00" % string
(cons (Stdlib.String.make 64 "0" % char)
(cons
(Stdlib.String.init 1000
(fun i => Char.chr (Z.add 32 (Z.modulo i (Z.sub 126 32)))))
(cons "" % string [])))))).
Definition test_roundtrip_hexs (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Stdlib.List.iter test_roundtrip_hex inputs.
Definition test_roundtrip_strings (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Stdlib.List.iter test_roundtrip_string inputs.
Definition tests : list (string * variant * (unit -> unit)) :=
cons
("hash hex/dehex" % string,
(* ❌ Variants not supported *)
variant, test_roundtrip_hexs)
(cons
("hash print/parse" % string,
(* ❌ Variants not supported *)
variant, test_roundtrip_strings) []).
src/lib_crypto/test/test_crypto_box.ml 21 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let (sk, pk, pkh) = Crypto_box.random_keypair ()
let zero_nonce = Crypto_box.zero_nonce
let chkey = Crypto_box.precompute sk pk
let test_check_pow () =
let target = Crypto_box.make_target 2. in
let pow = Crypto_box.generate_proof_of_work pk target in
Alcotest.(check bool)
"check_pow"
(Crypto_box.check_proof_of_work pk pow target)
true
let test_neutrize sk pk () =
Alcotest.check
(Alcotest.testable Crypto_box.pp_pk Crypto_box.equal)
"neuterize"
(Crypto_box.neuterize sk)
pk
let test_hash pk pkh () =
Alcotest.check
(Alcotest.testable
Crypto_box.Public_key_hash.pp
Crypto_box.Public_key_hash.equal)
"test_hash"
(Crypto_box.hash pk)
pkh
let test_fast_box msg () =
let msglen = Bytes.length msg in
let buf_length = msglen + Crypto_box.zerobytes in
let buf = Bytes.make buf_length '\x00' in
Bytes.blit msg 0 buf Crypto_box.zerobytes msglen ;
(* encryption / decryption *)
Crypto_box.fast_box_noalloc chkey zero_nonce buf ;
ignore (Crypto_box.fast_box_open_noalloc chkey zero_nonce buf) ;
let res =
Bytes.sub buf Crypto_box.zerobytes (buf_length - Crypto_box.zerobytes)
in
Alcotest.check
Alcotest.(testable (fun fmt x -> Hex.pp fmt (Hex.of_bytes x)) Bytes.equal)
"test_fastbox enc/dec"
res
msg
let tests =
[ ("Neutrize Secret roundtrip", `Quick, test_neutrize sk pk);
("Public Key Hash roundtrip", `Quick, test_hash pk pkh);
("Check PoW", `Slow, test_check_pow);
("Test hacl fastbox", `Quick, test_fast_box (Bytes.of_string "test")) ]
let () = Alcotest.run "tezos-crypto" [("crypto_box", tests)]
src/lib_crypto/test/test_crypto_box.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition zero_nonce : Tezos_crypto.Crypto_box.nonce := Crypto_box.zero_nonce.
Definition chkey : Tezos_crypto.Crypto_box.channel_key :=
Crypto_box.precompute sk pk.
Definition test_check_pow {A : Type} (function_parameter : unit) : A :=
let 'tt := function_parameter in
let target :=
Crypto_box.make_target
(* ❌ Float constant 2. is approximated by the integer 2 *)
2 in
let pow := Crypto_box.generate_proof_of_work None pk target in
op_startypeminuserrorstar "check_pow" % string
(Crypto_box.check_proof_of_work pk pow target) true.
Definition test_neutrize {A B : Type}
(sk : Tezos_crypto.Crypto_box.secret_key) (pk : A) (function_parameter : unit)
: B :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar Crypto_box.pp_pk Crypto_box.equal)
"neuterize" % string (Crypto_box.neuterize sk) pk.
Definition test_hash {A B : Type}
(pk : Tezos_crypto.Crypto_box.public_key) (pkh : A)
(function_parameter : unit) : B :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar Crypto_box.Public_key_hash.pp
Crypto_box.Public_key_hash.equal) "test_hash" % string
(Crypto_box.hash pk) pkh.
Definition test_fast_box {A : Type} (msg : string) (function_parameter : unit)
: A :=
let 'tt := function_parameter in
let msglen := String.length msg in
let buf_length := Z.add msglen Crypto_box.zerobytes in
let buf := Stdlib.Bytes.make buf_length "000" % char in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.Bytes.blit msg 0 buf Crypto_box.zerobytes msglen in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Crypto_box.fast_box_noalloc chkey zero_nonce buf in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.ignore (Crypto_box.fast_box_open_noalloc chkey zero_nonce buf)
in
let res :=
String.sub buf Crypto_box.zerobytes (Z.sub buf_length Crypto_box.zerobytes)
in
op_startypeminuserrorstar op_startypeminuserrorstar
"test_fastbox enc/dec" % string res msg.
Definition tests {A : Type} : list (string * variant * (unit -> A)) :=
cons
("Neutrize Secret roundtrip" % string,
(* ❌ Variants not supported *)
variant, (test_neutrize sk pk))
(cons
("Public Key Hash roundtrip" % string,
(* ❌ Variants not supported *)
variant, (test_hash pk pkh))
(cons
("Check PoW" % string,
(* ❌ Variants not supported *)
variant, test_check_pow)
(cons
("Test hacl fastbox" % string,
(* ❌ Variants not supported *)
variant, (test_fast_box (Stdlib.Bytes.of_string "test" % string)))
[]))).
src/lib_crypto/test/test_deterministic_nonce.ml 23 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let test_hash_matches (module X : S.SIGNATURE) () =
let (_, _, sk) = X.generate_key () in
let data = Bytes.of_string "ce input sa pun eu aici oare?" in
let nonce = X.deterministic_nonce sk data in
let nonce_hash = X.deterministic_nonce_hash sk data in
let hashed_nonce = Blake2B.hash_bytes [Bigstring.to_bytes nonce] in
if nonce_hash <> Blake2B.to_bytes hashed_nonce then
Alcotest.failf
"the hash of deterministic_nonce is NOT deterministic_nonce_hash"
let ed25519 = (module Ed25519 : S.SIGNATURE)
let p256 = (module P256 : S.SIGNATURE)
let secp256k1 = (module Secp256k1 : S.SIGNATURE)
let tests =
[ ("hash_matches_ed25519", `Quick, test_hash_matches ed25519);
("hash_matches_p256", `Quick, test_hash_matches p256);
("hash_matches_secp256k1", `Quick, test_hash_matches secp256k1) ]
let () = Alcotest.run "tezos-crypto" [("deterministic_nonce", tests)]
src/lib_crypto/test/test_deterministic_nonce.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition test_hash_matches
(X :
{'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
Public_key_hash_Table_t, Public_key_hash_Error_table_t,
Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark)
: _ &
Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
Public_key_hash_Map_t Public_key_hash_Table_t
Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t
Public_key_t Secret_key_t t watermark}) : unit -> unit :=
let X := projT2 X in
fun function_parameter =>
let 'tt := function_parameter in
let '(_, _, sk) := X.(Tezos_crypto__S.SIGNATURE.generate_key) None tt in
let data := Stdlib.Bytes.of_string "ce input sa pun eu aici oare?" % string
in
let nonce := X.(Tezos_crypto__S.SIGNATURE.deterministic_nonce) sk data in
let nonce_hash :=
X.(Tezos_crypto__S.SIGNATURE.deterministic_nonce_hash) sk data in
let hashed_nonce :=
Blake2B.hash_bytes None (cons (Bigstring.to_bytes nonce) []) in
if nequiv_decb nonce_hash (Blake2B.to_bytes hashed_nonce) then
op_startypeminuserrorstar
"the hash of deterministic_nonce is NOT deterministic_nonce_hash" %
string
else
tt.
Definition ed25519
: {'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
Public_key_hash_Table_t, Public_key_hash_Error_table_t,
Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark) :
_ &
Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
Public_key_hash_Map_t Public_key_hash_Table_t
Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t Public_key_t
Secret_key_t t watermark} := Ed25519.
Definition p256
: {'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
Public_key_hash_Table_t, Public_key_hash_Error_table_t,
Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark) :
_ &
Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
Public_key_hash_Map_t Public_key_hash_Table_t
Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t Public_key_t
Secret_key_t t watermark} := P256.
Definition secp256k1
: {'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
Public_key_hash_Table_t, Public_key_hash_Error_table_t,
Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark) :
_ &
Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
Public_key_hash_Map_t Public_key_hash_Table_t
Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t Public_key_t
Secret_key_t t watermark} := Secp256k1.
Definition tests : list (string * variant * (unit -> unit)) :=
cons
("hash_matches_ed25519" % string,
(* ❌ Variants not supported *)
variant, (test_hash_matches ed25519))
(cons
("hash_matches_p256" % string,
(* ❌ Variants not supported *)
variant, (test_hash_matches p256))
(cons
("hash_matches_secp256k1" % string,
(* ❌ Variants not supported *)
variant, (test_hash_matches secp256k1)) [])).
src/lib_crypto/test/test_ed25519.ml 17 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type B58CHECK = sig
type t
val pp : Format.formatter -> t -> unit
include S.B58_DATA with type t := t
end
let test_b58check_roundtrip :
type t. (module B58CHECK with type t = t) -> t -> unit =
fun m input ->
let module M = (val m) in
let testable = Alcotest.testable M.pp ( = ) in
Roundtrips.test_rt_opt
"b58check"
testable
M.to_b58check
M.of_b58check_opt
input
let test_b58check_roundtrips () =
let (pubkey_hash, pubkey, seckey) = Ed25519.generate_key () in
test_b58check_roundtrip (module Ed25519.Public_key_hash) pubkey_hash ;
test_b58check_roundtrip (module Ed25519.Public_key) pubkey ;
test_b58check_roundtrip (module Ed25519.Secret_key) seckey
let test_b58check_invalid input =
Roundtrips.test_decode_opt_fail
"b58check"
(Alcotest.testable Ed25519.Public_key_hash.pp Ed25519.Public_key_hash.( = ))
Ed25519.Public_key_hash.of_b58check_opt
input
let test_b58check_invalids () =
List.iter
test_b58check_invalid
[ "ThisIsGarbageNotACheck";
"\x00";
String.make 1000 '\x00';
String.make 2048 'a';
String.init 2048 (fun _ -> Char.chr (Random.int 256));
"" ]
let tests =
[ ("b58check.roundtrip", `Quick, test_b58check_roundtrips);
("b58check.invalid", `Slow, test_b58check_invalids) ]
let () = Alcotest.run "tezos-crypto" [("ed25519", tests)]
src/lib_crypto/test/test_ed25519.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module B58CHECK.
Record signature {t : Type} := {
t := t;
pp : Stdlib.Format.formatter -> t -> unit;
include;
}.
Arguments signature : clear implicits.
End B58CHECK.
Definition test_b58check_roundtrip {t : Type}
(m : {_ : unit & B58CHECK.signature t}) (input : t) : unit :=
let M := projT2 m in
let testable := op_startypeminuserrorstar M.(B58CHECK.pp) equiv_decb in
op_startypeminuserrorstar "b58check" % string testable
M.(B58CHECK.to_b58check) M.(B58CHECK.of_b58check_opt) input.
Definition test_b58check_roundtrips (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let '(pubkey_hash, pubkey, seckey) := Ed25519.generate_key None tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := test_b58check_roundtrip Ed25519.Public_key_hash pubkey_hash in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := test_b58check_roundtrip Ed25519.Public_key pubkey in
test_b58check_roundtrip Ed25519.Secret_key seckey.
Definition test_b58check_invalid {A B : Type} (input : A) : B :=
op_startypeminuserrorstar "b58check" % string
(op_startypeminuserrorstar Ed25519.Public_key_hash.pp
Ed25519.Public_key_hash.op_eq) Ed25519.Public_key_hash.of_b58check_opt
input.
Definition test_b58check_invalids (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Stdlib.List.iter test_b58check_invalid
(cons "ThisIsGarbageNotACheck" % string
(cons " " % string
(cons (Stdlib.String.make 1000 "000" % char)
(cons (Stdlib.String.make 2048 "a" % char)
(cons
(Stdlib.String.init 2048
(fun function_parameter =>
let '_ := function_parameter in
Char.chr (Random.int 256))) (cons "" % string [])))))).
Definition tests : list (string * variant * (unit -> unit)) :=
cons
("b58check.roundtrip" % string,
(* ❌ Variants not supported *)
variant, test_b58check_roundtrips)
(cons
("b58check.invalid" % string,
(* ❌ Variants not supported *)
variant, test_b58check_invalids) []).
src/lib_crypto/test/test_merkle.ml 16 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Utils.Infix
type tree = Empty | Leaf of int | Node of tree * tree
let rec list_of_tree = function
| Empty ->
([], 0)
| Leaf x ->
([x], 1)
| Node (x, y) ->
let (x, sx) = list_of_tree x and (y, sy) = list_of_tree y in
assert (sx = sy) ;
(x @ y, sx + sy)
module Merkle = Blake2B.Generic_Merkle_tree (struct
type t = tree
type elt = int
let empty = Empty
let leaf i = Leaf i
let node x y = Node (x, y)
end)
let rec compare_list xs ys =
match (xs, ys) with
| ([], []) ->
true
| ([x], y :: ys) when x = y ->
ys = [] || compare_list xs ys
| (x :: xs, y :: ys) when x = y ->
compare_list xs ys
| (_, _) ->
false
let check_size i =
let l = 0 -- i in
let (l2, _) = list_of_tree (Merkle.compute l) in
if compare_list l l2 then ()
else
Format.kasprintf
failwith
"Failed for %d: %a"
i
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.pp_print_string ppf ";")
Format.pp_print_int)
l2
let test_compute _ = List.iter check_size (0 -- 99)
let check_path i =
let l = 0 -- i in
let orig = Merkle.compute l in
List.iter
(fun j ->
let path = Merkle.compute_path l j in
let (found, pos) = Merkle.check_path path j in
if found = orig && j = pos then ()
else Format.kasprintf failwith "Failed for %d in %d." j i)
l
let test_path _ = List.iter check_path (0 -- 128)
let tests = [("compute", `Quick, test_compute); ("path", `Quick, test_path)]
let () = Alcotest.run "tezos-crypto" [("merkel", tests)]
src/lib_crypto/test/test_merkle.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Utils.Infix.
Inductive tree : Type :=
| Empty : tree
| Leaf : Z -> tree
| Node : tree -> tree -> tree.
Fixpoint list_of_tree (function_parameter : tree) : (list Z) * Z :=
match function_parameter with
| Empty => ([], 0)
| Leaf x => ((cons x []), 1)
| Node x y =>
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb sx sy) in
((OCaml.Stdlib.app x y), (Z.add sx sy))
end.
(* ❌ Applications of functors are not handled. *)
functor_application
Fixpoint compare_list {A : Type} (xs : list A) (ys : list A) : bool :=
match (xs, ys) with
| ([], []) => true
| (cons x [], cons y ys) => orb (equiv_decb ys []) (compare_list xs ys)
| (cons x xs, cons y ys) => compare_list xs ys
| (_, _) => false
end.
Definition check_size (i : Z) : unit :=
let l := op_minusminus 0 i in
let '(l2, _) := list_of_tree (Merkle.compute l) in
if compare_list l l2 then
tt
else
Format.kasprintf OCaml.Stdlib.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Failed for " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Failed for %d: %a" % string) i
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.pp_print_string ppf ";" % string)) Format.pp_print_int) l2.
Definition test_compute {A : Type} (function_parameter : A) : unit :=
let '_ := function_parameter in
Stdlib.List.iter check_size (op_minusminus 0 99).
Definition check_path (i : Z) : unit :=
let l := op_minusminus 0 i in
let orig := Merkle.compute l in
Stdlib.List.iter
(fun j =>
let path := Merkle.compute_path l j in
let '(found, pos) := Merkle.check_path path j in
if andb (equiv_decb found orig) (equiv_decb j pos) then
tt
else
Format.kasprintf OCaml.Stdlib.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Failed for " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " in " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))))
"Failed for %d in %d." % string) j i) l.
Definition test_path {A : Type} (function_parameter : A) : unit :=
let '_ := function_parameter in
Stdlib.List.iter check_path (op_minusminus 0 128).
Definition tests {A : Type} : list (string * variant * (A -> unit)) :=
cons
("compute" % string,
(* ❌ Variants not supported *)
variant, test_compute)
(cons
("path" % string,
(* ❌ Variants not supported *)
variant, test_path) []).
src/lib_crypto/test/test_pvss.ml 57 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* pvss tests here *)
module Pvss = Pvss_secp256k1
module Sp = Secp256k1_group
module Setup : sig
val shares : Pvss.Encrypted_share.t list
val commitments : Pvss.Commitment.t list
val proof : Pvss.proof
val secret_scalar : Sp.Group.Scalar.t
val secret : Pvss.Secret_key.t
val public_secret : Pvss.Public_key.t
val other_shares : Pvss.Encrypted_share.t list
val other_commitments : Pvss.Commitment.t list
val other_proof : Pvss.proof
val other_secret : Pvss.Secret_key.t
type keypair = {
secret_key : Pvss.Secret_key.t;
public_key : Pvss.Public_key.t;
}
val public_keys : Pvss.Public_key.t list
val keypairs : keypair list
val reveals :
(Pvss.Encrypted_share.t * (Pvss.Clear_share.t * Pvss.proof)) list
val convert_encoding : 'a Data_encoding.t -> 'b Data_encoding.t -> 'a -> 'b
val group_encoding : Sp.Group.t Data_encoding.t
end = struct
type keypair = {
secret_key : Pvss.Secret_key.t;
public_key : Pvss.Public_key.t;
}
let group_encoding =
Data_encoding.(conv Sp.Group.to_bits Sp.Group.of_bits_exn string)
let scalar_encoding =
Data_encoding.(
conv Sp.Group.Scalar.to_bits Sp.Group.Scalar.of_bits_exn string)
let convert_encoding de1 de2 x =
Data_encoding.Binary.of_bytes_exn
de2
(Data_encoding.Binary.to_bytes_exn de1 x)
(** Random value of Z in the range [0,2^256] *)
let rand_Z () =
[Random.int64 Int64.max_int |> Z.of_int64 |> Z.to_bits]
|> Blake2B.hash_string |> Blake2B.to_string |> Z.of_bits
(** Generates n random keypairs *)
let random_keypairs n =
List.init n (fun _ ->
let s = Sp.Group.Scalar.of_Z (rand_Z ()) in
let secret_key =
convert_encoding scalar_encoding Pvss.Secret_key.encoding s
in
{secret_key; public_key = Pvss.Secret_key.to_public_key secret_key})
let t = 5
let n = 8
let random_scalar () = Sp.Group.Scalar.of_Z (rand_Z ())
let secret_of_scalar s =
convert_encoding scalar_encoding Pvss.Secret_key.encoding s
let secret_scalar = random_scalar ()
let secret = secret_of_scalar secret_scalar
let public_secret = Pvss.Secret_key.to_public_key secret
let other_secret = secret_of_scalar (random_scalar ())
let keypairs = random_keypairs n
let public_keys = List.map (fun {public_key; _} -> public_key) keypairs
let ( (shares, commitments, proof),
(other_shares, other_commitments, other_proof) ) =
( Pvss.dealer_shares_and_proof ~secret ~t ~public_keys,
Pvss.dealer_shares_and_proof ~secret:other_secret ~t ~public_keys )
let reveals =
List.map2
(fun share keypair ->
( share,
Pvss.reveal_share
share
~secret_key:keypair.secret_key
~public_key:keypair.public_key ))
shares
keypairs
end
let test_dealer_proof () =
let shr = (Setup.shares, Setup.other_shares)
and cmt = (Setup.commitments, Setup.other_commitments)
and prf = (Setup.proof, Setup.other_proof) in
for i = 0 to 1 do
for j = 0 to 1 do
for k = 0 to 1 do
let pick = function 0 -> fst | _ -> snd in
assert (
Pvss.check_dealer_proof
(pick i shr)
(pick j cmt)
~proof:(pick k prf)
~public_keys:Setup.public_keys
= (i = j && j = k) )
done
done
done
let test_share_reveal () =
(* check reveal shares *)
let shares_valid =
List.map2
(fun (share, (reveal, proof)) public_key ->
Pvss.check_revealed_share share reveal ~public_key proof)
Setup.reveals
Setup.public_keys
in
List.iteri
(fun i b ->
print_endline (string_of_int i) ;
assert b)
shares_valid
let test_reconstruct () =
let indices = [0; 1; 2; 3; 4] in
let reconstructed =
Pvss.reconstruct
(List.map
(fun n ->
let (_, (r, _)) = List.nth Setup.reveals n in
r)
indices)
indices
in
assert (
Sp.Group.(( = ))
(Setup.convert_encoding
Pvss.Public_key.encoding
Setup.group_encoding
reconstructed)
(Setup.convert_encoding
Pvss.Public_key.encoding
Setup.group_encoding
Setup.public_secret) )
let tests =
[ ("dealer_proof", `Quick, test_dealer_proof);
("reveal", `Quick, test_share_reveal);
("recontruct", `Quick, test_reconstruct) ]
let () = Alcotest.run "test-pvss" [("pvss", tests)]
src/lib_crypto/test/test_pvss.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
Module Setup.
Record keypair := {
secret_key : Pvss.Secret_key.t;
public_key : Pvss.Public_key.t }.
Definition group_encoding
: Tezos_data_encoding.Data_encoding.encoding Sp.Group.t :=
conv Sp.Group.to_bits Sp.Group.of_bits_exn None string.
Definition scalar_encoding
: Tezos_data_encoding.Data_encoding.encoding Sp.Group.Scalar.t :=
conv Sp.Group.Scalar.to_bits Sp.Group.Scalar.of_bits_exn None string.
Definition convert_encoding {A B : Type}
(de1 : Tezos_data_encoding__Data_encoding.Encoding.t A)
(de2 : Tezos_data_encoding__Data_encoding.Encoding.t B) (x : A) : B :=
Data_encoding.Binary.of_bytes_exn de2
(Data_encoding.Binary.to_bytes_exn de1 x).
Definition rand_Z (function_parameter : unit) : Z.t :=
let 'tt := function_parameter in
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(cons
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply (Random.int64 Int64.max_int)
Z.of_int64) Z.to_bits) [])
(let arg := Blake2B.hash_string in
fun eta => arg None eta)) Blake2B.to_string) Z.of_bits.
Definition random_keypairs (n : Z) : list keypair :=
Stdlib.List.init n
(fun function_parameter =>
let '_ := function_parameter in
let s := Sp.Group.Scalar.of_Z (rand_Z tt) in
let secret_key :=
convert_encoding scalar_encoding Pvss.Secret_key.encoding s in
{| secret_key := secret_key;
public_key := Pvss.Secret_key.to_public_key secret_key |}).
Definition t : Z := 5.
Definition n : Z := 8.
Definition random_scalar (function_parameter : unit) : Sp.Group.Scalar.t :=
let 'tt := function_parameter in
Sp.Group.Scalar.of_Z (rand_Z tt).
Definition secret_of_scalar (s : Sp.Group.Scalar.t) : Pvss.Secret_key.t :=
convert_encoding scalar_encoding Pvss.Secret_key.encoding s.
Definition secret_scalar : Sp.Group.Scalar.t := random_scalar tt.
Definition secret : Pvss.Secret_key.t := secret_of_scalar secret_scalar.
Definition public_secret
: Tezos_crypto__Pvss_secp256k1.Public_key.(Tezos_crypto__Pvss_secp256k1.ENCODED.t) :=
Pvss.Secret_key.to_public_key secret.
Definition other_secret : Pvss.Secret_key.t :=
secret_of_scalar (random_scalar tt).
Definition keypairs : list keypair := random_keypairs n.
Definition public_keys : list Pvss.Public_key.t :=
List.map
(fun function_parameter =>
let '{| public_key := public_key |} := function_parameter in
public_key) keypairs.
Definition reveals
: list (Pvss.Encrypted_share.t * (Pvss.Clear_share.t * Pvss.proof)) :=
Stdlib.List.map2
(fun share =>
fun keypair =>
(share,
(Pvss.reveal_share share (secret_key keypair) (public_key keypair))))
shares keypairs.
End Setup.
Definition test_dealer_proof (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let shr : (list Pvss.Encrypted_share.t) * (list Pvss.Encrypted_share.t) :=
(Setup.shares, Setup.other_shares)
with cmt : (list Pvss.Commitment.t) * (list Pvss.Commitment.t) :=
(Setup.commitments, Setup.other_commitments)
with prf : Pvss.proof * Pvss.proof :=
(Setup.proof, Setup.other_proof) in
(* ❌ For loops not handled. *)
for.
Definition test_share_reveal (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let shares_valid :=
Stdlib.List.map2
(fun function_parameter =>
let '(share, (reveal, proof)) := function_parameter in
fun public_key =>
Pvss.check_revealed_share share reveal public_key proof) Setup.reveals
Setup.public_keys in
Stdlib.List.iteri
(fun i =>
fun b =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.print_endline (OCaml.Stdlib.string_of_int i) in
(* ❌ Assert instruction is not handled. *)
assert b) shares_valid.
Definition test_reconstruct (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let indices := cons 0 (cons 1 (cons 2 (cons 3 (cons 4 [])))) in
let reconstructed :=
Pvss.reconstruct
(List.map
(fun n =>
let '(_, (r, _)) := Stdlib.List.nth Setup.reveals n in
r) indices) indices in
(* ❌ Assert instruction is not handled. *)
assert
(op_eq
(Setup.convert_encoding Pvss.Public_key.encoding Setup.group_encoding
reconstructed)
(Setup.convert_encoding Pvss.Public_key.encoding Setup.group_encoding
Setup.public_secret)).
Definition tests : list (string * variant * (unit -> unit)) :=
cons
("dealer_proof" % string,
(* ❌ Variants not supported *)
variant, test_dealer_proof)
(cons
("reveal" % string,
(* ❌ Variants not supported *)
variant, test_share_reveal)
(cons
("recontruct" % string,
(* ❌ Variants not supported *)
variant, test_reconstruct) [])).
src/lib_crypto/znz.ml 4 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type ZN = sig
type t
include S.B58_DATA with type t := t
include S.ENCODER with type t := t
val zero : t
val one : t
val n : Z.t
val ( + ) : t -> t -> t
val ( * ) : t -> t -> t
val ( - ) : t -> t -> t
val ( = ) : t -> t -> bool
val of_int : int -> t
val of_Z : Z.t -> t
val to_Z : t -> Z.t
val of_bits_exn : String.t -> t
val to_bits : t -> String.t
val pow : t -> Z.t -> t
val inv : t -> t option
end
module type INT = sig
val n : Z.t
end
module MakeZn
(N : INT) (B : sig
val b58_prefix : string
end) : ZN = struct
type t = Z.t
let n = N.n
let max_char_length = 2 * Z.numbits n
let zero = Z.zero
let one = Z.one
let of_Z r = Z.(erem r n)
let to_Z a = a
let of_int u = u |> Z.of_int |> of_Z
let to_bits h =
h |> Zplus.serialize |> fun s -> String.sub s 0 (String.length s - 1)
let of_bits_exn bits =
(* Do not process oversized inputs. *)
if Compare.Int.(String.length bits > max_char_length) then
failwith "input too long"
else
(* Make sure the input is in the range [0, N.n-1]. Do not reduce modulo
N.n for free! *)
let x = Zplus.deserialize bits in
if Zplus.(x < zero || x >= N.n) then failwith "out of range" else of_Z x
let pow a x = Z.powm a Z.(erem x (sub n one)) n
let ( + ) x y = Z.(erem (add x y) n)
let ( * ) x y = Z.(erem (mul x y) n)
let ( - ) x y = Z.(erem (sub x y) n)
let ( = ) x y = Z.equal x y
let inv a = Zplus.invert a n
let title = Format.sprintf "Znz.Make(%s)" (Z.to_string N.n)
let name = Format.sprintf "An element of Z/nZ for n = %s" (Z.to_string N.n)
type Base58.data += Data of t
let b58check_encoding =
Base58.register_encoding
~prefix:B.b58_prefix
~length:32
~to_raw:to_bits
~of_raw:(fun s -> try Some (of_bits_exn s) with _ -> None)
~wrap:(fun x -> Data x)
include Helpers.MakeB58 (struct
type nonrec t = t
let name = name
let b58check_encoding = b58check_encoding
end)
include Helpers.MakeEncoder (struct
type nonrec t = t
let name = name
let title = title
let raw_encoding = Data_encoding.(conv to_bits of_bits_exn string)
let to_b58check = to_b58check
let to_short_b58check = to_short_b58check
let of_b58check = of_b58check
let of_b58check_opt = of_b58check_opt
let of_b58check_exn = of_b58check_exn
end)
end
src/lib_crypto/znz.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module ZN.
Record signature {t : Type} := {
t := t;
include;
include;
zero : t;
one : t;
n : Z.t;
op_plus : t -> t -> t;
op_star : t -> t -> t;
op_minus : t -> t -> t;
op_eq : t -> t -> bool;
of_int : Z -> t;
of_Z : Z.t -> t;
to_Z : t -> Z.t;
of_bits_exn : Stdlib.String.t -> t;
to_bits : t -> Stdlib.String.t;
pow : t -> Z.t -> t;
inv : t -> option t;
}.
Arguments signature : clear implicits.
End ZN.
Module INT.
Record signature := {
n : Z.t;
}.
End INT.
(* ❌ Functors are not handled. *)
functor
src/lib_crypto/zplus.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* let re_trailing_null =
Re_pcre.regexp "^(.*?)\000*$"
let remove_trailing_null s =
Re.get (Re.exec re_trailing_null s) 1 *)
let remove_trailing_null s =
let n = String.length s in
let i = ref (n - 1) in
while !i >= 0 && s.[!i] = '\000' do
i := !i - 1
done ;
String.sub s 0 (!i + 1)
let serialize z =
let n = if Z.(lt z zero) then Z.(neg (add (add z z) one)) else Z.(add z z) in
n |> Z.to_bits |> remove_trailing_null
let deserialize z =
let n = Z.of_bits z in
let z = Z.shift_right_trunc n 1 in
if Z.(n land one = zero) then z else Z.neg z
let leq a b = Z.compare a b <= 0
let geq a b = Z.compare a b >= 0
let lt a b = Z.compare a b < 0
let gt a b = Z.compare a b > 0
let ( < ) = lt
let ( > ) = gt
let ( <= ) = leq
let ( >= ) = geq
let zero = Z.zero
let one = Z.one
let invert a n = try Some (Z.invert a n) with Division_by_zero -> None
src/lib_crypto/zplus.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition remove_trailing_null (s : string) : string :=
let n := OCaml.String.length s in
let i := Stdlib.ref (Z.sub n 1) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ While loops not handled. *)
while in
Stdlib.String.sub s 0 (Z.add (Stdlib.op_exclamation i) 1).
Definition serialize (z : Z.t) : string :=
let n :=
if lt z zero then
neg (add (add z z) one)
else
add z z in
OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply n Z.to_bits)
remove_trailing_null.
Definition deserialize (z : string) : Z.t :=
let n := Z.of_bits z in
let z := Z.shift_right_trunc n 1 in
if equiv_decb (land n one) zero then
z
else
Z.neg z.
Definition leq (a : Z.t) (b : Z.t) : bool := OCaml.Stdlib.le (Z.compare a b) 0.
Definition geq (a : Z.t) (b : Z.t) : bool := OCaml.Stdlib.ge (Z.compare a b) 0.
Definition lt (a : Z.t) (b : Z.t) : bool := OCaml.Stdlib.lt (Z.compare a b) 0.
Definition gt (a : Z.t) (b : Z.t) : bool := OCaml.Stdlib.gt (Z.compare a b) 0.
Definition op_lt : Z.t -> Z.t -> bool := lt.
Definition op_gt : Z.t -> Z.t -> bool := gt.
Definition op_lteq : Z.t -> Z.t -> bool := leq.
Definition op_gteq : Z.t -> Z.t -> bool := geq.
Definition zero : Z.t := Z.zero.
Definition one : Z.t := Z.one.
Definition invert (a : Z.t) (n : Z.t) : option Z.t :=
(* ❌ Try-with are not handled *)
try (Some (Z.invert a n)).
src/lib_data_encoding/binary_description.ml 36 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type recursives = string list
type references = {
descriptions : (string * Binary_schema.toplevel_encoding) list;
}
[@@unwrapped]
(* Simple Union find implementation, there are several optimizations
that give UF it's usual time complexity that could be added.
If this is a bottleneck, they're easy to add. *)
module UF : sig
type t
val add : t -> Binary_schema.description -> unit
val find : t -> string -> Binary_schema.description
val union :
t -> new_cannonical:Binary_schema.description -> existing:string -> unit
val empty : unit -> t
end = struct
open Binary_schema
type ele = Ref of string | Root of description
type t = (string, ele) Hashtbl.t
let add t x = Hashtbl.replace t x.title (Root x)
let rec find tbl key =
match Hashtbl.find tbl key with Ref s -> find tbl s | Root desc -> desc
let union tbl ~new_cannonical ~existing =
add tbl new_cannonical ;
let root = find tbl existing in
if root.title = new_cannonical.title then ()
else Hashtbl.replace tbl root.title (Ref new_cannonical.title)
let empty () = Hashtbl.create 128
end
let fixup_references uf =
let open Binary_schema in
let rec fixup_layout = function
| Ref s ->
Ref (UF.find uf s).title
| Enum (i, name) ->
Enum (i, (UF.find uf name).title)
| Seq (layout, len) ->
Seq (fixup_layout layout, len)
| ( Zero_width
| Int _
| Bool
| RangedInt (_, _)
| RangedFloat (_, _)
| Float
| Bytes
| String
| Padding ) as enc ->
enc
in
let field = function
| Named_field (name, kind, layout) ->
Named_field (name, kind, fixup_layout layout)
| Anonymous_field (kind, layout) ->
Anonymous_field (kind, fixup_layout layout)
| (Dynamic_size_field _ | Optional_field _) as field ->
field
in
function
| Obj {fields} ->
Obj {fields = List.map field fields}
| Cases ({cases; _} as x) ->
Cases
{
x with
cases =
List.map
(fun (i, name, fields) -> (i, name, List.map field fields))
cases;
}
| Int_enum _ as ie ->
ie
let z_reference_name = "Z.t"
let z_reference_description =
"A variable length sequence of bytes, encoding a Zarith number. Each byte \
has a running unary size bit: the most significant bit of each byte tells \
is this is the last byte in the sequence (0) or if there is more to read \
(1). The second most significant bit of the first byte is reserved for the \
sign (positive if zero). Size and sign bits ignored, data is then the \
binary representation of the absolute value of the number in little endian \
order."
let z_encoding =
Binary_schema.Obj {fields = [Named_field ("Z.t", `Dynamic, Bytes)]}
let add_z_reference uf {descriptions} =
UF.add
uf
{title = z_reference_name; description = Some z_reference_description} ;
{descriptions = (z_reference_name, z_encoding) :: descriptions}
let n_reference_name = "N.t"
let n_reference_description =
"A variable length sequence of bytes, encoding a Zarith number. Each byte \
has a running unary size bit: the most significant bit of each byte tells \
is this is the last byte in the sequence (0) or if there is more to read \
(1). Size bits ignored, data is then the binary representation of the \
absolute value of the number in little endian order."
let n_encoding =
Binary_schema.Obj {fields = [Named_field ("N.t", `Dynamic, Bytes)]}
let add_n_reference uf {descriptions} =
UF.add
uf
{title = n_reference_name; description = Some n_reference_description} ;
{descriptions = (n_reference_name, n_encoding) :: descriptions}
let dedup_canonicalize uf =
let tbl :
(Binary_schema.toplevel_encoding, Binary_schema.description) Hashtbl.t =
Hashtbl.create 100
in
let rec help prev_len acc = function
| [] ->
let fixedup =
List.map
(fun (desc, layout) -> (desc, fixup_references uf layout))
acc
in
if List.length fixedup = prev_len then
List.map (fun (name, layout) -> (UF.find uf name, layout)) fixedup
else (
Hashtbl.clear tbl ;
help (List.length fixedup) [] fixedup )
| (name, layout) :: tl -> (
match Hashtbl.find_opt tbl layout with
| None ->
let desc = UF.find uf name in
Hashtbl.add tbl layout desc ;
help prev_len ((desc.title, layout) :: acc) tl
| Some original_desc ->
UF.union uf ~new_cannonical:original_desc ~existing:name ;
help prev_len acc tl )
in
help 0 []
type pdesc = P : 'x Encoding.desc -> pdesc
let describe (type x) (encoding : x Encoding.t) =
let open Encoding in
let uf = UF.empty () in
let uf_add_name title = UF.add uf {title; description = None} in
let add_reference name description {descriptions} =
{descriptions = (name, description) :: descriptions}
in
let new_reference =
let x = ref ~-1 in
fun () ->
x := !x + 1 ;
let name = "X_" ^ string_of_int !x in
uf_add_name name ; name
in
let may_new_reference = function
| None ->
new_reference ()
| Some name ->
uf_add_name name ; name
in
let rec extract_dynamic :
type x.
string option ->
x Encoding.desc ->
Binary_size.unsigned_integer option * string option * pdesc =
fun ref_name -> function
| Conv {encoding; _} ->
extract_dynamic ref_name encoding.encoding
| Describe {id = ref_name; encoding; _} ->
extract_dynamic (Some ref_name) encoding.encoding
| Splitted {encoding; _} ->
extract_dynamic ref_name encoding.encoding
| Delayed f ->
extract_dynamic ref_name (f ()).encoding
| Dynamic_size {kind; encoding} ->
(Some kind, ref_name, P encoding.encoding)
| enc ->
(None, ref_name, P enc)
in
let rec field_descr :
type a.
recursives ->
references ->
a Encoding.field ->
Binary_schema.field_descr list * references =
fun recursives references -> function
| Req {name; encoding = {encoding; _}; _}
| Dft {name; encoding = {encoding; _}; _} -> (
let (dynamics, ref_name, P field) = extract_dynamic None encoding in
let (layout, references) =
layout ref_name recursives references field
in
if layout = Zero_width then ([], references)
else
let field_descr =
Binary_schema.Named_field (name, classify_desc field, layout)
in
match dynamics with
| Some kind ->
( [Dynamic_size_field (ref_name, 1, kind); field_descr],
references )
| None ->
([field_descr], references) )
| Opt {kind = `Variable; name; encoding = {encoding; _}; _} ->
let (layout, references) =
layout None recursives references encoding
in
([Named_field (name, `Variable, layout)], references)
| Opt {kind = `Dynamic; name; encoding = {encoding; _}; _} ->
let (layout, references) =
layout None recursives references encoding
in
( [ Binary_schema.Optional_field name;
Named_field (name, classify_desc encoding, layout) ],
references )
and obj fields = Binary_schema.Obj {fields}
and union :
type a.
string option ->
recursives ->
references ->
Kind.t ->
Binary_size.tag_size ->
a case list ->
string * references =
fun ref_name recursives references kind size cases ->
let cases =
List.sort (fun (t1, _) (t2, _) -> (compare : int -> int -> int) t1 t2)
@@ List.fold_left
(fun acc case ->
match case with
| Case {tag = Json_only; _} ->
acc
| Case {tag = Tag tag; _} ->
(tag, case) :: acc)
[]
cases
in
let tag_field =
Binary_schema.Named_field
( "Tag",
`Fixed (Binary_size.tag_size size),
Int (size :> Binary_schema.integer_extended) )
in
let (cases, references) =
List.fold_right
(fun (tag, Case case) (cases, references) ->
let (fields, references) =
fields None recursives references case.encoding.encoding
in
((tag, Some case.title, tag_field :: fields) :: cases, references))
cases
([], references)
in
let name = may_new_reference ref_name in
let references =
add_reference name (Cases {kind; tag_size = size; cases}) references
in
(name, references)
and describe :
type b.
?description:string ->
title:string ->
string ->
recursives ->
references ->
b desc ->
string * references =
fun ?description ~title name recursives references encoding ->
let new_cannonical = {Binary_schema.title; description} in
UF.add uf new_cannonical ;
let (layout, references) = layout None recursives references encoding in
match layout with
| Ref ref_name ->
UF.union uf ~existing:ref_name ~new_cannonical ;
(ref_name, references)
| layout ->
UF.add uf new_cannonical ;
( name,
add_reference
name
(obj [Anonymous_field (classify_desc encoding, layout)])
references )
and enum : type a. (a, _) Hashtbl.t -> a array -> _ =
fun tbl encoding_array ->
( Binary_size.range_to_size
~minimum:0
~maximum:(Array.length encoding_array),
List.map
(fun i -> (i, fst @@ Hashtbl.find tbl encoding_array.(i)))
(List.init (Array.length encoding_array) (fun i -> i)) )
and fields :
type b.
string option ->
recursives ->
references ->
b Encoding.desc ->
Binary_schema.fields * references =
fun ref_name recursives references -> function
| Obj field ->
field_descr recursives references field
| Objs {left; right; _} ->
let (left_fields, references) =
fields None recursives references left.encoding
in
let (right_fields, references) =
fields None recursives references right.encoding
in
(left_fields @ right_fields, references)
| Null ->
([Anonymous_field (`Fixed 0, Zero_width)], references)
| Empty ->
([Anonymous_field (`Fixed 0, Zero_width)], references)
| Ignore ->
([Anonymous_field (`Fixed 0, Zero_width)], references)
| Constant _ ->
([Anonymous_field (`Fixed 0, Zero_width)], references)
| Dynamic_size {kind; encoding} ->
let (fields, refs) =
fields None recursives references encoding.encoding
in
(Dynamic_size_field (None, List.length fields, kind) :: fields, refs)
| Check_size {encoding; _} ->
fields ref_name recursives references encoding.encoding
| Conv {encoding; _} ->
fields ref_name recursives references encoding.encoding
| Describe {id = name; encoding; _} ->
fields (Some name) recursives references encoding.encoding
| Splitted {encoding; _} ->
fields ref_name recursives references encoding.encoding
| Delayed func ->
fields ref_name recursives references (func ()).encoding
| List (len, {encoding; _}) ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (`Variable, Seq (layout, len))], references)
| Array (len, {encoding; _}) ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (`Variable, Seq (layout, len))], references)
| Bytes kind ->
([Anonymous_field ((kind :> Kind.t), Bytes)], references)
| String kind ->
([Anonymous_field ((kind :> Kind.t), String)], references)
| Padded ({encoding = e; _}, n) ->
let (fields, references) = fields ref_name recursives references e in
(fields @ [Named_field ("padding", `Fixed n, Padding)], references)
| String_enum (tbl, encoding_array) as encoding ->
let (size, cases) = enum tbl encoding_array in
let name = may_new_reference ref_name in
( [Anonymous_field (classify_desc encoding, Ref name)],
add_reference name (Int_enum {size; cases}) references )
| Tup {encoding; _} ->
let (layout, references) =
layout ref_name recursives references encoding
in
if layout = Zero_width then ([], references)
else ([Anonymous_field (classify_desc encoding, layout)], references)
| Tups {left; right; _} ->
let (fields1, references) =
fields None recursives references left.encoding
in
let (fields2, references) =
fields None recursives references right.encoding
in
(fields1 @ fields2, references)
| Union {kind; tag_size; cases} ->
let (name, references) =
union None recursives references kind tag_size cases
in
([Anonymous_field (kind, Ref name)], references)
| Mu {kind; name; title; description; fix} as encoding ->
let kind = (kind :> Kind.t) in
let title = match title with Some title -> title | None -> name in
if List.mem name recursives then
([Anonymous_field (kind, Ref name)], references)
else
let {encoding; _} = fix {encoding; json_encoding = None} in
let (name, references) =
describe
~title
?description
name
(name :: recursives)
references
encoding
in
([Anonymous_field (kind, Ref name)], references)
| Bool as encoding ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (classify_desc encoding, layout)], references)
| Int8 as encoding ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (classify_desc encoding, layout)], references)
| Uint8 as encoding ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (classify_desc encoding, layout)], references)
| Int16 as encoding ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (classify_desc encoding, layout)], references)
| Uint16 as encoding ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (classify_desc encoding, layout)], references)
| Int31 as encoding ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (classify_desc encoding, layout)], references)
| Int32 as encoding ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (classify_desc encoding, layout)], references)
| Int64 as encoding ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (classify_desc encoding, layout)], references)
| N as encoding ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (classify_desc encoding, layout)], references)
| Z as encoding ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (classify_desc encoding, layout)], references)
| RangedInt _ as encoding ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (classify_desc encoding, layout)], references)
| RangedFloat _ as encoding ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (classify_desc encoding, layout)], references)
| Float as encoding ->
let (layout, references) =
layout None recursives references encoding
in
([Anonymous_field (classify_desc encoding, layout)], references)
and layout :
type c.
string option ->
recursives ->
references ->
c Encoding.desc ->
Binary_schema.layout * references =
fun ref_name recursives references -> function
| Null ->
(Zero_width, references)
| Empty ->
(Zero_width, references)
| Ignore ->
(Zero_width, references)
| Constant _ ->
(Zero_width, references)
| Bool ->
(Bool, references)
| Int8 ->
(Int `Int8, references)
| Uint8 ->
(Int `Uint8, references)
| Int16 ->
(Int `Int16, references)
| Uint16 ->
(Int `Uint16, references)
| Int31 ->
(RangedInt (~-1073741824, 1073741823), references)
| Int32 ->
(Int `Int32, references)
| Int64 ->
(Int `Int64, references)
| N ->
(Ref n_reference_name, add_n_reference uf references)
| Z ->
(Ref z_reference_name, add_z_reference uf references)
| RangedInt {minimum; maximum} ->
(RangedInt (minimum, maximum), references)
| RangedFloat {minimum; maximum} ->
(RangedFloat (minimum, maximum), references)
| Float ->
(Float, references)
| Bytes _kind ->
(Bytes, references)
| String _kind ->
(String, references)
| Padded _ as enc ->
let name = may_new_reference ref_name in
let (fields, references) = fields None recursives references enc in
let references = add_reference name (obj fields) references in
(Ref name, references)
| String_enum (tbl, encoding_array) ->
let name = may_new_reference ref_name in
let (size, cases) = enum tbl encoding_array in
let references =
add_reference name (Int_enum {size; cases}) references
in
(Enum (size, name), references)
| Array (len, data) ->
let (descr, references) =
layout None recursives references data.encoding
in
(Seq (descr, len), references)
| List (len, data) ->
let (layout, references) =
layout None recursives references data.encoding
in
(Seq (layout, len), references)
| Obj (Req {encoding = {encoding; _}; _})
| Obj (Dft {encoding = {encoding; _}; _}) ->
layout ref_name recursives references encoding
| Obj (Opt _) as enc ->
let name = may_new_reference ref_name in
let (fields, references) = fields None recursives references enc in
let references = add_reference name (obj fields) references in
(Ref name, references)
| Objs {left; right; _} ->
let name = may_new_reference ref_name in
let (fields1, references) =
fields None recursives references left.encoding
in
let (fields2, references) =
fields None recursives references right.encoding
in
let references =
add_reference name (obj (fields1 @ fields2)) references
in
(Ref name, references)
| Tup {encoding; _} ->
layout ref_name recursives references encoding
| Tups _ as descr ->
let name = may_new_reference ref_name in
let (fields, references) = fields None recursives references descr in
let references = add_reference name (obj fields) references in
(Ref name, references)
| Union {kind; tag_size; cases} ->
let (name, references) =
union ref_name recursives references kind tag_size cases
in
(Ref name, references)
| Mu {name; title; description; fix; _} as encoding ->
let title = match title with Some title -> title | None -> name in
if List.mem name recursives then (Ref name, references)
else
let {encoding; _} = fix {encoding; json_encoding = None} in
let (name, references) =
describe
name
~title
?description
(name :: recursives)
references
encoding
in
(Ref name, references)
| Conv {encoding; _} ->
layout ref_name recursives references encoding.encoding
| Describe {id = name; encoding; _} ->
layout (Some name) recursives references encoding.encoding
| Splitted {encoding; _} ->
layout ref_name recursives references encoding.encoding
| Dynamic_size _ as encoding ->
let name = may_new_reference ref_name in
let (fields, references) =
fields None recursives references encoding
in
UF.add uf {title = name; description = None} ;
(Ref name, add_reference name (obj fields) references)
| Check_size {encoding; _} ->
layout ref_name recursives references encoding.encoding
| Delayed func ->
layout ref_name recursives references (func ()).encoding
in
let (fields, references) =
fields None [] {descriptions = []} encoding.encoding
in
uf_add_name "" ;
let (_, toplevel) = List.hd (dedup_canonicalize uf [("", obj fields)]) in
let filtered =
List.filter
(fun (name, encoding) ->
match encoding with
| Binary_schema.Obj {fields = [Anonymous_field (_, Ref reference)]} ->
UF.union uf ~new_cannonical:(UF.find uf name) ~existing:reference ;
false
| _ ->
true)
references.descriptions
in
let fields = List.rev (dedup_canonicalize uf filtered) in
{Binary_schema.toplevel; fields}
src/lib_data_encoding/binary_description.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition recursives := list string.
Record references := {
descriptions :
list (string * Tezos_data_encoding.Binary_schema.toplevel_encoding) }.
Module UF.
Import Binary_schema.
Inductive ele : Type :=
| Ref : string -> ele
| Root : Tezos_data_encoding.Binary_schema.description -> ele.
Definition t := Stdlib.Hashtbl.t string ele.
Definition add
(t : Stdlib.Hashtbl.t string ele)
(x : Tezos_data_encoding.Binary_schema.description) : unit :=
Hashtbl.replace t (title x) (Root x).
Fixpoint find (tbl : Stdlib.Hashtbl.t string ele) (key : string)
: Tezos_data_encoding.Binary_schema.description :=
match Hashtbl.find tbl key with
| Ref s => find tbl s
| Root desc => desc
end.
Definition union
(tbl : Stdlib.Hashtbl.t string ele)
(new_cannonical : Tezos_data_encoding.Binary_schema.description)
(existing : string) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := add tbl new_cannonical in
let root := find tbl existing in
if equiv_decb (title root) (title new_cannonical) then
tt
else
Hashtbl.replace tbl (title root) (Ref (title new_cannonical)).
Definition empty {A B : Type} (function_parameter : unit)
: Stdlib.Hashtbl.t A B :=
let 'tt := function_parameter in
Hashtbl.create None 128.
End UF.
Definition fixup_references (uf : UF.t)
: Tezos_data_encoding.Binary_schema.toplevel_encoding ->
Tezos_data_encoding.Binary_schema.toplevel_encoding :=
let fix fixup_layout
(function_parameter : Tezos_data_encoding.Binary_schema.layout)
: Tezos_data_encoding.Binary_schema.layout :=
match function_parameter with
| Tezos_data_encoding.Binary_schema.Ref s =>
Tezos_data_encoding.Binary_schema.Ref (title (UF.find uf s))
| Tezos_data_encoding.Binary_schema.Enum i name =>
Tezos_data_encoding.Binary_schema.Enum i (title (UF.find uf name))
| Tezos_data_encoding.Binary_schema.Seq layout len =>
Tezos_data_encoding.Binary_schema.Seq (fixup_layout layout) len
|
(Tezos_data_encoding.Binary_schema.Zero_width |
Tezos_data_encoding.Binary_schema.Int _ |
Tezos_data_encoding.Binary_schema.Bool |
Tezos_data_encoding.Binary_schema.RangedInt _ _ |
Tezos_data_encoding.Binary_schema.RangedFloat _ _ |
Tezos_data_encoding.Binary_schema.Float |
Tezos_data_encoding.Binary_schema.Bytes |
Tezos_data_encoding.Binary_schema.String |
Tezos_data_encoding.Binary_schema.Padding) as enc => enc
end in
let field (function_parameter : Tezos_data_encoding.Binary_schema.field_descr)
: Tezos_data_encoding.Binary_schema.field_descr :=
match function_parameter with
| Tezos_data_encoding.Binary_schema.Named_field name kind layout =>
Tezos_data_encoding.Binary_schema.Named_field name kind
(fixup_layout layout)
| Tezos_data_encoding.Binary_schema.Anonymous_field kind layout =>
Tezos_data_encoding.Binary_schema.Anonymous_field kind
(fixup_layout layout)
|
(Tezos_data_encoding.Binary_schema.Dynamic_size_field _ _ _ |
Tezos_data_encoding.Binary_schema.Optional_field _) as field => field
end in
fun function_parameter =>
match function_parameter with
| Tezos_data_encoding.Binary_schema.Obj {| fields := fields |} =>
Tezos_data_encoding.Binary_schema.Obj
{| fields := List.map field fields |}
| Tezos_data_encoding.Binary_schema.Cases ({| cases := cases |} as x) =>
Tezos_data_encoding.Binary_schema.Cases
(* ❌ Record substitution not handled *)
record_substitution
| (Tezos_data_encoding.Binary_schema.Int_enum _) as ie => ie
end.
Definition z_reference_name : string := "Z.t" % string.
Definition z_reference_description : string :=
"A variable length sequence of bytes, encoding a Zarith number. Each byte has a running unary size bit: the most significant bit of each byte tells is this is the last byte in the sequence (0) or if there is more to read (1). The second most significant bit of the first byte is reserved for the sign (positive if zero). Size and sign bits ignored, data is then the binary representation of the absolute value of the number in little endian order."
% string.
Definition z_encoding : Tezos_data_encoding.Binary_schema.toplevel_encoding :=
Tezos_data_encoding.Binary_schema.Obj
{|
fields :=
cons
(Tezos_data_encoding.Binary_schema.Named_field "Z.t" % string
(* ❌ Variants not supported *)
variant Tezos_data_encoding.Binary_schema.Bytes) [] |}.
Definition add_z_reference (uf : UF.t) (function_parameter : references)
: references :=
let '{| descriptions := descriptions |} := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
UF.add uf
{| title := z_reference_name; description := Some z_reference_description
|} in
{| descriptions := cons (z_reference_name, z_encoding) descriptions |}.
Definition n_reference_name : string := "N.t" % string.
Definition n_reference_description : string :=
"A variable length sequence of bytes, encoding a Zarith number. Each byte has a running unary size bit: the most significant bit of each byte tells is this is the last byte in the sequence (0) or if there is more to read (1). Size bits ignored, data is then the binary representation of the absolute value of the number in little endian order."
% string.
Definition n_encoding : Tezos_data_encoding.Binary_schema.toplevel_encoding :=
Tezos_data_encoding.Binary_schema.Obj
{|
fields :=
cons
(Tezos_data_encoding.Binary_schema.Named_field "N.t" % string
(* ❌ Variants not supported *)
variant Tezos_data_encoding.Binary_schema.Bytes) [] |}.
Definition add_n_reference (uf : UF.t) (function_parameter : references)
: references :=
let '{| descriptions := descriptions |} := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
UF.add uf
{| title := n_reference_name; description := Some n_reference_description
|} in
{| descriptions := cons (n_reference_name, n_encoding) descriptions |}.
Definition dedup_canonicalize (uf : UF.t)
: (list (string * Tezos_data_encoding.Binary_schema.toplevel_encoding)) ->
list
(Tezos_data_encoding.Binary_schema.description *
Tezos_data_encoding.Binary_schema.toplevel_encoding) :=
let tbl := Hashtbl.create None 100 in
let fix help
(prev_len : Z) (acc :
list (string * Tezos_data_encoding.Binary_schema.toplevel_encoding))
(function_parameter :
list (string * Tezos_data_encoding.Binary_schema.toplevel_encoding))
: list
(Tezos_data_encoding.Binary_schema.description *
Tezos_data_encoding.Binary_schema.toplevel_encoding) :=
match function_parameter with
| [] =>
let fixedup :=
List.map
(fun function_parameter =>
let '(desc, layout) := function_parameter in
(desc, (fixup_references uf layout))) acc in
if equiv_decb (OCaml.List.length fixedup) prev_len then
List.map
(fun function_parameter =>
let '(name, layout) := function_parameter in
((UF.find uf name), layout)) fixedup
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Hashtbl.clear tbl in
help (OCaml.List.length fixedup) [] fixedup
| cons (name, layout) tl =>
match Hashtbl.find_opt tbl layout with
| None =>
let desc := UF.find uf name in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Hashtbl.add tbl layout desc in
help prev_len (cons ((title desc), layout) acc) tl
| Some original_desc =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := UF.union uf original_desc name in
help prev_len acc tl
end
end in
help 0 [].
Inductive pdesc : Type :=
| P : forall {x : Type}, (Tezos_data_encoding.Encoding.desc x) -> pdesc.
Definition describe {A : Type} (encoding : Tezos_data_encoding.Encoding.t A)
: Tezos_data_encoding.Binary_schema.t :=
let uf := UF.empty tt in
let uf_add_name (title : string) : unit :=
UF.add uf {| title := title; description := None |} in
let add_reference
(name : string) (description :
Tezos_data_encoding.Binary_schema.toplevel_encoding) (function_parameter :
references) : references :=
let '{| descriptions := descriptions |} := function_parameter in
{| descriptions := cons (name, description) descriptions |} in
let new_reference :=
let x := Stdlib.ref (Z.opp 1) in
fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq x (Z.add (Stdlib.op_exclamation x) 1) in
let name :=
String.append "X_" % string
(OCaml.Stdlib.string_of_int (Stdlib.op_exclamation x)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := uf_add_name name in
name in
let may_new_reference (function_parameter : option string) : string :=
match function_parameter with
| None => new_reference tt
| Some name =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := uf_add_name name in
name
end in
let fix extract_dynamic {x : Type}
(ref_name : option string) (function_parameter :
Tezos_data_encoding.Encoding.desc x)
: (option Tezos_data_encoding.Binary_size.unsigned_integer) *
(option string) * pdesc :=
match function_parameter with
| Tezos_data_encoding.Encoding.Conv {| encoding := encoding |} =>
extract_dynamic ref_name (encoding encoding)
|
Tezos_data_encoding.Encoding.Describe {|
id := ref_name; encoding := encoding |} =>
extract_dynamic (Some ref_name) (encoding encoding)
| Tezos_data_encoding.Encoding.Splitted {| encoding := encoding |} =>
extract_dynamic ref_name (encoding encoding)
| Tezos_data_encoding.Encoding.Delayed f =>
extract_dynamic ref_name (encoding (f tt))
|
Tezos_data_encoding.Encoding.Dynamic_size {|
kind := kind; encoding := encoding |} =>
((Some kind), ref_name, (P (encoding encoding)))
| enc => (None, ref_name, (P enc))
end in
let fix field_descr {a : Type}
(recursives : recursives) (references : references) (function_parameter :
Tezos_data_encoding.Encoding.field a)
: (list Tezos_data_encoding.Binary_schema.field_descr) * references :=
match function_parameter with
|
Tezos_data_encoding.Encoding.Req {|
name := name; encoding := {| encoding := encoding |} |} |
Tezos_data_encoding.Encoding.Dft {|
name := name; encoding := {| encoding := encoding |} |} =>
let '(dynamics, ref_name, P field) := extract_dynamic None encoding in
let '(layout, references) := layout ref_name recursives references field
in
if equiv_decb layout Tezos_data_encoding.Binary_schema.Zero_width then
([], references)
else
let field_descr :=
Tezos_data_encoding.Binary_schema.Named_field name
(classify_desc field) layout in
match dynamics with
| Some kind =>
((cons
(Tezos_data_encoding.Binary_schema.Dynamic_size_field ref_name 1
kind) (cons field_descr [])), references)
| None => ((cons field_descr []), references)
end
|
Tezos_data_encoding.Encoding.Opt {|
name := name;
kind := Variable;
encoding := {| encoding := encoding |}
|} =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Named_field name
(* ❌ Variants not supported *)
variant layout) []), references)
|
Tezos_data_encoding.Encoding.Opt {|
name := name;
kind := Dynamic;
encoding := {| encoding := encoding |}
|} =>
let '(layout, references) := layout None recursives references encoding in
((cons (Tezos_data_encoding.Binary_schema.Optional_field name)
(cons
(Tezos_data_encoding.Binary_schema.Named_field name
(classify_desc encoding) layout) [])), references)
end
with obj (fields : Tezos_data_encoding.Binary_schema.fields)
: Tezos_data_encoding.Binary_schema.toplevel_encoding :=
Tezos_data_encoding.Binary_schema.Obj {| fields := fields |}
with union {a : Type}
(ref_name : option string) (recursives : recursives) (references :
references) (kind : Tezos_data_encoding.Encoding.Kind.t) (size :
Tezos_data_encoding.Binary_size.tag_size) (cases :
list (Tezos_data_encoding.Encoding.case a)) : string * references :=
let cases :=
apply
(Stdlib.List.sort
(fun function_parameter =>
let '(t1, _) := function_parameter in
fun function_parameter =>
let '(t2, _) := function_parameter in
OCaml.Stdlib.compare t1 t2))
(Stdlib.List.fold_left
(fun acc =>
fun case =>
match case with
|
Tezos_data_encoding.Encoding.Case {|
tag := Tezos_data_encoding.Encoding.Json_only |} => acc
|
Tezos_data_encoding.Encoding.Case {|
tag := Tezos_data_encoding.Encoding.Tag tag |} =>
cons (tag, case) acc
end) [] cases) in
let tag_field :=
Tezos_data_encoding.Binary_schema.Named_field "Tag" % string
(* ❌ Variants not supported *)
variant (Tezos_data_encoding.Binary_schema.Int size) in
let '(cases, references) :=
Stdlib.List.fold_right
(fun function_parameter =>
let '(tag, Tezos_data_encoding.Encoding.Case case) :=
function_parameter in
fun function_parameter =>
let '(cases, references) := function_parameter in
let '(fields, references) :=
fields None recursives references (encoding (encoding case)) in
((cons (tag, (Some (title case)), (cons tag_field fields)) cases),
references)) cases ([], references) in
let name := may_new_reference ref_name in
let references :=
add_reference name
(Tezos_data_encoding.Binary_schema.Cases
{| kind := kind; tag_size := size; cases := cases |}) references in
(name, references)
with describe {b : Type}
(description : option string) (title : string) (name : string) (recursives :
recursives) (references : references) (encoding :
Tezos_data_encoding.Encoding.desc b) : string * references :=
let new_cannonical :=
{| Binary_schema.title := title; Binary_schema.description := description
|} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := UF.add uf new_cannonical in
let '(layout, references) := layout None recursives references encoding in
match layout with
| Tezos_data_encoding.Binary_schema.Ref ref_name =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := UF.union uf new_cannonical ref_name in
(ref_name, references)
| layout =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := UF.add uf new_cannonical in
(name,
(add_reference name
(obj
(cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) [])) references))
end
with enum {a : Type}
(tbl : Stdlib.Hashtbl.t a (string * Z)) (encoding_array : array a)
: Tezos_data_encoding.Binary_size.integer * (list (Z * string)) :=
((Binary_size.range_to_size 0 (Array.length encoding_array)),
(List.map
(fun i =>
(i, (apply fst (Hashtbl.find tbl (Array.get encoding_array i)))))
(Stdlib.List.init (Array.length encoding_array) (fun i => i))))
with fields {b : Type}
(ref_name : option string) (recursives : recursives) (references :
references) (function_parameter : Tezos_data_encoding.Encoding.desc b)
: Tezos_data_encoding.Binary_schema.fields * references :=
match function_parameter with
| Tezos_data_encoding.Encoding.Obj field =>
field_descr recursives references field
| Tezos_data_encoding.Encoding.Objs {| left := left; right := right |} =>
let '(left_fields, references) :=
fields None recursives references (encoding left) in
let '(right_fields, references) :=
fields None recursives references (encoding right) in
((OCaml.Stdlib.app left_fields right_fields), references)
| Tezos_data_encoding.Encoding.Null =>
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(* ❌ Variants not supported *)
variant Tezos_data_encoding.Binary_schema.Zero_width) []), references)
| Tezos_data_encoding.Encoding.Empty =>
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(* ❌ Variants not supported *)
variant Tezos_data_encoding.Binary_schema.Zero_width) []), references)
| Tezos_data_encoding.Encoding.Ignore =>
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(* ❌ Variants not supported *)
variant Tezos_data_encoding.Binary_schema.Zero_width) []), references)
| Tezos_data_encoding.Encoding.Constant _ =>
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(* ❌ Variants not supported *)
variant Tezos_data_encoding.Binary_schema.Zero_width) []), references)
|
Tezos_data_encoding.Encoding.Dynamic_size {|
kind := kind; encoding := encoding |} =>
let '(fields, refs) :=
fields None recursives references (encoding encoding) in
((cons
(Tezos_data_encoding.Binary_schema.Dynamic_size_field None
(OCaml.List.length fields) kind) fields), refs)
| Tezos_data_encoding.Encoding.Check_size {| encoding := encoding |} =>
fields ref_name recursives references (encoding encoding)
| Tezos_data_encoding.Encoding.Conv {| encoding := encoding |} =>
fields ref_name recursives references (encoding encoding)
|
Tezos_data_encoding.Encoding.Describe {|
id := name; encoding := encoding |} =>
fields (Some name) recursives references (encoding encoding)
| Tezos_data_encoding.Encoding.Splitted {| encoding := encoding |} =>
fields ref_name recursives references (encoding encoding)
| Tezos_data_encoding.Encoding.Delayed func =>
fields ref_name recursives references (encoding (func tt))
| Tezos_data_encoding.Encoding.List len {| encoding := encoding |} =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(* ❌ Variants not supported *)
variant (Tezos_data_encoding.Binary_schema.Seq layout len)) []),
references)
| Tezos_data_encoding.Encoding.Array len {| encoding := encoding |} =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(* ❌ Variants not supported *)
variant (Tezos_data_encoding.Binary_schema.Seq layout len)) []),
references)
| Tezos_data_encoding.Encoding.Bytes kind =>
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field kind
Tezos_data_encoding.Binary_schema.Bytes) []), references)
| Tezos_data_encoding.Encoding.String kind =>
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field kind
Tezos_data_encoding.Binary_schema.String) []), references)
| Tezos_data_encoding.Encoding.Padded {| encoding := e |} n =>
let '(fields, references) := fields ref_name recursives references e in
((OCaml.Stdlib.app fields
(cons
(Tezos_data_encoding.Binary_schema.Named_field "padding" % string
(* ❌ Variants not supported *)
variant Tezos_data_encoding.Binary_schema.Padding) [])), references)
| (Tezos_data_encoding.Encoding.String_enum tbl encoding_array) as encoding
=>
let '(size, cases) := enum tbl encoding_array in
let name := may_new_reference ref_name in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) (Tezos_data_encoding.Binary_schema.Ref name))
[]),
(add_reference name
(Tezos_data_encoding.Binary_schema.Int_enum
{| size := size; cases := cases |}) references))
| Tezos_data_encoding.Encoding.Tup {| encoding := encoding |} =>
let '(layout, references) :=
layout ref_name recursives references encoding in
if equiv_decb layout Tezos_data_encoding.Binary_schema.Zero_width then
([], references)
else
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) []), references)
| Tezos_data_encoding.Encoding.Tups {| left := left; right := right |} =>
let '(fields1, references) :=
fields None recursives references (encoding left) in
let '(fields2, references) :=
fields None recursives references (encoding right) in
((OCaml.Stdlib.app fields1 fields2), references)
|
Tezos_data_encoding.Encoding.Union {|
kind := kind; tag_size := tag_size; cases := cases |} =>
let '(name, references) :=
union None recursives references kind tag_size cases in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field kind
(Tezos_data_encoding.Binary_schema.Ref name)) []), references)
|
(Tezos_data_encoding.Encoding.Mu {|
kind := kind;
name := name;
title := title;
description := description;
fix := fix
|}) as encoding =>
let kind := kind in
let title :=
match title with
| Some title => title
| None => name
end in
if Stdlib.List.mem name recursives then
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field kind
(Tezos_data_encoding.Binary_schema.Ref name)) []), references)
else
let '{| encoding := encoding |} :=
fix {| encoding := encoding; json_encoding := None |} in
let '(name, references) :=
describe description title name (cons name recursives) references
encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field kind
(Tezos_data_encoding.Binary_schema.Ref name)) []), references)
| Tezos_data_encoding.Encoding.Bool as encoding =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) []), references)
| Tezos_data_encoding.Encoding.Int8 as encoding =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) []), references)
| Tezos_data_encoding.Encoding.Uint8 as encoding =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) []), references)
| Tezos_data_encoding.Encoding.Int16 as encoding =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) []), references)
| Tezos_data_encoding.Encoding.Uint16 as encoding =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) []), references)
| Tezos_data_encoding.Encoding.Int31 as encoding =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) []), references)
| Tezos_data_encoding.Encoding.Int32 as encoding =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) []), references)
| Tezos_data_encoding.Encoding.Int64 as encoding =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) []), references)
| Tezos_data_encoding.Encoding.N as encoding =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) []), references)
| Tezos_data_encoding.Encoding.Z as encoding =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) []), references)
| (Tezos_data_encoding.Encoding.RangedInt _) as encoding =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) []), references)
| (Tezos_data_encoding.Encoding.RangedFloat _) as encoding =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) []), references)
| Tezos_data_encoding.Encoding.Float as encoding =>
let '(layout, references) := layout None recursives references encoding in
((cons
(Tezos_data_encoding.Binary_schema.Anonymous_field
(classify_desc encoding) layout) []), references)
end
with layout {c : Type}
(ref_name : option string) (recursives : recursives) (references :
references) (function_parameter : Tezos_data_encoding.Encoding.desc c)
: Tezos_data_encoding.Binary_schema.layout * references :=
match function_parameter with
| Tezos_data_encoding.Encoding.Null =>
(Tezos_data_encoding.Binary_schema.Zero_width, references)
| Tezos_data_encoding.Encoding.Empty =>
(Tezos_data_encoding.Binary_schema.Zero_width, references)
| Tezos_data_encoding.Encoding.Ignore =>
(Tezos_data_encoding.Binary_schema.Zero_width, references)
| Tezos_data_encoding.Encoding.Constant _ =>
(Tezos_data_encoding.Binary_schema.Zero_width, references)
| Tezos_data_encoding.Encoding.Bool =>
(Tezos_data_encoding.Binary_schema.Bool, references)
| Tezos_data_encoding.Encoding.Int8 =>
((Tezos_data_encoding.Binary_schema.Int
(* ❌ Variants not supported *)
variant), references)
| Tezos_data_encoding.Encoding.Uint8 =>
((Tezos_data_encoding.Binary_schema.Int
(* ❌ Variants not supported *)
variant), references)
| Tezos_data_encoding.Encoding.Int16 =>
((Tezos_data_encoding.Binary_schema.Int
(* ❌ Variants not supported *)
variant), references)
| Tezos_data_encoding.Encoding.Uint16 =>
((Tezos_data_encoding.Binary_schema.Int
(* ❌ Variants not supported *)
variant), references)
| Tezos_data_encoding.Encoding.Int31 =>
((Tezos_data_encoding.Binary_schema.RangedInt (Z.opp 1073741824)
1073741823), references)
| Tezos_data_encoding.Encoding.Int32 =>
((Tezos_data_encoding.Binary_schema.Int
(* ❌ Variants not supported *)
variant), references)
| Tezos_data_encoding.Encoding.Int64 =>
((Tezos_data_encoding.Binary_schema.Int
(* ❌ Variants not supported *)
variant), references)
| Tezos_data_encoding.Encoding.N =>
((Tezos_data_encoding.Binary_schema.Ref n_reference_name),
(add_n_reference uf references))
| Tezos_data_encoding.Encoding.Z =>
((Tezos_data_encoding.Binary_schema.Ref z_reference_name),
(add_z_reference uf references))
|
Tezos_data_encoding.Encoding.RangedInt {|
minimum := minimum; maximum := maximum |} =>
((Tezos_data_encoding.Binary_schema.RangedInt minimum maximum), references)
|
Tezos_data_encoding.Encoding.RangedFloat {|
minimum := minimum; maximum := maximum |} =>
((Tezos_data_encoding.Binary_schema.RangedFloat minimum maximum),
references)
| Tezos_data_encoding.Encoding.Float =>
(Tezos_data_encoding.Binary_schema.Float, references)
| Tezos_data_encoding.Encoding.Bytes _kind =>
(Tezos_data_encoding.Binary_schema.Bytes, references)
| Tezos_data_encoding.Encoding.String _kind =>
(Tezos_data_encoding.Binary_schema.String, references)
| (Tezos_data_encoding.Encoding.Padded _ _) as enc =>
let name := may_new_reference ref_name in
let '(fields, references) := fields None recursives references enc in
let references := add_reference name (obj fields) references in
((Tezos_data_encoding.Binary_schema.Ref name), references)
| Tezos_data_encoding.Encoding.String_enum tbl encoding_array =>
let name := may_new_reference ref_name in
let '(size, cases) := enum tbl encoding_array in
let references :=
add_reference name
(Tezos_data_encoding.Binary_schema.Int_enum
{| size := size; cases := cases |}) references in
((Tezos_data_encoding.Binary_schema.Enum size name), references)
| Tezos_data_encoding.Encoding.Array len data =>
let '(descr, references) :=
layout None recursives references (encoding data) in
((Tezos_data_encoding.Binary_schema.Seq descr len), references)
| Tezos_data_encoding.Encoding.List len data =>
let '(layout, references) :=
layout None recursives references (encoding data) in
((Tezos_data_encoding.Binary_schema.Seq layout len), references)
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Req {|
encoding := {| encoding := encoding |} |}) |
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Dft {|
encoding := {| encoding := encoding |} |}) =>
layout ref_name recursives references encoding
|
(Tezos_data_encoding.Encoding.Obj (Tezos_data_encoding.Encoding.Opt _)) as
enc =>
let name := may_new_reference ref_name in
let '(fields, references) := fields None recursives references enc in
let references := add_reference name (obj fields) references in
((Tezos_data_encoding.Binary_schema.Ref name), references)
| Tezos_data_encoding.Encoding.Objs {| left := left; right := right |} =>
let name := may_new_reference ref_name in
let '(fields1, references) :=
fields None recursives references (encoding left) in
let '(fields2, references) :=
fields None recursives references (encoding right) in
let references :=
add_reference name (obj (OCaml.Stdlib.app fields1 fields2)) references
in
((Tezos_data_encoding.Binary_schema.Ref name), references)
| Tezos_data_encoding.Encoding.Tup {| encoding := encoding |} =>
layout ref_name recursives references encoding
| (Tezos_data_encoding.Encoding.Tups _) as descr =>
let name := may_new_reference ref_name in
let '(fields, references) := fields None recursives references descr in
let references := add_reference name (obj fields) references in
((Tezos_data_encoding.Binary_schema.Ref name), references)
|
Tezos_data_encoding.Encoding.Union {|
kind := kind; tag_size := tag_size; cases := cases |} =>
let '(name, references) :=
union ref_name recursives references kind tag_size cases in
((Tezos_data_encoding.Binary_schema.Ref name), references)
|
(Tezos_data_encoding.Encoding.Mu {|
name := name;
title := title;
description := description;
fix := fix
|}) as encoding =>
let title :=
match title with
| Some title => title
| None => name
end in
if Stdlib.List.mem name recursives then
((Tezos_data_encoding.Binary_schema.Ref name), references)
else
let '{| encoding := encoding |} :=
fix {| encoding := encoding; json_encoding := None |} in
let '(name, references) :=
describe description title name (cons name recursives) references
encoding in
((Tezos_data_encoding.Binary_schema.Ref name), references)
| Tezos_data_encoding.Encoding.Conv {| encoding := encoding |} =>
layout ref_name recursives references (encoding encoding)
|
Tezos_data_encoding.Encoding.Describe {|
id := name; encoding := encoding |} =>
layout (Some name) recursives references (encoding encoding)
| Tezos_data_encoding.Encoding.Splitted {| encoding := encoding |} =>
layout ref_name recursives references (encoding encoding)
| (Tezos_data_encoding.Encoding.Dynamic_size _) as encoding =>
let name := may_new_reference ref_name in
let '(fields, references) := fields None recursives references encoding in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := UF.add uf {| title := name; description := None |} in
((Tezos_data_encoding.Binary_schema.Ref name),
(add_reference name (obj fields) references))
| Tezos_data_encoding.Encoding.Check_size {| encoding := encoding |} =>
layout ref_name recursives references (encoding encoding)
| Tezos_data_encoding.Encoding.Delayed func =>
layout ref_name recursives references (encoding (func tt))
end in
let '(fields, references) :=
fields None [] {| descriptions := [] |} (encoding encoding) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := uf_add_name "" % string in
let '(_, toplevel) :=
Stdlib.List.hd (dedup_canonicalize uf (cons ("" % string, (obj fields)) []))
in
let filtered :=
Stdlib.List.filter
(fun function_parameter =>
let '(name, encoding) := function_parameter in
match encoding with
|
Tezos_data_encoding.Binary_schema.Obj {|
fields :=
cons
(Tezos_data_encoding.Binary_schema.Anonymous_field _
(Tezos_data_encoding.Binary_schema.Ref
reference)) []
|} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := UF.union uf (UF.find uf name) reference in
false
| _ => true
end) (descriptions references) in
let fields := List.rev (dedup_canonicalize uf filtered) in
{| Binary_schema.toplevel := toplevel; Binary_schema.fields := fields |}.
src/lib_data_encoding/binary_error.ml 8 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type read_error =
| Not_enough_data
| Extra_bytes
| No_case_matched
| Unexpected_tag of int
| Invalid_size of int
| Invalid_int of {min : int; v : int; max : int}
| Invalid_float of {min : float; v : float; max : float}
| Trailing_zero
| Size_limit_exceeded
| List_too_long
| Array_too_long
let pp_read_error ppf = function
| Not_enough_data ->
Format.fprintf ppf "Not enough data"
| Extra_bytes ->
Format.fprintf ppf "Extra bytes"
| No_case_matched ->
Format.fprintf ppf "No case matched"
| Unexpected_tag tag ->
Format.fprintf ppf "Unexpected tag %d" tag
| Invalid_size sz ->
Format.fprintf ppf "Invalid size %d" sz
| Invalid_int {min; v; max} ->
Format.fprintf ppf "Invalid int (%d <= %d <= %d) " min v max
| Invalid_float {min; v; max} ->
Format.fprintf ppf "Invalid float (%f <= %f <= %f) " min v max
| Trailing_zero ->
Format.fprintf ppf "Trailing zero in Z"
| Size_limit_exceeded ->
Format.fprintf ppf "Size limit exceeded"
| List_too_long ->
Format.fprintf ppf "List length limit exceeded"
| Array_too_long ->
Format.fprintf ppf "Array length limit exceeded"
exception Read_error of read_error
type write_error =
| Size_limit_exceeded
| No_case_matched
| Invalid_int of {min : int; v : int; max : int}
| Invalid_float of {min : float; v : float; max : float}
| Invalid_bytes_length of {expected : int; found : int}
| Invalid_string_length of {expected : int; found : int}
| Invalid_natural
| List_too_long
| Array_too_long
let pp_write_error ppf = function
| Size_limit_exceeded ->
Format.fprintf ppf "Size limit exceeded"
| No_case_matched ->
Format.fprintf ppf "No case matched"
| Invalid_int {min; v; max} ->
Format.fprintf ppf "Invalid int (%d <= %d <= %d) " min v max
| Invalid_float {min; v; max} ->
Format.fprintf ppf "Invalid float (%f <= %f <= %f) " min v max
| Invalid_bytes_length {expected; found} ->
Format.fprintf
ppf
"Invalid bytes length (expected: %d ; found %d)"
expected
found
| Invalid_string_length {expected; found} ->
Format.fprintf
ppf
"Invalid string length (expected: %d ; found %d)"
expected
found
| Invalid_natural ->
Format.fprintf ppf "Negative natural"
| List_too_long ->
Format.fprintf ppf "List length limit exceeded"
| Array_too_long ->
Format.fprintf ppf "Array length limit exceeded"
exception Write_error of write_error
src/lib_data_encoding/binary_error.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive read_error : Type :=
| Not_enough_data : read_error
| Extra_bytes : read_error
| No_case_matched : read_error
| Unexpected_tag : Z -> read_error
| Invalid_size : Z -> read_error
| Invalid_int : Z -> Z -> Z -> read_error
| Invalid_float : Z -> Z -> Z -> read_error
| Trailing_zero : read_error
| Size_limit_exceeded : read_error
| List_too_long : read_error
| Array_too_long : read_error.
Definition pp_read_error
(ppf : Stdlib.Format.formatter) (function_parameter : read_error) : unit :=
match function_parameter with
| Not_enough_data =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Not enough data" % string
CamlinternalFormatBasics.End_of_format) "Not enough data" % string)
| Extra_bytes =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Extra bytes" % string
CamlinternalFormatBasics.End_of_format) "Extra bytes" % string)
| No_case_matched =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "No case matched" % string
CamlinternalFormatBasics.End_of_format) "No case matched" % string)
| Unexpected_tag tag =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Unexpected tag " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"Unexpected tag %d" % string) tag
| Invalid_size sz =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Invalid size " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "Invalid size %d" % string)
sz
| Invalid_int {| min := min; v := v; max := max |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Invalid int (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " <= " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " <= " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ") " % string
CamlinternalFormatBasics.End_of_format)))))))
"Invalid int (%d <= %d <= %d) " % string) min v max
| Invalid_float {| min := min; v := v; max := max |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Invalid float (" % string
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " <= " % string
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " <= " % string
(CamlinternalFormatBasics.Float
CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ") " % string
CamlinternalFormatBasics.End_of_format)))))))
"Invalid float (%f <= %f <= %f) " % string) min v max
| Trailing_zero =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Trailing zero in Z" % string
CamlinternalFormatBasics.End_of_format) "Trailing zero in Z" % string)
| Size_limit_exceeded =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Size limit exceeded" % string
CamlinternalFormatBasics.End_of_format) "Size limit exceeded" % string)
| List_too_long =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"List length limit exceeded" % string
CamlinternalFormatBasics.End_of_format)
"List length limit exceeded" % string)
| Array_too_long =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Array length limit exceeded" % string
CamlinternalFormatBasics.End_of_format)
"Array length limit exceeded" % string)
end.
(* ❌ The definition of exceptions is not handled. *)
exception
Inductive write_error : Type :=
| Size_limit_exceeded : write_error
| No_case_matched : write_error
| Invalid_int : Z -> Z -> Z -> write_error
| Invalid_float : Z -> Z -> Z -> write_error
| Invalid_bytes_length : Z -> Z -> write_error
| Invalid_string_length : Z -> Z -> write_error
| Invalid_natural : write_error
| List_too_long : write_error
| Array_too_long : write_error.
Definition pp_write_error
(ppf : Stdlib.Format.formatter) (function_parameter : write_error) : unit :=
match function_parameter with
| Size_limit_exceeded =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Size limit exceeded" % string
CamlinternalFormatBasics.End_of_format) "Size limit exceeded" % string)
| No_case_matched =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "No case matched" % string
CamlinternalFormatBasics.End_of_format) "No case matched" % string)
| Invalid_int {| min := min; v := v; max := max |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Invalid int (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " <= " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " <= " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ") " % string
CamlinternalFormatBasics.End_of_format)))))))
"Invalid int (%d <= %d <= %d) " % string) min v max
| Invalid_float {| min := min; v := v; max := max |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Invalid float (" % string
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " <= " % string
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " <= " % string
(CamlinternalFormatBasics.Float
CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ") " % string
CamlinternalFormatBasics.End_of_format)))))))
"Invalid float (%f <= %f <= %f) " % string) min v max
| Invalid_bytes_length {| expected := expected; found := found |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid bytes length (expected: " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " ; found " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"Invalid bytes length (expected: %d ; found %d)" % string) expected
found
| Invalid_string_length {| expected := expected; found := found |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid string length (expected: " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " ; found " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"Invalid string length (expected: %d ; found %d)" % string) expected
found
| Invalid_natural =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Negative natural" % string
CamlinternalFormatBasics.End_of_format) "Negative natural" % string)
| List_too_long =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"List length limit exceeded" % string
CamlinternalFormatBasics.End_of_format)
"List length limit exceeded" % string)
| Array_too_long =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Array length limit exceeded" % string
CamlinternalFormatBasics.End_of_format)
"Array length limit exceeded" % string)
end.
(* ❌ The definition of exceptions is not handled. *)
exception
src/lib_data_encoding/binary_length.ml 23 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Binary_error
let n_length value =
let bits = Z.numbits value in
if bits = 0 then 1 else (bits + 6) / 7
let z_length value = (Z.numbits value + 1 + 6) / 7
let rec length : type x. x Encoding.t -> x -> int =
fun e value ->
let open Encoding in
match e.encoding with
(* Fixed *)
| Null ->
0
| Empty ->
0
| Constant _ ->
0
| Bool ->
Binary_size.bool
| Int8 ->
Binary_size.int8
| Uint8 ->
Binary_size.uint8
| Int16 ->
Binary_size.int16
| Uint16 ->
Binary_size.uint16
| Int31 ->
Binary_size.int31
| Int32 ->
Binary_size.int32
| Int64 ->
Binary_size.int64
| N ->
n_length value
| Z ->
z_length value
| RangedInt {minimum; maximum} ->
Binary_size.integer_to_size
@@ Binary_size.range_to_size ~minimum ~maximum
| Float ->
Binary_size.float
| RangedFloat _ ->
Binary_size.float
| Bytes (`Fixed n) ->
n
| String (`Fixed n) ->
n
| Padded (e, n) ->
length e value + n
| String_enum (_, arr) ->
Binary_size.integer_to_size @@ Binary_size.enum_size arr
| Objs {kind = `Fixed n; _} ->
n
| Tups {kind = `Fixed n; _} ->
n
| Union {kind = `Fixed n; _} ->
n
(* Dynamic *)
| Objs {kind = `Dynamic; left; right} ->
let (v1, v2) = value in
length left v1 + length right v2
| Tups {kind = `Dynamic; left; right} ->
let (v1, v2) = value in
length left v1 + length right v2
| Union {kind = `Dynamic; tag_size; cases} ->
let rec length_case = function
| [] ->
raise (Write_error No_case_matched)
| Case {tag = Json_only; _} :: tl ->
length_case tl
| Case {encoding = e; proj; _} :: tl -> (
match proj value with
| None ->
length_case tl
| Some value ->
Binary_size.tag_size tag_size + length e value )
in
length_case cases
| Mu {kind = `Dynamic; fix; _} ->
length (fix e) value
| Obj (Opt {kind = `Dynamic; encoding = e; _}) -> (
match value with None -> 1 | Some value -> 1 + length e value )
(* Variable *)
| Ignore ->
0
| Bytes `Variable ->
Bytes.length value
| String `Variable ->
String.length value
| Array (Some max_length, _e) when Array.length value > max_length ->
raise (Write_error Array_too_long)
| Array (_, e) ->
Array.fold_left (fun acc v -> length e v + acc) 0 value
| List (Some max_length, _e) when List.length value > max_length ->
raise (Write_error List_too_long)
| List (_, e) ->
List.fold_left (fun acc v -> length e v + acc) 0 value
| Objs {kind = `Variable; left; right} ->
let (v1, v2) = value in
length left v1 + length right v2
| Tups {kind = `Variable; left; right} ->
let (v1, v2) = value in
length left v1 + length right v2
| Obj (Opt {kind = `Variable; encoding = e; _}) -> (
match value with None -> 0 | Some value -> length e value )
| Union {kind = `Variable; tag_size; cases} ->
let rec length_case = function
| [] ->
raise (Write_error No_case_matched)
| Case {tag = Json_only; _} :: tl ->
length_case tl
| Case {encoding = e; proj; _} :: tl -> (
match proj value with
| None ->
length_case tl
| Some value ->
Binary_size.tag_size tag_size + length e value )
in
length_case cases
| Mu {kind = `Variable; fix; _} ->
length (fix e) value
(* Recursive*)
| Obj (Req {encoding = e; _}) ->
length e value
| Obj (Dft {encoding = e; _}) ->
length e value
| Tup e ->
length e value
| Conv {encoding = e; proj; _} ->
length e (proj value)
| Describe {encoding = e; _} ->
length e value
| Splitted {encoding = e; _} ->
length e value
| Dynamic_size {kind; encoding = e} ->
let length = length e value in
Binary_size.integer_to_size kind + length
| Check_size {limit; encoding = e} ->
let length = length e value in
if length > limit then raise (Write_error Size_limit_exceeded) ;
length
| Delayed f ->
length (f ()) value
let fixed_length e =
match Encoding.classify e with
| `Fixed n ->
Some n
| `Dynamic | `Variable ->
None
let fixed_length_exn e =
match fixed_length e with
| Some n ->
n
| None ->
invalid_arg "Data_encoding.Binary.fixed_length_exn"
src/lib_data_encoding/binary_length.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Binary_error.
Definition n_length (value : Z.t) : Z :=
let bits := Z.numbits value in
if equiv_decb bits 0 then
1
else
Z.div (Z.add bits 6) 7.
Definition z_length (value : Z.t) : Z :=
Z.div (Z.add (Z.add (Z.numbits value) 1) 6) 7.
Fixpoint length {x : Type} (e : Tezos_data_encoding.Encoding.t x) (value : x)
: Z :=
match encoding e with
| Tezos_data_encoding.Encoding.Null => 0
| Tezos_data_encoding.Encoding.Empty => 0
| Tezos_data_encoding.Encoding.Constant _ => 0
| Tezos_data_encoding.Encoding.Bool => Binary_size.bool
| Tezos_data_encoding.Encoding.Int8 => Binary_size.int8
| Tezos_data_encoding.Encoding.Uint8 => Binary_size.uint8
| Tezos_data_encoding.Encoding.Int16 => Binary_size.int16
| Tezos_data_encoding.Encoding.Uint16 => Binary_size.uint16
| Tezos_data_encoding.Encoding.Int31 => Binary_size.int31
| Tezos_data_encoding.Encoding.Int32 => Binary_size.int32
| Tezos_data_encoding.Encoding.Int64 => Binary_size.int64
| Tezos_data_encoding.Encoding.N => n_length value
| Tezos_data_encoding.Encoding.Z => z_length value
|
Tezos_data_encoding.Encoding.RangedInt {|
minimum := minimum; maximum := maximum |} =>
apply Binary_size.integer_to_size
(Binary_size.range_to_size minimum maximum)
| Tezos_data_encoding.Encoding.Float => Binary_size.float
| Tezos_data_encoding.Encoding.RangedFloat _ => Binary_size.float
| Tezos_data_encoding.Encoding.Bytes (Fixed n) => n
| Tezos_data_encoding.Encoding.String (Fixed n) => n
| Tezos_data_encoding.Encoding.Padded e n => Z.add (length e value) n
| Tezos_data_encoding.Encoding.String_enum _ arr =>
apply Binary_size.integer_to_size (Binary_size.enum_size arr)
| Tezos_data_encoding.Encoding.Objs {| kind := Fixed n |} => n
| Tezos_data_encoding.Encoding.Tups {| kind := Fixed n |} => n
| Tezos_data_encoding.Encoding.Union {| kind := Fixed n |} => n
|
Tezos_data_encoding.Encoding.Objs {|
kind := Dynamic; left := left; right := right |} =>
let '(v1, v2) := value in
Z.add (length left v1) (length right v2)
|
Tezos_data_encoding.Encoding.Tups {|
kind := Dynamic; left := left; right := right |} =>
let '(v1, v2) := value in
Z.add (length left v1) (length right v2)
|
Tezos_data_encoding.Encoding.Union {|
kind := Dynamic; tag_size := tag_size; cases := cases |} =>
let fix length_case
(function_parameter : list (Tezos_data_encoding.Encoding.case x)) : Z :=
match function_parameter with
| [] =>
Stdlib.raise
(Write_error Tezos_data_encoding.Binary_error.No_case_matched)
|
cons
(Tezos_data_encoding.Encoding.Case {|
tag := Tezos_data_encoding.Encoding.Json_only |}) tl =>
length_case tl
|
cons
(Tezos_data_encoding.Encoding.Case {| encoding := e; proj := proj |})
tl =>
match proj value with
| None => length_case tl
| Some value => Z.add (Binary_size.tag_size tag_size) (length e value)
end
end in
length_case cases
| Tezos_data_encoding.Encoding.Mu {| kind := Dynamic; fix := fix |} =>
length (fix e) value
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Opt {| kind := Dynamic; encoding := e |}) =>
match value with
| None => 1
| Some value => Z.add 1 (length e value)
end
| Tezos_data_encoding.Encoding.Ignore => 0
| Tezos_data_encoding.Encoding.Bytes Variable => String.length value
| Tezos_data_encoding.Encoding.String Variable => OCaml.String.length value
| Tezos_data_encoding.Encoding.Array (Some max_length) _e =>
Stdlib.raise (Write_error Tezos_data_encoding.Binary_error.Array_too_long)
| Tezos_data_encoding.Encoding.Array _ e =>
Array.fold_left (fun acc => fun v => Z.add (length e v) acc) 0 value
| Tezos_data_encoding.Encoding.List (Some max_length) _e =>
Stdlib.raise (Write_error Tezos_data_encoding.Binary_error.List_too_long)
| Tezos_data_encoding.Encoding.List _ e =>
Stdlib.List.fold_left (fun acc => fun v => Z.add (length e v) acc) 0 value
|
Tezos_data_encoding.Encoding.Objs {|
kind := Variable; left := left; right := right |} =>
let '(v1, v2) := value in
Z.add (length left v1) (length right v2)
|
Tezos_data_encoding.Encoding.Tups {|
kind := Variable; left := left; right := right |} =>
let '(v1, v2) := value in
Z.add (length left v1) (length right v2)
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Opt {| kind := Variable; encoding := e |})
=>
match value with
| None => 0
| Some value => length e value
end
|
Tezos_data_encoding.Encoding.Union {|
kind := Variable; tag_size := tag_size; cases := cases |} =>
let fix length_case
(function_parameter : list (Tezos_data_encoding.Encoding.case x)) : Z :=
match function_parameter with
| [] =>
Stdlib.raise
(Write_error Tezos_data_encoding.Binary_error.No_case_matched)
|
cons
(Tezos_data_encoding.Encoding.Case {|
tag := Tezos_data_encoding.Encoding.Json_only |}) tl =>
length_case tl
|
cons
(Tezos_data_encoding.Encoding.Case {| encoding := e; proj := proj |})
tl =>
match proj value with
| None => length_case tl
| Some value => Z.add (Binary_size.tag_size tag_size) (length e value)
end
end in
length_case cases
| Tezos_data_encoding.Encoding.Mu {| kind := Variable; fix := fix |} =>
length (fix e) value
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Req {| encoding := e |}) => length e value
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Dft {| encoding := e |}) => length e value
| Tezos_data_encoding.Encoding.Tup e => length e value
| Tezos_data_encoding.Encoding.Conv {| proj := proj; encoding := e |} =>
length e (proj value)
| Tezos_data_encoding.Encoding.Describe {| encoding := e |} => length e value
| Tezos_data_encoding.Encoding.Splitted {| encoding := e |} => length e value
| Tezos_data_encoding.Encoding.Dynamic_size {| kind := kind; encoding := e |}
=>
let length := length e value in
Z.add (Binary_size.integer_to_size kind) length
| Tezos_data_encoding.Encoding.Check_size {| limit := limit; encoding := e |}
=>
let length := length e value in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt length limit then
Stdlib.raise
(Write_error Tezos_data_encoding.Binary_error.Size_limit_exceeded)
else
tt in
length
| Tezos_data_encoding.Encoding.Delayed f => length (f tt) value
end.
Definition fixed_length {A : Type} (e : Tezos_data_encoding.Encoding.encoding A)
: option Z :=
match Encoding.classify e with
| Fixed n => Some n
| Dynamic | Variable => None
end.
Definition fixed_length_exn {A : Type}
(e : Tezos_data_encoding.Encoding.encoding A) : Z :=
match fixed_length e with
| Some n => n
| None =>
OCaml.Stdlib.invalid_arg "Data_encoding.Binary.fixed_length_exn" % string
end.
src/lib_data_encoding/binary_reader.ml 81 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Binary_error
let raise e = raise (Read_error e)
type state = {
buffer : Bytes.t;
mutable offset : int;
mutable remaining_bytes : int;
mutable allowed_bytes : int option;
}
let check_allowed_bytes state size =
match state.allowed_bytes with
| Some len when len < size ->
raise Size_limit_exceeded
| Some len ->
Some (len - size)
| None ->
None
let check_remaining_bytes state size =
if state.remaining_bytes < size then raise Not_enough_data ;
state.remaining_bytes - size
let read_atom size conv state =
let offset = state.offset in
state.remaining_bytes <- check_remaining_bytes state size ;
state.allowed_bytes <- check_allowed_bytes state size ;
state.offset <- state.offset + size ;
conv state.buffer offset
(** Reader for all the atomic types. *)
module Atom = struct
let uint8 = read_atom Binary_size.uint8 TzEndian.get_uint8
let uint16 = read_atom Binary_size.int16 TzEndian.get_uint16
let int8 = read_atom Binary_size.int8 TzEndian.get_int8
let int16 = read_atom Binary_size.int16 TzEndian.get_int16
let int32 = read_atom Binary_size.int32 TzEndian.get_int32
let int64 = read_atom Binary_size.int64 TzEndian.get_int64
let float = read_atom Binary_size.float TzEndian.get_double
let bool state = int8 state <> 0
let uint30 =
read_atom Binary_size.uint30
@@ fun buffer ofs ->
let v = Int32.to_int (TzEndian.get_int32 buffer ofs) in
if v < 0 then raise (Invalid_int {min = 0; v; max = (1 lsl 30) - 1}) ;
v
let int31 =
read_atom Binary_size.int31
@@ fun buffer ofs -> Int32.to_int (TzEndian.get_int32 buffer ofs)
let int = function
| `Int31 ->
int31
| `Int16 ->
int16
| `Int8 ->
int8
| `Uint30 ->
uint30
| `Uint16 ->
uint16
| `Uint8 ->
uint8
let ranged_int ~minimum ~maximum state =
let read_int =
match Binary_size.range_to_size ~minimum ~maximum with
| `Int8 ->
int8
| `Int16 ->
int16
| `Int31 ->
int31
| `Uint8 ->
uint8
| `Uint16 ->
uint16
| `Uint30 ->
uint30
in
let ranged = read_int state in
let ranged = if minimum > 0 then ranged + minimum else ranged in
if not (minimum <= ranged && ranged <= maximum) then
raise (Invalid_int {min = minimum; v = ranged; max = maximum}) ;
ranged
let ranged_float ~minimum ~maximum state =
let ranged = float state in
if not (minimum <= ranged && ranged <= maximum) then
raise (Invalid_float {min = minimum; v = ranged; max = maximum}) ;
ranged
let rec read_z res value bit_in_value state =
let byte = uint8 state in
let value = value lor ((byte land 0x7F) lsl bit_in_value) in
let bit_in_value = bit_in_value + 7 in
let (bit_in_value, value) =
if bit_in_value < 8 then (bit_in_value, value)
else (
Buffer.add_char res (Char.unsafe_chr (value land 0xFF)) ;
(bit_in_value - 8, value lsr 8) )
in
if byte land 0x80 = 0x80 then read_z res value bit_in_value state
else (
if bit_in_value > 0 then Buffer.add_char res (Char.unsafe_chr value) ;
if byte = 0x00 then raise Trailing_zero ;
Z.of_bits (Buffer.contents res) )
let n state =
let first = uint8 state in
let first_value = first land 0x7F in
if first land 0x80 = 0x80 then
read_z (Buffer.create 100) first_value 7 state
else Z.of_int first_value
let z state =
let first = uint8 state in
let first_value = first land 0x3F in
let sign = first land 0x40 <> 0 in
if first land 0x80 = 0x80 then
let n = read_z (Buffer.create 100) first_value 6 state in
if sign then Z.neg n else n
else
let n = Z.of_int first_value in
if sign then Z.neg n else n
let string_enum arr state =
let read_index =
match Binary_size.enum_size arr with
| `Uint8 ->
uint8
| `Uint16 ->
uint16
| `Uint30 ->
uint30
in
let index = read_index state in
if index >= Array.length arr then raise No_case_matched ;
arr.(index)
let fixed_length_bytes length =
read_atom length @@ fun buf ofs -> Bytes.sub buf ofs length
let fixed_length_string length =
read_atom length @@ fun buf ofs -> Bytes.sub_string buf ofs length
let tag = function `Uint8 -> uint8 | `Uint16 -> uint16
end
(** Main recursive reading function, in continuation passing style. *)
let rec read_rec : type ret. ret Encoding.t -> state -> ret =
fun e state ->
let open Encoding in
match e.encoding with
| Null ->
()
| Empty ->
()
| Constant _ ->
()
| Ignore ->
()
| Bool ->
Atom.bool state
| Int8 ->
Atom.int8 state
| Uint8 ->
Atom.uint8 state
| Int16 ->
Atom.int16 state
| Uint16 ->
Atom.uint16 state
| Int31 ->
Atom.int31 state
| Int32 ->
Atom.int32 state
| Int64 ->
Atom.int64 state
| N ->
Atom.n state
| Z ->
Atom.z state
| Float ->
Atom.float state
| Bytes (`Fixed n) ->
Atom.fixed_length_bytes n state
| Bytes `Variable ->
Atom.fixed_length_bytes state.remaining_bytes state
| String (`Fixed n) ->
Atom.fixed_length_string n state
| String `Variable ->
Atom.fixed_length_string state.remaining_bytes state
| Padded (e, n) ->
let v = read_rec e state in
ignore (Atom.fixed_length_string n state : string) ;
v
| RangedInt {minimum; maximum} ->
Atom.ranged_int ~minimum ~maximum state
| RangedFloat {minimum; maximum} ->
Atom.ranged_float ~minimum ~maximum state
| String_enum (_, arr) ->
Atom.string_enum arr state
| Array (max_length, e) ->
let max_length = match max_length with Some l -> l | None -> max_int in
let l = read_list List_too_long max_length e state in
Array.of_list l
| List (max_length, e) ->
let max_length = match max_length with Some l -> l | None -> max_int in
read_list Array_too_long max_length e state
| Obj (Req {encoding = e; _}) ->
read_rec e state
| Obj (Dft {encoding = e; _}) ->
read_rec e state
| Obj (Opt {kind = `Dynamic; encoding = e; _}) ->
let present = Atom.bool state in
if not present then None else Some (read_rec e state)
| Obj (Opt {kind = `Variable; encoding = e; _}) ->
if state.remaining_bytes = 0 then None else Some (read_rec e state)
| Objs {kind = `Fixed sz; left; right} ->
ignore (check_remaining_bytes state sz : int) ;
ignore (check_allowed_bytes state sz : int option) ;
let left = read_rec left state in
let right = read_rec right state in
(left, right)
| Objs {kind = `Dynamic; left; right} ->
let left = read_rec left state in
let right = read_rec right state in
(left, right)
| Objs {kind = `Variable; left; right} ->
read_variable_pair left right state
| Tup e ->
read_rec e state
| Tups {kind = `Fixed sz; left; right} ->
ignore (check_remaining_bytes state sz : int) ;
ignore (check_allowed_bytes state sz : int option) ;
let left = read_rec left state in
let right = read_rec right state in
(left, right)
| Tups {kind = `Dynamic; left; right} ->
let left = read_rec left state in
let right = read_rec right state in
(left, right)
| Tups {kind = `Variable; left; right} ->
read_variable_pair left right state
| Conv {inj; encoding; _} ->
inj (read_rec encoding state)
| Union {tag_size; cases; _} ->
let ctag = Atom.tag tag_size state in
let (Case {encoding; inj; _}) =
try
List.find
(function
| Case {tag = Tag tag; _} ->
tag = ctag
| Case {tag = Json_only; _} ->
false)
cases
with Not_found -> raise (Unexpected_tag ctag)
in
inj (read_rec encoding state)
| Dynamic_size {kind; encoding = e} ->
let sz = Atom.int kind state in
let remaining = check_remaining_bytes state sz in
state.remaining_bytes <- sz ;
ignore (check_allowed_bytes state sz : int option) ;
let v = read_rec e state in
if state.remaining_bytes <> 0 then raise Extra_bytes ;
state.remaining_bytes <- remaining ;
v
| Check_size {limit; encoding = e} ->
let old_allowed_bytes = state.allowed_bytes in
let limit =
match state.allowed_bytes with
| None ->
limit
| Some current_limit ->
min current_limit limit
in
state.allowed_bytes <- Some limit ;
let v = read_rec e state in
let allowed_bytes =
match old_allowed_bytes with
| None ->
None
| Some old_limit ->
let remaining =
match state.allowed_bytes with
| None ->
assert false
| Some remaining ->
remaining
in
let read = limit - remaining in
Some (old_limit - read)
in
state.allowed_bytes <- allowed_bytes ;
v
| Describe {encoding = e; _} ->
read_rec e state
| Splitted {encoding = e; _} ->
read_rec e state
| Mu {fix; _} ->
read_rec (fix e) state
| Delayed f ->
read_rec (f ()) state
and read_variable_pair :
type left right.
left Encoding.t -> right Encoding.t -> state -> left * right =
fun e1 e2 state ->
match (Encoding.classify e1, Encoding.classify e2) with
| ((`Dynamic | `Fixed _), `Variable) ->
let left = read_rec e1 state in
let right = read_rec e2 state in
(left, right)
| (`Variable, `Fixed n) ->
if n > state.remaining_bytes then raise Not_enough_data ;
state.remaining_bytes <- state.remaining_bytes - n ;
let left = read_rec e1 state in
assert (state.remaining_bytes = 0) ;
state.remaining_bytes <- n ;
let right = read_rec e2 state in
assert (state.remaining_bytes = 0) ;
(left, right)
| _ ->
assert false
(* Should be rejected by [Encoding.Kind.combine] *)
and read_list : type a. read_error -> int -> a Encoding.t -> state -> a list =
fun error max_length e state ->
let rec loop max_length acc =
if state.remaining_bytes = 0 then List.rev acc
else if max_length = 0 then raise error
else
let v = read_rec e state in
loop (max_length - 1) (v :: acc)
in
loop max_length []
(** ******************** *)
(** Various entry points *)
let read encoding buffer ofs len =
let state =
{buffer; offset = ofs; remaining_bytes = len; allowed_bytes = None}
in
match read_rec encoding state with
| exception Read_error _ ->
None
| v ->
Some (state.offset, v)
let of_bytes_exn encoding buffer =
let len = Bytes.length buffer in
let state =
{buffer; offset = 0; remaining_bytes = len; allowed_bytes = None}
in
let v = read_rec encoding state in
if state.offset <> len then raise Extra_bytes ;
v
let of_bytes encoding buffer =
try Some (of_bytes_exn encoding buffer) with Read_error _ -> None
src/lib_data_encoding/binary_reader.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Binary_error.
Definition raise {A : Type} (e : Tezos_data_encoding.Binary_error.read_error)
: A := Stdlib.raise (Read_error e).
Record state := {
buffer : Stdlib.Bytes.t;
offset : Z;
remaining_bytes : Z;
allowed_bytes : option Z }.
Definition check_allowed_bytes (state : state) (size : Z) : option Z :=
match allowed_bytes state with
| Some len => raise Tezos_data_encoding.Binary_error.Size_limit_exceeded
| Some len => Some (Z.sub len size)
| None => None
end.
Definition check_remaining_bytes (state : state) (size : Z) : Z :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt (remaining_bytes state) size then
raise Tezos_data_encoding.Binary_error.Not_enough_data
else
tt in
Z.sub (remaining_bytes state) size.
Definition read_atom {A : Type}
(size : Z) (conv : Stdlib.Bytes.t -> Z -> A) (state : state) : A :=
let offset := offset state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "remaining_bytes" % string
(check_remaining_bytes state size) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "allowed_bytes" % string
(check_allowed_bytes state size) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "offset" % string (Z.add (offset state) size) in
conv (buffer state) offset.
Module Atom.
Definition uint8 : state -> Z :=
read_atom Binary_size.uint8 TzEndian.get_uint8.
Definition uint16 : state -> Z :=
read_atom Binary_size.int16 TzEndian.get_uint16.
Definition int8 : state -> Z := read_atom Binary_size.int8 TzEndian.get_int8.
Definition int16 : state -> Z :=
read_atom Binary_size.int16 TzEndian.get_int16.
Definition int32 : state -> int32 :=
read_atom Binary_size.int32 TzEndian.get_int32.
Definition int64 : state -> int64 :=
read_atom Binary_size.int64 TzEndian.get_int64.
Definition float : state -> Z :=
read_atom Binary_size.float TzEndian.get_double.
Definition bool (state : state) : bool := nequiv_decb (int8 state) 0.
Definition uint30 : state -> Z :=
apply (read_atom Binary_size.uint30)
(fun buffer =>
fun ofs =>
let v := Int32.to_int (TzEndian.get_int32 buffer ofs) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt v 0 then
raise
(Tezos_data_encoding.Binary_error.Invalid_int
{| min := 0; v := v; max := Z.sub (Z.shiftl 1 30) 1 |})
else
tt in
v).
Definition int31 : state -> Z :=
apply (read_atom Binary_size.int31)
(fun buffer => fun ofs => Int32.to_int (TzEndian.get_int32 buffer ofs)).
Definition int (function_parameter : variant) : state -> Z :=
match function_parameter with
| Int31 => int31
| Int16 => int16
| Int8 => int8
| Uint30 => uint30
| Uint16 => uint16
| Uint8 => uint8
end.
Definition ranged_int (minimum : Z) (maximum : Z) (state : state) : Z :=
let read_int :=
match Binary_size.range_to_size minimum maximum with
| Int8 => int8
| Int16 => int16
| Int31 => int31
| Uint8 => uint8
| Uint16 => uint16
| Uint30 => uint30
end in
let ranged := read_int state in
let ranged :=
if OCaml.Stdlib.gt minimum 0 then
Z.add ranged minimum
else
ranged in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
negb
(andb (OCaml.Stdlib.le minimum ranged)
(OCaml.Stdlib.le ranged maximum)) then
raise
(Tezos_data_encoding.Binary_error.Invalid_int
{| min := minimum; v := ranged; max := maximum |})
else
tt in
ranged.
Definition ranged_float (minimum : Z) (maximum : Z) (state : state) : Z :=
let ranged := Z state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
negb
(andb (OCaml.Stdlib.le minimum ranged)
(OCaml.Stdlib.le ranged maximum)) then
raise
(Tezos_data_encoding.Binary_error.Invalid_float
{| min := minimum; v := ranged; max := maximum |})
else
tt in
ranged.
Fixpoint read_z
(res : Stdlib.Buffer.t) (value : Z) (bit_in_value : Z) (state : state)
: Z.t :=
let byte := uint8 state in
let value := Z.lor value (Z.shiftl (Z.land byte 127) bit_in_value) in
let bit_in_value := Z.add bit_in_value 7 in
let '(bit_in_value, value) :=
if OCaml.Stdlib.lt bit_in_value 8 then
(bit_in_value, value)
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Buffer.add_char res (Char.unsafe_chr (Z.land value 255)) in
((Z.sub bit_in_value 8), (Z.shiftr value 8)) in
if equiv_decb (Z.land byte 128) 128 then
read_z res value bit_in_value state
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt bit_in_value 0 then
Buffer.add_char res (Char.unsafe_chr value)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if equiv_decb byte 0 then
raise Tezos_data_encoding.Binary_error.Trailing_zero
else
tt in
Z.of_bits (Buffer.contents res).
Definition n (state : state) : Z.t :=
let first := uint8 state in
let first_value := Z.land first 127 in
if equiv_decb (Z.land first 128) 128 then
read_z (Buffer.create 100) first_value 7 state
else
Z.of_int first_value.
Definition z (state : state) : Z.t :=
let first := uint8 state in
let first_value := Z.land first 63 in
let sign := nequiv_decb (Z.land first 64) 0 in
if equiv_decb (Z.land first 128) 128 then
let n := read_z (Buffer.create 100) first_value 6 state in
if sign then
Z.neg n
else
n
else
let n := Z.of_int first_value in
if sign then
Z.neg n
else
n.
Definition string_enum {A : Type} (arr : array A) (state : state) : A :=
let read_index :=
match Binary_size.enum_size arr with
| Uint8 => uint8
| Uint16 => uint16
| Uint30 => uint30
end in
let index := read_index state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.ge index (Array.length arr) then
raise Tezos_data_encoding.Binary_error.No_case_matched
else
tt in
Array.get arr index.
Definition fixed_length_bytes (length : Z) : state -> string :=
apply (read_atom length) (fun buf => fun ofs => String.sub buf ofs length).
Definition fixed_length_string (length : Z) : state -> string :=
apply (read_atom length)
(fun buf => fun ofs => Stdlib.Bytes.sub_string buf ofs length).
Definition tag (function_parameter : variant) : state -> Z :=
match function_parameter with
| Uint8 => uint8
| Uint16 => uint16
end.
End Atom.
Fixpoint read_rec {ret : Type}
(e : Tezos_data_encoding.Encoding.t ret) (state : state) : ret :=
match encoding e with
| Tezos_data_encoding.Encoding.Null => tt
| Tezos_data_encoding.Encoding.Empty => tt
| Tezos_data_encoding.Encoding.Constant _ => tt
| Tezos_data_encoding.Encoding.Ignore => tt
| Tezos_data_encoding.Encoding.Bool => Atom.bool state
| Tezos_data_encoding.Encoding.Int8 => Atom.int8 state
| Tezos_data_encoding.Encoding.Uint8 => Atom.uint8 state
| Tezos_data_encoding.Encoding.Int16 => Atom.int16 state
| Tezos_data_encoding.Encoding.Uint16 => Atom.uint16 state
| Tezos_data_encoding.Encoding.Int31 => Atom.int31 state
| Tezos_data_encoding.Encoding.Int32 => Atom.int32 state
| Tezos_data_encoding.Encoding.Int64 => Atom.int64 state
| Tezos_data_encoding.Encoding.N => Atom.n state
| Tezos_data_encoding.Encoding.Z => Atom.z state
| Tezos_data_encoding.Encoding.Float => Atom.float state
| Tezos_data_encoding.Encoding.Bytes (Fixed n) =>
Atom.fixed_length_bytes n state
| Tezos_data_encoding.Encoding.Bytes Variable =>
Atom.fixed_length_bytes (remaining_bytes state) state
| Tezos_data_encoding.Encoding.String (Fixed n) =>
Atom.fixed_length_string n state
| Tezos_data_encoding.Encoding.String Variable =>
Atom.fixed_length_string (remaining_bytes state) state
| Tezos_data_encoding.Encoding.Padded e n =>
let v := read_rec e state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.ignore (Atom.fixed_length_string n state) in
v
|
Tezos_data_encoding.Encoding.RangedInt {|
minimum := minimum; maximum := maximum |} =>
Atom.ranged_int minimum maximum state
|
Tezos_data_encoding.Encoding.RangedFloat {|
minimum := minimum; maximum := maximum |} =>
Atom.ranged_float minimum maximum state
| Tezos_data_encoding.Encoding.String_enum _ arr => Atom.string_enum arr state
| Tezos_data_encoding.Encoding.Array max_length e =>
let max_length :=
match max_length with
| Some l => l
| None => Stdlib.max_int
end in
let l :=
read_list Tezos_data_encoding.Binary_error.List_too_long max_length e
state in
Array.of_list l
| Tezos_data_encoding.Encoding.List max_length e =>
let max_length :=
match max_length with
| Some l => l
| None => Stdlib.max_int
end in
read_list Tezos_data_encoding.Binary_error.Array_too_long max_length e state
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Req {| encoding := e |}) => read_rec e state
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Dft {| encoding := e |}) => read_rec e state
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Opt {| kind := Dynamic; encoding := e |}) =>
let present := Atom.bool state in
if negb present then
None
else
Some (read_rec e state)
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Opt {| kind := Variable; encoding := e |})
=>
if equiv_decb (remaining_bytes state) 0 then
None
else
Some (read_rec e state)
|
Tezos_data_encoding.Encoding.Objs {|
kind := Fixed sz; left := left; right := right |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.ignore (check_remaining_bytes state sz) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.ignore (check_allowed_bytes state sz) in
let left := read_rec left state in
let right := read_rec right state in
(left, right)
|
Tezos_data_encoding.Encoding.Objs {|
kind := Dynamic; left := left; right := right |} =>
let left := read_rec left state in
let right := read_rec right state in
(left, right)
|
Tezos_data_encoding.Encoding.Objs {|
kind := Variable; left := left; right := right |} =>
read_variable_pair left right state
| Tezos_data_encoding.Encoding.Tup e => read_rec e state
|
Tezos_data_encoding.Encoding.Tups {|
kind := Fixed sz; left := left; right := right |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.ignore (check_remaining_bytes state sz) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.ignore (check_allowed_bytes state sz) in
let left := read_rec left state in
let right := read_rec right state in
(left, right)
|
Tezos_data_encoding.Encoding.Tups {|
kind := Dynamic; left := left; right := right |} =>
let left := read_rec left state in
let right := read_rec right state in
(left, right)
|
Tezos_data_encoding.Encoding.Tups {|
kind := Variable; left := left; right := right |} =>
read_variable_pair left right state
| Tezos_data_encoding.Encoding.Conv {| inj := inj; encoding := encoding |} =>
inj (read_rec encoding state)
|
Tezos_data_encoding.Encoding.Union {|
tag_size := tag_size; cases := cases |} =>
let ctag := Atom.tag tag_size state in
let
'Tezos_data_encoding.Encoding.Case {| encoding := encoding; inj := inj |} :=
(* ❌ Try-with are not handled *)
try
(Stdlib.List.find
(fun function_parameter =>
match function_parameter with
|
Tezos_data_encoding.Encoding.Case {|
tag := Tezos_data_encoding.Encoding.Tag tag |} =>
equiv_decb tag ctag
|
Tezos_data_encoding.Encoding.Case {|
tag := Tezos_data_encoding.Encoding.Json_only |} => false
end) cases) in
inj (read_rec encoding state)
| Tezos_data_encoding.Encoding.Dynamic_size {| kind := kind; encoding := e |}
=>
let sz := Atom.int kind state in
let remaining := check_remaining_bytes state sz in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "remaining_bytes" % string sz in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.ignore (check_allowed_bytes state sz) in
let v := read_rec e state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb (remaining_bytes state) 0 then
raise Tezos_data_encoding.Binary_error.Extra_bytes
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "remaining_bytes" % string remaining in
v
| Tezos_data_encoding.Encoding.Check_size {| limit := limit; encoding := e |}
=>
let old_allowed_bytes := allowed_bytes state in
let limit :=
match allowed_bytes state with
| None => limit
| Some current_limit => OCaml.Stdlib.min current_limit limit
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "allowed_bytes" % string (Some limit) in
let v := read_rec e state in
let allowed_bytes :=
match old_allowed_bytes with
| None => None
| Some old_limit =>
let remaining :=
match allowed_bytes state with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some remaining => remaining
end in
let read := Z.sub limit remaining in
Some (Z.sub old_limit read)
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "allowed_bytes" % string allowed_bytes in
v
| Tezos_data_encoding.Encoding.Describe {| encoding := e |} =>
read_rec e state
| Tezos_data_encoding.Encoding.Splitted {| encoding := e |} =>
read_rec e state
| Tezos_data_encoding.Encoding.Mu {| fix := fix |} => read_rec (fix e) state
| Tezos_data_encoding.Encoding.Delayed f => read_rec (f tt) state
end
with read_variable_pair {left right : Type}
(e1 : Tezos_data_encoding.Encoding.t left)
(e2 : Tezos_data_encoding.Encoding.t right) (state : state) : left * right :=
match ((Encoding.classify e1), (Encoding.classify e2)) with
| (Dynamic | Fixed _, Variable) =>
let left := read_rec e1 state in
let right := read_rec e2 state in
(left, right)
| (Variable, Fixed n) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt n (remaining_bytes state) then
raise Tezos_data_encoding.Binary_error.Not_enough_data
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "remaining_bytes" % string
(Z.sub (remaining_bytes state) n) in
let left := read_rec e1 state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb (remaining_bytes state) 0) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "remaining_bytes" % string n in
let right := read_rec e2 state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb (remaining_bytes state) 0) in
(left, right)
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end
with read_list {a : Type}
(error : Tezos_data_encoding.Binary_error.read_error) (max_length : Z)
(e : Tezos_data_encoding.Encoding.t a) (state : state) : list a :=
let fix loop (max_length : Z) (acc : list a) : list a :=
if equiv_decb (remaining_bytes state) 0 then
List.rev acc
else
if equiv_decb max_length 0 then
raise error
else
let v := read_rec e state in
loop (Z.sub max_length 1) (cons v acc) in
loop max_length [].
Definition read {A : Type}
(encoding : Tezos_data_encoding.Encoding.t A) (buffer : Stdlib.Bytes.t)
(ofs : Z) (len : Z) : option (Z * A) :=
let state :=
{| buffer := buffer; offset := ofs; remaining_bytes := len;
allowed_bytes := None |} in
let 'v := read_rec encoding state in
Some ((offset state), v).
Definition of_bytes_exn {A : Type}
(encoding : Tezos_data_encoding.Encoding.t A) (buffer : Stdlib.Bytes.t) : A :=
let len := String.length buffer in
let state :=
{| buffer := buffer; offset := 0; remaining_bytes := len;
allowed_bytes := None |} in
let v := read_rec encoding state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb (offset state) len then
raise Tezos_data_encoding.Binary_error.Extra_bytes
else
tt in
v.
Definition of_bytes {A : Type}
(encoding : Tezos_data_encoding.Encoding.t A) (buffer : Stdlib.Bytes.t)
: option A :=
(* ❌ Try-with are not handled *)
try (Some (of_bytes_exn encoding buffer)).
src/lib_data_encoding/binary_schema.ml 54 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Encoding
type integer_extended = [Binary_size.integer | `Int32 | `Int64]
type field_descr =
| Named_field of string * Kind.t * layout
| Anonymous_field of Kind.t * layout
| Dynamic_size_field of string option * int * Binary_size.unsigned_integer
| Optional_field of string
and layout =
| Zero_width
| Int of integer_extended
| Bool
| RangedInt of int * int
| RangedFloat of float * float
| Float
| Bytes
| String
| Enum of Binary_size.integer * string
| Seq of layout * int option (* For arrays and lists *)
| Ref of string
| Padding
and fields = field_descr list
and toplevel_encoding =
| Obj of {fields : fields}
| Cases of {
kind : Kind.t;
tag_size : Binary_size.tag_size;
cases : (int * string option * fields) list;
}
| Int_enum of {size : Binary_size.integer; cases : (int * string) list}
and description = {title : string; description : string option}
type t = {
toplevel : toplevel_encoding;
fields : (description * toplevel_encoding) list;
}
module Printer_ast = struct
type table = {headers : string list; body : string list list}
type t =
| Table of table
| Union of Binary_size.tag_size * (description * table) list
let pp_size ppf = function
| `Fixed size ->
Format.fprintf ppf "%d byte%s" size (if size = 1 then "" else "s")
| `Variable ->
Format.fprintf ppf "Variable"
| `Dynamic ->
Format.fprintf ppf "Determined from data"
let pp_int ppf (int : integer_extended) =
Format.fprintf
ppf
"%s"
( match int with
| `Int16 ->
"signed 16-bit integer"
| `Int31 ->
"signed 31-bit integer"
| `Uint30 ->
"unsigned 30-bit integer"
| `Int32 ->
"signed 32-bit integer"
| `Int64 ->
"signed 64-bit integer"
| `Int8 ->
"signed 8-bit integer"
| `Uint16 ->
"unsigned 16-bit integer"
| `Uint8 ->
"unsigned 8-bit integer" )
let rec pp_layout ppf = function
| Zero_width ->
Format.fprintf ppf "placeholder (not actually present in the encoding)"
| Int integer ->
Format.fprintf ppf "%a" pp_int integer
| Bool ->
Format.fprintf ppf "boolean (0 for false, 255 for true)"
| RangedInt (minimum, maximum) when minimum <= 0 ->
Format.fprintf
ppf
"%a in the range %d to %d"
pp_int
(Binary_size.range_to_size ~minimum ~maximum :> integer_extended)
minimum
maximum
| RangedInt (minimum, maximum) (* when minimum > 0 *) ->
Format.fprintf
ppf
"%a in the range %d to %d (shifted by %d)"
pp_int
(Binary_size.range_to_size ~minimum ~maximum :> integer_extended)
minimum
maximum
minimum
| RangedFloat (minimum, maximum) ->
Format.fprintf
ppf
"double-precision floating-point number, in the range %f to %f"
minimum
maximum
| Float ->
Format.fprintf ppf "double-precision floating-point number"
| Bytes ->
Format.fprintf ppf "bytes"
| String ->
Format.fprintf ppf "bytes"
| Ref reference ->
Format.fprintf ppf "$%s" reference
| Padding ->
Format.fprintf ppf "padding"
| Enum (size, reference) ->
Format.fprintf
ppf
"%a encoding an enumeration (see %s)"
pp_int
(size :> integer_extended)
reference
| Seq (data, len) -> (
Format.fprintf ppf "sequence of " ;
( match len with
| None ->
()
| Some len ->
Format.fprintf ppf "at most %d " len ) ;
match data with
| Ref reference ->
Format.fprintf ppf "$%s" reference
| _ ->
pp_layout ppf data )
let pp_tag_size ppf tag =
Format.fprintf ppf "%s"
@@ match tag with `Uint8 -> "8-bit" | `Uint16 -> "16-bit"
let field_descr () =
let reference = ref 0 in
let string_of_layout = Format.asprintf "%a" pp_layout in
let anon_num () =
let value = !reference in
reference := value + 1 ;
string_of_int value
in
function
| Named_field (name, kind, desc) ->
[name; Format.asprintf "%a" pp_size kind; string_of_layout desc]
| Dynamic_size_field (Some name, 1, size) ->
[ Format.asprintf "# bytes in field \"%s\"" name;
Format.asprintf
"%a"
pp_size
(`Fixed (Binary_size.integer_to_size size));
string_of_layout (Int (size :> integer_extended)) ]
| Dynamic_size_field (None, 1, size) ->
[ Format.asprintf "# bytes in next field";
Format.asprintf
"%a"
pp_size
(`Fixed (Binary_size.integer_to_size size));
string_of_layout (Int (size :> integer_extended)) ]
| Dynamic_size_field (_, i, size) ->
[ Format.asprintf "# bytes in next %d fields" i;
Format.asprintf
"%a"
pp_size
(`Fixed (Binary_size.integer_to_size size));
string_of_layout (Int (size :> integer_extended)) ]
| Anonymous_field (kind, desc) ->
[ "Unnamed field " ^ anon_num ();
Format.asprintf "%a" pp_size kind;
string_of_layout desc ]
| Optional_field name ->
[ Format.asprintf "? presence of field \"%s\"" name;
Format.asprintf "%a" pp_size (`Fixed 1);
string_of_layout Bool ]
let binary_table_headers = ["Name"; "Size"; "Contents"]
let enum_headers = ["Case number"; "Encoded string"]
let toplevel (descr, encoding) =
match encoding with
| Obj {fields} ->
( descr,
Table
{
headers = binary_table_headers;
body = List.map (field_descr ()) fields;
} )
| Cases {kind; tag_size; cases} ->
( {
title =
Format.asprintf
"%s (%a, %a tag)"
descr.title
pp_size
kind
pp_tag_size
tag_size;
description = descr.description;
},
Union
( tag_size,
List.map
(fun (tag, name, fields) ->
( {
title =
( match name with
| Some name ->
Format.asprintf "%s (tag %d)" name tag
| None ->
Format.asprintf "Tag %d" tag );
description = None;
},
{
headers = binary_table_headers;
body = List.map (field_descr ()) fields;
} ))
cases ) )
| Int_enum {size; cases} ->
( {
title =
Format.asprintf
"%s (Enumeration: %a):"
descr.title
pp_int
(size :> integer_extended);
description = descr.description;
},
Table
{
headers = enum_headers;
body =
List.map (fun (num, str) -> [string_of_int num; str]) cases;
} )
end
module Printer = struct
let rec pad char ppf = function
| 0 ->
()
| n ->
Format.pp_print_char ppf char ;
pad char ppf (n - 1)
let pp_title level ppf title =
let char = if level = 1 then '*' else if level = 2 then '=' else '`' in
let sub = String.map (fun _ -> char) title in
Format.fprintf ppf "%s@ %s@\n@\n" title sub
let pp_table ppf {Printer_ast.headers; body} =
let max_widths =
List.fold_left
(List.map2 (fun len str -> max (String.length str) len))
(List.map String.length headers)
body
in
let pp_row pad_char ppf =
Format.fprintf ppf "|%a" (fun ppf ->
List.iter2
(fun width str ->
Format.fprintf
ppf
" %s%a |"
str
(pad pad_char)
(width - String.length str))
max_widths)
in
let pp_line c ppf =
Format.fprintf ppf "+%a" (fun ppf ->
List.iter2
(fun width _str -> Format.fprintf ppf "%a+" (pad c) (width + 2))
max_widths)
in
Format.fprintf
ppf
"%a@\n%a@\n%a@\n%a@\n@\n"
(pp_line '-')
headers
(pp_row ' ')
headers
(pp_line '=')
headers
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf "@\n")
(fun ppf s ->
Format.fprintf ppf "%a@\n%a" (pp_row ' ') s (pp_line '-') s))
body
let pp_option_nl ppf = function
| Some s ->
Format.fprintf ppf "%s@\n@\n" s
| None ->
()
let pp_toplevel ppf = function
| Printer_ast.Table table ->
pp_table ppf table
| Union (_tag_size, tables) ->
Format.fprintf
ppf
"%a"
(fun ppf ->
Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf "@\n")
(fun ppf (descr, table) ->
Format.fprintf
ppf
"%a%a%a"
(pp_title 2)
descr.title
pp_option_nl
descr.description
pp_table
table)
ppf)
tables
let pp ppf {toplevel; fields} =
let (_, toplevel) =
Printer_ast.toplevel ({title = ""; description = None}, toplevel)
in
Format.fprintf
ppf
"%a@\n%a"
pp_toplevel
toplevel
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf "@\n")
(fun ppf (descr, toplevel) ->
Format.fprintf
ppf
"%a%a%a"
(pp_title 1)
descr.title
pp_option_nl
descr.description
pp_toplevel
toplevel))
(List.map Printer_ast.toplevel fields)
end
module Encoding = struct
let description_encoding =
conv
(fun {title; description} -> (title, description))
(fun (title, description) -> {title; description})
(obj2 (req "title" string) (opt "description" string))
let integer_cases =
[("Int16", `Int16); ("Int8", `Int8); ("Uint16", `Uint16); ("Uint8", `Uint8)]
let integer_encoding : Binary_size.integer encoding =
string_enum integer_cases
let integer_extended_encoding =
string_enum (("Int64", `Int64) :: ("Int32", `Int32) :: integer_cases)
let layout_encoding =
mu "layout" (fun layout ->
union
[ case
~title:"Zero_width"
(Tag 0)
(obj1 (req "kind" (constant "Zero_width")))
(function Zero_width -> Some () | _ -> None)
(fun () -> Zero_width);
case
~title:"Int"
(Tag 1)
(obj2
(req "size" integer_extended_encoding)
(req "kind" (constant "Int")))
(function Int integer -> Some (integer, ()) | _ -> None)
(fun (integer, _) -> Int integer);
case
~title:"Bool"
(Tag 2)
(obj1 (req "kind" (constant "Bool")))
(function Bool -> Some () | _ -> None)
(fun () -> Bool);
case
~title:"RangedInt"
(Tag 3)
(obj3
(req "min" int31)
(req "max" int31)
(req "kind" (constant "RangedInt")))
(function
| RangedInt (min, max) -> Some (min, max, ()) | _ -> None)
(fun (min, max, _) -> RangedInt (min, max));
case
~title:"RangedFloat"
(Tag 4)
(obj3
(req "min" float)
(req "max" float)
(req "kind" (constant "RangedFloat")))
(function
| RangedFloat (min, max) -> Some (min, max, ()) | _ -> None)
(fun (min, max, ()) -> RangedFloat (min, max));
case
~title:"Float"
(Tag 5)
(obj1 (req "kind" (constant "Float")))
(function Float -> Some () | _ -> None)
(fun () -> Float);
case
~title:"Bytes"
(Tag 6)
(obj1 (req "kind" (constant "Bytes")))
(function Bytes -> Some () | _ -> None)
(fun () -> Bytes);
case
~title:"String"
(Tag 7)
(obj1 (req "kind" (constant "String")))
(function String -> Some () | _ -> None)
(fun () -> String);
case
~title:"Enum"
(Tag 8)
(obj3
(req "size" integer_encoding)
(req "reference" string)
(req "kind" (constant "Enum")))
(function
| Enum (size, cases) -> Some (size, cases, ()) | _ -> None)
(fun (size, cases, _) -> Enum (size, cases));
case
~title:"Seq"
(Tag 9)
(obj3
(req "layout" layout)
(req "kind" (constant "Seq"))
(opt "max_length" int31))
(function
| Seq (layout, len) -> Some (layout, (), len) | _ -> None)
(fun (layout, (), len) -> Seq (layout, len));
case
~title:"Ref"
(Tag 10)
(obj2 (req "name" string) (req "kind" (constant "Ref")))
(function Ref layout -> Some (layout, ()) | _ -> None)
(fun (name, ()) -> Ref name);
case
~title:"Padding"
(Tag 11)
(obj1 (req "kind" (constant "Padding")))
(function Padding -> Some () | _ -> None)
(fun () -> Padding) ])
let kind_enum_cases () =
[ case
~title:"Dynamic"
(Tag 0)
(obj1 (req "kind" (constant "Dynamic")))
(function `Dynamic -> Some () | _ -> None)
(fun () -> `Dynamic);
case
~title:"Variable"
(Tag 1)
(obj1 (req "kind" (constant "Variable")))
(function `Variable -> Some () | _ -> None)
(fun () -> `Variable) ]
let kind_t_encoding =
def "schema.kind"
@@ union
( case
~title:"Fixed"
(Tag 2)
(obj2 (req "size" int31) (req "kind" (constant "Float")))
(function `Fixed n -> Some (n, ()) | _ -> None)
(fun (n, _) -> `Fixed n)
:: kind_enum_cases () )
let unsigned_integer_encoding =
string_enum [("Uint30", `Uint30); ("Uint16", `Uint16); ("Uint8", `Uint8)]
let field_descr_encoding =
let dynamic_layout_encoding = dynamic_size layout_encoding in
def "schema.field"
@@ union
[ case
~title:"Named_field"
(Tag 0)
(obj4
(req "name" string)
(req "layout" dynamic_layout_encoding)
(req "data_kind" kind_t_encoding)
(req "kind" (constant "named")))
(function
| Named_field (name, kind, layout) ->
Some (name, layout, kind, ())
| _ ->
None)
(fun (name, kind, layout, _) -> Named_field (name, layout, kind));
case
~title:"Anonymous_field"
(Tag 1)
(obj3
(req "layout" dynamic_layout_encoding)
(req "kind" (constant "anon"))
(req "data_kind" kind_t_encoding))
(function
| Anonymous_field (kind, layout) ->
Some (layout, (), kind)
| _ ->
None)
(fun (kind, _, layout) -> Anonymous_field (layout, kind));
case
~title:"Dynamic_field"
(Tag 2)
(obj4
(req "kind" (constant "dyn"))
(opt "name" string)
(req "num_fields" int31)
(req "size" unsigned_integer_encoding))
(function
| Dynamic_size_field (name, i, size) ->
Some ((), name, i, size)
| _ ->
None)
(fun ((), name, i, size) -> Dynamic_size_field (name, i, size));
case
~title:"Optional_field"
(Tag 3)
(obj2
(req "kind" (constant "option_indicator"))
(req "name" string))
(function Optional_field s -> Some ((), s) | _ -> None)
(fun ((), s) -> Optional_field s) ]
let tag_size_encoding = string_enum [("Uint16", `Uint16); ("Uint8", `Uint8)]
let binary_description_encoding =
union
[ case
~title:"Obj"
(Tag 0)
(obj1 (req "fields" (list (dynamic_size field_descr_encoding))))
(function Obj {fields} -> Some fields | _ -> None)
(fun fields -> Obj {fields});
case
~title:"Cases"
(Tag 1)
(obj3
(req "tag_size" tag_size_encoding)
(req "kind" (dynamic_size kind_t_encoding))
(req
"cases"
(list
( def "union case"
@@ conv
(fun (tag, name, fields) -> (tag, fields, name))
(fun (tag, fields, name) -> (tag, name, fields))
@@ obj3
(req "tag" int31)
(req
"fields"
(list (dynamic_size field_descr_encoding)))
(opt "name" string) ))))
(function
| Cases {kind; tag_size; cases} ->
Some (tag_size, kind, cases)
| _ ->
None)
(fun (tag_size, kind, cases) -> Cases {kind; tag_size; cases});
case
~title:"Int_enum"
(Tag 2)
(obj2
(req "size" integer_encoding)
(req "cases" (list (tup2 int31 string))))
(function Int_enum {size; cases} -> Some (size, cases) | _ -> None)
(fun (size, cases) -> Int_enum {size; cases}) ]
let encoding =
conv
(fun {toplevel; fields} -> (toplevel, fields))
(fun (toplevel, fields) -> {toplevel; fields})
@@ obj2
(req "toplevel" binary_description_encoding)
(req
"fields"
(list
(obj2
(req "description" description_encoding)
(req "encoding" binary_description_encoding))))
end
let encoding = Encoding.encoding
let pp = Printer.pp
src/lib_data_encoding/binary_schema.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Encoding.
Definition integer_extended := variant.
Reserved Notation "'fields".
Inductive field_descr : Type :=
| Named_field : string -> Tezos_data_encoding.Encoding.Kind.t -> layout ->
field_descr
| Anonymous_field : Tezos_data_encoding.Encoding.Kind.t -> layout -> field_descr
| Dynamic_size_field : (option string) -> Z ->
Tezos_data_encoding.Binary_size.unsigned_integer -> field_descr
| Optional_field : string -> field_descr
with layout : Type :=
| Zero_width : layout
| Int : integer_extended -> layout
| Bool : layout
| RangedInt : Z -> Z -> layout
| RangedFloat : Z -> Z -> layout
| Float : layout
| Bytes : layout
| String : layout
| Enum : Tezos_data_encoding.Binary_size.integer -> string -> layout
| Seq : layout -> (option Z) -> layout
| Ref : string -> layout
| Padding : layout
with toplevel_encoding : Type :=
| Obj : 'fields -> toplevel_encoding
| Cases : Tezos_data_encoding.Encoding.Kind.t ->
Tezos_data_encoding.Binary_size.tag_size ->
(list (Z * (option string) * 'fields)) -> toplevel_encoding
| Int_enum : Tezos_data_encoding.Binary_size.integer -> (list (Z * string)) ->
toplevel_encoding
where "'fields" := ( list field_descr).
Definition fields := 'fields.
Record t := {
toplevel : toplevel_encoding;
fields : list (description * toplevel_encoding) }.
Module Printer_ast.
Record table := {
headers : list string;
body : list (list string) }.
Inductive t : Type :=
| Table : table -> t
| Union : Tezos_data_encoding.Binary_size.tag_size ->
(list (description * table)) -> t.
Definition pp_size
(ppf : Stdlib.Format.formatter) (function_parameter : variant) : unit :=
match function_parameter with
| Fixed size =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " byte" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))) "%d byte%s" % string)
size
(if equiv_decb size 1 then
"" % string
else
"s" % string)
| Variable =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Variable" % string
CamlinternalFormatBasics.End_of_format) "Variable" % string)
| Dynamic =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Determined from data" % string
CamlinternalFormatBasics.End_of_format)
"Determined from data" % string)
end.
Definition pp_int (ppf : Stdlib.Format.formatter) (int : integer_extended)
: unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
match Z with
| Int16 => "signed 16-bit integer" % string
| Int31 => "signed 31-bit integer" % string
| Uint30 => "unsigned 30-bit integer" % string
| Int32 => "signed 32-bit integer" % string
| Int64 => "signed 64-bit integer" % string
| Int8 => "signed 8-bit integer" % string
| Uint16 => "unsigned 16-bit integer" % string
| Uint8 => "unsigned 8-bit integer" % string
end.
Fixpoint pp_layout
(ppf : Stdlib.Format.formatter) (function_parameter : layout) : unit :=
match function_parameter with
| Zero_width =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"placeholder (not actually present in the encoding)" % string
CamlinternalFormatBasics.End_of_format)
"placeholder (not actually present in the encoding)" % string)
| Int integer =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) pp_int integer
| Bool =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"boolean (0 for false, 255 for true)" % string
CamlinternalFormatBasics.End_of_format)
"boolean (0 for false, 255 for true)" % string)
| RangedInt minimum maximum =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " in the range " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " to " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)))))
"%a in the range %d to %d" % string) pp_int
(Binary_size.range_to_size minimum maximum) minimum maximum
| RangedInt minimum maximum =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " in the range " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " to " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" (shifted by " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))))))
"%a in the range %d to %d (shifted by %d)" % string) pp_int
(Binary_size.range_to_size minimum maximum) minimum maximum minimum
| RangedFloat minimum maximum =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"double-precision floating-point number, in the range " % string
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " to " % string
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))))
"double-precision floating-point number, in the range %f to %f" %
string) minimum maximum
| Float =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"double-precision floating-point number" % string
CamlinternalFormatBasics.End_of_format)
"double-precision floating-point number" % string)
| Bytes =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "bytes" % string
CamlinternalFormatBasics.End_of_format) "bytes" % string)
| String =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "bytes" % string
CamlinternalFormatBasics.End_of_format) "bytes" % string)
| Ref reference =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "$" % char
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "$%s" % string) reference
| Padding =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "padding" % string
CamlinternalFormatBasics.End_of_format) "padding" % string)
| Enum size reference =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" encoding an enumeration (see " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))
"%a encoding an enumeration (see %s)" % string) pp_int size reference
| Seq data len =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "sequence of " % string
CamlinternalFormatBasics.End_of_format) "sequence of " % string)
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match len with
| None => tt
| Some len =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "at most " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal " " % char
CamlinternalFormatBasics.End_of_format)))
"at most %d " % string) len
end in
match data with
| Ref reference =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "$" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "$%s" % string)
reference
| _ => pp_layout ppf data
end
end.
Definition pp_tag_size (ppf : Stdlib.Format.formatter) (tag : variant)
: unit :=
apply
(Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string))
match tag with
| Uint8 => "8-bit" % string
| Uint16 => "16-bit" % string
end.
Definition field_descr (function_parameter : unit)
: field_descr -> list string :=
let 'tt := function_parameter in
let reference := Stdlib.ref 0 in
let string_of_layout :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) pp_layout in
let anon_num (function_parameter : unit) : string :=
let 'tt := function_parameter in
let value := Stdlib.op_exclamation reference in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq reference (Z.add value 1) in
OCaml.Stdlib.string_of_int value in
fun function_parameter =>
match function_parameter with
| Named_field name kind desc =>
cons name
(cons
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string) pp_size
kind) (cons (string_of_layout desc) []))
| Dynamic_size_field (Some name) 1 size =>
cons
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"# bytes in field """ % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal """" % char
CamlinternalFormatBasics.End_of_format)))
"# bytes in field ""%s""" % string) name)
(cons
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string) pp_size
(* ❌ Variants not supported *)
variant) (cons (string_of_layout (Int size)) []))
| Dynamic_size_field None 1 size =>
cons
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"# bytes in next field" % string
CamlinternalFormatBasics.End_of_format)
"# bytes in next field" % string))
(cons
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string) pp_size
(* ❌ Variants not supported *)
variant) (cons (string_of_layout (Int size)) []))
| Dynamic_size_field _ i size =>
cons
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"# bytes in next " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " fields" % string
CamlinternalFormatBasics.End_of_format)))
"# bytes in next %d fields" % string) i)
(cons
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string) pp_size
(* ❌ Variants not supported *)
variant) (cons (string_of_layout (Int size)) []))
| Anonymous_field kind desc =>
cons (String.append "Unnamed field " % string (anon_num tt))
(cons
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string) pp_size
kind) (cons (string_of_layout desc) []))
| Optional_field name =>
cons
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"? presence of field """ % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal """" % char
CamlinternalFormatBasics.End_of_format)))
"? presence of field ""%s""" % string) name)
(cons
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string) pp_size
(* ❌ Variants not supported *)
variant) (cons (string_of_layout Bool) []))
end.
Definition binary_table_headers : list string :=
cons "Name" % string (cons "Size" % string (cons "Contents" % string [])).
Definition enum_headers : list string :=
cons "Case number" % string (cons "Encoded string" % string []).
Definition toplevel (function_parameter : description * toplevel_encoding)
: description * t :=
let '(descr, encoding) := function_parameter in
match encoding with
| Obj {| fields := fields |} =>
(descr,
(Table
{| headers := binary_table_headers;
body := List.map (field_descr tt) fields |}))
| Cases {| kind := kind; tag_size := tag_size; cases := cases |} =>
({|
title :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ", " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" tag)" % string
CamlinternalFormatBasics.End_of_format))))))
"%s (%a, %a tag)" % string) (title descr) pp_size kind pp_tag_size
tag_size; description := description descr |},
(Union tag_size
(List.map
(fun function_parameter =>
let '(tag, name, fields) := function_parameter in
({|
title :=
match name with
| Some name =>
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (tag " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))
"%s (tag %d)" % string) name tag
| None =>
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Tag " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"Tag %d" % string) tag
end; description := None |},
{| headers := binary_table_headers;
body := List.map (field_descr tt) fields |})) cases)))
| Int_enum {| size := size; cases := cases |} =>
({|
title :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (Enumeration: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "):" % string
CamlinternalFormatBasics.End_of_format))))
"%s (Enumeration: %a):" % string) (title descr) pp_int size;
description := description descr |},
(Table
{| headers := enum_headers;
body :=
List.map
(fun function_parameter =>
let '(num, str) := function_parameter in
cons (OCaml.Stdlib.string_of_int num) (cons str [])) cases |}))
end.
End Printer_ast.
Module Printer.
Fixpoint pad
(char : ascii) (ppf : Stdlib.Format.formatter) (function_parameter : Z)
: unit :=
match function_parameter with
| 0 => tt
| n =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_print_char ppf ascii in
pad ascii ppf (Z.sub n 1)
end.
Definition pp_title
(level : Z) (ppf : Stdlib.Format.formatter) (title : string) : unit :=
let char :=
if equiv_decb level 1 then
"*" % char
else
if equiv_decb level 2 then
"=" % char
else
"`" % char in
let sub :=
Stdlib.String.map
(fun function_parameter =>
let '_ := function_parameter in
ascii) title in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
CamlinternalFormatBasics.End_of_format)))))
"%s@ %s@
@
" % string) title sub.
Definition pp_table
(ppf : Stdlib.Format.formatter) (function_parameter : Printer_ast.table)
: unit :=
let '{| Printer_ast.headers := headers; Printer_ast.body := body |} :=
function_parameter in
let max_widths :=
Stdlib.List.fold_left
(Stdlib.List.map2
(fun len => fun str => OCaml.Stdlib.max (OCaml.String.length str) len))
(List.map OCaml.String.length headers) body in
let pp_row (pad_char : ascii) (ppf : Stdlib.Format.formatter)
: (list string) -> unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "|" % char
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "|%a" % string)
(fun ppf =>
Stdlib.List.iter2
(fun width =>
fun str =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " |" % string
CamlinternalFormatBasics.End_of_format))))
" %s%a |" % string) str (pad pad_char)
(Z.sub width (OCaml.String.length str))) max_widths) in
let pp_line {A : Type} (c : ascii) (ppf : Stdlib.Format.formatter)
: (list A) -> unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "+" % char
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "+%a" % string)
(fun ppf =>
Stdlib.List.iter2
(fun width =>
fun _str =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "+" % char
CamlinternalFormatBasics.End_of_format)) "%a+" % string)
(pad c) (Z.add width 2)) max_widths) in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
CamlinternalFormatBasics.End_of_format)))))))))
"%a@
%a@
%a@
%a@
@
" % string) (pp_line "-" % char) headers
(pp_row " " % char) headers (pp_line "=" % char) headers
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
CamlinternalFormatBasics.End_of_format) "@
" % string)))
(fun ppf =>
fun s =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))
"%a@
%a" % string) (pp_row " " % char) s (pp_line "-" % char) s))
body.
Definition pp_option_nl
(ppf : Stdlib.Format.formatter) (function_parameter : option string)
: unit :=
match function_parameter with
| Some s =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
CamlinternalFormatBasics.End_of_format))) "%s@
@
" % string) s
| None => tt
end.
Definition pp_toplevel
(ppf : Stdlib.Format.formatter) (function_parameter : Printer_ast.t)
: unit :=
match function_parameter with
| Printer_ast.Table table => pp_table ppf table
| Printer_ast.Union _tag_size tables =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string)
(fun ppf =>
Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
CamlinternalFormatBasics.End_of_format) "@
" % string)))
(fun ppf =>
fun function_parameter =>
let '(descr, table) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))
"%a%a%a" % string) (pp_title 2) (title descr) pp_option_nl
(description descr) pp_table table) ppf) tables
end.
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
let '{| toplevel := toplevel; fields := fields |} := function_parameter in
let '(_, toplevel) :=
Printer_ast.toplevel
({| title := "" % string; description := None |}, toplevel) in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))) "%a@
%a" % string)
pp_toplevel toplevel
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
CamlinternalFormatBasics.End_of_format) "@
" % string)))
(fun ppf =>
fun function_parameter =>
let '(descr, toplevel) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))
"%a%a%a" % string) (pp_title 1) (title descr) pp_option_nl
(description descr) pp_toplevel toplevel))
(List.map Printer_ast.toplevel fields).
End Printer.
Module Encoding.
Definition description_encoding
: Tezos_data_encoding.Encoding.encoding description :=
conv
(fun function_parameter =>
let '{| title := title; description := description |} :=
function_parameter in
(title, description))
(fun function_parameter =>
let '(title, description) := function_parameter in
{| title := title; description := description |}) None
(obj2 (req None None "title" % string string)
(opt None None "description" % string string)).
Definition integer_cases : list (string * variant) :=
cons
("Int16" % string,
(* ❌ Variants not supported *)
variant)
(cons
("Int8" % string,
(* ❌ Variants not supported *)
variant)
(cons
("Uint16" % string,
(* ❌ Variants not supported *)
variant)
(cons
("Uint8" % string,
(* ❌ Variants not supported *)
variant) []))).
Definition integer_encoding
: Tezos_data_encoding.Encoding.encoding
Tezos_data_encoding.Binary_size.integer := string_enum integer_cases.
Definition integer_extended_encoding
: Tezos_data_encoding.Encoding.encoding variant :=
string_enum
(cons
("Int64" % string,
(* ❌ Variants not supported *)
variant)
(cons
("Int32" % string,
(* ❌ Variants not supported *)
variant) integer_cases)).
Definition layout_encoding : Tezos_data_encoding.Encoding.encoding layout :=
mu "layout" % string None None
(fun layout =>
union None
(cons
(case "Zero_width" % string None
(Tezos_data_encoding.Encoding.Tag 0)
(obj1
(req None None "kind" % string (constant "Zero_width" % string)))
(fun function_parameter =>
match function_parameter with
| Zero_width => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Zero_width))
(cons
(case "Int" % string None (Tezos_data_encoding.Encoding.Tag 1)
(obj2 (req None None "size" % string integer_extended_encoding)
(req None None "kind" % string (constant "Int" % string)))
(fun function_parameter =>
match function_parameter with
| Int integer => Some (integer, tt)
| _ => None
end)
(fun function_parameter =>
let '(integer, _) := function_parameter in
Int integer))
(cons
(case "Bool" % string None (Tezos_data_encoding.Encoding.Tag 2)
(obj1
(req None None "kind" % string (constant "Bool" % string)))
(fun function_parameter =>
match function_parameter with
| Bool => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Bool))
(cons
(case "RangedInt" % string None
(Tezos_data_encoding.Encoding.Tag 3)
(obj3 (req None None "min" % string int31)
(req None None "max" % string int31)
(req None None "kind" % string
(constant "RangedInt" % string)))
(fun function_parameter =>
match function_parameter with
| RangedInt min max => Some (min, max, tt)
| _ => None
end)
(fun function_parameter =>
let '(min, max, _) := function_parameter in
RangedInt min max))
(cons
(case "RangedFloat" % string None
(Tezos_data_encoding.Encoding.Tag 4)
(obj3 (req None None "min" % string float)
(req None None "max" % string float)
(req None None "kind" % string
(constant "RangedFloat" % string)))
(fun function_parameter =>
match function_parameter with
| RangedFloat min max => Some (min, max, tt)
| _ => None
end)
(fun function_parameter =>
let '(min, max, tt) := function_parameter in
RangedFloat min max))
(cons
(case "Float" % string None
(Tezos_data_encoding.Encoding.Tag 5)
(obj1
(req None None "kind" % string
(constant "Float" % string)))
(fun function_parameter =>
match function_parameter with
| Float => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Float))
(cons
(case "Bytes" % string None
(Tezos_data_encoding.Encoding.Tag 6)
(obj1
(req None None "kind" % string
(constant "Bytes" % string)))
(fun function_parameter =>
match function_parameter with
| Bytes => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Bytes))
(cons
(case "String" % string None
(Tezos_data_encoding.Encoding.Tag 7)
(obj1
(req None None "kind" % string
(constant "String" % string)))
(fun function_parameter =>
match function_parameter with
| String => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
String))
(cons
(case "Enum" % string None
(Tezos_data_encoding.Encoding.Tag 8)
(obj3
(req None None "size" % string integer_encoding)
(req None None "reference" % string string)
(req None None "kind" % string
(constant "Enum" % string)))
(fun function_parameter =>
match function_parameter with
| Enum size cases => Some (size, cases, tt)
| _ => None
end)
(fun function_parameter =>
let '(size, cases, _) := function_parameter in
Enum size cases))
(cons
(case "Seq" % string None
(Tezos_data_encoding.Encoding.Tag 9)
(obj3 (req None None "layout" % string layout)
(req None None "kind" % string
(constant "Seq" % string))
(opt None None "max_length" % string int31))
(fun function_parameter =>
match function_parameter with
| Seq layout len => Some (layout, tt, len)
| _ => None
end)
(fun function_parameter =>
let '(layout, tt, len) := function_parameter
in
Seq layout len))
(cons
(case "Ref" % string None
(Tezos_data_encoding.Encoding.Tag 10)
(obj2 (req None None "name" % string string)
(req None None "kind" % string
(constant "Ref" % string)))
(fun function_parameter =>
match function_parameter with
| Ref layout => Some (layout, tt)
| _ => None
end)
(fun function_parameter =>
let '(name, tt) := function_parameter in
Ref name))
(cons
(case "Padding" % string None
(Tezos_data_encoding.Encoding.Tag 11)
(obj1
(req None None "kind" % string
(constant "Padding" % string)))
(fun function_parameter =>
match function_parameter with
| Padding => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Padding)) []))))))))))))).
Definition kind_enum_cases (function_parameter : unit)
: list (Tezos_data_encoding.Encoding.case variant) :=
let 'tt := function_parameter in
cons
(case "Dynamic" % string None (Tezos_data_encoding.Encoding.Tag 0)
(obj1 (req None None "kind" % string (constant "Dynamic" % string)))
(fun function_parameter =>
match function_parameter with
| Dynamic => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Variants not supported *)
variant))
(cons
(case "Variable" % string None (Tezos_data_encoding.Encoding.Tag 1)
(obj1 (req None None "kind" % string (constant "Variable" % string)))
(fun function_parameter =>
match function_parameter with
| Variable => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Variants not supported *)
variant)) []).
Definition kind_t_encoding : Tezos_data_encoding.Encoding.encoding variant :=
apply
(let arg := def "schema.kind" % string in
fun eta => arg None None eta)
(union None
(cons
(case "Fixed" % string None (Tezos_data_encoding.Encoding.Tag 2)
(obj2 (req None None "size" % string int31)
(req None None "kind" % string (constant "Float" % string)))
(fun function_parameter =>
match function_parameter with
| Fixed n => Some (n, tt)
| _ => None
end)
(fun function_parameter =>
let '(n, _) := function_parameter in
(* ❌ Variants not supported *)
variant)) (kind_enum_cases tt))).
Definition unsigned_integer_encoding
: Tezos_data_encoding.Encoding.encoding variant :=
string_enum
(cons
("Uint30" % string,
(* ❌ Variants not supported *)
variant)
(cons
("Uint16" % string,
(* ❌ Variants not supported *)
variant)
(cons
("Uint8" % string,
(* ❌ Variants not supported *)
variant) []))).
Definition field_descr_encoding
: Tezos_data_encoding.Encoding.encoding field_descr :=
let dynamic_layout_encoding := dynamic_size None layout_encoding in
apply
(let arg := def "schema.field" % string in
fun eta => arg None None eta)
(union None
(cons
(case "Named_field" % string None (Tezos_data_encoding.Encoding.Tag 0)
(obj4 (req None None "name" % string string)
(req None None "layout" % string dynamic_layout_encoding)
(req None None "data_kind" % string kind_t_encoding)
(req None None "kind" % string (constant "named" % string)))
(fun function_parameter =>
match function_parameter with
| Named_field name kind layout => Some (name, layout, kind, tt)
| _ => None
end)
(fun function_parameter =>
let '(name, kind, layout, _) := function_parameter in
Named_field name layout kind))
(cons
(case "Anonymous_field" % string None
(Tezos_data_encoding.Encoding.Tag 1)
(obj3 (req None None "layout" % string dynamic_layout_encoding)
(req None None "kind" % string (constant "anon" % string))
(req None None "data_kind" % string kind_t_encoding))
(fun function_parameter =>
match function_parameter with
| Anonymous_field kind layout => Some (layout, tt, kind)
| _ => None
end)
(fun function_parameter =>
let '(kind, _, layout) := function_parameter in
Anonymous_field layout kind))
(cons
(case "Dynamic_field" % string None
(Tezos_data_encoding.Encoding.Tag 2)
(obj4 (req None None "kind" % string (constant "dyn" % string))
(opt None None "name" % string string)
(req None None "num_fields" % string int31)
(req None None "size" % string unsigned_integer_encoding))
(fun function_parameter =>
match function_parameter with
| Dynamic_size_field name i size => Some (tt, name, i, size)
| _ => None
end)
(fun function_parameter =>
let '(tt, name, i, size) := function_parameter in
Dynamic_size_field name i size))
(cons
(case "Optional_field" % string None
(Tezos_data_encoding.Encoding.Tag 3)
(obj2
(req None None "kind" % string
(constant "option_indicator" % string))
(req None None "name" % string string))
(fun function_parameter =>
match function_parameter with
| Optional_field s => Some (tt, s)
| _ => None
end)
(fun function_parameter =>
let '(tt, s) := function_parameter in
Optional_field s)) []))))).
Definition tag_size_encoding
: Tezos_data_encoding.Encoding.encoding variant :=
string_enum
(cons
("Uint16" % string,
(* ❌ Variants not supported *)
variant)
(cons
("Uint8" % string,
(* ❌ Variants not supported *)
variant) [])).
Definition binary_description_encoding
: Tezos_data_encoding.Encoding.encoding toplevel_encoding :=
union None
(cons
(case "Obj" % string None (Tezos_data_encoding.Encoding.Tag 0)
(obj1
(req None None "fields" % string
(list None (dynamic_size None field_descr_encoding))))
(fun function_parameter =>
match function_parameter with
| Obj {| fields := fields |} => Some fields
| _ => None
end) (fun fields => Obj {| fields := fields |}))
(cons
(case "Cases" % string None (Tezos_data_encoding.Encoding.Tag 1)
(obj3 (req None None "tag_size" % string tag_size_encoding)
(req None None "kind" % string (dynamic_size None kind_t_encoding))
(req None None "cases" % string
(list None
(apply
(let arg := def "union case" % string in
fun eta => arg None None eta)
(apply
(let arg :=
conv
(fun function_parameter =>
let '(tag, name, fields) := function_parameter in
(tag, fields, name))
(fun function_parameter =>
let '(tag, fields, name) := function_parameter in
(tag, name, fields)) in
fun eta => arg None eta)
(obj3 (req None None "tag" % string int31)
(req None None "fields" % string
(list None (dynamic_size None field_descr_encoding)))
(opt None None "name" % string string)))))))
(fun function_parameter =>
match function_parameter with
| Cases {| kind := kind; tag_size := tag_size; cases := cases |}
=> Some (tag_size, kind, cases)
| _ => None
end)
(fun function_parameter =>
let '(tag_size, kind, cases) := function_parameter in
Cases {| kind := kind; tag_size := tag_size; cases := cases |}))
(cons
(case "Int_enum" % string None (Tezos_data_encoding.Encoding.Tag 2)
(obj2 (req None None "size" % string integer_encoding)
(req None None "cases" % string (list None (tup2 int31 string))))
(fun function_parameter =>
match function_parameter with
| Int_enum {| size := size; cases := cases |} =>
Some (size, cases)
| _ => None
end)
(fun function_parameter =>
let '(size, cases) := function_parameter in
Int_enum {| size := size; cases := cases |})) []))).
Definition encoding : Tezos_data_encoding.Encoding.encoding t :=
apply
(let arg :=
conv
(fun function_parameter =>
let '{| toplevel := toplevel; fields := fields |} :=
function_parameter in
(toplevel, fields))
(fun function_parameter =>
let '(toplevel, fields) := function_parameter in
{| toplevel := toplevel; fields := fields |}) in
fun eta => arg None eta)
(obj2 (req None None "toplevel" % string binary_description_encoding)
(req None None "fields" % string
(list None
(obj2 (req None None "description" % string description_encoding)
(req None None "encoding" % string binary_description_encoding))))).
End Encoding.
Definition encoding : Tezos_data_encoding.Encoding.encoding t :=
Encoding.encoding.
Definition pp : Stdlib.Format.formatter -> t -> unit := Printer.pp.
src/lib_data_encoding/binary_size.ml 39 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let bool = 1
let int8 = 1
let uint8 = 1
let char = 1
let int16 = 2
let uint16 = 2
let uint30 = 4
let uint32 = 4
let uint64 = 8
let int31 = 4
let int32 = 4
let int64 = 8
let float = 8
type tag_size = [`Uint8 | `Uint16]
let tag_size = function `Uint8 -> uint8 | `Uint16 -> uint16
type signed_integer = [`Int31 | `Int16 | `Int8]
type unsigned_integer = [`Uint30 | `Uint16 | `Uint8]
type integer = [signed_integer | unsigned_integer]
let signed_range_to_size min max : [> signed_integer] =
if min >= ~-128 && max <= 127 then `Int8
else if min >= ~-32_768 && max <= 32_767 then `Int16
else `Int31
(* max should be centered at zero *)
let unsigned_range_to_size max : [> unsigned_integer] =
assert (max >= 0) ;
if max <= 255 then `Uint8 else if max <= 65535 then `Uint16 else `Uint30
let integer_to_size = function
| `Int31 ->
int31
| `Int16 ->
int16
| `Int8 ->
int8
| `Uint30 ->
uint30
| `Uint16 ->
uint16
| `Uint8 ->
uint8
let max_int = function
| `Uint30 | `Int31 ->
(1 lsl 30) - 1
| `Int16 ->
(1 lsl 15) - 1
| `Int8 ->
(1 lsl 7) - 1
| `Uint16 ->
(1 lsl 16) - 1
| `Uint8 ->
(1 lsl 8) - 1
let min_int = function
| `Uint8 | `Uint16 | `Uint30 ->
0
| `Int31 ->
-(1 lsl 30)
| `Int16 ->
-(1 lsl 15)
| `Int8 ->
-(1 lsl 7)
let range_to_size ~minimum ~maximum : integer =
if minimum < 0 then signed_range_to_size minimum maximum
else unsigned_range_to_size (maximum - minimum)
let enum_size arr = unsigned_range_to_size (Array.length arr)
src/lib_data_encoding/binary_size.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition bool : Z := 1.
Definition int8 : Z := 1.
Definition uint8 : Z := 1.
Definition char : Z := 1.
Definition int16 : Z := 2.
Definition uint16 : Z := 2.
Definition uint30 : Z := 4.
Definition uint32 : Z := 4.
Definition uint64 : Z := 8.
Definition int31 : Z := 4.
Definition int32 : Z := 4.
Definition int64 : Z := 8.
Definition float : Z := 8.
Definition tag_size := variant.
Definition tag_size (function_parameter : variant) : Z :=
match function_parameter with
| Uint8 => uint8
| Uint16 => uint16
end.
Definition signed_integer := variant.
Definition unsigned_integer := variant.
Definition integer := variant.
Definition signed_range_to_size (min : Z) (max : Z) : variant :=
if andb (OCaml.Stdlib.ge min (Z.opp 128)) (OCaml.Stdlib.le max 127) then
(* ❌ Variants not supported *)
variant
else
if andb (OCaml.Stdlib.ge min (Z.opp 32768)) (OCaml.Stdlib.le max 32767) then
(* ❌ Variants not supported *)
variant
else
(* ❌ Variants not supported *)
variant.
Definition unsigned_range_to_size (max : Z) : variant :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.ge max 0) in
if OCaml.Stdlib.le max 255 then
(* ❌ Variants not supported *)
variant
else
if OCaml.Stdlib.le max 65535 then
(* ❌ Variants not supported *)
variant
else
(* ❌ Variants not supported *)
variant.
Definition integer_to_size (function_parameter : variant) : Z :=
match function_parameter with
| Int31 => int31
| Int16 => int16
| Int8 => int8
| Uint30 => uint30
| Uint16 => uint16
| Uint8 => uint8
end.
Definition max_int (function_parameter : variant) : Z :=
match function_parameter with
| Uint30 | Int31 => Z.sub (Z.shiftl 1 30) 1
| Int16 => Z.sub (Z.shiftl 1 15) 1
| Int8 => Z.sub (Z.shiftl 1 7) 1
| Uint16 => Z.sub (Z.shiftl 1 16) 1
| Uint8 => Z.sub (Z.shiftl 1 8) 1
end.
Definition min_int (function_parameter : variant) : Z :=
match function_parameter with
| Uint8 | Uint16 | Uint30 => 0
| Int31 => Z.opp (Z.shiftl 1 30)
| Int16 => Z.opp (Z.shiftl 1 15)
| Int8 => Z.opp (Z.shiftl 1 7)
end.
Definition range_to_size (minimum : Z) (maximum : Z) : integer :=
if OCaml.Stdlib.lt minimum 0 then
signed_range_to_size minimum maximum
else
unsigned_range_to_size (Z.sub maximum minimum).
Definition enum_size {A : Type} (arr : array A) : variant :=
unsigned_range_to_size (Array.length arr).
src/lib_data_encoding/binary_stream.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Facilities to decode streams of binary data *)
type buffer = {buffer : Bytes.t; ofs : int; len : int}
type t = {
current : buffer;
(* buffer queue (classical double list implementation) *)
pending : Bytes.t list;
pending_rev : Bytes.t list;
(* number unread bytes in 'current + pending + pending_rev' *)
unread : int;
}
let is_empty {unread; _} = unread = 0
let of_buffer current =
{current; pending = []; pending_rev = []; unread = current.len}
let of_bytes buffer =
let len = Bytes.length buffer in
of_buffer {buffer; ofs = 0; len}
let empty = of_bytes (Bytes.create 0)
let push buffer stream =
{
stream with
pending_rev = buffer :: stream.pending_rev;
unread = stream.unread + Bytes.length buffer;
}
exception Need_more_data
let split buffer len =
assert (len <= buffer.len) ;
( {buffer with len},
{buffer with ofs = buffer.ofs + len; len = buffer.len - len} )
let read stream len =
if len > stream.unread then raise Need_more_data ;
if len <= stream.current.len then
let (res, current) = split stream.current len in
(res, {stream with current; unread = stream.unread - len})
else
let res = {buffer = Bytes.create len; ofs = 0; len} in
Bytes.blit
stream.current.buffer
stream.current.ofs
res.buffer
0
stream.current.len ;
let rec loop ofs pending_rev = function
| [] ->
loop ofs [] (List.rev pending_rev)
| buffer :: pending ->
let current = {buffer; ofs = 0; len = Bytes.length buffer} in
let to_read = len - ofs in
if to_read <= current.len then (
Bytes.blit current.buffer 0 res.buffer ofs to_read ;
( res,
{
current =
{current with ofs = to_read; len = current.len - to_read};
pending;
pending_rev;
unread = stream.unread - len;
} ) )
else (
Bytes.blit current.buffer 0 res.buffer ofs current.len ;
loop (ofs + current.len) pending_rev pending )
in
loop stream.current.len stream.pending_rev stream.pending
src/lib_data_encoding/binary_stream.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record buffer := {
buffer : Stdlib.Bytes.t;
ofs : Z;
len : Z }.
Record t := {
current : buffer;
pending : list Stdlib.Bytes.t;
pending_rev : list Stdlib.Bytes.t;
unread : Z }.
Definition is_empty (function_parameter : t) : bool :=
let '{| unread := unread |} := function_parameter in
equiv_decb unread 0.
Definition of_buffer (current : buffer) : t :=
{| current := current; pending := []; pending_rev := []; unread := len current
|}.
Definition of_bytes (buffer : Stdlib.Bytes.t) : t :=
let len := String.length buffer in
of_buffer {| buffer := buffer; ofs := 0; len := len |}.
Definition empty : t := of_bytes (Stdlib.Bytes.create 0).
Definition push (buffer : Stdlib.Bytes.t) (stream : t) : t :=
(* ❌ Record substitution not handled *)
record_substitution.
(* ❌ The definition of exceptions is not handled. *)
exception
Definition split (buffer : buffer) (len : Z) : buffer * buffer :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.le len (len buffer)) in
((* ❌ Record substitution not handled *)
record_substitution,
(* ❌ Record substitution not handled *)
record_substitution).
Definition read (stream : t) (len : Z) : buffer * t :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt len (unread stream) then
Stdlib.raise Need_more_data
else
tt in
if OCaml.Stdlib.le len (len (current stream)) then
let '(res, current) := split (current stream) len in
(res,
(* ❌ Record substitution not handled *)
record_substitution)
else
let res := {| buffer := Stdlib.Bytes.create len; ofs := 0; len := len |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.Bytes.blit (buffer (current stream)) (ofs (current stream))
(buffer res) 0 (len (current stream)) in
let fix loop
(ofs : Z) (pending_rev : list Stdlib.Bytes.t) (function_parameter :
list Stdlib.Bytes.t) : buffer * t :=
match function_parameter with
| [] => loop ofs [] (List.rev pending_rev)
| cons buffer pending =>
let current :=
{| buffer := buffer; ofs := 0; len := String.length buffer |} in
let to_read := Z.sub len ofs in
if OCaml.Stdlib.le to_read (len current) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.Bytes.blit (buffer current) 0 (buffer res) ofs to_read
in
(res,
{|
current :=
(* ❌ Record substitution not handled *)
record_substitution; pending := pending;
pending_rev := pending_rev; unread := Z.sub (unread stream) len |})
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.Bytes.blit (buffer current) 0 (buffer res) ofs (len current)
in
loop (Z.add ofs (len current)) pending_rev pending
end in
loop (len (current stream)) (pending_rev stream) (pending stream).
src/lib_data_encoding/binary_stream_reader.ml 77 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Binary_error
let raise e = raise (Read_error e)
(** Persistent state of the binary reader. *)
type state = {
stream : Binary_stream.t; (** All the remaining data to be read. *)
remaining_bytes : int option;
(** Total number of bytes that should be from 'stream' (None =
illimited). Reading less bytes should raise [Extra_bytes] and
trying to read more bytes should raise [Not_enough_data]. *)
allowed_bytes : int option;
(** Maximum number of bytes that are allowed to be read from 'stream'
before to fail (None = illimited). *)
total_read : int;
(** Total number of bytes that has been read from [stream] since the
beginning. *)
}
(** Return type for the function [read_rec]. See [Data_encoding] for its
description. *)
type 'ret status =
| Success of {result : 'ret; size : int; stream : Binary_stream.t}
| Await of (Bytes.t -> 'ret status)
| Error of read_error
let check_remaining_bytes state size =
match state.remaining_bytes with
| Some len when len < size ->
raise Not_enough_data
| Some len ->
Some (len - size)
| None ->
None
let check_allowed_bytes state size =
match state.allowed_bytes with
| Some len when len < size ->
raise Size_limit_exceeded
| Some len ->
Some (len - size)
| None ->
None
(** [read_atom resume size conv state k] reads [size] bytes from [state],
pass it to [conv] to be decoded, and finally call the continuation [k]
with the decoded value and the updated state.
The function [conv] is also allowed to raise [Read_error err].
In that case the exception is catched and [Error err] is returned.
If there is not enough [remaining_bytes] to be read in [state], the
function returns [Error Not_enough_data] instead of calling
the continuation.
If there is not enough [allowed_bytes] to be read in [state], the
function returns [Error Size_limit_exceeded] instead of calling
the continuation.
If there is not enough bytes to be read in [state], the function
returns [Await resume] instead of calling the continuation. *)
let read_atom resume size conv state k =
match
let remaining_bytes = check_remaining_bytes state size in
let allowed_bytes = check_allowed_bytes state size in
let (res, stream) = Binary_stream.read state.stream size in
( conv res.buffer res.ofs,
{
remaining_bytes;
allowed_bytes;
stream;
total_read = state.total_read + size;
} )
with
| exception Read_error error ->
Error error
| exception Binary_stream.Need_more_data ->
Await resume
| v ->
k v
(* tail call *)
(** Reader for all the atomic types. *)
module Atom = struct
let uint8 r = read_atom r Binary_size.uint8 TzEndian.get_uint8
let uint16 r = read_atom r Binary_size.int16 TzEndian.get_uint16
let int8 r = read_atom r Binary_size.int8 TzEndian.get_int8
let int16 r = read_atom r Binary_size.int16 TzEndian.get_int16
let int32 r = read_atom r Binary_size.int32 TzEndian.get_int32
let int64 r = read_atom r Binary_size.int64 TzEndian.get_int64
let float r = read_atom r Binary_size.float TzEndian.get_double
let bool resume state k =
int8 resume state @@ fun (v, state) -> k (v <> 0, state)
let uint30 r =
read_atom r Binary_size.uint30
@@ fun buffer ofs ->
let v = Int32.to_int (TzEndian.get_int32 buffer ofs) in
if v < 0 then raise (Invalid_int {min = 0; v; max = (1 lsl 30) - 1}) ;
v
let int31 r =
read_atom r Binary_size.int31
@@ fun buffer ofs -> Int32.to_int (TzEndian.get_int32 buffer ofs)
let int = function
| `Int31 ->
int31
| `Int16 ->
int16
| `Int8 ->
int8
| `Uint30 ->
uint30
| `Uint16 ->
uint16
| `Uint8 ->
uint8
let ranged_int ~minimum ~maximum resume state k =
let read_int =
match Binary_size.range_to_size ~minimum ~maximum with
| `Int8 ->
int8
| `Int16 ->
int16
| `Int31 ->
int31
| `Uint8 ->
uint8
| `Uint16 ->
uint16
| `Uint30 ->
uint30
in
read_int resume state
@@ fun (ranged, state) ->
let ranged = if minimum > 0 then ranged + minimum else ranged in
if not (minimum <= ranged && ranged <= maximum) then
Error (Invalid_int {min = minimum; v = ranged; max = maximum})
else k (ranged, state)
let ranged_float ~minimum ~maximum resume state k =
float resume state
@@ fun (ranged, state) ->
if not (minimum <= ranged && ranged <= maximum) then
Error (Invalid_float {min = minimum; v = ranged; max = maximum})
else k (ranged, state)
let rec read_z res value bit_in_value state k =
let resume buffer =
let stream = Binary_stream.push buffer state.stream in
read_z res value bit_in_value {state with stream} k
in
uint8 resume state
@@ fun (byte, state) ->
let value = value lor ((byte land 0x7F) lsl bit_in_value) in
let bit_in_value = bit_in_value + 7 in
let (bit_in_value, value) =
if bit_in_value < 8 then (bit_in_value, value)
else (
Buffer.add_char res (Char.unsafe_chr (value land 0xFF)) ;
(bit_in_value - 8, value lsr 8) )
in
if byte land 0x80 = 0x80 then read_z res value bit_in_value state k
else (
if bit_in_value > 0 then Buffer.add_char res (Char.unsafe_chr value) ;
if byte = 0x00 then raise Trailing_zero ;
k (Z.of_bits (Buffer.contents res), state) )
let n resume state k =
uint8 resume state
@@ fun (first, state) ->
let first_value = first land 0x7F in
if first land 0x80 = 0x80 then
read_z (Buffer.create 100) first_value 7 state k
else k (Z.of_int first_value, state)
let z resume state k =
uint8 resume state
@@ fun (first, state) ->
let first_value = first land 0x3F in
let sign = first land 0x40 <> 0 in
if first land 0x80 = 0x80 then
read_z (Buffer.create 100) first_value 6 state
@@ fun (n, state) -> k ((if sign then Z.neg n else n), state)
else
let n = Z.of_int first_value in
k ((if sign then Z.neg n else n), state)
let string_enum arr resume state k =
let read_index =
match Binary_size.enum_size arr with
| `Uint8 ->
uint8
| `Uint16 ->
uint16
| `Uint30 ->
uint30
in
read_index resume state
@@ fun (index, state) ->
if index >= Array.length arr then Error No_case_matched
else k (arr.(index), state)
let fixed_length_bytes length r =
read_atom r length @@ fun buf ofs -> Bytes.sub buf ofs length
let fixed_length_string length r =
read_atom r length @@ fun buf ofs -> Bytes.sub_string buf ofs length
let tag = function `Uint8 -> uint8 | `Uint16 -> uint16
end
let rec skip n state k =
let resume buffer =
let stream = Binary_stream.push buffer state.stream in
try skip n {state with stream} k with Read_error err -> Error err
in
Atom.fixed_length_string n resume state
@@ fun ((_, state) : string * _) -> k state
(** Main recursive reading function, in continuation passing style. *)
let rec read_rec :
type next ret.
bool ->
next Encoding.t ->
state ->
(next * state -> ret status) ->
ret status =
fun whole e state k ->
let resume buffer =
let stream = Binary_stream.push buffer state.stream in
try read_rec whole e {state with stream} k
with Read_error err -> Error err
in
let open Encoding in
assert (Encoding.classify e <> `Variable || state.remaining_bytes <> None) ;
match e.encoding with
| Null ->
k ((), state)
| Empty ->
k ((), state)
| Constant _ ->
k ((), state)
| Ignore ->
k ((), state)
| Bool ->
Atom.bool resume state k
| Int8 ->
Atom.int8 resume state k
| Uint8 ->
Atom.uint8 resume state k
| Int16 ->
Atom.int16 resume state k
| Uint16 ->
Atom.uint16 resume state k
| Int31 ->
Atom.int31 resume state k
| Int32 ->
Atom.int32 resume state k
| Int64 ->
Atom.int64 resume state k
| N ->
Atom.n resume state k
| Z ->
Atom.z resume state k
| Float ->
Atom.float resume state k
| Bytes (`Fixed n) ->
Atom.fixed_length_bytes n resume state k
| Bytes `Variable ->
let size = remaining_bytes state in
Atom.fixed_length_bytes size resume state k
| String (`Fixed n) ->
Atom.fixed_length_string n resume state k
| String `Variable ->
let size = remaining_bytes state in
Atom.fixed_length_string size resume state k
| Padded (e, n) ->
read_rec false e state
@@ fun (v, state) -> skip n state @@ fun state -> k (v, state)
| RangedInt {minimum; maximum} ->
Atom.ranged_int ~minimum ~maximum resume state k
| RangedFloat {minimum; maximum} ->
Atom.ranged_float ~minimum ~maximum resume state k
| String_enum (_, arr) ->
Atom.string_enum arr resume state k
| Array (max_length, e) ->
let max_length = match max_length with Some l -> l | None -> max_int in
read_list Array_too_long max_length e state
@@ fun (l, state) -> k (Array.of_list l, state)
| List (max_length, e) ->
let max_length = match max_length with Some l -> l | None -> max_int in
read_list List_too_long max_length e state k
| Obj (Req {encoding = e; _}) ->
read_rec whole e state k
| Obj (Dft {encoding = e; _}) ->
read_rec whole e state k
| Obj (Opt {kind = `Dynamic; encoding = e; _}) ->
Atom.bool resume state
@@ fun (present, state) ->
if not present then k (None, state)
else read_rec whole e state @@ fun (v, state) -> k (Some v, state)
| Obj (Opt {kind = `Variable; encoding = e; _}) ->
let size = remaining_bytes state in
if size = 0 then k (None, state)
else read_rec whole e state @@ fun (v, state) -> k (Some v, state)
| Objs {kind = `Fixed sz; left; right} ->
ignore (check_remaining_bytes state sz : int option) ;
ignore (check_allowed_bytes state sz : int option) ;
read_rec false left state
@@ fun (left, state) ->
read_rec whole right state
@@ fun (right, state) -> k ((left, right), state)
| Objs {kind = `Dynamic; left; right} ->
read_rec false left state
@@ fun (left, state) ->
read_rec whole right state
@@ fun (right, state) -> k ((left, right), state)
| Objs {kind = `Variable; left; right} ->
read_variable_pair left right state k
| Tup e ->
read_rec whole e state k
| Tups {kind = `Fixed sz; left; right} ->
ignore (check_remaining_bytes state sz : int option) ;
ignore (check_allowed_bytes state sz : int option) ;
read_rec false left state
@@ fun (left, state) ->
read_rec whole right state
@@ fun (right, state) -> k ((left, right), state)
| Tups {kind = `Dynamic; left; right} ->
read_rec false left state
@@ fun (left, state) ->
read_rec whole right state
@@ fun (right, state) -> k ((left, right), state)
| Tups {kind = `Variable; left; right} ->
read_variable_pair left right state k
| Conv {inj; encoding; _} ->
read_rec whole encoding state @@ fun (v, state) -> k (inj v, state)
| Union {tag_size; cases; _} -> (
Atom.tag tag_size resume state
@@ fun (ctag, state) ->
match
List.find_opt
(function
| Case {tag = Tag tag; _} ->
tag = ctag
| Case {tag = Json_only; _} ->
false)
cases
with
| None ->
Error (Unexpected_tag ctag)
| Some (Case {encoding; inj; _}) ->
read_rec whole encoding state @@ fun (v, state) -> k (inj v, state) )
| Dynamic_size {kind; encoding = e} ->
Atom.int kind resume state
@@ fun (sz, state) ->
let remaining = check_remaining_bytes state sz in
let state = {state with remaining_bytes = Some sz} in
ignore (check_allowed_bytes state sz : int option) ;
read_rec true e state
@@ fun (v, state) ->
if state.remaining_bytes <> Some 0 then Error Extra_bytes
else k (v, {state with remaining_bytes = remaining})
| Check_size {limit; encoding = e} ->
let old_allowed_bytes = state.allowed_bytes in
let limit =
match state.allowed_bytes with
| None ->
limit
| Some current_limit ->
min current_limit limit
in
( match state.remaining_bytes with
| Some remaining when whole && limit < remaining ->
raise Size_limit_exceeded
| _ ->
() ) ;
let state = {state with allowed_bytes = Some limit} in
read_rec whole e state
@@ fun (v, state) ->
let allowed_bytes =
match old_allowed_bytes with
| None ->
None
| Some old_limit ->
let remaining =
match state.allowed_bytes with
| None ->
assert false
| Some remaining ->
remaining
in
let read = limit - remaining in
Some (old_limit - read)
in
k (v, {state with allowed_bytes})
| Describe {encoding = e; _} ->
read_rec whole e state k
| Splitted {encoding = e; _} ->
read_rec whole e state k
| Mu {fix; _} ->
read_rec whole (fix e) state k
| Delayed f ->
read_rec whole (f ()) state k
and remaining_bytes {remaining_bytes; _} =
match remaining_bytes with
| None ->
(* This function should only be called with a variable encoding,
for which the `remaining_bytes` should never be `None`. *)
assert false
| Some len ->
len
and read_variable_pair :
type left right ret.
left Encoding.t ->
right Encoding.t ->
state ->
((left * right) * state -> ret status) ->
ret status =
fun e1 e2 state k ->
let size = remaining_bytes state in
match (Encoding.classify e1, Encoding.classify e2) with
| ((`Dynamic | `Fixed _), `Variable) ->
read_rec false e1 state
@@ fun (left, state) ->
read_rec true e2 state @@ fun (right, state) -> k ((left, right), state)
| (`Variable, `Fixed n) ->
if n > size then Error Not_enough_data
else
let state = {state with remaining_bytes = Some (size - n)} in
read_rec true e1 state
@@ fun (left, state) ->
assert (state.remaining_bytes = Some 0) ;
let state = {state with remaining_bytes = Some n} in
read_rec true e2 state
@@ fun (right, state) ->
assert (state.remaining_bytes = Some 0) ;
k ((left, right), state)
| _ ->
assert false
(* Should be rejected by [Encoding.Kind.combine] *)
and read_list :
type a ret.
read_error ->
int ->
a Encoding.t ->
state ->
(a list * state -> ret status) ->
ret status =
fun error max_length e state k ->
let rec loop state acc max_length =
let size = remaining_bytes state in
if size = 0 then k (List.rev acc, state)
else if max_length = 0 then raise error
else
read_rec false e state
@@ fun (v, state) -> loop state (v :: acc) (max_length - 1)
in
loop state [] max_length
let read_rec e state k =
try read_rec false e state k with Read_error err -> Error err
(** ******************** *)
(** Various entry points *)
let success (v, state) =
Success {result = v; size = state.total_read; stream = state.stream}
let read_stream ?(init = Binary_stream.empty) encoding =
match Encoding.classify encoding with
| `Variable ->
invalid_arg "Data_encoding.Binary.read_stream: variable encoding"
| `Dynamic | `Fixed _ ->
(* No hardcoded read limit in a stream. *)
let state =
{
remaining_bytes = None;
allowed_bytes = None;
stream = init;
total_read = 0;
}
in
read_rec encoding state success
src/lib_data_encoding/binary_stream_reader.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Binary_error.
Definition raise {A : Type} (e : Tezos_data_encoding.Binary_error.read_error)
: A := Stdlib.raise (Read_error e).
Record state := {
stream : Tezos_data_encoding.Binary_stream.t;
remaining_bytes : option Z;
allowed_bytes : option Z;
total_read : Z }.
Inductive status (ret : Type) : Type :=
| Success : ret -> Z -> Tezos_data_encoding.Binary_stream.t -> status ret
| Await : (Stdlib.Bytes.t -> status ret) -> status ret
| Error : Tezos_data_encoding.Binary_error.read_error -> status ret.
Arguments Success {_}.
Arguments Await {_}.
Arguments Error {_}.
Definition check_remaining_bytes (state : state) (size : Z) : option Z :=
match remaining_bytes state with
| Some len => raise Tezos_data_encoding.Binary_error.Not_enough_data
| Some len => Some (Z.sub len size)
| None => None
end.
Definition check_allowed_bytes (state : state) (size : Z) : option Z :=
match allowed_bytes state with
| Some len => raise Tezos_data_encoding.Binary_error.Size_limit_exceeded
| Some len => Some (Z.sub len size)
| None => None
end.
Definition read_atom {A B : Type}
(resume : Stdlib.Bytes.t -> status A) (size : Z)
(conv : Stdlib.Bytes.t -> Z -> B) (state : state)
(k : (B * state) -> status A) : status A :=
let 'v :=
let remaining_bytes := check_remaining_bytes state size in
let allowed_bytes := check_allowed_bytes state size in
let '(res, stream) := Binary_stream.read (stream state) size in
((conv (buffer res) (ofs res)),
{| stream := stream; remaining_bytes := remaining_bytes;
allowed_bytes := allowed_bytes;
total_read := Z.add (total_read state) size |}) in
k v.
Module Atom.
Definition uint8 {A : Type} (r : Stdlib.Bytes.t -> status A)
: state -> ((Z * state) -> status A) -> status A :=
read_atom r Binary_size.uint8 TzEndian.get_uint8.
Definition uint16 {A : Type} (r : Stdlib.Bytes.t -> status A)
: state -> ((Z * state) -> status A) -> status A :=
read_atom r Binary_size.int16 TzEndian.get_uint16.
Definition int8 {A : Type} (r : Stdlib.Bytes.t -> status A)
: state -> ((Z * state) -> status A) -> status A :=
read_atom r Binary_size.int8 TzEndian.get_int8.
Definition int16 {A : Type} (r : Stdlib.Bytes.t -> status A)
: state -> ((Z * state) -> status A) -> status A :=
read_atom r Binary_size.int16 TzEndian.get_int16.
Definition int32 {A : Type} (r : Stdlib.Bytes.t -> status A)
: state -> ((int32 * state) -> status A) -> status A :=
read_atom r Binary_size.int32 TzEndian.get_int32.
Definition int64 {A : Type} (r : Stdlib.Bytes.t -> status A)
: state -> ((int64 * state) -> status A) -> status A :=
read_atom r Binary_size.int64 TzEndian.get_int64.
Definition float {A : Type} (r : Stdlib.Bytes.t -> status A)
: state -> ((Z * state) -> status A) -> status A :=
read_atom r Binary_size.float TzEndian.get_double.
Definition bool {A : Type}
(resume : Stdlib.Bytes.t -> status A) (state : state)
(k : (bool * state) -> status A) : status A :=
apply (int8 resume state)
(fun function_parameter =>
let '(v, state) := function_parameter in
k ((nequiv_decb v 0), state)).
Definition uint30 {A : Type} (r : Stdlib.Bytes.t -> status A)
: state -> ((Z * state) -> status A) -> status A :=
apply (read_atom r Binary_size.uint30)
(fun buffer =>
fun ofs =>
let v := Int32.to_int (TzEndian.get_int32 buffer ofs) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt v 0 then
raise
(Tezos_data_encoding.Binary_error.Invalid_int
{| min := 0; v := v; max := Z.sub (Z.shiftl 1 30) 1 |})
else
tt in
v).
Definition int31 {A : Type} (r : Stdlib.Bytes.t -> status A)
: state -> ((Z * state) -> status A) -> status A :=
apply (read_atom r Binary_size.int31)
(fun buffer => fun ofs => Int32.to_int (TzEndian.get_int32 buffer ofs)).
Definition int {A : Type} (function_parameter : variant)
: (Stdlib.Bytes.t -> status A) ->
state -> ((Z * state) -> status A) -> status A :=
match function_parameter with
| Int31 => int31
| Int16 => int16
| Int8 => int8
| Uint30 => uint30
| Uint16 => uint16
| Uint8 => uint8
end.
Definition ranged_int {A : Type}
(minimum : Z) (maximum : Z) (resume : Stdlib.Bytes.t -> status A)
(state : state) (k : (Z * state) -> status A) : status A :=
let read_int :=
match Binary_size.range_to_size minimum maximum with
| Int8 => int8
| Int16 => int16
| Int31 => int31
| Uint8 => uint8
| Uint16 => uint16
| Uint30 => uint30
end in
apply (read_int resume state)
(fun function_parameter =>
let '(ranged, state) := function_parameter in
let ranged :=
if OCaml.Stdlib.gt minimum 0 then
Z.add ranged minimum
else
ranged in
if
negb
(andb (OCaml.Stdlib.le minimum ranged)
(OCaml.Stdlib.le ranged maximum)) then
inr
(Tezos_data_encoding.Binary_error.Invalid_int
{| min := minimum; v := ranged; max := maximum |})
else
k (ranged, state)).
Definition ranged_float {A : Type}
(minimum : Z) (maximum : Z) (resume : Stdlib.Bytes.t -> status A)
(state : state) (k : (Z * state) -> status A) : status A :=
apply (Z resume state)
(fun function_parameter =>
let '(ranged, state) := function_parameter in
if
negb
(andb (OCaml.Stdlib.le minimum ranged)
(OCaml.Stdlib.le ranged maximum)) then
inr
(Tezos_data_encoding.Binary_error.Invalid_float
{| min := minimum; v := ranged; max := maximum |})
else
k (ranged, state)).
Fixpoint read_z {A : Type}
(res : Stdlib.Buffer.t) (value : Z) (bit_in_value : Z) (state : state)
(k : (Z.t * state) -> status A) : status A :=
let resume (buffer : Stdlib.Bytes.t) : status A :=
let stream := Binary_stream.push buffer (stream state) in
read_z res value bit_in_value
(* ❌ Record substitution not handled *)
record_substitution k in
apply (uint8 resume state)
(fun function_parameter =>
let '(byte, state) := function_parameter in
let value := Z.lor value (Z.shiftl (Z.land byte 127) bit_in_value) in
let bit_in_value := Z.add bit_in_value 7 in
let '(bit_in_value, value) :=
if OCaml.Stdlib.lt bit_in_value 8 then
(bit_in_value, value)
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Buffer.add_char res (Char.unsafe_chr (Z.land value 255)) in
((Z.sub bit_in_value 8), (Z.shiftr value 8)) in
if equiv_decb (Z.land byte 128) 128 then
read_z res value bit_in_value state k
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt bit_in_value 0 then
Buffer.add_char res (Char.unsafe_chr value)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if equiv_decb byte 0 then
raise Tezos_data_encoding.Binary_error.Trailing_zero
else
tt in
k ((Z.of_bits (Buffer.contents res)), state)).
Definition n {A : Type}
(resume : Stdlib.Bytes.t -> status A) (state : state)
(k : (Z.t * state) -> status A) : status A :=
apply (uint8 resume state)
(fun function_parameter =>
let '(first, state) := function_parameter in
let first_value := Z.land first 127 in
if equiv_decb (Z.land first 128) 128 then
read_z (Buffer.create 100) first_value 7 state k
else
k ((Z.of_int first_value), state)).
Definition z {A : Type}
(resume : Stdlib.Bytes.t -> status A) (state : state)
(k : (Z.t * state) -> status A) : status A :=
apply (uint8 resume state)
(fun function_parameter =>
let '(first, state) := function_parameter in
let first_value := Z.land first 63 in
let sign := nequiv_decb (Z.land first 64) 0 in
if equiv_decb (Z.land first 128) 128 then
apply (read_z (Buffer.create 100) first_value 6 state)
(fun function_parameter =>
let '(n, state) := function_parameter in
k
((if sign then
Z.neg n
else
n), state))
else
let n := Z.of_int first_value in
k
((if sign then
Z.neg n
else
n), state)).
Definition string_enum {A B : Type}
(arr : array A) (resume : Stdlib.Bytes.t -> status B) (state : state)
(k : (A * state) -> status B) : status B :=
let read_index :=
match Binary_size.enum_size arr with
| Uint8 => uint8
| Uint16 => uint16
| Uint30 => uint30
end in
apply (read_index resume state)
(fun function_parameter =>
let '(index, state) := function_parameter in
if OCaml.Stdlib.ge index (Array.length arr) then
inr Tezos_data_encoding.Binary_error.No_case_matched
else
k ((Array.get arr index), state)).
Definition fixed_length_bytes {A : Type}
(length : Z) (r : Stdlib.Bytes.t -> status A)
: state -> ((string * state) -> status A) -> status A :=
apply (read_atom r length) (fun buf => fun ofs => String.sub buf ofs length).
Definition fixed_length_string {A : Type}
(length : Z) (r : Stdlib.Bytes.t -> status A)
: state -> ((string * state) -> status A) -> status A :=
apply (read_atom r length)
(fun buf => fun ofs => Stdlib.Bytes.sub_string buf ofs length).
Definition tag {A : Type} (function_parameter : variant)
: (Stdlib.Bytes.t -> status A) ->
state -> ((Z * state) -> status A) -> status A :=
match function_parameter with
| Uint8 => uint8
| Uint16 => uint16
end.
End Atom.
Fixpoint skip {A : Type} (n : Z) (state : state) (k : state -> status A)
: status A :=
let resume (buffer : Stdlib.Bytes.t) : status A :=
let stream := Binary_stream.push buffer (stream state) in
(* ❌ Try-with are not handled *)
try
(skip n
(* ❌ Record substitution not handled *)
record_substitution k) in
apply (Atom.fixed_length_string n resume state)
(fun function_parameter =>
let '(_, state) := function_parameter in
k state).
Fixpoint read_rec {next ret : Type}
(whole : bool) (e : Tezos_data_encoding.Encoding.t next) (state : state)
(k : (next * state) -> status ret) : status ret :=
let resume (buffer : Stdlib.Bytes.t) : status ret :=
let stream := Binary_stream.push buffer (stream state) in
(* ❌ Try-with are not handled *)
try
(read_rec whole e
(* ❌ Record substitution not handled *)
record_substitution k) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(orb
(nequiv_decb (Encoding.classify e)
(* ❌ Variants not supported *)
variant) (nequiv_decb (remaining_bytes state) None)) in
match encoding e with
| Tezos_data_encoding.Encoding.Null => k (tt, state)
| Tezos_data_encoding.Encoding.Empty => k (tt, state)
| Tezos_data_encoding.Encoding.Constant _ => k (tt, state)
| Tezos_data_encoding.Encoding.Ignore => k (tt, state)
| Tezos_data_encoding.Encoding.Bool => Atom.bool resume state k
| Tezos_data_encoding.Encoding.Int8 => Atom.int8 resume state k
| Tezos_data_encoding.Encoding.Uint8 => Atom.uint8 resume state k
| Tezos_data_encoding.Encoding.Int16 => Atom.int16 resume state k
| Tezos_data_encoding.Encoding.Uint16 => Atom.uint16 resume state k
| Tezos_data_encoding.Encoding.Int31 => Atom.int31 resume state k
| Tezos_data_encoding.Encoding.Int32 => Atom.int32 resume state k
| Tezos_data_encoding.Encoding.Int64 => Atom.int64 resume state k
| Tezos_data_encoding.Encoding.N => Atom.n resume state k
| Tezos_data_encoding.Encoding.Z => Atom.z resume state k
| Tezos_data_encoding.Encoding.Float => Atom.float resume state k
| Tezos_data_encoding.Encoding.Bytes (Fixed n) =>
Atom.fixed_length_bytes n resume state k
| Tezos_data_encoding.Encoding.Bytes Variable =>
let size := remaining_bytes state in
Atom.fixed_length_bytes size resume state k
| Tezos_data_encoding.Encoding.String (Fixed n) =>
Atom.fixed_length_string n resume state k
| Tezos_data_encoding.Encoding.String Variable =>
let size := remaining_bytes state in
Atom.fixed_length_string size resume state k
| Tezos_data_encoding.Encoding.Padded e n =>
apply (read_rec false e state)
(fun function_parameter =>
let '(v, state) := function_parameter in
apply (skip n state) (fun state => k (v, state)))
|
Tezos_data_encoding.Encoding.RangedInt {|
minimum := minimum; maximum := maximum |} =>
Atom.ranged_int minimum maximum resume state k
|
Tezos_data_encoding.Encoding.RangedFloat {|
minimum := minimum; maximum := maximum |} =>
Atom.ranged_float minimum maximum resume state k
| Tezos_data_encoding.Encoding.String_enum _ arr =>
Atom.string_enum arr resume state k
| Tezos_data_encoding.Encoding.Array max_length e =>
let max_length :=
match max_length with
| Some l => l
| None => Stdlib.max_int
end in
apply
(read_list Tezos_data_encoding.Binary_error.Array_too_long max_length e
state)
(fun function_parameter =>
let '(l, state) := function_parameter in
k ((Array.of_list l), state))
| Tezos_data_encoding.Encoding.List max_length e =>
let max_length :=
match max_length with
| Some l => l
| None => Stdlib.max_int
end in
read_list Tezos_data_encoding.Binary_error.List_too_long max_length e state
k
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Req {| encoding := e |}) =>
read_rec whole e state k
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Dft {| encoding := e |}) =>
read_rec whole e state k
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Opt {| kind := Dynamic; encoding := e |}) =>
apply (Atom.bool resume state)
(fun function_parameter =>
let '(present, state) := function_parameter in
if negb present then
k (None, state)
else
apply (read_rec whole e state)
(fun function_parameter =>
let '(v, state) := function_parameter in
k ((Some v), state)))
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Opt {| kind := Variable; encoding := e |})
=>
let size := remaining_bytes state in
if equiv_decb size 0 then
k (None, state)
else
apply (read_rec whole e state)
(fun function_parameter =>
let '(v, state) := function_parameter in
k ((Some v), state))
|
Tezos_data_encoding.Encoding.Objs {|
kind := Fixed sz; left := left; right := right |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.ignore (check_remaining_bytes state sz) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.ignore (check_allowed_bytes state sz) in
apply (read_rec false left state)
(fun function_parameter =>
let '(left, state) := function_parameter in
apply (read_rec whole right state)
(fun function_parameter =>
let '(right, state) := function_parameter in
k ((left, right), state)))
|
Tezos_data_encoding.Encoding.Objs {|
kind := Dynamic; left := left; right := right |} =>
apply (read_rec false left state)
(fun function_parameter =>
let '(left, state) := function_parameter in
apply (read_rec whole right state)
(fun function_parameter =>
let '(right, state) := function_parameter in
k ((left, right), state)))
|
Tezos_data_encoding.Encoding.Objs {|
kind := Variable; left := left; right := right |} =>
read_variable_pair left right state k
| Tezos_data_encoding.Encoding.Tup e => read_rec whole e state k
|
Tezos_data_encoding.Encoding.Tups {|
kind := Fixed sz; left := left; right := right |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.ignore (check_remaining_bytes state sz) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.ignore (check_allowed_bytes state sz) in
apply (read_rec false left state)
(fun function_parameter =>
let '(left, state) := function_parameter in
apply (read_rec whole right state)
(fun function_parameter =>
let '(right, state) := function_parameter in
k ((left, right), state)))
|
Tezos_data_encoding.Encoding.Tups {|
kind := Dynamic; left := left; right := right |} =>
apply (read_rec false left state)
(fun function_parameter =>
let '(left, state) := function_parameter in
apply (read_rec whole right state)
(fun function_parameter =>
let '(right, state) := function_parameter in
k ((left, right), state)))
|
Tezos_data_encoding.Encoding.Tups {|
kind := Variable; left := left; right := right |} =>
read_variable_pair left right state k
| Tezos_data_encoding.Encoding.Conv {| inj := inj; encoding := encoding |} =>
apply (read_rec whole encoding state)
(fun function_parameter =>
let '(v, state) := function_parameter in
k ((inj v), state))
|
Tezos_data_encoding.Encoding.Union {|
tag_size := tag_size; cases := cases |} =>
apply (Atom.tag tag_size resume state)
(fun function_parameter =>
let '(ctag, state) := function_parameter in
match
Stdlib.List.find_opt
(fun function_parameter =>
match function_parameter with
|
Tezos_data_encoding.Encoding.Case {|
tag := Tezos_data_encoding.Encoding.Tag tag |} =>
equiv_decb tag ctag
|
Tezos_data_encoding.Encoding.Case {|
tag := Tezos_data_encoding.Encoding.Json_only |} => false
end) cases with
| None => inr (Tezos_data_encoding.Binary_error.Unexpected_tag ctag)
|
Some
(Tezos_data_encoding.Encoding.Case {|
encoding := encoding; inj := inj |}) =>
apply (read_rec whole encoding state)
(fun function_parameter =>
let '(v, state) := function_parameter in
k ((inj v), state))
end)
| Tezos_data_encoding.Encoding.Dynamic_size {| kind := kind; encoding := e |}
=>
apply (Atom.int kind resume state)
(fun function_parameter =>
let '(sz, state) := function_parameter in
let remaining := check_remaining_bytes state sz in
let state :=
(* ❌ Record substitution not handled *)
record_substitution in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.ignore (check_allowed_bytes state sz) in
apply (read_rec true e state)
(fun function_parameter =>
let '(v, state) := function_parameter in
if nequiv_decb (remaining_bytes state) (Some 0) then
inr Tezos_data_encoding.Binary_error.Extra_bytes
else
k
(v,
(* ❌ Record substitution not handled *)
record_substitution)))
| Tezos_data_encoding.Encoding.Check_size {| limit := limit; encoding := e |}
=>
let old_allowed_bytes := allowed_bytes state in
let limit :=
match allowed_bytes state with
| None => limit
| Some current_limit => OCaml.Stdlib.min current_limit limit
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match remaining_bytes state with
| Some remaining =>
raise Tezos_data_encoding.Binary_error.Size_limit_exceeded
| _ => tt
end in
let state :=
(* ❌ Record substitution not handled *)
record_substitution in
apply (read_rec whole e state)
(fun function_parameter =>
let '(v, state) := function_parameter in
let allowed_bytes :=
match old_allowed_bytes with
| None => None
| Some old_limit =>
let remaining :=
match allowed_bytes state with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some remaining => remaining
end in
let read := Z.sub limit remaining in
Some (Z.sub old_limit read)
end in
k
(v,
(* ❌ Record substitution not handled *)
record_substitution))
| Tezos_data_encoding.Encoding.Describe {| encoding := e |} =>
read_rec whole e state k
| Tezos_data_encoding.Encoding.Splitted {| encoding := e |} =>
read_rec whole e state k
| Tezos_data_encoding.Encoding.Mu {| fix := fix |} =>
read_rec whole (fix e) state k
| Tezos_data_encoding.Encoding.Delayed f => read_rec whole (f tt) state k
end
with remaining_bytes (function_parameter : state) : Z :=
let '{| remaining_bytes := remaining_bytes |} := function_parameter in
match remaining_bytes with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some len => len
end
with read_variable_pair {left ret right : Type}
(e1 : Tezos_data_encoding.Encoding.t left)
(e2 : Tezos_data_encoding.Encoding.t right) (state : state)
(k : ((left * right) * state) -> status ret) : status ret :=
let size := remaining_bytes state in
match ((Encoding.classify e1), (Encoding.classify e2)) with
| (Dynamic | Fixed _, Variable) =>
apply (read_rec false e1 state)
(fun function_parameter =>
let '(left, state) := function_parameter in
apply (read_rec true e2 state)
(fun function_parameter =>
let '(right, state) := function_parameter in
k ((left, right), state)))
| (Variable, Fixed n) =>
if OCaml.Stdlib.gt n size then
inr Tezos_data_encoding.Binary_error.Not_enough_data
else
let state :=
(* ❌ Record substitution not handled *)
record_substitution in
apply (read_rec true e1 state)
(fun function_parameter =>
let '(left, state) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb (remaining_bytes state) (Some 0)) in
let state :=
(* ❌ Record substitution not handled *)
record_substitution in
apply (read_rec true e2 state)
(fun function_parameter =>
let '(right, state) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb (remaining_bytes state) (Some 0)) in
k ((left, right), state)))
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end
with read_list {a ret : Type}
(error : Tezos_data_encoding.Binary_error.read_error) (max_length : Z)
(e : Tezos_data_encoding.Encoding.t a) (state : state)
(k : ((list a) * state) -> status ret) : status ret :=
let fix loop (state : state) (acc : list a) (max_length : Z) : status ret :=
let size := remaining_bytes state in
if equiv_decb size 0 then
k ((List.rev acc), state)
else
if equiv_decb max_length 0 then
raise error
else
apply (read_rec false e state)
(fun function_parameter =>
let '(v, state) := function_parameter in
loop state (cons v acc) (Z.sub max_length 1)) in
loop state [] max_length.
Definition read_rec {A B : Type}
(e : Tezos_data_encoding.Encoding.t A) (state : state)
(k : (A * state) -> status B) : status B :=
(* ❌ Try-with are not handled *)
try (read_rec false e state k).
Definition success {A : Type} (function_parameter : A * state) : status A :=
let '(v, state) := function_parameter in
Success {| result := v; size := total_read state; stream := stream state |}.
Definition read_stream {A : Type}
(op_staroptstar : option Tezos_data_encoding.Binary_stream.t)
: (Tezos_data_encoding.Encoding.encoding A) -> status A :=
let init :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Binary_stream.empty
end in
fun encoding =>
match Encoding.classify encoding with
| Variable =>
OCaml.Stdlib.invalid_arg
"Data_encoding.Binary.read_stream: variable encoding" % string
| Dynamic | Fixed _ =>
let state :=
{| stream := init; remaining_bytes := None; allowed_bytes := None;
total_read := 0 |} in
read_rec encoding state success
end.
src/lib_data_encoding/binary_writer.ml 80 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Binary_error
let raise error = raise (Write_error error)
(** Imperative state of the binary writer. *)
type state = {
mutable buffer : Bytes.t; (** The buffer where to write. *)
mutable offset : int;
(** The offset of the next byte to be written in [buffer]. *)
mutable allowed_bytes : int option;
(** Maximum number of bytes that are allowed to be write in [buffer]
(after [offset]) before to fail (None = illimited). *)
}
let check_allowed_bytes state size =
match state.allowed_bytes with
| Some len when len < size ->
raise Size_limit_exceeded
| Some len ->
state.allowed_bytes <- Some (len - size)
| None ->
()
(** [may_resize state size] will first ensure there is enough
space in [state.buffer] for writing [size] bytes (starting at
[state.offset]).
When the buffer does not have enough space for writing [size] bytes,
but still has enough [allowed_bytes], it will replace the buffer
with a buffer large enough.
@raise [Binary_error.Write_error Size_limit_exceeded] when there is
not enough allowed bytes to write [size] bytes. *)
let may_resize state size =
check_allowed_bytes state size ;
let buffer_len = Bytes.length state.buffer in
if buffer_len - state.offset < size then (
let new_buffer = Bytes.create (max (2 * buffer_len) (buffer_len + size)) in
Bytes.blit state.buffer 0 new_buffer 0 state.offset ;
state.buffer <- new_buffer ) ;
state.offset <- state.offset + size
(** Writer for all the atomic types. *)
module Atom = struct
let check_int_range min v max =
if v < min || max < v then raise (Invalid_int {min; v; max})
let check_float_range min v max =
if v < min || max < v then raise (Invalid_float {min; v; max})
let set_int kind buffer ofs v =
match kind with
| `Int31 | `Uint30 ->
TzEndian.set_int32 buffer ofs (Int32.of_int v)
| `Int16 | `Uint16 ->
TzEndian.set_int16 buffer ofs v
| `Int8 | `Uint8 ->
TzEndian.set_int8 buffer ofs v
let int kind state v =
check_int_range (Binary_size.min_int kind) v (Binary_size.max_int kind) ;
let ofs = state.offset in
may_resize state (Binary_size.integer_to_size kind) ;
set_int kind state.buffer ofs v
let int8 = int `Int8
let uint8 = int `Uint8
let int16 = int `Int16
let uint16 = int `Uint16
let uint30 = int `Uint30
let int31 = int `Int31
let bool state v = uint8 state (if v then 255 else 0)
let int32 state v =
let ofs = state.offset in
may_resize state Binary_size.int32 ;
TzEndian.set_int32 state.buffer ofs v
let int64 state v =
let ofs = state.offset in
may_resize state Binary_size.int64 ;
TzEndian.set_int64 state.buffer ofs v
let ranged_int ~minimum ~maximum state v =
check_int_range minimum v maximum ;
let v = if minimum >= 0 then v - minimum else v in
match Binary_size.range_to_size ~minimum ~maximum with
| `Uint8 ->
uint8 state v
| `Uint16 ->
uint16 state v
| `Uint30 ->
uint30 state v
| `Int8 ->
int8 state v
| `Int16 ->
int16 state v
| `Int31 ->
int31 state v
let n state v =
if Z.sign v < 0 then raise Invalid_natural ;
if Z.equal v Z.zero then uint8 state 0x00
else
let bits = Z.numbits v in
let get_chunk pos len = Z.to_int (Z.extract v pos len) in
let length = Binary_length.n_length v in
let offset = state.offset in
may_resize state length ;
for i = 0 to length - 1 do
let pos = i * 7 in
let chunk_len = if i = length - 1 then bits - pos else 7 in
TzEndian.set_int8
state.buffer
(offset + i)
((if i = length - 1 then 0x00 else 0x80) lor get_chunk pos chunk_len)
done
let z state v =
let sign = Z.sign v < 0 in
let bits = Z.numbits v in
if Z.equal v Z.zero then uint8 state 0x00
else
let v = Z.abs v in
let get_chunk pos len = Z.to_int (Z.extract v pos len) in
let length = Binary_length.z_length v in
let offset = state.offset in
may_resize state length ;
TzEndian.set_int8
state.buffer
offset
( (if sign then 0x40 else 0x00)
lor (if bits > 6 then 0x80 else 0x00)
lor get_chunk 0 6 ) ;
for i = 1 to length - 1 do
let pos = 6 + ((i - 1) * 7) in
let chunk_len = if i = length - 1 then bits - pos else 7 in
TzEndian.set_int8
state.buffer
(offset + i)
((if i = length - 1 then 0x00 else 0x80) lor get_chunk pos chunk_len)
done
let float state v =
let ofs = state.offset in
may_resize state Binary_size.float ;
TzEndian.set_double state.buffer ofs v
let ranged_float ~minimum ~maximum state v =
check_float_range minimum v maximum ;
float state v
let string_enum tbl arr state v =
let value =
try snd (Hashtbl.find tbl v) with Not_found -> raise No_case_matched
in
match Binary_size.enum_size arr with
| `Uint30 ->
uint30 state value
| `Uint16 ->
uint16 state value
| `Uint8 ->
uint8 state value
let fixed_kind_bytes length state s =
if Bytes.length s <> length then
raise (Invalid_bytes_length {expected = length; found = Bytes.length s}) ;
let ofs = state.offset in
may_resize state length ;
Bytes.blit s 0 state.buffer ofs length
let fixed_kind_string length state s =
if String.length s <> length then
raise
(Invalid_string_length {expected = length; found = String.length s}) ;
let ofs = state.offset in
may_resize state length ;
Bytes.blit_string s 0 state.buffer ofs length
let tag = function `Uint8 -> uint8 | `Uint16 -> uint16
end
(** Main recursive writing function. *)
let rec write_rec : type a. a Encoding.t -> state -> a -> unit =
fun e state value ->
let open Encoding in
match e.encoding with
| Null ->
()
| Empty ->
()
| Constant _ ->
()
| Ignore ->
()
| Bool ->
Atom.bool state value
| Int8 ->
Atom.int8 state value
| Uint8 ->
Atom.uint8 state value
| Int16 ->
Atom.int16 state value
| Uint16 ->
Atom.uint16 state value
| Int31 ->
Atom.int31 state value
| Int32 ->
Atom.int32 state value
| Int64 ->
Atom.int64 state value
| N ->
Atom.n state value
| Z ->
Atom.z state value
| Float ->
Atom.float state value
| Bytes (`Fixed n) ->
Atom.fixed_kind_bytes n state value
| Bytes `Variable ->
let length = Bytes.length value in
Atom.fixed_kind_bytes length state value
| String (`Fixed n) ->
Atom.fixed_kind_string n state value
| String `Variable ->
let length = String.length value in
Atom.fixed_kind_string length state value
| Padded (e, n) ->
write_rec e state value ;
Atom.fixed_kind_string n state (String.make n '\000')
| RangedInt {minimum; maximum} ->
Atom.ranged_int ~minimum ~maximum state value
| RangedFloat {minimum; maximum} ->
Atom.ranged_float ~minimum ~maximum state value
| String_enum (tbl, arr) ->
Atom.string_enum tbl arr state value
| Array (Some max_length, _e) when Array.length value > max_length ->
raise Array_too_long
| Array (_, e) ->
Array.iter (write_rec e state) value
| List (Some max_length, _e) when List.length value > max_length ->
raise List_too_long
| List (_, e) ->
List.iter (write_rec e state) value
| Obj (Req {encoding = e; _}) ->
write_rec e state value
| Obj (Opt {kind = `Dynamic; encoding = e; _}) -> (
match value with
| None ->
Atom.bool state false
| Some value ->
Atom.bool state true ; write_rec e state value )
| Obj (Opt {kind = `Variable; encoding = e; _}) -> (
match value with None -> () | Some value -> write_rec e state value )
| Obj (Dft {encoding = e; _}) ->
write_rec e state value
| Objs {left; right; _} ->
let (v1, v2) = value in
write_rec left state v1 ; write_rec right state v2
| Tup e ->
write_rec e state value
| Tups {left; right; _} ->
let (v1, v2) = value in
write_rec left state v1 ; write_rec right state v2
| Conv {encoding = e; proj; _} ->
write_rec e state (proj value)
| Union {tag_size; cases; _} ->
let rec write_case = function
| [] ->
raise No_case_matched
| Case {tag = Json_only; _} :: tl ->
write_case tl
| Case {encoding = e; proj; tag = Tag tag; _} :: tl -> (
match proj value with
| None ->
write_case tl
| Some value ->
Atom.tag tag_size state tag ;
write_rec e state value )
in
write_case cases
| Dynamic_size {kind; encoding = e} ->
let initial_offset = state.offset in
Atom.int kind state 0 ;
(* place holder for [size] *)
write_with_limit (Binary_size.max_int kind) e state value ;
(* patch the written [size] *)
Atom.set_int
kind
state.buffer
initial_offset
(state.offset - initial_offset - Binary_size.integer_to_size kind)
| Check_size {limit; encoding = e} ->
write_with_limit limit e state value
| Describe {encoding = e; _} ->
write_rec e state value
| Splitted {encoding = e; _} ->
write_rec e state value
| Mu {fix; _} ->
write_rec (fix e) state value
| Delayed f ->
write_rec (f ()) state value
and write_with_limit : type a. int -> a Encoding.t -> state -> a -> unit =
fun limit e state value ->
(* backup the current limit *)
let old_limit = state.allowed_bytes in
(* install the new limit (only if smaller than the current limit) *)
let limit =
match state.allowed_bytes with
| None ->
limit
| Some old_limit ->
min old_limit limit
in
state.allowed_bytes <- Some limit ;
write_rec e state value ;
(* restore the previous limit (minus the read bytes) *)
match old_limit with
| None ->
state.allowed_bytes <- None
| Some old_limit ->
let remaining =
match state.allowed_bytes with None -> assert false | Some len -> len
in
let read = limit - remaining in
state.allowed_bytes <- Some (old_limit - read)
(** ******************** *)
(** Various entry points *)
let write e v buffer offset len =
(* By harcoding [allowed_bytes] with the buffer length,
we ensure that [write] will never reallocate the buffer. *)
let state = {buffer; offset; allowed_bytes = Some len} in
try write_rec e state v ; Some state.offset with Write_error _ -> None
let to_bytes_exn e v =
match Encoding.classify e with
| `Fixed n ->
(* Preallocate the complete buffer *)
let state =
{buffer = Bytes.create n; offset = 0; allowed_bytes = Some n}
in
write_rec e state v ; state.buffer
| `Dynamic | `Variable ->
(* Preallocate a minimal buffer and let's not hardcode a
limit to its extension. *)
let state =
{buffer = Bytes.create 128; offset = 0; allowed_bytes = None}
in
write_rec e state v ;
Bytes.sub state.buffer 0 state.offset
let to_bytes e v = try Some (to_bytes_exn e v) with Write_error _ -> None
src/lib_data_encoding/binary_writer.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Binary_error.
Definition raise {A : Type}
(error : Tezos_data_encoding.Binary_error.write_error) : A :=
Stdlib.raise (Write_error error).
Record state := {
buffer : Stdlib.Bytes.t;
offset : Z;
allowed_bytes : option Z }.
Definition check_allowed_bytes (state : state) (size : Z) : unit :=
match allowed_bytes state with
| Some len => raise Tezos_data_encoding.Binary_error.Size_limit_exceeded
| Some len =>
(* ❌ Set record field not handled. *)
set_record_field state "allowed_bytes" % string (Some (Z.sub len size))
| None => tt
end.
Definition may_resize (state : state) (size : Z) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := check_allowed_bytes state size in
let buffer_len := String.length (buffer state) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt (Z.sub buffer_len (offset state)) size then
let new_buffer :=
Stdlib.Bytes.create
(OCaml.Stdlib.max (Z.mul 2 buffer_len) (Z.add buffer_len size)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.Bytes.blit (buffer state) 0 new_buffer 0 (offset state) in
(* ❌ Set record field not handled. *)
set_record_field state "buffer" % string new_buffer
else
tt in
(* ❌ Set record field not handled. *)
set_record_field state "offset" % string (Z.add (offset state) size).
Module Atom.
Definition check_int_range (min : Z) (v : Z) (max : Z) : unit :=
if orb (OCaml.Stdlib.lt v min) (OCaml.Stdlib.lt max v) then
raise
(Tezos_data_encoding.Binary_error.Invalid_int
{| min := min; v := v; max := max |})
else
tt.
Definition check_float_range (min : Z) (v : Z) (max : Z) : unit :=
if orb (OCaml.Stdlib.lt v min) (OCaml.Stdlib.lt max v) then
raise
(Tezos_data_encoding.Binary_error.Invalid_float
{| min := min; v := v; max := max |})
else
tt.
Definition set_int (kind : variant) (buffer : string) (ofs : Z) (v : Z)
: unit :=
match kind with
| Int31 | Uint30 => TzEndian.set_int32 buffer ofs (Int32.of_int v)
| Int16 | Uint16 => TzEndian.set_int16 buffer ofs v
| Int8 | Uint8 => TzEndian.set_int8 buffer ofs v
end.
Definition int (kind : variant) (state : state) (v : Z) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
check_int_range (Binary_size.min_int kind) v (Binary_size.max_int kind) in
let ofs := offset state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := may_resize state (Binary_size.integer_to_size kind) in
set_int kind (buffer state) ofs v.
Definition int8 : state -> Z -> unit :=
Z
(* ❌ Variants not supported *)
variant.
Definition uint8 : state -> Z -> unit :=
Z
(* ❌ Variants not supported *)
variant.
Definition int16 : state -> Z -> unit :=
Z
(* ❌ Variants not supported *)
variant.
Definition uint16 : state -> Z -> unit :=
Z
(* ❌ Variants not supported *)
variant.
Definition uint30 : state -> Z -> unit :=
Z
(* ❌ Variants not supported *)
variant.
Definition int31 : state -> Z -> unit :=
Z
(* ❌ Variants not supported *)
variant.
Definition bool (state : state) (v : bool) : unit :=
uint8 state
(if v then
255
else
0).
Definition int32 (state : state) (v : int32) : unit :=
let ofs := offset state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := may_resize state Binary_size.int32 in
TzEndian.set_int32 (buffer state) ofs v.
Definition int64 (state : state) (v : int64) : unit :=
let ofs := offset state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := may_resize state Binary_size.int64 in
TzEndian.set_int64 (buffer state) ofs v.
Definition ranged_int (minimum : Z) (maximum : Z) (state : state) (v : Z)
: unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := check_int_range minimum v maximum in
let v :=
if OCaml.Stdlib.ge minimum 0 then
Z.sub v minimum
else
v in
match Binary_size.range_to_size minimum maximum with
| Uint8 => uint8 state v
| Uint16 => uint16 state v
| Uint30 => uint30 state v
| Int8 => int8 state v
| Int16 => int16 state v
| Int31 => int31 state v
end.
Definition n (state : state) (v : Z.t) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt (Z.sign v) 0 then
raise Tezos_data_encoding.Binary_error.Invalid_natural
else
tt in
if Z.equal v Z.zero then
uint8 state 0
else
let bits := Z.numbits v in
let get_chunk (pos : Z) (len : Z) : Z :=
Z.to_int (Z.extract v pos len) in
let length := Binary_length.n_length v in
let offset := offset state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := may_resize state length in
(* ❌ For loops not handled. *)
for.
Definition z (state : state) (v : Z.t) : unit :=
let sign := OCaml.Stdlib.lt (Z.sign v) 0 in
let bits := Z.numbits v in
if Z.equal v Z.zero then
uint8 state 0
else
let v := Z.abs v in
let get_chunk (pos : Z) (len : Z) : Z :=
Z.to_int (Z.extract v pos len) in
let length := Binary_length.z_length v in
let offset := offset state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := may_resize state length in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
TzEndian.set_int8 (buffer state) offset
(Z.lor
(Z.lor
(if sign then
64
else
0)
(if OCaml.Stdlib.gt bits 6 then
128
else
0)) (get_chunk 0 6)) in
(* ❌ For loops not handled. *)
for.
Definition float (state : state) (v : Z) : unit :=
let ofs := offset state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := may_resize state Binary_size.float in
TzEndian.set_double (buffer state) ofs v.
Definition ranged_float (minimum : Z) (maximum : Z) (state : state) (v : Z)
: unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := check_float_range minimum v maximum in
Z state v.
Definition string_enum {A B C : Type}
(tbl : Stdlib.Hashtbl.t A (B * Z)) (arr : array C) (state : state) (v : A)
: unit :=
let value :=
(* ❌ Try-with are not handled *)
try (snd (Hashtbl.find tbl v)) in
match Binary_size.enum_size arr with
| Uint30 => uint30 state value
| Uint16 => uint16 state value
| Uint8 => uint8 state value
end.
Definition fixed_kind_bytes (length : Z) (state : state) (s : string)
: unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb (String.length s) length then
raise
(Tezos_data_encoding.Binary_error.Invalid_bytes_length
{| expected := length; found := String.length s |})
else
tt in
let ofs := offset state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := may_resize state length in
Stdlib.Bytes.blit s 0 (buffer state) ofs length.
Definition fixed_kind_string (length : Z) (state : state) (s : string)
: unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb (OCaml.String.length s) length then
raise
(Tezos_data_encoding.Binary_error.Invalid_string_length
{| expected := length; found := OCaml.String.length s |})
else
tt in
let ofs := offset state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := may_resize state length in
Stdlib.Bytes.blit_string s 0 (buffer state) ofs length.
Definition tag (function_parameter : variant) : state -> Z -> unit :=
match function_parameter with
| Uint8 => uint8
| Uint16 => uint16
end.
End Atom.
Fixpoint write_rec {a : Type}
(e : Tezos_data_encoding.Encoding.t a) (state : state) (value : a) : unit :=
match encoding e with
| Tezos_data_encoding.Encoding.Null => tt
| Tezos_data_encoding.Encoding.Empty => tt
| Tezos_data_encoding.Encoding.Constant _ => tt
| Tezos_data_encoding.Encoding.Ignore => tt
| Tezos_data_encoding.Encoding.Bool => Atom.bool state value
| Tezos_data_encoding.Encoding.Int8 => Atom.int8 state value
| Tezos_data_encoding.Encoding.Uint8 => Atom.uint8 state value
| Tezos_data_encoding.Encoding.Int16 => Atom.int16 state value
| Tezos_data_encoding.Encoding.Uint16 => Atom.uint16 state value
| Tezos_data_encoding.Encoding.Int31 => Atom.int31 state value
| Tezos_data_encoding.Encoding.Int32 => Atom.int32 state value
| Tezos_data_encoding.Encoding.Int64 => Atom.int64 state value
| Tezos_data_encoding.Encoding.N => Atom.n state value
| Tezos_data_encoding.Encoding.Z => Atom.z state value
| Tezos_data_encoding.Encoding.Float => Atom.float state value
| Tezos_data_encoding.Encoding.Bytes (Fixed n) =>
Atom.fixed_kind_bytes n state value
| Tezos_data_encoding.Encoding.Bytes Variable =>
let length := String.length value in
Atom.fixed_kind_bytes length state value
| Tezos_data_encoding.Encoding.String (Fixed n) =>
Atom.fixed_kind_string n state value
| Tezos_data_encoding.Encoding.String Variable =>
let length := OCaml.String.length value in
Atom.fixed_kind_string length state value
| Tezos_data_encoding.Encoding.Padded e n =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := write_rec e state value in
Atom.fixed_kind_string n state (Stdlib.String.make n "000" % char)
|
Tezos_data_encoding.Encoding.RangedInt {|
minimum := minimum; maximum := maximum |} =>
Atom.ranged_int minimum maximum state value
|
Tezos_data_encoding.Encoding.RangedFloat {|
minimum := minimum; maximum := maximum |} =>
Atom.ranged_float minimum maximum state value
| Tezos_data_encoding.Encoding.String_enum tbl arr =>
Atom.string_enum tbl arr state value
| Tezos_data_encoding.Encoding.Array (Some max_length) _e =>
raise Tezos_data_encoding.Binary_error.Array_too_long
| Tezos_data_encoding.Encoding.Array _ e =>
Array.iter (write_rec e state) value
| Tezos_data_encoding.Encoding.List (Some max_length) _e =>
raise Tezos_data_encoding.Binary_error.List_too_long
| Tezos_data_encoding.Encoding.List _ e =>
Stdlib.List.iter (write_rec e state) value
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Req {| encoding := e |}) =>
write_rec e state value
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Opt {| kind := Dynamic; encoding := e |}) =>
match value with
| None => Atom.bool state false
| Some value =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Atom.bool state true in
write_rec e state value
end
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Opt {| kind := Variable; encoding := e |})
=>
match value with
| None => tt
| Some value => write_rec e state value
end
|
Tezos_data_encoding.Encoding.Obj
(Tezos_data_encoding.Encoding.Dft {| encoding := e |}) =>
write_rec e state value
| Tezos_data_encoding.Encoding.Objs {| left := left; right := right |} =>
let '(v1, v2) := value in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := write_rec left state v1 in
write_rec right state v2
| Tezos_data_encoding.Encoding.Tup e => write_rec e state value
| Tezos_data_encoding.Encoding.Tups {| left := left; right := right |} =>
let '(v1, v2) := value in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := write_rec left state v1 in
write_rec right state v2
| Tezos_data_encoding.Encoding.Conv {| proj := proj; encoding := e |} =>
write_rec e state (proj value)
|
Tezos_data_encoding.Encoding.Union {|
tag_size := tag_size; cases := cases |} =>
let fix write_case
(function_parameter : list (Tezos_data_encoding.Encoding.case a))
: unit :=
match function_parameter with
| [] => raise Tezos_data_encoding.Binary_error.No_case_matched
|
cons
(Tezos_data_encoding.Encoding.Case {|
tag := Tezos_data_encoding.Encoding.Json_only |}) tl =>
write_case tl
|
cons
(Tezos_data_encoding.Encoding.Case {|
encoding := e;
proj := proj;
tag := Tezos_data_encoding.Encoding.Tag tag
|}) tl =>
match proj value with
| None => write_case tl
| Some value =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Atom.tag tag_size state tag in
write_rec e state value
end
end in
write_case cases
| Tezos_data_encoding.Encoding.Dynamic_size {| kind := kind; encoding := e |}
=>
let initial_offset := offset state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Atom.int kind state 0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := write_with_limit (Binary_size.max_int kind) e state value in
Atom.set_int kind (buffer state) initial_offset
(Z.sub (Z.sub (offset state) initial_offset)
(Binary_size.integer_to_size kind))
| Tezos_data_encoding.Encoding.Check_size {| limit := limit; encoding := e |}
=> write_with_limit limit e state value
| Tezos_data_encoding.Encoding.Describe {| encoding := e |} =>
write_rec e state value
| Tezos_data_encoding.Encoding.Splitted {| encoding := e |} =>
write_rec e state value
| Tezos_data_encoding.Encoding.Mu {| fix := fix |} =>
write_rec (fix e) state value
| Tezos_data_encoding.Encoding.Delayed f => write_rec (f tt) state value
end
with write_with_limit {a : Type}
(limit : Z) (e : Tezos_data_encoding.Encoding.t a) (state : state) (value : a)
: unit :=
let old_limit := allowed_bytes state in
let limit :=
match allowed_bytes state with
| None => limit
| Some old_limit => OCaml.Stdlib.min old_limit limit
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "allowed_bytes" % string (Some limit) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := write_rec e state value in
match old_limit with
| None =>
(* ❌ Set record field not handled. *)
set_record_field state "allowed_bytes" % string None
| Some old_limit =>
let remaining :=
match allowed_bytes state with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some len => len
end in
let read := Z.sub limit remaining in
(* ❌ Set record field not handled. *)
set_record_field state "allowed_bytes" % string
(Some (Z.sub old_limit read))
end.
Definition write {A : Type}
(e : Tezos_data_encoding.Encoding.t A) (v : A) (buffer : Stdlib.Bytes.t)
(offset : Z) (len : Z) : option Z :=
let state :=
{| buffer := buffer; offset := offset; allowed_bytes := Some len |} in
(* ❌ Try-with are not handled *)
try
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ := write_rec e state v in
Some (offset state)).
Definition to_bytes_exn {A : Type}
(e : Tezos_data_encoding.Encoding.encoding A) (v : A) : Stdlib.Bytes.t :=
match Encoding.classify e with
| Fixed n =>
let state :=
{| buffer := Stdlib.Bytes.create n; offset := 0; allowed_bytes := Some n
|} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := write_rec e state v in
buffer state
| Dynamic | Variable =>
let state :=
{| buffer := Stdlib.Bytes.create 128; offset := 0; allowed_bytes := None
|} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := write_rec e state v in
String.sub (buffer state) 0 (offset state)
end.
Definition to_bytes {A : Type}
(e : Tezos_data_encoding.Encoding.encoding A) (v : A)
: option Stdlib.Bytes.t :=
(* ❌ Try-with are not handled *)
try (Some (to_bytes_exn e v)).
src/lib_data_encoding/bson.ml success
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) type bson = Json_repr_bson.bson type t = bson let construct e v = Json_repr_bson.Json_encoding.construct (Json.convert e) v let destruct e v = Json_repr_bson.Json_encoding.destruct (Json.convert e) v
src/lib_data_encoding/bson.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition bson := Json_repr_bson.bson.
Definition t := bson.
Definition construct {A : Type} (e : Tezos_data_encoding.Encoding.t A) (v : A)
: Json_repr_bson.Repr.value :=
Json_repr_bson.Json_encoding.construct (Json.convert e) v.
Definition destruct {A : Type}
(e : Tezos_data_encoding.Encoding.t A) (v : Json_repr_bson.Repr.value) : A :=
Json_repr_bson.Json_encoding.destruct (Json.convert e) v.
src/lib_data_encoding/bytes_encodings.ml success
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* this module is a temporary fix waiting for ocaml 4.08 *)
(** {1 Binary encoding/decoding of integers} *)
external get_uint8 : bytes -> int -> int = "%bytes_safe_get"
external get_uint16_ne : bytes -> int -> int = "%caml_bytes_get16"
external get_int32_ne : bytes -> int -> int32 = "%caml_bytes_get32"
external get_int64_ne : bytes -> int -> int64 = "%caml_bytes_get64"
external set_int8 : bytes -> int -> int -> unit = "%bytes_safe_set"
external set_int16_ne : bytes -> int -> int -> unit = "%caml_bytes_set16"
external set_int32_ne : bytes -> int -> int32 -> unit = "%caml_bytes_set32"
external set_int64_ne : bytes -> int -> int64 -> unit = "%caml_bytes_set64"
external swap16 : int -> int = "%bswap16"
external swap32 : int32 -> int32 = "%bswap_int32"
external swap64 : int64 -> int64 = "%bswap_int64"
let get_int8 b i = (get_uint8 b i lsl (Sys.int_size - 8)) asr (Sys.int_size - 8)
let get_uint16_le b i =
if Sys.big_endian then swap16 (get_uint16_ne b i) else get_uint16_ne b i
let get_uint16_be b i =
if not Sys.big_endian then swap16 (get_uint16_ne b i) else get_uint16_ne b i
let get_int16_ne b i =
(get_uint16_ne b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
let get_int16_le b i =
(get_uint16_le b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
let get_int16_be b i =
(get_uint16_be b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
let get_int32_le b i =
if Sys.big_endian then swap32 (get_int32_ne b i) else get_int32_ne b i
let get_int32_be b i =
if not Sys.big_endian then swap32 (get_int32_ne b i) else get_int32_ne b i
let get_int64_le b i =
if Sys.big_endian then swap64 (get_int64_ne b i) else get_int64_ne b i
let get_int64_be b i =
if not Sys.big_endian then swap64 (get_int64_ne b i) else get_int64_ne b i
let set_int16_le b i x =
if Sys.big_endian then set_int16_ne b i (swap16 x) else set_int16_ne b i x
let set_int16_be b i x =
if not Sys.big_endian then set_int16_ne b i (swap16 x)
else set_int16_ne b i x
let set_int32_le b i x =
if Sys.big_endian then set_int32_ne b i (swap32 x) else set_int32_ne b i x
let set_int32_be b i x =
if not Sys.big_endian then set_int32_ne b i (swap32 x)
else set_int32_ne b i x
let set_int64_le b i x =
if Sys.big_endian then set_int64_ne b i (swap64 x) else set_int64_ne b i x
let set_int64_be b i x =
if not Sys.big_endian then set_int64_ne b i (swap64 x)
else set_int64_ne b i x
let set_uint8 = set_int8
let set_uint16_ne = set_int16_ne
let set_uint16_be = set_int16_be
let set_uint16_le = set_int16_le
module type S = sig
(** {1 Binary encoding/decoding of integers} *)
(** The functions in this section binary encode and decode integers to
and from byte sequences.
All following functions raise [Invalid_argument] if the space
needed at index [i] to decode or encode the integer is not
available.
Little-endian (resp. big-endian) encoding means that least
(resp. most) significant bytes are stored first. Big-endian is
also known as network byte order. Native-endian encoding is
either little-endian or big-endian depending on {!Sys.big_endian}.
32-bit and 64-bit integers are represented by the [int32] and
[int64] types, which can be interpreted either as signed or
unsigned numbers.
8-bit and 16-bit integers are represented by the [int] type,
which has more bits than the binary encoding. These extra bits
are handled as follows:
{ul
{- Functions that decode signed (resp. unsigned) 8-bit or 16-bit
integers represented by [int] values sign-extend
(resp. zero-extend) their result.}
{- Functions that encode 8-bit or 16-bit integers represented by
[int] values truncate their input to their least significant
bytes.}
}
*)
(** [get_uint8 b i] is [b]'s unsigned 8-bit integer starting at byte index [i].
@since 4.08
*)
val get_uint8 : bytes -> int -> int
(** [get_int8 b i] is [b]'s signed 8-bit integer starting at byte index [i].
@since 4.08
*)
val get_int8 : bytes -> int -> int
(** [get_uint16_ne b i] is [b]'s native-endian unsigned 16-bit integer
starting at byte index [i].
@since 4.08
*)
val get_uint16_ne : bytes -> int -> int
(** [get_uint16_be b i] is [b]'s big-endian unsigned 16-bit integer
starting at byte index [i].
@since 4.08
*)
val get_uint16_be : bytes -> int -> int
(** [get_uint16_le b i] is [b]'s little-endian unsigned 16-bit integer
starting at byte index [i].
@since 4.08
*)
val get_uint16_le : bytes -> int -> int
(** [get_int16_ne b i] is [b]'s native-endian signed 16-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int16_ne : bytes -> int -> int
(** [get_int16_be b i] is [b]'s big-endian signed 16-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int16_be : bytes -> int -> int
(** [get_int16_le b i] is [b]'s little-endian signed 16-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int16_le : bytes -> int -> int
(** [get_int32_ne b i] is [b]'s native-endian 32-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int32_ne : bytes -> int -> int32
(** [get_int32_be b i] is [b]'s big-endian 32-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int32_be : bytes -> int -> int32
(** [get_int32_le b i] is [b]'s little-endian 32-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int32_le : bytes -> int -> int32
(** [get_int64_ne b i] is [b]'s native-endian 64-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int64_ne : bytes -> int -> int64
(** [get_int64_be b i] is [b]'s big-endian 64-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int64_be : bytes -> int -> int64
(** [get_int64_le b i] is [b]'s little-endian 64-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int64_le : bytes -> int -> int64
(** [set_uint8 b i v] sets [b]'s unsigned 8-bit integer starting at byte index
[i] to [v].
@since 4.08
*)
val set_uint8 : bytes -> int -> int -> unit
(** [set_int8 b i v] sets [b]'s signed 8-bit integer starting at byte index
[i] to [v].
@since 4.08
*)
val set_int8 : bytes -> int -> int -> unit
(** [set_uint16_ne b i v] sets [b]'s native-endian unsigned 16-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_uint16_ne : bytes -> int -> int -> unit
(** [set_uint16_be b i v] sets [b]'s big-endian unsigned 16-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_uint16_be : bytes -> int -> int -> unit
(** [set_uint16_le b i v] sets [b]'s little-endian unsigned 16-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_uint16_le : bytes -> int -> int -> unit
(** [set_int16_ne b i v] sets [b]'s native-endian signed 16-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int16_ne : bytes -> int -> int -> unit
(** [set_int16_be b i v] sets [b]'s big-endian signed 16-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int16_be : bytes -> int -> int -> unit
(** [set_int16_le b i v] sets [b]'s little-endian signed 16-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int16_le : bytes -> int -> int -> unit
(** [set_int32_ne b i v] sets [b]'s native-endian 32-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int32_ne : bytes -> int -> int32 -> unit
(** [set_int32_be b i v] sets [b]'s big-endian 32-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int32_be : bytes -> int -> int32 -> unit
(** [set_int32_le b i v] sets [b]'s little-endian 32-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int32_le : bytes -> int -> int32 -> unit
(** [set_int64_ne b i v] sets [b]'s native-endian 64-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int64_ne : bytes -> int -> int64 -> unit
(** [set_int64_be b i v] sets [b]'s big-endian 64-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int64_be : bytes -> int -> int64 -> unit
(** [set_int64_le b i v] sets [b]'s little-endian 64-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int64_le : bytes -> int -> int64 -> unit
end
src/lib_data_encoding/bytes_encodings.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Parameter get_uint8 : string -> Z -> Z.
Parameter get_uint16_ne : string -> Z -> Z.
Parameter get_int32_ne : string -> Z -> int32.
Parameter get_int64_ne : string -> Z -> int64.
Parameter set_int8 : string -> Z -> Z -> unit.
Parameter set_int16_ne : string -> Z -> Z -> unit.
Parameter set_int32_ne : string -> Z -> int32 -> unit.
Parameter set_int64_ne : string -> Z -> int64 -> unit.
Parameter swap16 : Z -> Z.
Parameter swap32 : int32 -> int32.
Parameter swap64 : int64 -> int64.
Definition get_int8 (b : string) (i : Z) : Z :=
Stdlib.asr (Z.shiftl (get_uint8 b i) (Z.sub Sys.int_size 8))
(Z.sub Sys.int_size 8).
Definition get_uint16_le (b : string) (i : Z) : Z :=
if Sys.big_endian then
swap16 (get_uint16_ne b i)
else
get_uint16_ne b i.
Definition get_uint16_be (b : string) (i : Z) : Z :=
if negb Sys.big_endian then
swap16 (get_uint16_ne b i)
else
get_uint16_ne b i.
Definition get_int16_ne (b : string) (i : Z) : Z :=
Stdlib.asr (Z.shiftl (get_uint16_ne b i) (Z.sub Sys.int_size 16))
(Z.sub Sys.int_size 16).
Definition get_int16_le (b : string) (i : Z) : Z :=
Stdlib.asr (Z.shiftl (get_uint16_le b i) (Z.sub Sys.int_size 16))
(Z.sub Sys.int_size 16).
Definition get_int16_be (b : string) (i : Z) : Z :=
Stdlib.asr (Z.shiftl (get_uint16_be b i) (Z.sub Sys.int_size 16))
(Z.sub Sys.int_size 16).
Definition get_int32_le (b : string) (i : Z) : int32 :=
if Sys.big_endian then
swap32 (get_int32_ne b i)
else
get_int32_ne b i.
Definition get_int32_be (b : string) (i : Z) : int32 :=
if negb Sys.big_endian then
swap32 (get_int32_ne b i)
else
get_int32_ne b i.
Definition get_int64_le (b : string) (i : Z) : int64 :=
if Sys.big_endian then
swap64 (get_int64_ne b i)
else
get_int64_ne b i.
Definition get_int64_be (b : string) (i : Z) : int64 :=
if negb Sys.big_endian then
swap64 (get_int64_ne b i)
else
get_int64_ne b i.
Definition set_int16_le (b : string) (i : Z) (x : Z) : unit :=
if Sys.big_endian then
set_int16_ne b i (swap16 x)
else
set_int16_ne b i x.
Definition set_int16_be (b : string) (i : Z) (x : Z) : unit :=
if negb Sys.big_endian then
set_int16_ne b i (swap16 x)
else
set_int16_ne b i x.
Definition set_int32_le (b : string) (i : Z) (x : int32) : unit :=
if Sys.big_endian then
set_int32_ne b i (swap32 x)
else
set_int32_ne b i x.
Definition set_int32_be (b : string) (i : Z) (x : int32) : unit :=
if negb Sys.big_endian then
set_int32_ne b i (swap32 x)
else
set_int32_ne b i x.
Definition set_int64_le (b : string) (i : Z) (x : int64) : unit :=
if Sys.big_endian then
set_int64_ne b i (swap64 x)
else
set_int64_ne b i x.
Definition set_int64_be (b : string) (i : Z) (x : int64) : unit :=
if negb Sys.big_endian then
set_int64_ne b i (swap64 x)
else
set_int64_ne b i x.
Definition set_uint8 : string -> Z -> Z -> unit := set_int8.
Definition set_uint16_ne : string -> Z -> Z -> unit := set_int16_ne.
Definition set_uint16_be : string -> Z -> Z -> unit := set_int16_be.
Definition set_uint16_le : string -> Z -> Z -> unit := set_int16_le.
Module S.
Record signature := {
get_uint8 : string -> Z -> Z;
get_int8 : string -> Z -> Z;
get_uint16_ne : string -> Z -> Z;
get_uint16_be : string -> Z -> Z;
get_uint16_le : string -> Z -> Z;
get_int16_ne : string -> Z -> Z;
get_int16_be : string -> Z -> Z;
get_int16_le : string -> Z -> Z;
get_int32_ne : string -> Z -> int32;
get_int32_be : string -> Z -> int32;
get_int32_le : string -> Z -> int32;
get_int64_ne : string -> Z -> int64;
get_int64_be : string -> Z -> int64;
get_int64_le : string -> Z -> int64;
set_uint8 : string -> Z -> Z -> unit;
set_int8 : string -> Z -> Z -> unit;
set_uint16_ne : string -> Z -> Z -> unit;
set_uint16_be : string -> Z -> Z -> unit;
set_uint16_le : string -> Z -> Z -> unit;
set_int16_ne : string -> Z -> Z -> unit;
set_int16_be : string -> Z -> Z -> unit;
set_int16_le : string -> Z -> Z -> unit;
set_int32_ne : string -> Z -> int32 -> unit;
set_int32_be : string -> Z -> int32 -> unit;
set_int32_le : string -> Z -> int32 -> unit;
set_int64_ne : string -> Z -> int64 -> unit;
set_int64_be : string -> Z -> int64 -> unit;
set_int64_le : string -> Z -> int64 -> unit;
}.
End S.
src/lib_data_encoding/data_encoding.ml 22 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Encoding = struct
include Encoding
let splitted ~json ~binary = raw_splitted ~json:(Json.convert json) ~binary
let assoc enc =
let json = Json_encoding.assoc (Json.convert enc) in
let binary = list (tup2 string enc) in
raw_splitted ~json ~binary
module Bounded = struct
let string length =
raw_splitted
~binary:
(let kind = Binary_size.unsigned_range_to_size length in
check_size (length + Binary_size.integer_to_size kind)
@@ dynamic_size ~kind Variable.string)
~json:
(let open Json_encoding in
conv
(fun s ->
if String.length s > length then invalid_arg "oversized string" ;
s)
(fun s ->
if String.length s > length then
raise
(Cannot_destruct ([], Invalid_argument "oversized string")) ;
s)
string)
let bytes length =
raw_splitted
~binary:
(let kind = Binary_size.unsigned_range_to_size length in
check_size (length + Binary_size.integer_to_size kind)
@@ dynamic_size ~kind Variable.bytes)
~json:
(let open Json_encoding in
conv
(fun s ->
if Bytes.length s > length then invalid_arg "oversized string" ;
s)
(fun s ->
if Bytes.length s > length then
raise
(Cannot_destruct ([], Invalid_argument "oversized string")) ;
s)
Json.bytes_jsont)
end
type 'a lazy_state = Value of 'a | Bytes of Bytes.t | Both of Bytes.t * 'a
type 'a lazy_t = {mutable state : 'a lazy_state; encoding : 'a t}
let force_decode le =
match le.state with
| Value value ->
Some value
| Both (_, value) ->
Some value
| Bytes bytes -> (
match Binary_reader.of_bytes le.encoding bytes with
| Some expr ->
le.state <- Both (bytes, expr) ;
Some expr
| None ->
None )
let force_bytes le =
match le.state with
| Bytes bytes ->
bytes
| Both (bytes, _) ->
bytes
| Value value ->
let bytes = Binary_writer.to_bytes_exn le.encoding value in
le.state <- Both (bytes, value) ;
bytes
let lazy_encoding encoding =
let binary =
Encoding.conv
force_bytes
(fun bytes -> {state = Bytes bytes; encoding})
Encoding.bytes
in
let json =
Encoding.conv
(fun le ->
match force_decode le with Some r -> r | None -> raise Exit)
(fun value -> {state = Value value; encoding})
encoding
in
splitted ~json ~binary
let make_lazy encoding value = {encoding; state = Value value}
let apply_lazy ~fun_value ~fun_bytes ~fun_combine le =
match le.state with
| Value value ->
fun_value value
| Bytes bytes ->
fun_bytes bytes
| Both (bytes, value) ->
fun_combine (fun_value value) (fun_bytes bytes)
end
include Encoding
module With_version = With_version
module Registration = Registration
module Json = Json
module Bson = Bson
module Binary_schema = Binary_schema
module Binary = struct
include Binary_error
include Binary_length
include Binary_writer
include Binary_reader
include Binary_stream_reader
let describe = Binary_description.describe
end
type json = Json.t
let json = Json.encoding
type json_schema = Json.schema
let json_schema = Json.schema_encoding
type bson = Bson.t
src/lib_data_encoding/data_encoding.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Encoding.
(* ❌ Structure item `include` not handled. *)
include
Definition splitted {A : Type}
(json : Tezos_data_encoding.Encoding.t A) (binary : encoding A)
: encoding A := raw_splitted (Json.convert json) binary.
Definition assoc {A : Type} (enc : Tezos_data_encoding.Encoding.t A)
: encoding (list (string * A)) :=
let json := Json_encoding.assoc (Json.convert enc) in
let binary := list None (tup2 string enc) in
raw_splitted json binary.
Module Bounded.
Definition string (length : Z) : encoding string :=
raw_splitted
(conv
(fun s =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt (OCaml.String.length s) length then
OCaml.Stdlib.invalid_arg "oversized string" % string
else
tt in
s)
(fun s =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt (OCaml.String.length s) length then
Stdlib.raise
(Cannot_destruct
([], (OCaml.Invalid_argument "oversized string" % string)))
else
tt in
s) None string)
(let kind := Binary_size.unsigned_range_to_size length in
apply (check_size (Z.add length (Binary_size.integer_to_size kind)))
(dynamic_size (Some kind) Variable.string)).
Definition bytes (length : Z) : encoding Stdlib.Bytes.t :=
raw_splitted
(conv
(fun s =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt (String.length s) length then
OCaml.Stdlib.invalid_arg "oversized string" % string
else
tt in
s)
(fun s =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt (String.length s) length then
Stdlib.raise
(Cannot_destruct
([], (OCaml.Invalid_argument "oversized string" % string)))
else
tt in
s) None Json.bytes_jsont)
(let kind := Binary_size.unsigned_range_to_size length in
apply (check_size (Z.add length (Binary_size.integer_to_size kind)))
(dynamic_size (Some kind) Variable.bytes)).
End Bounded.
Inductive lazy_state (a : Type) : Type :=
| Value : a -> lazy_state a
| Bytes : Stdlib.Bytes.t -> lazy_state a
| Both : Stdlib.Bytes.t -> a -> lazy_state a.
Arguments Value {_}.
Arguments Bytes {_}.
Arguments Both {_}.
Record lazy_t {a : Type} := {
state : lazy_state a;
encoding : t a }.
Arguments lazy_t : clear implicits.
Definition force_decode {A : Type} (le : lazy_t A) : option A :=
match state le with
| Value value => Some value
| Both _ value => Some value
| Bytes bytes =>
match Binary_reader.of_bytes (encoding le) string with
| Some expr =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field le "state" % string (Both string expr) in
Some expr
| None => None
end
end.
Definition force_bytes {A : Type} (le : lazy_t A) : Stdlib.Bytes.t :=
match state le with
| Bytes bytes => string
| Both bytes _ => string
| Value value =>
let bytes := Binary_writer.to_bytes_exn (encoding le) value in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field le "state" % string (Both string value) in
string
end.
Definition lazy_encoding {A : Type} (encoding : t A) : encoding (lazy_t A) :=
let binary :=
Encoding.conv force_bytes
(fun bytes => {| state := Bytes string; encoding := encoding |}) None
Encoding.bytes in
let json :=
Encoding.conv
(fun le =>
match force_decode le with
| Some r => r
| None => Stdlib.raise Exit
end) (fun value => {| state := Value value; encoding := encoding |})
None encoding in
splitted json binary.
Definition make_lazy {A : Type} (encoding : t A) (value : A) : lazy_t A :=
{| state := Value value; encoding := encoding |}.
Definition apply_lazy {A B : Type}
(fun_value : A -> B) (fun_bytes : Stdlib.Bytes.t -> B)
(fun_combine : B -> B -> B) (le : lazy_t A) : B :=
match state le with
| Value value => fun_value value
| Bytes bytes => fun_bytes string
| Both bytes value => fun_combine (fun_value value) (fun_bytes string)
end.
End Encoding.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
Module Binary.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition describe {A : Type}
: (Tezos_data_encoding.Encoding.t A) -> Tezos_data_encoding.Binary_schema.t :=
Binary_description.describe.
End Binary.
Definition json := Json.t.
Definition json : Tezos_data_encoding.Encoding.t Json.json := Json.encoding.
Definition json_schema := Json.schema.
Definition json_schema : Tezos_data_encoding.Encoding.t Json.schema :=
Json.schema_encoding.
Definition bson := Bson.t.
src/lib_data_encoding/encoding.ml 135 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Kind = struct
type t = [`Fixed of int | `Dynamic | `Variable]
type length = [`Fixed of int | `Variable]
type enum = [`Dynamic | `Variable]
let combine name : t -> t -> t =
fun k1 k2 ->
match (k1, k2) with
| (`Fixed n1, `Fixed n2) ->
`Fixed (n1 + n2)
| (`Dynamic, `Dynamic) | (`Fixed _, `Dynamic) | (`Dynamic, `Fixed _) ->
`Dynamic
| (`Variable, `Fixed _) | ((`Dynamic | `Fixed _), `Variable) ->
`Variable
| (`Variable, `Dynamic) ->
Printf.ksprintf
invalid_arg
"Cannot merge two %s when the left element is of variable length \
and the right one of dynamic length. You should use the reverse \
order, or wrap the second one with Data_encoding.dynamic_size."
name
| (`Variable, `Variable) ->
Printf.ksprintf
invalid_arg
"Cannot merge two %s with variable length. You should wrap one of \
them with Data_encoding.dynamic_size."
name
let merge : t -> t -> t =
fun k1 k2 ->
match (k1, k2) with
| (`Fixed n1, `Fixed n2) when n1 = n2 ->
`Fixed n1
| (`Fixed _, `Fixed _) ->
`Dynamic
| (`Dynamic, `Dynamic) | (`Fixed _, `Dynamic) | (`Dynamic, `Fixed _) ->
`Dynamic
| (`Variable, (`Dynamic | `Fixed _))
| ((`Dynamic | `Fixed _), `Variable)
| (`Variable, `Variable) ->
`Variable
let merge_list sz : t list -> t = function
| [] ->
assert false (* should be rejected by Data_encoding.union *)
| k :: ks -> (
match List.fold_left merge k ks with
| `Fixed n ->
`Fixed (n + Binary_size.tag_size sz)
| k ->
k )
end
type case_tag = Tag of int | Json_only
type 'a desc =
| Null : unit desc
| Empty : unit desc
| Ignore : unit desc
| Constant : string -> unit desc
| Bool : bool desc
| Int8 : int desc
| Uint8 : int desc
| Int16 : int desc
| Uint16 : int desc
| Int31 : int desc
| Int32 : Int32.t desc
| Int64 : Int64.t desc
| N : Z.t desc
| Z : Z.t desc
| RangedInt : {minimum : int; maximum : int} -> int desc
| RangedFloat : {minimum : float; maximum : float} -> float desc
| Float : float desc
| Bytes : Kind.length -> Bytes.t desc
| String : Kind.length -> string desc
| Padded : 'a t * int -> 'a desc
| String_enum : ('a, string * int) Hashtbl.t * 'a array -> 'a desc
| Array : int option * 'a t -> 'a array desc
| List : int option * 'a t -> 'a list desc
| Obj : 'a field -> 'a desc
| Objs : {kind : Kind.t; left : 'a t; right : 'b t} -> ('a * 'b) desc
| Tup : 'a t -> 'a desc
| Tups : {kind : Kind.t; left : 'a t; right : 'b t} -> ('a * 'b) desc
| Union : {
kind : Kind.t;
tag_size : Binary_size.tag_size;
cases : 'a case list;
}
-> 'a desc
| Mu : {
kind : Kind.enum;
name : string;
title : string option;
description : string option;
fix : 'a t -> 'a t;
}
-> 'a desc
| Conv : {
proj : 'a -> 'b;
inj : 'b -> 'a;
encoding : 'b t;
schema : Json_schema.schema option;
}
-> 'a desc
| Describe : {
id : string;
title : string option;
description : string option;
encoding : 'a t;
}
-> 'a desc
| Splitted : {
encoding : 'a t;
json_encoding : 'a Json_encoding.encoding;
is_obj : bool;
is_tup : bool;
}
-> 'a desc
| Dynamic_size : {
kind : Binary_size.unsigned_integer;
encoding : 'a t;
}
-> 'a desc
| Check_size : {limit : int; encoding : 'a t} -> 'a desc
| Delayed : (unit -> 'a t) -> 'a desc
and _ field =
| Req : {
name : string;
encoding : 'a t;
title : string option;
description : string option;
}
-> 'a field
| Opt : {
name : string;
kind : Kind.enum;
encoding : 'a t;
title : string option;
description : string option;
}
-> 'a option field
| Dft : {
name : string;
encoding : 'a t;
default : 'a;
title : string option;
description : string option;
}
-> 'a field
and 'a case =
| Case : {
title : string;
description : string option;
encoding : 'a t;
proj : 't -> 'a option;
inj : 'a -> 't;
tag : case_tag;
}
-> 't case
and 'a t = {
encoding : 'a desc;
mutable json_encoding : 'a Json_encoding.encoding option;
}
type 'a encoding = 'a t
let rec classify : type a. a t -> Kind.t = fun e -> classify_desc e.encoding
and classify_desc : type a. a desc -> Kind.t =
fun e ->
match e with
(* Fixed *)
| Null ->
`Fixed 0
| Empty ->
`Fixed 0
| Constant _ ->
`Fixed 0
| Bool ->
`Fixed Binary_size.bool
| Int8 ->
`Fixed Binary_size.int8
| Uint8 ->
`Fixed Binary_size.uint8
| Int16 ->
`Fixed Binary_size.int16
| Uint16 ->
`Fixed Binary_size.uint16
| Int31 ->
`Fixed Binary_size.int31
| Int32 ->
`Fixed Binary_size.int32
| Int64 ->
`Fixed Binary_size.int64
| N ->
`Dynamic
| Z ->
`Dynamic
| RangedInt {minimum; maximum} ->
`Fixed Binary_size.(integer_to_size @@ range_to_size ~minimum ~maximum)
| Float ->
`Fixed Binary_size.float
| RangedFloat _ ->
`Fixed Binary_size.float
(* Tagged *)
| Bytes kind ->
(kind :> Kind.t)
| String kind ->
(kind :> Kind.t)
| Padded ({encoding; _}, n) -> (
match classify_desc encoding with
| `Fixed m ->
`Fixed (n + m)
| _ ->
assert false (* by construction (see [Fixed.padded]) *) )
| String_enum (_, cases) ->
`Fixed Binary_size.(integer_to_size @@ enum_size cases)
| Obj (Opt {kind; _}) ->
(kind :> Kind.t)
| Objs {kind; _} ->
kind
| Tups {kind; _} ->
kind
| Union {kind; _} ->
(kind :> Kind.t)
| Mu {kind; _} ->
(kind :> Kind.t)
(* Variable *)
| Ignore ->
`Fixed 0
| Array _ ->
`Variable
| List _ ->
`Variable
(* Recursive *)
| Obj (Req {encoding; _}) ->
classify encoding
| Obj (Dft {encoding; _}) ->
classify encoding
| Tup encoding ->
classify encoding
| Conv {encoding; _} ->
classify encoding
| Describe {encoding; _} ->
classify encoding
| Splitted {encoding; _} ->
classify encoding
| Dynamic_size _ ->
`Dynamic
| Check_size {encoding; _} ->
classify encoding
| Delayed f ->
classify (f ())
let make ?json_encoding encoding = {encoding; json_encoding}
module Fixed = struct
let string n =
if n <= 0 then
invalid_arg
"Cannot create a string encoding of negative or null fixed length." ;
make @@ String (`Fixed n)
let bytes n =
if n <= 0 then
invalid_arg
"Cannot create a byte encoding of negative or null fixed length." ;
make @@ Bytes (`Fixed n)
let add_padding e n =
if n <= 0 then
invalid_arg "Cannot create a padding of negative or null fixed length." ;
match classify e with
| `Fixed _ ->
make @@ Padded (e, n)
| _ ->
invalid_arg "Cannot pad non-fixed size encoding"
end
let rec is_zeroable : type t. t encoding -> bool =
fun e ->
(* Whether an encoding can ever produce zero-byte of encoding. It is dnagerous
to place zero-size elements in a collection (list/array) because
they are indistinguishable from the abscence of elements. *)
match e.encoding with
(* trivially true *)
| Null ->
true (* always true *)
| Empty ->
true (* always true *)
| Ignore ->
true (* always true *)
| Constant _ ->
true (* always true *)
(* trivially false *)
| Bool ->
false
| Int8 ->
false
| Uint8 ->
false
| Int16 ->
false
| Uint16 ->
false
| Int31 ->
false
| Int32 ->
false
| Int64 ->
false
| N ->
false
| Z ->
false
| RangedInt _ ->
false
| RangedFloat _ ->
false
| Float ->
false
| Bytes _ ->
false
| String _ ->
false
| Padded _ ->
false
| String_enum _ ->
false
(* true in some cases, but in practice always protected by Dynamic *)
| Array _ ->
true (* 0-element array *)
| List _ ->
true (* 0-element list *)
(* represented as whatever is inside: truth mostly propagates *)
| Obj (Req {encoding = e; _}) ->
is_zeroable e (* represented as-is *)
| Obj (Opt {kind = `Variable; _}) ->
true (* optional field ommited *)
| Obj (Dft {encoding = e; _}) ->
is_zeroable e (* represented as-is *)
| Obj _ ->
false
| Objs {left; right; _} ->
is_zeroable left && is_zeroable right
| Tup e ->
is_zeroable e
| Tups {left; right; _} ->
is_zeroable left && is_zeroable right
| Union _ ->
false (* includes a tag *)
(* other recursive cases: truth propagates *)
| Mu {kind = `Dynamic; _} ->
false (* size prefix *)
| Mu {kind = `Variable; fix; _} ->
is_zeroable (fix e)
| Conv {encoding; _} ->
is_zeroable encoding
| Describe {encoding; _} ->
is_zeroable encoding
| Splitted {encoding; _} ->
is_zeroable encoding
| Check_size {encoding; _} ->
is_zeroable encoding
(* Unscrutable: true by default *)
| Delayed f ->
is_zeroable (f ())
(* Protected against zeroable *)
| Dynamic_size _ ->
false
(* always some data for size *)
module Variable = struct
let string = make @@ String `Variable
let bytes = make @@ Bytes `Variable
let check_not_variable name e =
match classify e with
| `Variable ->
Printf.ksprintf
invalid_arg
"Cannot insert variable length element in %s. You should wrap the \
contents using Data_encoding.dynamic_size."
name
| `Dynamic | `Fixed _ ->
()
let check_not_zeroable name e =
if is_zeroable e then
Printf.ksprintf
invalid_arg
"Cannot insert potentially zero-sized element in %s."
name
else ()
let array ?max_length e =
check_not_variable "an array" e ;
check_not_zeroable "an array" e ;
let encoding = make @@ Array (max_length, e) in
match (classify e, max_length) with
| (`Fixed n, Some max_length) ->
let limit = n * max_length in
make @@ Check_size {limit; encoding}
| (_, _) ->
encoding
let list ?max_length e =
check_not_variable "a list" e ;
check_not_zeroable "a list" e ;
let encoding = make @@ List (max_length, e) in
match (classify e, max_length) with
| (`Fixed n, Some max_length) ->
let limit = n * max_length in
make @@ Check_size {limit; encoding}
| (_, _) ->
encoding
end
let dynamic_size ?(kind = `Uint30) e =
make @@ Dynamic_size {kind; encoding = e}
let check_size limit encoding = make @@ Check_size {limit; encoding}
let delayed f = make @@ Delayed f
let null = make @@ Null
let empty = make @@ Empty
let unit = make @@ Ignore
let constant s = make @@ Constant s
let bool = make @@ Bool
let int8 = make @@ Int8
let uint8 = make @@ Uint8
let int16 = make @@ Int16
let uint16 = make @@ Uint16
let int31 = make @@ Int31
let int32 = make @@ Int32
let ranged_int minimum maximum =
let minimum = min minimum maximum and maximum = max minimum maximum in
if minimum < -(1 lsl 30) || (1 lsl 30) - 1 < maximum then
invalid_arg "Data_encoding.ranged_int" ;
make @@ RangedInt {minimum; maximum}
let ranged_float minimum maximum =
let minimum = min minimum maximum and maximum = max minimum maximum in
make @@ RangedFloat {minimum; maximum}
let int64 = make @@ Int64
let n = make @@ N
let z = make @@ Z
let float = make @@ Float
let string = dynamic_size Variable.string
let bytes = dynamic_size Variable.bytes
let array ?max_length e = dynamic_size (Variable.array ?max_length e)
let list ?max_length e = dynamic_size (Variable.list ?max_length e)
let string_enum = function
| [] ->
invalid_arg "data_encoding.string_enum: cannot have zero cases"
| [_case] ->
invalid_arg
"data_encoding.string_enum: cannot have a single case, use constant \
instead"
| _ :: _ as cases ->
let arr = Array.of_list (List.map snd cases) in
let tbl = Hashtbl.create (Array.length arr) in
List.iteri (fun ind (str, a) -> Hashtbl.add tbl a (str, ind)) cases ;
make @@ String_enum (tbl, arr)
let conv proj inj ?schema encoding = make @@ Conv {proj; inj; encoding; schema}
let def id ?title ?description encoding =
make @@ Describe {id; title; description; encoding}
let req ?title ?description n t =
Req {name = n; encoding = t; title; description}
let opt ?title ?description n encoding =
let kind =
match classify encoding with
| `Variable ->
`Variable
| `Fixed _ | `Dynamic ->
`Dynamic
in
Opt {name = n; kind; encoding; title; description}
let varopt ?title ?description n encoding =
Opt {name = n; kind = `Variable; encoding; title; description}
let dft ?title ?description n t d =
Dft {name = n; encoding = t; default = d; title; description}
let raw_splitted ~json ~binary =
make
@@ Splitted
{
encoding = binary;
json_encoding = json;
is_obj = false;
is_tup = false;
}
let rec is_obj : type a. a t -> bool =
fun e ->
match e.encoding with
| Obj _ ->
true
| Objs _ (* by construction *) ->
true
| Conv {encoding = e; _} ->
is_obj e
| Dynamic_size {encoding = e; _} ->
is_obj e
| Union {cases; _} ->
List.for_all (fun (Case {encoding = e; _}) -> is_obj e) cases
| Empty ->
true
| Ignore ->
true
| Mu {fix; _} ->
is_obj (fix e)
| Splitted {is_obj; _} ->
is_obj
| Delayed f ->
is_obj (f ())
| Describe {encoding; _} ->
is_obj encoding
| _ ->
false
let rec is_tup : type a. a t -> bool =
fun e ->
match e.encoding with
| Tup _ ->
true
| Tups _ (* by construction *) ->
true
| Conv {encoding = e; _} ->
is_tup e
| Dynamic_size {encoding = e; _} ->
is_tup e
| Union {cases; _} ->
List.for_all (function Case {encoding = e; _} -> is_tup e) cases
| Mu {fix; _} ->
is_tup (fix e)
| Splitted {is_tup; _} ->
is_tup
| Delayed f ->
is_tup (f ())
| Describe {encoding; _} ->
is_tup encoding
| _ ->
false
let raw_merge_objs left right =
let kind = Kind.combine "objects" (classify left) (classify right) in
make @@ Objs {kind; left; right}
let obj1 f1 = make @@ Obj f1
let obj2 f2 f1 = raw_merge_objs (obj1 f2) (obj1 f1)
let obj3 f3 f2 f1 = raw_merge_objs (obj1 f3) (obj2 f2 f1)
let obj4 f4 f3 f2 f1 = raw_merge_objs (obj2 f4 f3) (obj2 f2 f1)
let obj5 f5 f4 f3 f2 f1 = raw_merge_objs (obj1 f5) (obj4 f4 f3 f2 f1)
let obj6 f6 f5 f4 f3 f2 f1 = raw_merge_objs (obj2 f6 f5) (obj4 f4 f3 f2 f1)
let obj7 f7 f6 f5 f4 f3 f2 f1 =
raw_merge_objs (obj3 f7 f6 f5) (obj4 f4 f3 f2 f1)
let obj8 f8 f7 f6 f5 f4 f3 f2 f1 =
raw_merge_objs (obj4 f8 f7 f6 f5) (obj4 f4 f3 f2 f1)
let obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
raw_merge_objs (obj1 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1)
let obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
raw_merge_objs (obj2 f10 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1)
let merge_objs o1 o2 =
if is_obj o1 && is_obj o2 then raw_merge_objs o1 o2
else invalid_arg "Json_encoding.merge_objs"
let raw_merge_tups left right =
let kind = Kind.combine "tuples" (classify left) (classify right) in
make @@ Tups {kind; left; right}
let tup1 e1 = make @@ Tup e1
let tup2 e2 e1 = raw_merge_tups (tup1 e2) (tup1 e1)
let tup3 e3 e2 e1 = raw_merge_tups (tup1 e3) (tup2 e2 e1)
let tup4 e4 e3 e2 e1 = raw_merge_tups (tup2 e4 e3) (tup2 e2 e1)
let tup5 e5 e4 e3 e2 e1 = raw_merge_tups (tup1 e5) (tup4 e4 e3 e2 e1)
let tup6 e6 e5 e4 e3 e2 e1 = raw_merge_tups (tup2 e6 e5) (tup4 e4 e3 e2 e1)
let tup7 e7 e6 e5 e4 e3 e2 e1 =
raw_merge_tups (tup3 e7 e6 e5) (tup4 e4 e3 e2 e1)
let tup8 e8 e7 e6 e5 e4 e3 e2 e1 =
raw_merge_tups (tup4 e8 e7 e6 e5) (tup4 e4 e3 e2 e1)
let tup9 e9 e8 e7 e6 e5 e4 e3 e2 e1 =
raw_merge_tups (tup1 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1)
let tup10 e10 e9 e8 e7 e6 e5 e4 e3 e2 e1 =
raw_merge_tups (tup2 e10 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1)
let merge_tups t1 t2 =
if is_tup t1 && is_tup t2 then raw_merge_tups t1 t2
else invalid_arg "Tezos_serial.Encoding.merge_tups"
let conv3 ty =
conv (fun (c, b, a) -> (c, (b, a))) (fun (c, (b, a)) -> (c, b, a)) ty
let obj3 f3 f2 f1 = conv3 (obj3 f3 f2 f1)
let tup3 f3 f2 f1 = conv3 (tup3 f3 f2 f1)
let conv4 ty =
conv
(fun (d, c, b, a) -> ((d, c), (b, a)))
(fun ((d, c), (b, a)) -> (d, c, b, a))
ty
let obj4 f4 f3 f2 f1 = conv4 (obj4 f4 f3 f2 f1)
let tup4 f4 f3 f2 f1 = conv4 (tup4 f4 f3 f2 f1)
let conv5 ty =
conv
(fun (e, d, c, b, a) -> (e, ((d, c), (b, a))))
(fun (e, ((d, c), (b, a))) -> (e, d, c, b, a))
ty
let obj5 f5 f4 f3 f2 f1 = conv5 (obj5 f5 f4 f3 f2 f1)
let tup5 f5 f4 f3 f2 f1 = conv5 (tup5 f5 f4 f3 f2 f1)
let conv6 ty =
conv
(fun (f, e, d, c, b, a) -> ((f, e), ((d, c), (b, a))))
(fun ((f, e), ((d, c), (b, a))) -> (f, e, d, c, b, a))
ty
let obj6 f6 f5 f4 f3 f2 f1 = conv6 (obj6 f6 f5 f4 f3 f2 f1)
let tup6 f6 f5 f4 f3 f2 f1 = conv6 (tup6 f6 f5 f4 f3 f2 f1)
let conv7 ty =
conv
(fun (g, f, e, d, c, b, a) -> ((g, (f, e)), ((d, c), (b, a))))
(fun ((g, (f, e)), ((d, c), (b, a))) -> (g, f, e, d, c, b, a))
ty
let obj7 f7 f6 f5 f4 f3 f2 f1 = conv7 (obj7 f7 f6 f5 f4 f3 f2 f1)
let tup7 f7 f6 f5 f4 f3 f2 f1 = conv7 (tup7 f7 f6 f5 f4 f3 f2 f1)
let conv8 ty =
conv
(fun (h, g, f, e, d, c, b, a) -> (((h, g), (f, e)), ((d, c), (b, a))))
(fun (((h, g), (f, e)), ((d, c), (b, a))) -> (h, g, f, e, d, c, b, a))
ty
let obj8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (obj8 f8 f7 f6 f5 f4 f3 f2 f1)
let tup8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (tup8 f8 f7 f6 f5 f4 f3 f2 f1)
let conv9 ty =
conv
(fun (i, h, g, f, e, d, c, b, a) ->
(i, (((h, g), (f, e)), ((d, c), (b, a)))))
(fun (i, (((h, g), (f, e)), ((d, c), (b, a)))) ->
(i, h, g, f, e, d, c, b, a))
ty
let obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1 = conv9 (obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1)
let tup9 f9 f8 f7 f6 f5 f4 f3 f2 f1 = conv9 (tup9 f9 f8 f7 f6 f5 f4 f3 f2 f1)
let conv10 ty =
conv
(fun (j, i, h, g, f, e, d, c, b, a) ->
((j, i), (((h, g), (f, e)), ((d, c), (b, a)))))
(fun ((j, i), (((h, g), (f, e)), ((d, c), (b, a)))) ->
(j, i, h, g, f, e, d, c, b, a))
ty
let obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
conv10 (obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1)
let tup10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
conv10 (tup10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1)
let check_cases tag_size cases =
if cases = [] then invalid_arg "Data_encoding.union: empty list of cases." ;
let max_tag = match tag_size with `Uint8 -> 256 | `Uint16 -> 256 * 256 in
ignore
@@ List.fold_left
(fun others (Case {tag; _}) ->
match tag with
| Json_only ->
others
| Tag tag ->
if List.mem tag others then
Format.kasprintf
invalid_arg
"The tag %d appears twice in an union."
tag ;
if tag < 0 || max_tag <= tag then
Format.kasprintf invalid_arg "The tag %d is invalid." tag ;
tag :: others)
[]
cases
let union ?(tag_size = `Uint8) cases =
check_cases tag_size cases ;
let kinds = List.map (fun (Case {encoding; _}) -> classify encoding) cases in
let kind = Kind.merge_list tag_size kinds in
make @@ Union {kind; tag_size; cases}
let case ~title ?description tag encoding proj inj =
Case {title; description; encoding; proj; inj; tag}
let rec is_nullable : type t. t encoding -> bool =
fun e ->
match e.encoding with
| Null ->
true
| Empty ->
false
| Ignore ->
true
| Constant _ ->
false
| Bool ->
false
| Int8 ->
false
| Uint8 ->
false
| Int16 ->
false
| Uint16 ->
false
| Int31 ->
false
| Int32 ->
false
| Int64 ->
false
| N ->
false
| Z ->
false
| RangedInt _ ->
false
| RangedFloat _ ->
false
| Float ->
false
| Bytes _ ->
false
| String _ ->
false
| Padded (e, _) ->
is_nullable e
| String_enum _ ->
false
| Array _ ->
false
| List _ ->
false
| Obj _ ->
false
| Objs _ ->
false
| Tup _ ->
false
| Tups _ ->
false
| Union {cases; _} ->
List.exists (fun (Case {encoding = e; _}) -> is_nullable e) cases
| Mu {fix; _} ->
is_nullable (fix e)
| Conv {encoding = e; _} ->
is_nullable e
| Describe {encoding = e; _} ->
is_nullable e
| Splitted {json_encoding; _} ->
Json_encoding.is_nullable json_encoding
| Dynamic_size {encoding = e; _} ->
is_nullable e
| Check_size {encoding = e; _} ->
is_nullable e
| Delayed _ ->
true
let option ty =
if is_nullable ty then
invalid_arg "Data_encoding.option: cannot nest nullable encodings" ;
(* TODO add a special construct `Option` in the GADT *)
union
~tag_size:`Uint8
[ case (Tag 1) ty ~title:"Some" (fun x -> x) (fun x -> Some x);
case
(Tag 0)
null
~title:"None"
(function None -> Some () | Some _ -> None)
(fun () -> None) ]
let mu name ?title ?description fix =
let kind =
try
let precursor =
make @@ Mu {kind = `Dynamic; name; title; description; fix}
in
match classify @@ fix precursor with
| `Fixed _ | `Dynamic ->
`Dynamic
| `Variable ->
raise Exit
with Exit | _ (* TODO variability error *) ->
let precursor =
make @@ Mu {kind = `Variable; name; title; description; fix}
in
ignore (classify @@ fix precursor) ;
`Variable
in
make @@ Mu {kind; name; title; description; fix}
let result ok_enc error_enc =
union
~tag_size:`Uint8
[ case
(Tag 1)
ok_enc
~title:"Ok"
(function Ok x -> Some x | Error _ -> None)
(fun x -> Ok x);
case
(Tag 0)
error_enc
~title:"Result"
(function Ok _ -> None | Error x -> Some x)
(fun x -> Error x) ]
src/lib_data_encoding/encoding.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Kind.
Definition t := variant.
Definition length := variant.
Definition enum := variant.
Definition combine (name : string) (k1 : t) (k2 : t) : t :=
match (k1, k2) with
| (Fixed n1, Fixed n2) =>
(* ❌ Variants not supported *)
variant
| (Dynamic, Dynamic) | (Fixed _, Dynamic) | (Dynamic, Fixed _) =>
(* ❌ Variants not supported *)
variant
| (Variable, Fixed _) | (Dynamic | Fixed _, Variable) =>
(* ❌ Variants not supported *)
variant
| (Variable, Dynamic) =>
Printf.ksprintf OCaml.Stdlib.invalid_arg
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Cannot merge two " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" when the left element is of variable length and the right one of dynamic length. You should use the reverse order, or wrap the second one with Data_encoding.dynamic_size."
% string CamlinternalFormatBasics.End_of_format)))
"Cannot merge two %s when the left element is of variable length and the right one of dynamic length. You should use the reverse order, or wrap the second one with Data_encoding.dynamic_size."
% string) name
| (Variable, Variable) =>
Printf.ksprintf OCaml.Stdlib.invalid_arg
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Cannot merge two " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" with variable length. You should wrap one of them with Data_encoding.dynamic_size."
% string CamlinternalFormatBasics.End_of_format)))
"Cannot merge two %s with variable length. You should wrap one of them with Data_encoding.dynamic_size."
% string) name
end.
Definition merge (k1 : t) (k2 : t) : t :=
match (k1, k2) with
| (Fixed n1, Fixed n2) =>
(* ❌ Variants not supported *)
variant
| (Fixed _, Fixed _) =>
(* ❌ Variants not supported *)
variant
| (Dynamic, Dynamic) | (Fixed _, Dynamic) | (Dynamic, Fixed _) =>
(* ❌ Variants not supported *)
variant
|
(Variable, Dynamic | Fixed _) | (Dynamic | Fixed _, Variable) |
(Variable, Variable) =>
(* ❌ Variants not supported *)
variant
end.
Definition merge_list
(sz : Tezos_data_encoding.Binary_size.tag_size)
(function_parameter : list t) : t :=
match function_parameter with
| [] =>
(* ❌ Assert instruction is not handled. *)
assert false
| cons k ks =>
match Stdlib.List.fold_left merge k ks with
| Fixed n =>
(* ❌ Variants not supported *)
variant
| k => k
end
end.
End Kind.
Inductive case_tag : Type :=
| Tag : Z -> case_tag
| Json_only : case_tag.
Inductive desc : forall (a : Type), Type :=
| Null : desc unit
| Empty : desc unit
| Ignore : desc unit
| Constant : string -> desc unit
| Bool : desc bool
| Int8 : desc Z
| Uint8 : desc Z
| Int16 : desc Z
| Uint16 : desc Z
| Int31 : desc Z
| Int32 : desc Stdlib.Int32.t
| Int64 : desc Stdlib.Int64.t
| N : desc Z.t
| Z : desc Z.t
| RangedInt : Z -> Z -> desc Z
| RangedFloat : Z -> Z -> desc Z
| Float : desc Z
| Bytes : Kind.length -> desc Stdlib.Bytes.t
| String : Kind.length -> desc string
| Padded : forall {a : Type}, (t a) -> Z -> desc a
| String_enum : forall {a : Type}, (Stdlib.Hashtbl.t a (string * Z)) ->
(array a) -> desc a
| Array : forall {a : Type}, (option Z) -> (t a) -> desc (array a)
| List : forall {a : Type}, (option Z) -> (t a) -> desc (list a)
| Obj : forall {a : Type}, (field a) -> desc a
| Objs : forall {a b : Type}, Kind.t -> (t a) -> (t b) -> desc (a * b)
| Tup : forall {a : Type}, (t a) -> desc a
| Tups : forall {a b : Type}, Kind.t -> (t a) -> (t b) -> desc (a * b)
| Union : forall {a : Type}, Kind.t -> Tezos_data_encoding.Binary_size.tag_size
-> (list (case a)) -> desc a
| Mu : forall {a : Type}, Kind.enum -> string -> (option string) ->
(option string) -> ((t a) -> t a) -> desc a
| Conv : forall {a b : Type}, (a -> b) -> (b -> a) -> (t b) ->
(option Json_schema.schema) -> desc a
| Describe : forall {a : Type}, string -> (option string) -> (option string) ->
(t a) -> desc a
| Splitted : forall {a : Type}, (t a) -> (Json_encoding.encoding a) -> bool ->
bool -> desc a
| Dynamic_size : forall {a : Type},
Tezos_data_encoding.Binary_size.unsigned_integer -> (t a) -> desc a
| Check_size : forall {a : Type}, Z -> (t a) -> desc a
| Delayed : forall {a : Type}, (unit -> t a) -> desc a
with field : forall (_ : Type), Type :=
| Req : forall {a : Type}, string -> (t a) -> (option string) -> (option string)
-> field a
| Opt : forall {a : Type}, string -> Kind.enum -> (t a) -> (option string) ->
(option string) -> field (option a)
| Dft : forall {a : Type}, string -> (t a) -> a -> (option string) ->
(option string) -> field a
with case : forall (a : Type), Type :=
| Case : forall {a t : Type}, string -> (option string) -> (t a) ->
(t -> option a) -> (a -> t) -> case_tag -> case t.
Definition encoding (a : Type) := t a.
Fixpoint classify {a : Type} (e : t a) : Kind.t := classify_desc (encoding e)
with classify_desc {a : Type} (e : desc a) : Kind.t :=
match e with
| Null =>
(* ❌ Variants not supported *)
variant
| Empty =>
(* ❌ Variants not supported *)
variant
| Constant _ =>
(* ❌ Variants not supported *)
variant
| Bool =>
(* ❌ Variants not supported *)
variant
| Int8 =>
(* ❌ Variants not supported *)
variant
| Uint8 =>
(* ❌ Variants not supported *)
variant
| Int16 =>
(* ❌ Variants not supported *)
variant
| Uint16 =>
(* ❌ Variants not supported *)
variant
| Int31 =>
(* ❌ Variants not supported *)
variant
| Int32 =>
(* ❌ Variants not supported *)
variant
| Int64 =>
(* ❌ Variants not supported *)
variant
| N =>
(* ❌ Variants not supported *)
variant
| Z =>
(* ❌ Variants not supported *)
variant
| RangedInt {| minimum := minimum; maximum := maximum |} =>
(* ❌ Variants not supported *)
variant
| Float =>
(* ❌ Variants not supported *)
variant
| RangedFloat _ =>
(* ❌ Variants not supported *)
variant
| Bytes kind => kind
| String kind => kind
| Padded {| encoding := encoding |} n =>
match classify_desc encoding with
| Fixed m =>
(* ❌ Variants not supported *)
variant
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end
| String_enum _ cases =>
(* ❌ Variants not supported *)
variant
| Obj (Opt {| kind := kind |}) => kind
| Objs {| kind := kind |} => kind
| Tups {| kind := kind |} => kind
| Union {| kind := kind |} => kind
| Mu {| kind := kind |} => kind
| Ignore =>
(* ❌ Variants not supported *)
variant
| Array _ _ =>
(* ❌ Variants not supported *)
variant
| List _ _ =>
(* ❌ Variants not supported *)
variant
| Obj (Req {| encoding := encoding |}) => classify encoding
| Obj (Dft {| encoding := encoding |}) => classify encoding
| Tup encoding => classify encoding
| Conv {| encoding := encoding |} => classify encoding
| Describe {| encoding := encoding |} => classify encoding
| Splitted {| encoding := encoding |} => classify encoding
| Dynamic_size _ =>
(* ❌ Variants not supported *)
variant
| Check_size {| encoding := encoding |} => classify encoding
| Delayed f => classify (f tt)
end.
Definition make {A : Type}
(json_encoding : option (Json_encoding.encoding A)) (encoding : desc A)
: t A := {| encoding := encoding; json_encoding := json_encoding |}.
Module Fixed.
Definition string (n : Z) : t string :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.le n 0 then
OCaml.Stdlib.invalid_arg
"Cannot create a string encoding of negative or null fixed length." %
string
else
tt in
apply
(let arg := make in
fun eta => arg None eta)
(String
(* ❌ Variants not supported *)
variant).
Definition bytes (n : Z) : t Stdlib.Bytes.t :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.le n 0 then
OCaml.Stdlib.invalid_arg
"Cannot create a byte encoding of negative or null fixed length." %
string
else
tt in
apply
(let arg := make in
fun eta => arg None eta)
(Bytes
(* ❌ Variants not supported *)
variant).
Definition add_padding {A : Type} (e : t A) (n : Z) : t A :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.le n 0 then
OCaml.Stdlib.invalid_arg
"Cannot create a padding of negative or null fixed length." % string
else
tt in
match classify e with
| Fixed _ =>
apply
(let arg := make in
fun eta => arg None eta) (Padded e n)
| _ =>
OCaml.Stdlib.invalid_arg "Cannot pad non-fixed size encoding" % string
end.
End Fixed.
Fixpoint is_zeroable {t : Type} (e : encoding t) : bool :=
match encoding e with
| Null => true
| Empty => true
| Ignore => true
| Constant _ => true
| Bool => false
| Int8 => false
| Uint8 => false
| Int16 => false
| Uint16 => false
| Int31 => false
| Int32 => false
| Int64 => false
| N => false
| Z => false
| RangedInt _ => false
| RangedFloat _ => false
| Float => false
| Bytes _ => false
| String _ => false
| Padded _ _ => false
| String_enum _ _ => false
| Array _ _ => true
| List _ _ => true
| Obj (Req {| encoding := e |}) => is_zeroable e
| Obj (Opt {| kind := Variable |}) => true
| Obj (Dft {| encoding := e |}) => is_zeroable e
| Obj _ => false
| Objs {| left := left; right := right |} =>
andb (is_zeroable left) (is_zeroable right)
| Tup e => is_zeroable e
| Tups {| left := left; right := right |} =>
andb (is_zeroable left) (is_zeroable right)
| Union _ => false
| Mu {| kind := Dynamic |} => false
| Mu {| kind := Variable; fix := fix |} => is_zeroable (fix e)
| Conv {| encoding := encoding |} => is_zeroable encoding
| Describe {| encoding := encoding |} => is_zeroable encoding
| Splitted {| encoding := encoding |} => is_zeroable encoding
| Check_size {| encoding := encoding |} => is_zeroable encoding
| Delayed f => is_zeroable (f tt)
| Dynamic_size _ => false
end.
Module Variable.
Definition string : t string :=
apply
(let arg := make in
fun eta => arg None eta)
(String
(* ❌ Variants not supported *)
variant).
Definition bytes : t Stdlib.Bytes.t :=
apply
(let arg := make in
fun eta => arg None eta)
(Bytes
(* ❌ Variants not supported *)
variant).
Definition check_not_variable {A : Type} (name : string) (e : t A) : unit :=
match classify e with
| Variable =>
Printf.ksprintf OCaml.Stdlib.invalid_arg
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot insert variable length element in " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
". You should wrap the contents using Data_encoding.dynamic_size."
% string CamlinternalFormatBasics.End_of_format)))
"Cannot insert variable length element in %s. You should wrap the contents using Data_encoding.dynamic_size."
% string) name
| Dynamic | Fixed _ => tt
end.
Definition check_not_zeroable {A : Type} (name : string) (e : encoding A)
: unit :=
if is_zeroable e then
Printf.ksprintf OCaml.Stdlib.invalid_arg
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot insert potentially zero-sized element in " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))
"Cannot insert potentially zero-sized element in %s." % string) name
else
tt.
Definition array {A : Type} (max_length : option Z) (e : encoding A)
: t (array A) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := check_not_variable "an array" % string e in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := check_not_zeroable "an array" % string e in
let encoding :=
apply
(let arg := make in
fun eta => arg None eta) (Array max_length e) in
match ((classify e), max_length) with
| (Fixed n, Some max_length) =>
let limit := Z.mul n max_length in
apply
(let arg := make in
fun eta => arg None eta)
(Check_size {| limit := limit; encoding := encoding |})
| (_, _) => encoding
end.
Definition list {A : Type} (max_length : option Z) (e : encoding A)
: t (list A) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := check_not_variable "a list" % string e in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := check_not_zeroable "a list" % string e in
let encoding :=
apply
(let arg := make in
fun eta => arg None eta) (List max_length e) in
match ((classify e), max_length) with
| (Fixed n, Some max_length) =>
let limit := Z.mul n max_length in
apply
(let arg := make in
fun eta => arg None eta)
(Check_size {| limit := limit; encoding := encoding |})
| (_, _) => encoding
end.
End Variable.
Definition dynamic_size {A : Type}
(op_staroptstar : option Tezos_data_encoding.Binary_size.unsigned_integer)
: (t A) -> t A :=
let kind :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun e =>
apply
(let arg := make in
fun eta => arg None eta) (Dynamic_size {| kind := kind; encoding := e |}).
Definition check_size {A : Type} (limit : Z) (encoding : t A) : t A :=
apply
(let arg := make in
fun eta => arg None eta)
(Check_size {| limit := limit; encoding := encoding |}).
Definition delayed {A : Type} (f : unit -> t A) : t A :=
apply
(let arg := make in
fun eta => arg None eta) (Delayed f).
Definition null : t unit :=
apply
(let arg := make in
fun eta => arg None eta) Null.
Definition empty : t unit :=
apply
(let arg := make in
fun eta => arg None eta) Empty.
Definition unit : t unit :=
apply
(let arg := make in
fun eta => arg None eta) Ignore.
Definition constant (s : string) : t unit :=
apply
(let arg := make in
fun eta => arg None eta) (Constant s).
Definition bool : t bool :=
apply
(let arg := make in
fun eta => arg None eta) Bool.
Definition int8 : t Z :=
apply
(let arg := make in
fun eta => arg None eta) Int8.
Definition uint8 : t Z :=
apply
(let arg := make in
fun eta => arg None eta) Uint8.
Definition int16 : t Z :=
apply
(let arg := make in
fun eta => arg None eta) Int16.
Definition uint16 : t Z :=
apply
(let arg := make in
fun eta => arg None eta) Uint16.
Definition int31 : t Z :=
apply
(let arg := make in
fun eta => arg None eta) Int31.
Definition int32 : t Stdlib.Int32.t :=
apply
(let arg := make in
fun eta => arg None eta) Int32.
Definition ranged_int (minimum : Z) (maximum : Z) : t Z :=
let minimum : Z :=
OCaml.Stdlib.min minimum maximum
with maximum : Z :=
OCaml.Stdlib.max minimum maximum in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
orb (OCaml.Stdlib.lt minimum (Z.opp (Z.shiftl 1 30)))
(OCaml.Stdlib.lt (Z.sub (Z.shiftl 1 30) 1) maximum) then
OCaml.Stdlib.invalid_arg "Data_encoding.ranged_int" % string
else
tt in
apply
(let arg := make in
fun eta => arg None eta)
(RangedInt {| minimum := minimum; maximum := maximum |}).
Definition ranged_float (minimum : Z) (maximum : Z) : t Z :=
let minimum : Z :=
OCaml.Stdlib.min minimum maximum
with maximum : Z :=
OCaml.Stdlib.max minimum maximum in
apply
(let arg := make in
fun eta => arg None eta)
(RangedFloat {| minimum := minimum; maximum := maximum |}).
Definition int64 : t Stdlib.Int64.t :=
apply
(let arg := make in
fun eta => arg None eta) Int64.
Definition n : t Z.t :=
apply
(let arg := make in
fun eta => arg None eta) N.
Definition z : t Z.t :=
apply
(let arg := make in
fun eta => arg None eta) Z.
Definition float : t Z :=
apply
(let arg := make in
fun eta => arg None eta) Float.
Definition string : t string := dynamic_size None Variable.string.
Definition bytes : t Stdlib.Bytes.t := dynamic_size None Variable.bytes.
Definition array {A : Type} (max_length : option Z) (e : encoding A)
: t (array A) := dynamic_size None (Variable.array max_length e).
Definition list {A : Type} (max_length : option Z) (e : encoding A)
: t (list A) := dynamic_size None (Variable.list max_length e).
Definition string_enum {A : Type} (function_parameter : list (string * A))
: t A :=
match function_parameter with
| [] =>
OCaml.Stdlib.invalid_arg
"data_encoding.string_enum: cannot have zero cases" % string
| cons _case [] =>
OCaml.Stdlib.invalid_arg
"data_encoding.string_enum: cannot have a single case, use constant instead"
% string
| (cons _ _) as cases =>
let arr := Array.of_list (List.map snd cases) in
let tbl := Hashtbl.create None (Array.length arr) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.List.iteri
(fun ind =>
fun function_parameter =>
let '(str, a) := function_parameter in
Hashtbl.add tbl a (str, ind)) cases in
apply
(let arg := make in
fun eta => arg None eta) (String_enum tbl arr)
end.
Definition conv {A B : Type}
(proj : A -> B) (inj : B -> A) (schema : option Json_schema.schema)
(encoding : t B) : t A :=
apply
(let arg := make in
fun eta => arg None eta)
(Conv {| proj := proj; inj := inj; encoding := encoding; schema := schema |}).
Definition def {A : Type}
(id : string) (title : option string) (description : option string)
(encoding : t A) : t A :=
apply
(let arg := make in
fun eta => arg None eta)
(Describe
{| id := id; title := title; description := description;
encoding := encoding |}).
Definition req {A : Type}
(title : option string) (description : option string) (n : string) (t : t A)
: field A :=
Req {| name := n; encoding := t; title := title; description := description |}.
Definition opt {A : Type}
(title : option string) (description : option string) (n : string)
(encoding : t A) : field (option A) :=
let kind :=
match classify encoding with
| Variable =>
(* ❌ Variants not supported *)
variant
| Fixed _ | Dynamic =>
(* ❌ Variants not supported *)
variant
end in
Opt
{| name := n; kind := kind; encoding := encoding; title := title;
description := description |}.
Definition varopt {A : Type}
(title : option string) (description : option string) (n : string)
(encoding : t A) : field (option A) :=
Opt
{| name := n;
kind :=
(* ❌ Variants not supported *)
variant; encoding := encoding; title := title;
description := description |}.
Definition dft {A : Type}
(title : option string) (description : option string) (n : string) (t : t A)
(d : A) : field A :=
Dft
{| name := n; encoding := t; default := d; title := title;
description := description |}.
Definition raw_splitted {A : Type}
(json : Json_encoding.encoding A) (binary : t A) : t A :=
apply
(let arg := make in
fun eta => arg None eta)
(Splitted
{| encoding := binary; json_encoding := json; is_obj := false;
is_tup := false |}).
Fixpoint is_obj {a : Type} (e : t a) : bool :=
match encoding e with
| Obj _ => true
| Objs _ => true
| Conv {| encoding := e |} => is_obj e
| Dynamic_size {| encoding := e |} => is_obj e
| Union {| cases := cases |} =>
Stdlib.List.for_all
(fun function_parameter =>
let 'Case {| encoding := e |} := function_parameter in
is_obj e) cases
| Empty => true
| Ignore => true
| Mu {| fix := fix |} => is_obj (fix e)
| Splitted {| is_obj := is_obj |} => is_obj
| Delayed f => is_obj (f tt)
| Describe {| encoding := encoding |} => is_obj encoding
| _ => false
end.
Fixpoint is_tup {a : Type} (e : t a) : bool :=
match encoding e with
| Tup _ => true
| Tups _ => true
| Conv {| encoding := e |} => is_tup e
| Dynamic_size {| encoding := e |} => is_tup e
| Union {| cases := cases |} =>
Stdlib.List.for_all
(fun function_parameter =>
let 'Case {| encoding := e |} := function_parameter in
is_tup e) cases
| Mu {| fix := fix |} => is_tup (fix e)
| Splitted {| is_tup := is_tup |} => is_tup
| Delayed f => is_tup (f tt)
| Describe {| encoding := encoding |} => is_tup encoding
| _ => false
end.
Definition raw_merge_objs {A B : Type} (left : t A) (right : t B) : t (A * B) :=
let kind := Kind.combine "objects" % string (classify left) (classify right)
in
apply
(let arg := make in
fun eta => arg None eta)
(Objs {| kind := kind; left := left; right := right |}).
Definition obj1 {A : Type} (f1 : field A) : t A :=
apply
(let arg := make in
fun eta => arg None eta) (Obj f1).
Definition obj2 {A B : Type} (f2 : field A) (f1 : field B) : t (A * B) :=
raw_merge_objs (obj1 f2) (obj1 f1).
Definition obj3 {A B C : Type} (f3 : field A) (f2 : field B) (f1 : field C)
: t (A * (B * C)) := raw_merge_objs (obj1 f3) (obj2 f2 f1).
Definition obj4 {A B C D : Type}
(f4 : field A) (f3 : field B) (f2 : field C) (f1 : field D)
: t ((A * B) * (C * D)) := raw_merge_objs (obj2 f4 f3) (obj2 f2 f1).
Definition obj5 {A B C D E : Type}
(f5 : field A) (f4 : field B) (f3 : field C) (f2 : field D) (f1 : field E)
: t (A * ((B * C) * (D * E))) := raw_merge_objs (obj1 f5) (obj4 f4 f3 f2 f1).
Definition obj6 {A B C D E F : Type}
(f6 : field A) (f5 : field B) (f4 : field C) (f3 : field D) (f2 : field E)
(f1 : field F) : t ((A * B) * ((C * D) * (E * F))) :=
raw_merge_objs (obj2 f6 f5) (obj4 f4 f3 f2 f1).
Definition obj7 {A B C D E F G : Type}
(f7 : field A) (f6 : field B) (f5 : field C) (f4 : field D) (f3 : field E)
(f2 : field F) (f1 : field G) : t ((A * (B * C)) * ((D * E) * (F * G))) :=
raw_merge_objs (obj3 f7 f6 f5) (obj4 f4 f3 f2 f1).
Definition obj8 {A B C D E F G H : Type}
(f8 : field A) (f7 : field B) (f6 : field C) (f5 : field D) (f4 : field E)
(f3 : field F) (f2 : field G) (f1 : field H)
: t (((A * B) * (C * D)) * ((E * F) * (G * H))) :=
raw_merge_objs (obj4 f8 f7 f6 f5) (obj4 f4 f3 f2 f1).
Definition obj9 {A B C D E F G H I : Type}
(f9 : field A) (f8 : field B) (f7 : field C) (f6 : field D) (f5 : field E)
(f4 : field F) (f3 : field G) (f2 : field H) (f1 : field I)
: t (A * (((B * C) * (D * E)) * ((F * G) * (H * I)))) :=
raw_merge_objs (obj1 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1).
Definition obj10 {A B C D E F G H I J : Type}
(f10 : field A) (f9 : field B) (f8 : field C) (f7 : field D) (f6 : field E)
(f5 : field F) (f4 : field G) (f3 : field H) (f2 : field I) (f1 : field J)
: t ((A * B) * (((C * D) * (E * F)) * ((G * H) * (I * J)))) :=
raw_merge_objs (obj2 f10 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1).
Definition merge_objs {A B : Type} (o1 : t A) (o2 : t B) : t (A * B) :=
if andb (is_obj o1) (is_obj o2) then
raw_merge_objs o1 o2
else
OCaml.Stdlib.invalid_arg "Json_encoding.merge_objs" % string.
Definition raw_merge_tups {A B : Type} (left : t A) (right : t B) : t (A * B) :=
let kind := Kind.combine "tuples" % string (classify left) (classify right) in
apply
(let arg := make in
fun eta => arg None eta)
(Tups {| kind := kind; left := left; right := right |}).
Definition tup1 {A : Type} (e1 : t A) : t A :=
apply
(let arg := make in
fun eta => arg None eta) (Tup e1).
Definition tup2 {A B : Type} (e2 : t A) (e1 : t B) : t (A * B) :=
raw_merge_tups (tup1 e2) (tup1 e1).
Definition tup3 {A B C : Type} (e3 : t A) (e2 : t B) (e1 : t C)
: t (A * (B * C)) := raw_merge_tups (tup1 e3) (tup2 e2 e1).
Definition tup4 {A B C D : Type} (e4 : t A) (e3 : t B) (e2 : t C) (e1 : t D)
: t ((A * B) * (C * D)) := raw_merge_tups (tup2 e4 e3) (tup2 e2 e1).
Definition tup5 {A B C D E : Type}
(e5 : t A) (e4 : t B) (e3 : t C) (e2 : t D) (e1 : t E)
: t (A * ((B * C) * (D * E))) := raw_merge_tups (tup1 e5) (tup4 e4 e3 e2 e1).
Definition tup6 {A B C D E F : Type}
(e6 : t A) (e5 : t B) (e4 : t C) (e3 : t D) (e2 : t E) (e1 : t F)
: t ((A * B) * ((C * D) * (E * F))) :=
raw_merge_tups (tup2 e6 e5) (tup4 e4 e3 e2 e1).
Definition tup7 {A B C D E F G : Type}
(e7 : t A) (e6 : t B) (e5 : t C) (e4 : t D) (e3 : t E) (e2 : t F) (e1 : t G)
: t ((A * (B * C)) * ((D * E) * (F * G))) :=
raw_merge_tups (tup3 e7 e6 e5) (tup4 e4 e3 e2 e1).
Definition tup8 {A B C D E F G H : Type}
(e8 : t A) (e7 : t B) (e6 : t C) (e5 : t D) (e4 : t E) (e3 : t F) (e2 : t G)
(e1 : t H) : t (((A * B) * (C * D)) * ((E * F) * (G * H))) :=
raw_merge_tups (tup4 e8 e7 e6 e5) (tup4 e4 e3 e2 e1).
Definition tup9 {A B C D E F G H I : Type}
(e9 : t A) (e8 : t B) (e7 : t C) (e6 : t D) (e5 : t E) (e4 : t F) (e3 : t G)
(e2 : t H) (e1 : t I) : t (A * (((B * C) * (D * E)) * ((F * G) * (H * I)))) :=
raw_merge_tups (tup1 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1).
Definition tup10 {A B C D E F G H I J : Type}
(e10 : t A) (e9 : t B) (e8 : t C) (e7 : t D) (e6 : t E) (e5 : t F) (e4 : t G)
(e3 : t H) (e2 : t I) (e1 : t J)
: t ((A * B) * (((C * D) * (E * F)) * ((G * H) * (I * J)))) :=
raw_merge_tups (tup2 e10 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1).
Definition merge_tups {A B : Type} (t1 : t A) (t2 : t B) : t (A * B) :=
if andb (is_tup t1) (is_tup t2) then
raw_merge_tups t1 t2
else
OCaml.Stdlib.invalid_arg "Tezos_serial.Encoding.merge_tups" % string.
Definition conv3 {A B C : Type} (ty : t (A * (B * C))) : t (A * B * C) :=
conv
(fun function_parameter =>
let '(c, b, a) := function_parameter in
(c, (b, a)))
(fun function_parameter =>
let '(c, (b, a)) := function_parameter in
(c, b, a)) None ty.
Definition obj3 {A B C : Type} (f3 : field A) (f2 : field B) (f1 : field C)
: t (A * B * C) := conv3 (obj3 f3 f2 f1).
Definition tup3 {A B C : Type} (f3 : t A) (f2 : t B) (f1 : t C)
: t (A * B * C) := conv3 (tup3 f3 f2 f1).
Definition conv4 {A B C D : Type} (ty : t ((A * B) * (C * D)))
: t (A * B * C * D) :=
conv
(fun function_parameter =>
let '(d, c, b, a) := function_parameter in
((d, c), (b, a)))
(fun function_parameter =>
let '((d, c), (b, a)) := function_parameter in
(d, c, b, a)) None ty.
Definition obj4 {A B C D : Type}
(f4 : field A) (f3 : field B) (f2 : field C) (f1 : field D)
: t (A * B * C * D) := conv4 (obj4 f4 f3 f2 f1).
Definition tup4 {A B C D : Type} (f4 : t A) (f3 : t B) (f2 : t C) (f1 : t D)
: t (A * B * C * D) := conv4 (tup4 f4 f3 f2 f1).
Definition conv5 {A B C D E : Type} (ty : t (A * ((B * C) * (D * E))))
: t (A * B * C * D * E) :=
conv
(fun function_parameter =>
let '(e, d, c, b, a) := function_parameter in
(e, ((d, c), (b, a))))
(fun function_parameter =>
let '(e, ((d, c), (b, a))) := function_parameter in
(e, d, c, b, a)) None ty.
Definition obj5 {A B C D E : Type}
(f5 : field A) (f4 : field B) (f3 : field C) (f2 : field D) (f1 : field E)
: t (A * B * C * D * E) := conv5 (obj5 f5 f4 f3 f2 f1).
Definition tup5 {A B C D E : Type}
(f5 : t A) (f4 : t B) (f3 : t C) (f2 : t D) (f1 : t E)
: t (A * B * C * D * E) := conv5 (tup5 f5 f4 f3 f2 f1).
Definition conv6 {A B C D E F : Type} (ty : t ((A * B) * ((C * D) * (E * F))))
: t (A * B * C * D * E * F) :=
conv
(fun function_parameter =>
let '(f, e, d, c, b, a) := function_parameter in
((f, e), ((d, c), (b, a))))
(fun function_parameter =>
let '((f, e), ((d, c), (b, a))) := function_parameter in
(f, e, d, c, b, a)) None ty.
Definition obj6 {A B C D E F : Type}
(f6 : field A) (f5 : field B) (f4 : field C) (f3 : field D) (f2 : field E)
(f1 : field F) : t (A * B * C * D * E * F) := conv6 (obj6 f6 f5 f4 f3 f2 f1).
Definition tup6 {A B C D E F : Type}
(f6 : t A) (f5 : t B) (f4 : t C) (f3 : t D) (f2 : t E) (f1 : t F)
: t (A * B * C * D * E * F) := conv6 (tup6 f6 f5 f4 f3 f2 f1).
Definition conv7 {A B C D E F G : Type}
(ty : t ((A * (B * C)) * ((D * E) * (F * G))))
: t (A * B * C * D * E * F * G) :=
conv
(fun function_parameter =>
let '(g, f, e, d, c, b, a) := function_parameter in
((g, (f, e)), ((d, c), (b, a))))
(fun function_parameter =>
let '((g, (f, e)), ((d, c), (b, a))) := function_parameter in
(g, f, e, d, c, b, a)) None ty.
Definition obj7 {A B C D E F G : Type}
(f7 : field A) (f6 : field B) (f5 : field C) (f4 : field D) (f3 : field E)
(f2 : field F) (f1 : field G) : t (A * B * C * D * E * F * G) :=
conv7 (obj7 f7 f6 f5 f4 f3 f2 f1).
Definition tup7 {A B C D E F G : Type}
(f7 : t A) (f6 : t B) (f5 : t C) (f4 : t D) (f3 : t E) (f2 : t F) (f1 : t G)
: t (A * B * C * D * E * F * G) := conv7 (tup7 f7 f6 f5 f4 f3 f2 f1).
Definition conv8 {A B C D E F G H : Type}
(ty : t (((A * B) * (C * D)) * ((E * F) * (G * H))))
: t (A * B * C * D * E * F * G * H) :=
conv
(fun function_parameter =>
let '(h, g, f, e, d, c, b, a) := function_parameter in
(((h, g), (f, e)), ((d, c), (b, a))))
(fun function_parameter =>
let '(((h, g), (f, e)), ((d, c), (b, a))) := function_parameter in
(h, g, f, e, d, c, b, a)) None ty.
Definition obj8 {A B C D E F G H : Type}
(f8 : field A) (f7 : field B) (f6 : field C) (f5 : field D) (f4 : field E)
(f3 : field F) (f2 : field G) (f1 : field H)
: t (A * B * C * D * E * F * G * H) := conv8 (obj8 f8 f7 f6 f5 f4 f3 f2 f1).
Definition tup8 {A B C D E F G H : Type}
(f8 : t A) (f7 : t B) (f6 : t C) (f5 : t D) (f4 : t E) (f3 : t F) (f2 : t G)
(f1 : t H) : t (A * B * C * D * E * F * G * H) :=
conv8 (tup8 f8 f7 f6 f5 f4 f3 f2 f1).
Definition conv9 {A B C D E F G H I : Type}
(ty : t (A * (((B * C) * (D * E)) * ((F * G) * (H * I)))))
: t (A * B * C * D * E * F * G * H * I) :=
conv
(fun function_parameter =>
let '(i, h, g, f, e, d, c, b, a) := function_parameter in
(i, (((h, g), (f, e)), ((d, c), (b, a)))))
(fun function_parameter =>
let '(i, (((h, g), (f, e)), ((d, c), (b, a)))) := function_parameter in
(i, h, g, f, e, d, c, b, a)) None ty.
Definition obj9 {A B C D E F G H I : Type}
(f9 : field A) (f8 : field B) (f7 : field C) (f6 : field D) (f5 : field E)
(f4 : field F) (f3 : field G) (f2 : field H) (f1 : field I)
: t (A * B * C * D * E * F * G * H * I) :=
conv9 (obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1).
Definition tup9 {A B C D E F G H I : Type}
(f9 : t A) (f8 : t B) (f7 : t C) (f6 : t D) (f5 : t E) (f4 : t F) (f3 : t G)
(f2 : t H) (f1 : t I) : t (A * B * C * D * E * F * G * H * I) :=
conv9 (tup9 f9 f8 f7 f6 f5 f4 f3 f2 f1).
Definition conv10 {A B C D E F G H I J : Type}
(ty : t ((A * B) * (((C * D) * (E * F)) * ((G * H) * (I * J)))))
: t (A * B * C * D * E * F * G * H * I * J) :=
conv
(fun function_parameter =>
let '(j, i, h, g, f, e, d, c, b, a) := function_parameter in
((j, i), (((h, g), (f, e)), ((d, c), (b, a)))))
(fun function_parameter =>
let '((j, i), (((h, g), (f, e)), ((d, c), (b, a)))) := function_parameter
in
(j, i, h, g, f, e, d, c, b, a)) None ty.
Definition obj10 {A B C D E F G H I J : Type}
(f10 : field A) (f9 : field B) (f8 : field C) (f7 : field D) (f6 : field E)
(f5 : field F) (f4 : field G) (f3 : field H) (f2 : field I) (f1 : field J)
: t (A * B * C * D * E * F * G * H * I * J) :=
conv10 (obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1).
Definition tup10 {A B C D E F G H I J : Type}
(f10 : t A) (f9 : t B) (f8 : t C) (f7 : t D) (f6 : t E) (f5 : t F) (f4 : t G)
(f3 : t H) (f2 : t I) (f1 : t J)
: t (A * B * C * D * E * F * G * H * I * J) :=
conv10 (tup10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1).
Definition check_cases {A : Type} (tag_size : variant) (cases : list (case A))
: unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if equiv_decb cases [] then
OCaml.Stdlib.invalid_arg
"Data_encoding.union: empty list of cases." % string
else
tt in
let max_tag :=
match tag_size with
| Uint8 => 256
| Uint16 => Z.mul 256 256
end in
apply OCaml.Stdlib.ignore
(Stdlib.List.fold_left
(fun others =>
fun function_parameter =>
let 'Case {| tag := tag |} := function_parameter in
match tag with
| Json_only => others
| Tag tag =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if Stdlib.List.mem tag others then
Format.kasprintf OCaml.Stdlib.invalid_arg
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "The tag " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" appears twice in an union." % string
CamlinternalFormatBasics.End_of_format)))
"The tag %d appears twice in an union." % string) tag
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if orb (OCaml.Stdlib.lt tag 0) (OCaml.Stdlib.le max_tag tag) then
Format.kasprintf OCaml.Stdlib.invalid_arg
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "The tag " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" is invalid." % string
CamlinternalFormatBasics.End_of_format)))
"The tag %d is invalid." % string) tag
else
tt in
cons tag others
end) [] cases).
Definition union {A : Type}
(op_staroptstar : option Tezos_data_encoding.Binary_size.tag_size)
: (list (case A)) -> t A :=
let tag_size :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun cases =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := check_cases tag_size cases in
let kinds :=
List.map
(fun function_parameter =>
let 'Case {| encoding := encoding |} := function_parameter in
classify encoding) cases in
let kind := Kind.merge_list tag_size kinds in
apply
(let arg := make in
fun eta => arg None eta)
(Union {| kind := kind; tag_size := tag_size; cases := cases |}).
Definition case {A B : Type}
(title : string) (description : option string) (tag : case_tag)
(encoding : t A) (proj : B -> option A) (inj : A -> B) : case B :=
Case
{| title := title; description := description; encoding := encoding;
proj := proj; inj := inj; tag := tag |}.
Fixpoint is_nullable {t : Type} (e : encoding t) : bool :=
match encoding e with
| Null => true
| Empty => false
| Ignore => true
| Constant _ => false
| Bool => false
| Int8 => false
| Uint8 => false
| Int16 => false
| Uint16 => false
| Int31 => false
| Int32 => false
| Int64 => false
| N => false
| Z => false
| RangedInt _ => false
| RangedFloat _ => false
| Float => false
| Bytes _ => false
| String _ => false
| Padded e _ => is_nullable e
| String_enum _ _ => false
| Array _ _ => false
| List _ _ => false
| Obj _ => false
| Objs _ => false
| Tup _ => false
| Tups _ => false
| Union {| cases := cases |} =>
Stdlib.List._exists
(fun function_parameter =>
let 'Case {| encoding := e |} := function_parameter in
is_nullable e) cases
| Mu {| fix := fix |} => is_nullable (fix e)
| Conv {| encoding := e |} => is_nullable e
| Describe {| encoding := e |} => is_nullable e
| Splitted {| json_encoding := json_encoding |} =>
Json_encoding.is_nullable json_encoding
| Dynamic_size {| encoding := e |} => is_nullable e
| Check_size {| encoding := e |} => is_nullable e
| Delayed _ => true
end.
Definition option {A : Type} (ty : encoding A) : t (option A) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if is_nullable ty then
OCaml.Stdlib.invalid_arg
"Data_encoding.option: cannot nest nullable encodings" % string
else
tt in
union
(Some
(* ❌ Variants not supported *)
variant)
(cons (case "Some" % string None (Tag 1) ty (fun x => x) (fun x => Some x))
(cons
(case "None" % string None (Tag 0) null
(fun function_parameter =>
match function_parameter with
| None => Some tt
| Some _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
None)) [])).
Definition mu {A : Type}
(name : string) (title : option string) (description : option string)
(fix : (t A) -> t A) : t A :=
let kind :=
(* ❌ Try-with are not handled *)
try
(let precursor :=
apply
(let arg := make in
fun eta => arg None eta)
(Mu
{|
kind :=
(* ❌ Variants not supported *)
variant; name := name; title := title;
description := description; fix := fix |}) in
match apply classify (fix precursor) with
| Fixed _ | Dynamic =>
(* ❌ Variants not supported *)
variant
| Variable => Stdlib.raise Exit
end) in
apply
(let arg := make in
fun eta => arg None eta)
(Mu
{| kind := kind; name := name; title := title; description := description;
fix := fix |}).
Definition result {A B : Type} (ok_enc : t A) (error_enc : t B) : t (sum A B) :=
union
(Some
(* ❌ Variants not supported *)
variant)
(cons
(case "Ok" % string None (Tag 1) ok_enc
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok x => Some x
| Stdlib.Error _ => None
end) (fun x => Stdlib.Ok x))
(cons
(case "Result" % string None (Tag 0) error_enc
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok _ => None
| Stdlib.Error x => Some x
end) (fun x => Stdlib.Error x)) [])).
src/lib_data_encoding/json.ml 33 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type json =
[ `O of (string * json) list
| `Bool of bool
| `Float of float
| `A of json list
| `Null
| `String of string ]
type schema = Json_schema.schema
type pair_builder = {
build :
'a 'b. Encoding.Kind.t -> 'a Encoding.t -> 'b Encoding.t ->
('a * 'b) Encoding.t;
}
exception Parse_error of string
let wrap_error f str =
try f str with exn -> raise (Json_encoding.Cannot_destruct ([], exn))
let int64_encoding =
let open Json_encoding in
def
"int64"
~title:"64 bit integers"
~description:"Decimal representation of 64 bit integers"
@@ conv Int64.to_string (wrap_error Int64.of_string) string
let n_encoding =
let open Json_encoding in
def
"positive_bignum"
~title:"Positive big number"
~description:"Decimal representation of a positive big number"
@@ conv
(fun z ->
if Z.sign z < 0 then invalid_arg "negative natural" ;
Z.to_string z)
(fun s ->
let n = Z.of_string s in
if Z.sign n < 0 then
raise
(Json_encoding.Cannot_destruct ([], Failure "negative natural")) ;
n)
string
let z_encoding =
let open Json_encoding in
def
"bignum"
~title:"Big number"
~description:"Decimal representation of a big number"
@@ conv Z.to_string Z.of_string string
let bytes_jsont =
let open Json_encoding in
let schema =
let open Json_schema in
create
{
title = None;
description = None;
default = None;
enum = None;
kind =
String
{
pattern = Some "^[a-zA-Z0-9]+$";
min_length = 0;
max_length = None;
};
format = None;
id = None;
}
in
conv
~schema
Hex.of_bytes
(wrap_error Hex.to_bytes)
(conv (fun (`Hex h) -> h) (fun h -> `Hex h) string)
let check_utf8 s =
Uutf.String.fold_utf_8
(fun valid _pos -> function `Uchar _ -> valid | `Malformed _ -> false)
true
s
let raw_string_encoding =
let open Json_encoding in
let utf8_case =
case string (fun s -> if check_utf8 s then Some s else None) (fun s -> s)
in
let obj_case =
case
(obj1
(req
"invalid_utf8_string"
(array (ranged_int ~minimum:0 ~maximum:255 "byte"))))
(fun s -> Some (Array.init (String.length s) (fun i -> Char.code s.[i])))
(fun a -> String.init (Array.length a) (fun i -> Char.chr a.(i)))
in
def
"unistring"
~title:"Universal string representation"
~description:
"Either a plain UTF8 string, or a sequence of bytes for strings that \
contain invalid byte sequences."
(union [utf8_case; obj_case])
let rec lift_union : type a. a Encoding.t -> a Encoding.t =
fun e ->
let open Encoding in
match e.encoding with
| Conv {proj; inj; encoding = e; schema} -> (
match lift_union e with
| {encoding = Union {kind; tag_size; cases}; _} ->
make
@@ Union
{
kind;
tag_size;
cases =
List.map
(fun (Case
{ title;
description;
encoding;
proj = proj';
inj = inj';
tag }) ->
Case
{
encoding;
title;
description;
proj = (fun x -> proj' (proj x));
inj = (fun x -> inj (inj' x));
tag;
})
cases;
}
| e ->
make @@ Conv {proj; inj; encoding = e; schema} )
| Objs {kind; left; right} ->
lift_union_in_pair
{build = (fun kind left right -> make @@ Objs {kind; left; right})}
kind
left
right
| Tups {kind; left; right} ->
lift_union_in_pair
{build = (fun kind left right -> make @@ Tups {kind; left; right})}
kind
left
right
| _ ->
e
and lift_union_in_pair :
type a b.
pair_builder ->
Encoding.Kind.t ->
a Encoding.t ->
b Encoding.t ->
(a * b) Encoding.t =
fun b p e1 e2 ->
let open Encoding in
match (lift_union e1, lift_union e2) with
| (e1, {encoding = Union {tag_size; cases; _}; _}) ->
make
@@ Union
{
kind = `Dynamic (* ignored *);
tag_size;
cases =
List.map
(fun (Case
{title; description; encoding = e2; proj; inj; tag}) ->
Case
{
encoding = lift_union_in_pair b p e1 e2;
title;
description;
proj =
(fun (x, y) ->
match proj y with
| None ->
None
| Some y ->
Some (x, y));
inj = (fun (x, y) -> (x, inj y));
tag;
})
cases;
}
| ({encoding = Union {tag_size; cases; _}; _}, e2) ->
make
@@ Union
{
kind = `Dynamic (* ignored *);
tag_size;
cases =
List.map
(fun (Case
{title; description; encoding = e1; proj; inj; tag}) ->
Case
{
encoding = lift_union_in_pair b p e1 e2;
title;
description;
proj =
(fun (x, y) ->
match proj x with
| None ->
None
| Some x ->
Some (x, y));
inj = (fun (x, y) -> (inj x, y));
tag;
})
cases;
}
| (e1, e2) ->
b.build p e1 e2
let rec json : type a. a Encoding.desc -> a Json_encoding.encoding =
let open Encoding in
let open Json_encoding in
function
| Null ->
null
| Empty ->
empty
| Constant s ->
constant s
| Ignore ->
unit
| Int8 ->
ranged_int ~minimum:~-(1 lsl 7) ~maximum:((1 lsl 7) - 1) "int8"
| Uint8 ->
ranged_int ~minimum:0 ~maximum:((1 lsl 8) - 1) "uint8"
| Int16 ->
ranged_int ~minimum:~-(1 lsl 15) ~maximum:((1 lsl 15) - 1) "int16"
| Uint16 ->
ranged_int ~minimum:0 ~maximum:((1 lsl 16) - 1) "uint16"
| RangedInt {minimum; maximum} ->
ranged_int ~minimum ~maximum "rangedInt"
| Int31 ->
int
| Int32 ->
int32
| Int64 ->
int64_encoding
| N ->
n_encoding
| Z ->
z_encoding
| Bool ->
bool
| Float ->
float
| RangedFloat {minimum; maximum} ->
ranged_float ~minimum ~maximum "rangedFloat"
| String (`Fixed expected) ->
let check s =
let found = String.length s in
if found <> expected then
raise
(Cannot_destruct
( [],
Unexpected
( Format.asprintf "string (len %d)" found,
Format.asprintf "string (len %d)" expected ) )) ;
s
in
conv check check raw_string_encoding
| String _ ->
raw_string_encoding
| Padded (e, _) ->
get_json e
| Bytes (`Fixed expected) ->
let check s =
let found = Bytes.length s in
if found <> expected then
raise
(Cannot_destruct
( [],
Unexpected
( Format.asprintf "string (len %d)" found,
Format.asprintf "string (len %d)" expected ) )) ;
s
in
conv check check bytes_jsont
| Bytes _ ->
bytes_jsont
| String_enum (tbl, _) ->
string_enum (Hashtbl.fold (fun a (str, _) acc -> (str, a) :: acc) tbl [])
| Array (_, e) ->
array (get_json e) (* FIXME TODO enforce max_length *)
| List (_, e) ->
list (get_json e)
| Obj f ->
obj1 (field_json f)
| Objs {left; right; _} ->
merge_objs (get_json left) (get_json right)
| Tup e ->
tup1 (get_json e)
| Tups {left; right; _} ->
merge_tups (get_json left) (get_json right)
| Conv {proj; inj; encoding = e; schema} ->
conv ?schema proj inj (get_json e)
| Describe {id; title; description; encoding = e} ->
def id ?title ?description (get_json e)
| Mu {name; fix; _} as ty ->
mu name (fun json_encoding -> get_json @@ fix (make ~json_encoding ty))
| Union {cases; _} ->
union (List.map case_json cases)
| Splitted {json_encoding; _} ->
json_encoding
| Dynamic_size {encoding = e; _} ->
get_json e
| Check_size {encoding; _} ->
get_json encoding
| Delayed f ->
get_json (f ())
and field_json : type a. a Encoding.field -> a Json_encoding.field =
let open Json_encoding in
function
| Encoding.Req {name; encoding = e; _} ->
req name (get_json e)
| Encoding.Opt {name; encoding = e; _} ->
opt name (get_json e)
| Encoding.Dft {name; encoding = e; default = d; _} ->
dft name (get_json e) d
and case_json : type a. a Encoding.case -> a Json_encoding.case =
let open Json_encoding in
function
| Encoding.Case {encoding = e; proj; inj; _} -> case (get_json e) proj inj
and get_json : type a. a Encoding.t -> a Json_encoding.encoding =
fun e ->
match e.json_encoding with
| None ->
let json_encoding = json (lift_union e).encoding in
e.json_encoding <- Some json_encoding ;
json_encoding
| Some json_encoding ->
json_encoding
let convert = get_json
type path = path_item list
and path_item =
[ `Field of string (** A field in an object. *)
| `Index of int (** An index in an array. *)
| `Star (** Any / every field or index. *)
| `Next (** The next element after an array. *) ]
include Json_encoding
let construct e v = construct (get_json e) v
let destruct e v = destruct (get_json e) v
let schema ?definitions_path e = schema ?definitions_path (get_json e)
let cannot_destruct fmt =
Format.kasprintf (fun msg -> raise (Cannot_destruct ([], Failure msg))) fmt
type t = json
let to_string ?(newline = false) ?minify j =
Format.asprintf
"%a%s"
Json_repr.(pp ?compact:minify (module Ezjsonm))
j
(if newline then "\n" else "")
let pp = Json_repr.(pp (module Ezjsonm))
let from_string s =
match Ezjsonm.from_string ("[" ^ s ^ "]") with
| exception Ezjsonm.Parse_error (_, msg) ->
Error msg
| `A [json] ->
Ok json
| _ ->
Error "Malformed value"
let from_stream (stream : string Lwt_stream.t) =
let buffer = ref "" in
Lwt_stream.filter_map
(fun str ->
buffer := !buffer ^ str ;
try
let json = Ezjsonm.from_string !buffer in
buffer := "" ;
Some (Ok json)
with Ezjsonm.Parse_error _ -> None)
stream
let encoding =
let binary : Json_repr.ezjsonm Encoding.t =
Encoding.conv
(fun json ->
Json_repr.convert
(module Json_repr.Ezjsonm)
(module Json_repr_bson.Repr)
json
|> Json_repr_bson.bson_to_bytes |> Bytes.to_string)
(fun s ->
try
Bytes.of_string s
|> Json_repr_bson.bytes_to_bson ~copy:false
|> Json_repr.convert
(module Json_repr_bson.Repr)
(module Json_repr.Ezjsonm)
with Json_repr_bson.Bson_decoding_error (msg, _, _) ->
raise (Parse_error msg))
Encoding.string
in
let json = Json_encoding.any_ezjson_value in
Encoding.raw_splitted ~binary ~json
let schema_encoding =
Encoding.conv Json_schema.to_json Json_schema.of_json encoding
src/lib_data_encoding/json.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition json := variant.
Definition schema := Json_schema.schema.
Record pair_builder := {
build :
(Tezos_data_encoding.Encoding.Kind.t ->
(Tezos_data_encoding.Encoding.t a) ->
(Tezos_data_encoding.Encoding.t b) ->
Tezos_data_encoding.Encoding.t (a * b)) * (a * b) }.
(* ❌ The definition of exceptions is not handled. *)
exception
Definition wrap_error {A B : Type} (f : A -> B) (str : A) : B :=
(* ❌ Try-with are not handled *)
try (f str).
Definition int64_encoding : Json_encoding.encoding int64 :=
apply
(def "int64" % string (Some "64 bit integers" % string)
(Some "Decimal representation of 64 bit integers" % string))
(conv Int64.to_string (wrap_error Int64.of_string) None string).
Definition n_encoding : Json_encoding.encoding Z.t :=
apply
(def "positive_bignum" % string (Some "Positive big number" % string)
(Some "Decimal representation of a positive big number" % string))
(conv
(fun z =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt (Z.sign z) 0 then
OCaml.Stdlib.invalid_arg "negative natural" % string
else
tt in
Z.to_string z)
(fun s =>
let n := Z.of_string s in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt (Z.sign n) 0 then
Stdlib.raise
(Cannot_destruct ([], (OCaml.Failure "negative natural" % string)))
else
tt in
n) None string).
Definition z_encoding : Json_encoding.encoding Z.t :=
apply
(def "bignum" % string (Some "Big number" % string)
(Some "Decimal representation of a big number" % string))
(conv Z.to_string Z.of_string None string).
Definition bytes_jsont : Json_encoding.encoding string :=
let schema :=
create
{| title := None; description := None; default := None; enum := None;
kind :=
Json_schema.String
{| pattern := Some "^[a-zA-Z0-9]+$" % string; min_length := 0;
max_length := None |}; format := None; id := None |} in
conv
(let arg := Hex.of_bytes in
fun eta => arg None eta) (wrap_error Hex.to_bytes) (Some schema)
(conv
(fun function_parameter =>
let 'Hex h := function_parameter in
h)
(fun h =>
(* ❌ Variants not supported *)
variant) None string).
Definition check_utf8 (s : string) : bool :=
Uutf.String.fold_utf_8 None None
(fun valid =>
fun _pos =>
fun function_parameter =>
match function_parameter with
| Uchar _ => valid
| Malformed _ => false
end) true s.
Definition raw_string_encoding : Json_encoding.encoding string :=
let utf8_case :=
case string
(fun s =>
if check_utf8 s then
Some s
else
None) (fun s => s) in
let obj_case :=
case
(obj1
(req None None "invalid_utf8_string" % string
(array (ranged_int 0 255 "byte" % string))))
(fun s =>
Some
(Array.init (OCaml.String.length s)
(fun i => Char.code (Stdlib.String.get s i))))
(fun a =>
Stdlib.String.init (Array.length a) (fun i => Char.chr (Array.get a i)))
in
def "unistring" % string (Some "Universal string representation" % string)
(Some
"Either a plain UTF8 string, or a sequence of bytes for strings that contain invalid byte sequences."
% string) (union (cons utf8_case (cons obj_case []))).
Fixpoint lift_union {a : Type} (e : Tezos_data_encoding.Encoding.t a)
: Tezos_data_encoding.Encoding.t a :=
match encoding e with
|
Tezos_data_encoding.Encoding.Conv {|
proj := proj; inj := inj; encoding := e; schema := schema |} =>
match lift_union e with
| {|
encoding :=
Tezos_data_encoding.Encoding.Union {|
kind := kind; tag_size := tag_size; cases := cases |}
|} =>
apply
(let arg := make in
fun eta => arg None eta)
(Tezos_data_encoding.Encoding.Union
{| kind := kind; tag_size := tag_size;
cases :=
List.map
(fun function_parameter =>
let
'Tezos_data_encoding.Encoding.Case {|
title := title;
description := description;
encoding := encoding;
proj := proj';
inj := inj';
tag := tag
|} := function_parameter in
Tezos_data_encoding.Encoding.Case
{| title := title; description := description;
encoding := encoding; proj := fun x => proj' (proj x);
inj := fun x => inj (inj' x); tag := tag |}) cases |})
| e =>
apply
(let arg := make in
fun eta => arg None eta)
(Tezos_data_encoding.Encoding.Conv
{| proj := proj; inj := inj; encoding := e; schema := schema |})
end
|
Tezos_data_encoding.Encoding.Objs {|
kind := kind; left := left; right := right |} =>
lift_union_in_pair
{|
build :=
fun kind =>
fun left =>
fun right =>
apply
(let arg := make in
fun eta => arg None eta)
(Tezos_data_encoding.Encoding.Objs
{| kind := kind; left := left; right := right |}) |} kind
left right
|
Tezos_data_encoding.Encoding.Tups {|
kind := kind; left := left; right := right |} =>
lift_union_in_pair
{|
build :=
fun kind =>
fun left =>
fun right =>
apply
(let arg := make in
fun eta => arg None eta)
(Tezos_data_encoding.Encoding.Tups
{| kind := kind; left := left; right := right |}) |} kind
left right
| _ => e
end
with lift_union_in_pair {a b : Type}
(b : pair_builder) (p : Tezos_data_encoding.Encoding.Kind.t)
(e1 : Tezos_data_encoding.Encoding.t a)
(e2 : Tezos_data_encoding.Encoding.t b)
: Tezos_data_encoding.Encoding.t (a * b) :=
match ((lift_union e1), (lift_union e2)) with
|
(e1, {|
encoding :=
Tezos_data_encoding.Encoding.Union {|
tag_size := tag_size; cases := cases |}
|}) =>
apply
(let arg := make in
fun eta => arg None eta)
(Tezos_data_encoding.Encoding.Union
{|
kind :=
(* ❌ Variants not supported *)
variant; tag_size := tag_size;
cases :=
List.map
(fun function_parameter =>
let
'Tezos_data_encoding.Encoding.Case {|
title := title;
description := description;
encoding := e2;
proj := proj;
inj := inj;
tag := tag
|} := function_parameter in
Tezos_data_encoding.Encoding.Case
{| title := title; description := description;
encoding := lift_union_in_pair b p e1 e2;
proj :=
fun function_parameter =>
let '(x, y) := function_parameter in
match proj y with
| None => None
| Some y => Some (x, y)
end;
inj :=
fun function_parameter =>
let '(x, y) := function_parameter in
(x, (inj y)); tag := tag |}) cases |})
|
({|
encoding :=
Tezos_data_encoding.Encoding.Union {|
tag_size := tag_size; cases := cases |}
|}, e2) =>
apply
(let arg := make in
fun eta => arg None eta)
(Tezos_data_encoding.Encoding.Union
{|
kind :=
(* ❌ Variants not supported *)
variant; tag_size := tag_size;
cases :=
List.map
(fun function_parameter =>
let
'Tezos_data_encoding.Encoding.Case {|
title := title;
description := description;
encoding := e1;
proj := proj;
inj := inj;
tag := tag
|} := function_parameter in
Tezos_data_encoding.Encoding.Case
{| title := title; description := description;
encoding := lift_union_in_pair b p e1 e2;
proj :=
fun function_parameter =>
let '(x, y) := function_parameter in
match proj x with
| None => None
| Some x => Some (x, y)
end;
inj :=
fun function_parameter =>
let '(x, y) := function_parameter in
((inj x), y); tag := tag |}) cases |})
| (e1, e2) => (build b) p e1 e2
end.
Fixpoint json {a : Type}
(function_parameter : Tezos_data_encoding.Encoding.desc a)
: Json_encoding.encoding a :=
match function_parameter with
| Tezos_data_encoding.Encoding.Null => null
| Tezos_data_encoding.Encoding.Empty => empty
| Tezos_data_encoding.Encoding.Constant s => constant s
| Tezos_data_encoding.Encoding.Ignore => unit
| Tezos_data_encoding.Encoding.Int8 =>
ranged_int (Z.opp (Z.shiftl 1 7)) (Z.sub (Z.shiftl 1 7) 1) "int8" % string
| Tezos_data_encoding.Encoding.Uint8 =>
ranged_int 0 (Z.sub (Z.shiftl 1 8) 1) "uint8" % string
| Tezos_data_encoding.Encoding.Int16 =>
ranged_int (Z.opp (Z.shiftl 1 15)) (Z.sub (Z.shiftl 1 15) 1)
"int16" % string
| Tezos_data_encoding.Encoding.Uint16 =>
ranged_int 0 (Z.sub (Z.shiftl 1 16) 1) "uint16" % string
|
Tezos_data_encoding.Encoding.RangedInt {|
minimum := minimum; maximum := maximum |} =>
ranged_int minimum maximum "rangedInt" % string
| Tezos_data_encoding.Encoding.Int31 => int
| Tezos_data_encoding.Encoding.Int32 => int32
| Tezos_data_encoding.Encoding.Int64 => int64_encoding
| Tezos_data_encoding.Encoding.N => n_encoding
| Tezos_data_encoding.Encoding.Z => z_encoding
| Tezos_data_encoding.Encoding.Bool => bool
| Tezos_data_encoding.Encoding.Float => float
|
Tezos_data_encoding.Encoding.RangedFloat {|
minimum := minimum; maximum := maximum |} =>
ranged_float minimum maximum "rangedFloat" % string
| Tezos_data_encoding.Encoding.String (Fixed expected) =>
let check (s : string) : string :=
let found := OCaml.String.length s in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb found expected then
Stdlib.raise
(Cannot_destruct
([],
(Unexpected
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"string (len " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"string (len %d)" % string) found)
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"string (len " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"string (len %d)" % string) expected))))
else
tt in
s in
conv check check None raw_string_encoding
| Tezos_data_encoding.Encoding.String _ => raw_string_encoding
| Tezos_data_encoding.Encoding.Padded e _ => get_json e
| Tezos_data_encoding.Encoding.Bytes (Fixed expected) =>
let check (s : string) : string :=
let found := String.length s in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb found expected then
Stdlib.raise
(Cannot_destruct
([],
(Unexpected
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"string (len " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"string (len %d)" % string) found)
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"string (len " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"string (len %d)" % string) expected))))
else
tt in
s in
conv check check None bytes_jsont
| Tezos_data_encoding.Encoding.Bytes _ => bytes_jsont
| Tezos_data_encoding.Encoding.String_enum tbl _ =>
string_enum
(Hashtbl.fold
(fun a =>
fun function_parameter =>
let '(str, _) := function_parameter in
fun acc => cons (str, a) acc) tbl [])
| Tezos_data_encoding.Encoding.Array _ e => array (get_json e)
| Tezos_data_encoding.Encoding.List _ e => list (get_json e)
| Tezos_data_encoding.Encoding.Obj f => obj1 (field_json f)
| Tezos_data_encoding.Encoding.Objs {| left := left; right := right |} =>
merge_objs (get_json left) (get_json right)
| Tezos_data_encoding.Encoding.Tup e => tup1 (get_json e)
| Tezos_data_encoding.Encoding.Tups {| left := left; right := right |} =>
merge_tups (get_json left) (get_json right)
|
Tezos_data_encoding.Encoding.Conv {|
proj := proj; inj := inj; encoding := e; schema := schema |} =>
conv proj inj schema (get_json e)
|
Tezos_data_encoding.Encoding.Describe {|
id := id; title := title; description := description; encoding := e |}
=> def id title description (get_json e)
| (Tezos_data_encoding.Encoding.Mu {| name := name; fix := fix |}) as ty =>
mu name None None
(fun json_encoding => apply get_json (fix (make (Some json_encoding) ty)))
| Tezos_data_encoding.Encoding.Union {| cases := cases |} =>
union (List.map case_json cases)
| Tezos_data_encoding.Encoding.Splitted {| json_encoding := json_encoding |}
=> json_encoding
| Tezos_data_encoding.Encoding.Dynamic_size {| encoding := e |} => get_json e
| Tezos_data_encoding.Encoding.Check_size {| encoding := encoding |} =>
get_json encoding
| Tezos_data_encoding.Encoding.Delayed f => get_json (f tt)
end
with field_json {a : Type}
(function_parameter : Tezos_data_encoding.Encoding.field a)
: Json_encoding.field a :=
match function_parameter with
| Tezos_data_encoding.Encoding.Req {| name := name; encoding := e |} =>
req None None name (get_json e)
| Tezos_data_encoding.Encoding.Opt {| name := name; encoding := e |} =>
opt None None name (get_json e)
|
Tezos_data_encoding.Encoding.Dft {|
name := name; encoding := e; default := d |} =>
dft None None name (get_json e) d
end
with case_json {a : Type}
(function_parameter : Tezos_data_encoding.Encoding.case a)
: Json_encoding.case a :=
let
'Tezos_data_encoding.Encoding.Case {|
encoding := e; proj := proj; inj := inj |} := function_parameter in
case (get_json e) proj inj
with get_json {a : Type} (e : Tezos_data_encoding.Encoding.t a)
: Json_encoding.encoding a :=
match json_encoding e with
| None =>
let json_encoding := json (encoding (lift_union e)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field e "json_encoding" % string (Some json_encoding) in
json_encoding
| Some json_encoding => json_encoding
end.
Definition convert {A : Type}
: (Tezos_data_encoding.Encoding.t A) -> Json_encoding.encoding A := get_json.
Reserved Notation "'path".
Reserved Notation "'path_item".
where "'path" := ( list 'path_item)
and "'path_item" := ( variant).
Definition path := 'path.
Definition path_item := 'path_item.
(* ❌ Structure item `include` not handled. *)
include
Definition construct {A : Type} (e : Tezos_data_encoding.Encoding.t A) (v : A)
: Json_repr.ezjsonm := construct (get_json e) v.
Definition destruct {A : Type}
(e : Tezos_data_encoding.Encoding.t A) (v : Json_repr.ezjsonm) : A :=
destruct (get_json e) v.
Definition schema {A : Type}
(definitions_path : option string) (e : Tezos_data_encoding.Encoding.t A)
: Json_schema.schema := schema definitions_path (get_json e).
Definition cannot_destruct {A B : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
Format.kasprintf
(fun msg => Stdlib.raise (Cannot_destruct ([], (OCaml.Failure msg)))) fmt.
Definition t := json.
Definition to_string (op_staroptstar : option bool)
: (option bool) -> Json_repr.Ezjsonm.(Json_repr.Repr.value) -> string :=
let newline :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun minify =>
fun j =>
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "%a%s" % string)
(pp minify None Ezjsonm) j
(if newline then
"
" % string
else
"" % string).
Definition pp
: Stdlib.Format.formatter -> Json_repr.Ezjsonm.(Json_repr.Repr.value) -> unit :=
pp None None Ezjsonm.
Definition from_string (s : string) : sum Ezjsonm.value string :=
match
Ezjsonm.from_string
(String.append "[" % string (String.append s "]" % string)) with
| A (cons json []) => Stdlib.Ok json
| _ => Stdlib.Error "Malformed value" % string
end.
Definition from_stream {A : Type} (stream : Lwt_stream.t string)
: Lwt_stream.t (sum variant A) :=
let buffer := Stdlib.ref "" % string in
Lwt_stream.filter_map
(fun str =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq buffer
(String.append (Stdlib.op_exclamation buffer) str) in
(* ❌ Try-with are not handled *)
try
(let json := Ezjsonm.from_string (Stdlib.op_exclamation buffer) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq buffer "" % string in
Some (Stdlib.Ok json))) stream.
Definition encoding : Tezos_data_encoding.Encoding.encoding Json_repr.ezjsonm :=
let binary :=
Encoding.conv
(fun json =>
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(Json_repr.convert Json_repr.Ezjsonm Json_repr_bson.Repr json)
(let arg := Json_repr_bson.bson_to_bytes in
fun eta => arg None None eta)) Stdlib.Bytes.to_string)
(fun s =>
(* ❌ Try-with are not handled *)
try
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply (Stdlib.Bytes.of_string s)
(let arg :=
Json_repr_bson.bytes_to_bson
(* ❌ expected an argument *)
expected_argument
(* ❌ expected an argument *)
expected_argument
(* ❌ expected an argument *)
expected_argument false in
fun eta => arg None None None eta))
(Json_repr.convert Json_repr_bson.Repr Json_repr.Ezjsonm))) None
Encoding.string in
let json := Json_encoding.any_ezjson_value in
Encoding.raw_splitted json binary.
Definition schema_encoding
: Tezos_data_encoding.Encoding.encoding Json_schema.schema :=
Encoding.conv Json_schema.to_json Json_schema.of_json None encoding.
src/lib_data_encoding/registration.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type id = string
type t =
| Record : {
encoding : 'a Encoding.t;
description : string option;
pp : (Format.formatter -> 'a -> unit) option;
}
-> t
module EncodingTable = Map.Make (String)
let table = ref EncodingTable.empty
let description (Record {description; _}) = description
let json_schema (Record {encoding; _}) =
let json_schema = Json.schema encoding in
json_schema
let binary_schema (Record {encoding; _}) =
let binary_schema = Binary_description.describe encoding in
binary_schema
let json_pretty_printer (Record {encoding; pp; _}) fmt json =
match pp with
| Some pp ->
let json = Json.destruct encoding json in
Format.fprintf fmt "%a" pp json
| None ->
Format.fprintf fmt "%a" Json.pp json
let binary_pretty_printer (Record {encoding; pp; _}) fmt bytes =
let data = Binary_reader.of_bytes_exn encoding bytes in
match pp with
| Some pp ->
Format.fprintf fmt "%a" pp data
| None ->
let json = Json.construct encoding data in
Format.fprintf fmt "%a" Json.pp json
let rec lookup_id_descr ({encoding; _} : 'a Encoding.t) =
match encoding with
| Splitted {encoding; _}
| Dynamic_size {encoding; _}
| Check_size {encoding; _} ->
lookup_id_descr encoding
| Describe {id; description; _} ->
Some (id, description)
| _ ->
None
let register ?pp encoding =
match lookup_id_descr encoding with
| None ->
invalid_arg "Data_encoding.Registration.register: non def(in)ed encoding"
| Some (id, description) ->
table :=
EncodingTable.update
id
(function
| None ->
let record = Record {encoding; description; pp} in
Some record
| Some _ ->
Format.kasprintf
Pervasives.invalid_arg
"Encoding %s previously registered"
id)
!table
let find id = EncodingTable.find_opt id !table
let list () = EncodingTable.bindings !table
let bytes_of_json (Record {encoding; _}) json =
let data = Json.destruct encoding json in
Binary_writer.to_bytes encoding data
let json_of_bytes (Record {encoding; _}) bytes =
match Binary_reader.of_bytes encoding bytes with
| Some v ->
Some (Json.construct encoding v)
| None ->
None
src/lib_data_encoding/registration.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition id := string.
Inductive t : Type :=
| Record : forall {a : Type}, (Tezos_data_encoding.Encoding.t a) ->
(option string) -> (option (Stdlib.Format.formatter -> a -> unit)) -> t.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition table : Stdlib.ref (EncodingTable.t t) :=
Stdlib.ref EncodingTable.empty.
Definition description (function_parameter : t) : option string :=
let 'Record {| description := description |} := function_parameter in
description.
Definition json_schema (function_parameter : t)
: Tezos_data_encoding.Json.schema :=
let 'Record {| encoding := encoding |} := function_parameter in
let json_schema := Json.schema None encoding in
json_schema.
Definition binary_schema (function_parameter : t)
: Tezos_data_encoding.Binary_schema.t :=
let 'Record {| encoding := encoding |} := function_parameter in
let binary_schema := Binary_description.describe encoding in
binary_schema.
Definition json_pretty_printer (function_parameter : t)
: Stdlib.Format.formatter -> Tezos_data_encoding.Json.json -> unit :=
let 'Record {| encoding := encoding; pp := pp |} := function_parameter in
fun fmt =>
fun json =>
match pp with
| Some pp =>
let json := Json.destruct encoding json in
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string) pp json
| None =>
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string) Json.pp
json
end.
Definition binary_pretty_printer (function_parameter : t)
: Stdlib.Format.formatter -> Stdlib.Bytes.t -> unit :=
let 'Record {| encoding := encoding; pp := pp |} := function_parameter in
fun fmt =>
fun bytes =>
let data := Binary_reader.of_bytes_exn encoding string in
match pp with
| Some pp =>
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string) pp data
| None =>
let json := Json.construct encoding data in
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string) Json.pp
json
end.
Fixpoint lookup_id_descr {a : Type}
(function_parameter : Tezos_data_encoding.Encoding.t a)
: option (string * (option string)) :=
let '{| encoding := encoding |} := function_parameter in
match encoding with
|
Tezos_data_encoding.Encoding.Splitted {| encoding := encoding |} |
Tezos_data_encoding.Encoding.Dynamic_size {| encoding := encoding |} |
Tezos_data_encoding.Encoding.Check_size {| encoding := encoding |} =>
lookup_id_descr encoding
|
Tezos_data_encoding.Encoding.Describe {|
id := id; description := description |} => Some (id, description)
| _ => None
end.
Definition register {A : Type}
(pp : option (Stdlib.Format.formatter -> A -> unit))
(encoding : Tezos_data_encoding.Encoding.t A) : unit :=
match lookup_id_descr encoding with
| None =>
OCaml.Stdlib.invalid_arg
"Data_encoding.Registration.register: non def(in)ed encoding" % string
| Some (id, description) =>
Stdlib.op_coloneq table
(EncodingTable.update id
(fun function_parameter =>
match function_parameter with
| None =>
let record :=
Record
{| encoding := encoding; description := description; pp := pp |}
in
Some record
| Some _ =>
Format.kasprintf Pervasives.invalid_arg
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Encoding " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" previously registered" % string
CamlinternalFormatBasics.End_of_format)))
"Encoding %s previously registered" % string) id
end) (Stdlib.op_exclamation table))
end.
Definition find (id : EncodingTable.key) : option t :=
EncodingTable.find_opt id (Stdlib.op_exclamation table).
Definition list (function_parameter : unit) : list (EncodingTable.key * t) :=
let 'tt := function_parameter in
EncodingTable.bindings (Stdlib.op_exclamation table).
Definition bytes_of_json (function_parameter : t)
: Tezos_data_encoding.Json.json -> option Stdlib.Bytes.t :=
let 'Record {| encoding := encoding |} := function_parameter in
fun json =>
let data := Json.destruct encoding json in
Binary_writer.to_bytes encoding data.
Definition json_of_bytes (function_parameter : t)
: Stdlib.Bytes.t -> option Tezos_data_encoding.Json.json :=
let 'Record {| encoding := encoding |} := function_parameter in
fun bytes =>
match Binary_reader.of_bytes encoding string with
| Some v => Some (Json.construct encoding v)
| None => None
end.
src/lib_data_encoding/test/bench_data_encoding.ml 23 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let bench ?(num_iterations = 1000) name thunk =
Gc.full_major () ;
Gc.compact () ;
let start_time = Sys.time () in
for _i = 0 to num_iterations - 1 do
thunk ()
done ;
let end_time = Sys.time () in
Format.printf
"Benchmark: %s took %f for %d iterations.@."
name
(end_time -. start_time)
num_iterations
let read_stream encoding bytes =
let rec loop bytes status =
match (bytes, status) with
| ([], Data_encoding.Binary.Success _) ->
()
| (bytes :: bytess, Await f) ->
loop bytess (f bytes)
| (_, _) ->
assert false
in
loop bytes (Data_encoding.Binary.read_stream encoding)
let bench_all ?(num_iterations = 1000) name encoding value =
bench
~num_iterations
("writing " ^ name ^ " json")
(fun () ->
ignore @@ Data_encoding.Json.to_string
@@ Data_encoding.Json.construct encoding value) ;
bench
~num_iterations
("writing " ^ name ^ " binary")
(fun () -> ignore @@ Data_encoding.Binary.to_bytes_exn encoding value) ;
let encoded_json =
Data_encoding.Json.to_string @@ Data_encoding.Json.construct encoding value
in
bench
~num_iterations
("reading " ^ name ^ " json")
(fun () ->
ignore
(Data_encoding.Json.destruct
encoding
(Ezjsonm.from_string encoded_json))) ;
let encoded_binary = Data_encoding.Binary.to_bytes_exn encoding value in
bench
~num_iterations
("reading " ^ name ^ " binary")
(fun () -> ignore @@ Data_encoding.Binary.of_bytes encoding encoded_binary) ;
bench
~num_iterations
("reading " ^ name ^ " streamed binary (one chunk)")
(fun () -> read_stream encoding [encoded_binary]) ;
bench
~num_iterations
("reading " ^ name ^ " streamed binary (small chunks)")
(fun () -> read_stream encoding (Helpers.cut 1 encoded_binary)) ;
()
type t = A of string | B of bool | I of int | F of float | R of t * t
let cases_encoding : t Data_encoding.t =
let open Data_encoding in
mu "recursive" (fun recursive ->
union
[ case
(Tag 0)
~title:"A"
string
(function A s -> Some s | _ -> None)
(fun s -> A s);
case
(Tag 1)
~title:"B"
bool
(function B bool -> Some bool | _ -> None)
(fun bool -> B bool);
case
(Tag 2)
~title:"I"
int31
(function I int -> Some int | _ -> None)
(fun int -> I int);
case
(Tag 3)
~title:"F"
float
(function F float -> Some float | _ -> None)
(fun float -> F float);
case
(Tag 4)
~title:"R"
(obj2 (req "field1" recursive) (req "field2" recursive))
(function R (a, b) -> Some (a, b) | _ -> None)
(fun (a, b) -> R (a, b)) ])
let () =
bench_all
"10000_element_int_list"
Data_encoding.(list int31)
~num_iterations:1000
(Array.to_list (Array.make 10000 0)) ;
bench_all
"option_element_int_list"
Data_encoding.(list (option int31))
(Array.to_list (Array.make 10000 (Some 0))) ;
let encoding = Data_encoding.(list (result (option int31) string)) in
let value = Array.to_list (Array.make 10000 (Error "hello")) in
bench_all "option_result_element_list" encoding value ;
let encoding = Data_encoding.(list cases_encoding) in
let value =
Array.to_list (Array.make 1000 (R (R (A "asdf", B true), F 1.0)))
in
bench ~num_iterations:1000 "binary_encoding" (fun () ->
ignore @@ Data_encoding.Binary.to_bytes encoding value) ;
bench_all
"binary_encoding_large_list"
Data_encoding.(list cases_encoding)
(Array.to_list (Array.make 2000 (R (R (A "asdf", B true), F 1.0))))
src/lib_data_encoding/test/bench_data_encoding.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition bench (op_staroptstar : option Z)
: string -> (unit -> unit) -> unit :=
let num_iterations :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 1000
end in
fun name =>
fun thunk =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Gc.full_major tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Gc.compact tt in
let start_time := Sys.time tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ For loops not handled. *)
for in
let end_time := Sys.time tt in
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Benchmark: " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " took " % string
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " for " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" iterations." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))
"Benchmark: %s took %f for %d iterations.@." % string) name
(Stdlib.op_minuspoint end_time start_time) num_iterations.
Definition read_stream {A : Type}
(encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
(bytes : list Stdlib.Bytes.t) : unit :=
let fix loop {B : Type}
(bytes : list Stdlib.Bytes.t) (status :
Tezos_data_encoding.Data_encoding.Binary.status B) : unit :=
match (string, status) with
| ([], Tezos_data_encoding.Data_encoding.Binary.Success _) => tt
| (cons bytes bytess, Tezos_data_encoding.Data_encoding.Binary.Await f) =>
loop bytess (f string)
| (_, _) =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
loop string (Data_encoding.Binary.read_stream None encoding).
Definition bench_all {A : Type} (op_staroptstar : option Z)
: string -> (Tezos_data_encoding__Data_encoding.Encoding.t A) -> A -> unit :=
let num_iterations :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 1000
end in
fun name =>
fun encoding =>
fun value =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
bench (Some num_iterations)
(String.append "writing " % string
(String.append name " json" % string))
(fun function_parameter =>
let 'tt := function_parameter in
apply OCaml.Stdlib.ignore
(apply
(let arg := Data_encoding.Json.to_string in
fun eta => arg None None eta)
(Data_encoding.Json.construct encoding value))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
bench (Some num_iterations)
(String.append "writing " % string
(String.append name " binary" % string))
(fun function_parameter =>
let 'tt := function_parameter in
apply OCaml.Stdlib.ignore
(Data_encoding.Binary.to_bytes_exn encoding value)) in
let encoded_json :=
apply
(let arg := Data_encoding.Json.to_string in
fun eta => arg None None eta)
(Data_encoding.Json.construct encoding value) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
bench (Some num_iterations)
(String.append "reading " % string
(String.append name " json" % string))
(fun function_parameter =>
let 'tt := function_parameter in
OCaml.Stdlib.ignore
(Data_encoding.Json.destruct encoding
(Ezjsonm.from_string encoded_json))) in
let encoded_binary := Data_encoding.Binary.to_bytes_exn encoding value
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
bench (Some num_iterations)
(String.append "reading " % string
(String.append name " binary" % string))
(fun function_parameter =>
let 'tt := function_parameter in
apply OCaml.Stdlib.ignore
(Data_encoding.Binary.of_bytes encoding encoded_binary)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
bench (Some num_iterations)
(String.append "reading " % string
(String.append name " streamed binary (one chunk)" % string))
(fun function_parameter =>
let 'tt := function_parameter in
read_stream encoding (cons encoded_binary [])) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
bench (Some num_iterations)
(String.append "reading " % string
(String.append name " streamed binary (small chunks)" % string))
(fun function_parameter =>
let 'tt := function_parameter in
read_stream encoding (op_startypeminuserrorstar 1 encoded_binary))
in
tt.
Inductive t : Type :=
| A : string -> t
| B : bool -> t
| I : Z -> t
| F : Z -> t
| R : t -> t -> t.
Definition cases_encoding : Tezos_data_encoding.Data_encoding.t t :=
mu "recursive" % string None None
(fun recursive =>
union None
(cons
(case "A" % string None (Tezos_data_encoding.Data_encoding.Tag 0)
string
(fun function_parameter =>
match function_parameter with
| A s => Some s
| _ => None
end) (fun s => A s))
(cons
(case "B" % string None (Tezos_data_encoding.Data_encoding.Tag 1)
bool
(fun function_parameter =>
match function_parameter with
| B bool => Some bool
| _ => None
end) (fun bool => B bool))
(cons
(case "I" % string None (Tezos_data_encoding.Data_encoding.Tag 2)
int31
(fun function_parameter =>
match function_parameter with
| I int => Some Z
| _ => None
end) (fun int => I Z))
(cons
(case "F" % string None
(Tezos_data_encoding.Data_encoding.Tag 3) float
(fun function_parameter =>
match function_parameter with
| F float => Some Z
| _ => None
end) (fun float => F Z))
(cons
(case "R" % string None
(Tezos_data_encoding.Data_encoding.Tag 4)
(obj2 (req None None "field1" % string recursive)
(req None None "field2" % string recursive))
(fun function_parameter =>
match function_parameter with
| R a b => Some (a, b)
| _ => None
end)
(fun function_parameter =>
let '(a, b) := function_parameter in
R a b)) [])))))).
src/lib_data_encoding/test/helpers.ml 16 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Data_encoding
let cut ?(copy = false) sz bytes =
let length = Bytes.length bytes in
if length <= sz then [bytes] (* if the result fits in the given sz *)
else
let may_copy = if copy then Bytes.copy else fun t -> t in
let nb_full = length / sz in
(* nb of blocks of size sz *)
let sz_full = nb_full * sz in
(* size of the full part *)
let acc =
(* eventually init acc with a non-full block *)
if sz_full = length then []
else [may_copy (Bytes.sub bytes sz_full (length - sz_full))]
in
let rec split_full_blocks curr_upper_limit acc =
let start = curr_upper_limit - sz in
assert (start >= 0) ;
(* copy the block [ start, curr_upper_limit [ of size sz *)
let acc = may_copy (Bytes.sub bytes start sz) :: acc in
if start = 0 then acc else split_full_blocks start acc
in
split_full_blocks sz_full acc
let no_exception f =
try f () with
| ( Json_encoding.Cannot_destruct _
| Json_encoding.Unexpected _
| Json_encoding.No_case_matched _
| Json_encoding.Bad_array_size _
| Json_encoding.Missing_field _
| Json_encoding.Unexpected_field _
| Json_encoding.Bad_schema _ ) as exn ->
Alcotest.failf
"@[v 2>json failed:@ %a@]"
(fun ppf -> Json_encoding.print_error ppf)
exn
| Binary.Read_error error ->
Alcotest.failf
"@[v 2>bytes reading failed:@ %a@]"
Binary.pp_read_error
error
| Binary.Write_error error ->
Alcotest.failf
"@[v 2>bytes writing failed:@ %a@]"
Binary.pp_write_error
error
let check_raises expected f =
match f () with
| exception exn when expected exn ->
()
| exception exn ->
Alcotest.failf "Unexpected exception: %s." (Printexc.to_string exn)
| _ ->
Alcotest.failf "Expecting exception, got success."
let chunked_read sz encoding bytes =
let status =
List.fold_left
(fun status chunk ->
match status with
| Binary.Await f ->
f chunk
| Success _ when Bytes.length chunk <> 0 ->
Error Extra_bytes
| Success _ | Error _ ->
status)
(Binary.read_stream encoding)
(cut sz bytes)
in
match status with
| Success {stream; _} when not (Binary_stream.is_empty stream) ->
Binary.Error Extra_bytes
| _ ->
status
let streamed_read encoding bytes =
List.fold_left
(fun ((status, count) as acc) chunk ->
match status with
| Binary.Await f ->
(f chunk, succ count)
| Success _ | Error _ ->
acc)
(Binary.read_stream encoding, 0)
(cut 1 bytes)
src/lib_data_encoding/test/helpers.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Data_encoding.
Definition cut (op_staroptstar : option bool) : Z -> string -> list string :=
let copy :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun sz =>
fun bytes =>
let length := String.length string in
if OCaml.Stdlib.le length sz then
cons string []
else
let may_copy :=
if copy then
Stdlib.Bytes.copy
else
fun t => t in
let nb_full := Z.div length sz in
let sz_full := Z.mul nb_full sz in
let acc :=
if equiv_decb sz_full length then
[]
else
cons (may_copy (String.sub string sz_full (Z.sub length sz_full)))
[] in
let fix split_full_blocks (curr_upper_limit : Z) (acc : list string)
: list string :=
let start := Z.sub curr_upper_limit sz in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.ge start 0) in
let acc := cons (may_copy (String.sub string start sz)) acc in
if equiv_decb start 0 then
acc
else
split_full_blocks start acc in
split_full_blocks sz_full acc.
Definition no_exception {A : Type} (f : unit -> A) : A :=
(* ❌ Try-with are not handled *)
try (f tt).
Definition check_raises {A : Type} (expected : exn -> bool) (f : unit -> A)
: unit :=
let '_ := f tt in
op_startypeminuserrorstar "Expecting exception, got success." % string.
Definition chunked_read {A : Type}
(sz : Z) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
(bytes : Stdlib.Bytes.t)
: Tezos_data_encoding.Data_encoding.Binary.status A :=
let status :=
Stdlib.List.fold_left
(fun status =>
fun chunk =>
match status with
| Tezos_data_encoding.Data_encoding.Binary.Await f => f chunk
| Tezos_data_encoding.Data_encoding.Binary.Success _ =>
Tezos_data_encoding.Data_encoding.Binary.Error
Tezos_data_encoding.Data_encoding.Binary.Extra_bytes
|
Tezos_data_encoding.Data_encoding.Binary.Success _ |
Tezos_data_encoding.Data_encoding.Binary.Error _ => status
end) (Binary.read_stream None encoding) (cut None sz string) in
match status with
| Tezos_data_encoding.Data_encoding.Binary.Success {| stream := stream |} =>
Tezos_data_encoding.Data_encoding.Binary.Error
Tezos_data_encoding.Data_encoding.Binary.Extra_bytes
| _ => status
end.
Definition streamed_read {A : Type}
(encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
(bytes : Stdlib.Bytes.t)
: (Tezos_data_encoding.Data_encoding.Binary.status A) * Z :=
Stdlib.List.fold_left
(fun function_parameter =>
let '(status, count) as acc := function_parameter in
fun chunk =>
match status with
| Tezos_data_encoding.Data_encoding.Binary.Await f =>
((f chunk), (Z.succ count))
|
Tezos_data_encoding.Data_encoding.Binary.Success _ |
Tezos_data_encoding.Data_encoding.Binary.Error _ => acc
end) ((Binary.read_stream None encoding), 0) (cut None 1 string).
src/lib_data_encoding/test/invalid_encoding.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Data_encoding
open Helpers
let test ?(expected = fun _ -> true) name f =
(name, `Quick, fun () -> check_raises expected f)
let tests =
[ test "multi_variable_tup" (fun () -> tup2 Variable.string Variable.string);
test "variable_in_list" (fun () -> list Variable.string);
test "nested_option" (fun () -> option (option int8));
test "merge_non_objs" (fun () -> merge_objs int8 string);
test "empty_union" (fun () -> union []);
test "duplicated_tag" (fun () ->
union
[ case (Tag 0) ~title:"" empty (fun () -> None) (fun () -> ());
case (Tag 0) ~title:"" empty (fun () -> None) (fun () -> ()) ]);
test "fixed_negative_size" (fun () -> Fixed.string ~-1);
test "fixed_null_size" (fun () -> Fixed.bytes 0);
test "array_null_size" (fun () -> Variable.list empty);
test "list_null_size" (fun () -> Variable.list null);
test "zeroable_in_list" (fun () -> list (obj1 (varopt "x" int8))) ]
src/lib_data_encoding/test/invalid_encoding.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Data_encoding.
Definition test {A B C D : Type} (op_staroptstar : option (A -> bool))
: B -> C -> B * variant * (unit -> D) :=
let expected :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
fun function_parameter =>
let '_ := function_parameter in
true
end in
fun name =>
fun f =>
(name,
(* ❌ Variants not supported *)
variant,
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar expected f)).
Definition tests {A : Type} : list (string * variant * (unit -> A)) :=
cons
(test None "multi_variable_tup" % string
(fun function_parameter =>
let 'tt := function_parameter in
tup2 Variable.string Variable.string))
(cons
(test None "variable_in_list" % string
(fun function_parameter =>
let 'tt := function_parameter in
list None Variable.string))
(cons
(test None "nested_option" % string
(fun function_parameter =>
let 'tt := function_parameter in
option (option int8)))
(cons
(test None "merge_non_objs" % string
(fun function_parameter =>
let 'tt := function_parameter in
merge_objs int8 string))
(cons
(test None "empty_union" % string
(fun function_parameter =>
let 'tt := function_parameter in
union None []))
(cons
(test None "duplicated_tag" % string
(fun function_parameter =>
let 'tt := function_parameter in
union None
(cons
(case "" % string None
(Tezos_data_encoding.Data_encoding.Tag 0) empty
(fun function_parameter =>
let 'tt := function_parameter in
None)
(fun function_parameter =>
let 'tt := function_parameter in
tt))
(cons
(case "" % string None
(Tezos_data_encoding.Data_encoding.Tag 0) empty
(fun function_parameter =>
let 'tt := function_parameter in
None)
(fun function_parameter =>
let 'tt := function_parameter in
tt)) []))))
(cons
(test None "fixed_negative_size" % string
(fun function_parameter =>
let 'tt := function_parameter in
Fixed.string (Z.opp 1)))
(cons
(test None "fixed_null_size" % string
(fun function_parameter =>
let 'tt := function_parameter in
Fixed.bytes 0))
(cons
(test None "array_null_size" % string
(fun function_parameter =>
let 'tt := function_parameter in
Variable.list None empty))
(cons
(test None "list_null_size" % string
(fun function_parameter =>
let 'tt := function_parameter in
Variable.list None null))
(cons
(test None "zeroable_in_list" % string
(fun function_parameter =>
let 'tt := function_parameter in
list None
(obj1 (varopt None None "x" % string int8)))) [])))))))))).
src/lib_data_encoding/test/randomized.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Various randomly generated data. *)
open Data_encoding
(** Generate encodings of the encoding and the randomized generator *)
let test_generator ?(iterations = 50) ty encoding generator =
for _ = 0 to iterations - 1 do
let value = generator () in
Success.json ty encoding value () ;
Success.bson ty encoding value () ;
Success.binary ty encoding value () ;
Success.stream ty encoding value ()
done
let rec make_int_list acc len () =
if len = 0 then acc
else make_int_list (Random.int64 Int64.max_int :: acc) (len - 1) ()
let test_randomized_int_list () =
test_generator Alcotest.(list int64) (list int64) (make_int_list [] 100)
let test_randomized_string_list () =
test_generator
Alcotest.(list string)
(list string)
(fun () -> List.map Int64.to_string (make_int_list [] 20 ()))
let test_randomized_variant_list () =
test_generator
Alcotest.(list (result (option string) string))
(list (result (option string) (obj1 (req "failure" string))))
(fun () ->
List.map
(fun x ->
let str = Int64.to_string x in
if Random.bool () then
if Random.bool () then Ok (Some str) else Ok None
else Error str)
(make_int_list [] 20 ()))
let tests =
[ ("int_list", `Quick, test_randomized_int_list);
("string_list", `Quick, test_randomized_string_list);
("variant_list", `Quick, test_randomized_variant_list) ]
src/lib_data_encoding/test/randomized.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Data_encoding.
Definition test_generator {A B C : Type} (op_staroptstar : option Z)
: A -> B -> (unit -> C) -> unit :=
let iterations :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 50
end in
fun ty =>
fun encoding =>
fun generator =>
(* ❌ For loops not handled. *)
for.
Fixpoint make_int_list
(acc : list Stdlib.Int64.t) (len : Z) (function_parameter : unit)
: list Stdlib.Int64.t :=
let 'tt := function_parameter in
if equiv_decb len 0 then
acc
else
make_int_list (cons (Random.int64 Int64.max_int) acc) (Z.sub len 1) tt.
Definition test_randomized_int_list (function_parameter : unit) : unit :=
let 'tt := function_parameter in
test_generator None op_startypeminuserrorstar (list None int64)
(make_int_list [] 100).
Definition test_randomized_string_list (function_parameter : unit) : unit :=
let 'tt := function_parameter in
test_generator None op_startypeminuserrorstar (list None string)
(fun function_parameter =>
let 'tt := function_parameter in
List.map Int64.to_string (make_int_list [] 20 tt)).
Definition test_randomized_variant_list (function_parameter : unit) : unit :=
let 'tt := function_parameter in
test_generator None op_startypeminuserrorstar
(list None
(result (option string) (obj1 (req None None "failure" % string string))))
(fun function_parameter =>
let 'tt := function_parameter in
List.map
(fun x =>
let str := Int64.to_string x in
if Random.bool tt then
if Random.bool tt then
Stdlib.Ok (Some str)
else
Stdlib.Ok None
else
Stdlib.Error str) (make_int_list [] 20 tt)).
Definition tests : list (string * variant * (unit -> unit)) :=
cons
("int_list" % string,
(* ❌ Variants not supported *)
variant, test_randomized_int_list)
(cons
("string_list" % string,
(* ❌ Variants not supported *)
variant, test_randomized_string_list)
(cons
("variant_list" % string,
(* ❌ Variants not supported *)
variant, test_randomized_variant_list) [])).
src/lib_data_encoding/test/success.ml 204 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Trivial back-and-forth test: a value is serialized, then
unserialized and compared to the original value. All backend
(json, bson, binary, and streamed binary) are tested for each of
the basic encoding described here. No serialization or
deserialization failure are expected in these tests. *)
(* TODO `varopt` ; `assoc` ; `Data_encoding.json` *)
open Data_encoding
open Helpers
open Types
let json ty encoding value () =
no_exception (fun () ->
let json = Json.construct encoding value in
let result = Json.destruct encoding json in
Alcotest.check ty "json" value result)
let bson ty encoding value () =
no_exception (fun () ->
let json = Bson.construct encoding value in
let result = Bson.destruct encoding json in
Alcotest.check ty "bson" value result)
let binary ty encoding value () =
no_exception (fun () ->
let bytes = Binary.to_bytes_exn encoding value in
let result = Binary.of_bytes_exn encoding bytes in
Alcotest.check ty "binary" value result)
let stream ty encoding value () =
no_exception (fun () ->
let bytes = Binary.to_bytes_exn encoding value in
let len_data = Bytes.length bytes in
for sz = 1 to max 1 len_data do
let name = Format.asprintf "stream (%d)" sz in
match chunked_read sz encoding bytes with
| Binary.Success {result; size; stream} ->
if
size <> Bytes.length bytes || not (Binary_stream.is_empty stream)
then Alcotest.failf "%s failed: remaining data" name ;
Alcotest.check ty name value result
| Binary.Await _ ->
Alcotest.failf "%s failed: not enough data" name
| Binary.Error error ->
Alcotest.failf
"@[<v 2>%s failed: read error@ %a@]"
name
Binary.pp_read_error
error
done)
let all name ty encoding value =
let stream_encoding =
match Data_encoding.classify encoding with
| `Variable ->
dynamic_size encoding
| `Dynamic | `Fixed _ ->
encoding
in
[ (name ^ ".json", `Quick, json ty encoding value);
(name ^ ".bson", `Quick, bson ty encoding value);
(name ^ ".binary", `Quick, binary ty encoding value);
(name ^ ".binary_stream", `Quick, stream ty stream_encoding value) ]
let all_int encoding size =
let name = Format.asprintf "int%d" size in
all (name ^ ".min") Alcotest.int encoding ~-(1 lsl (size - 1))
@ all (name ^ ".mean") Alcotest.int encoding 0
@ all (name ^ ".max") Alcotest.int encoding ((1 lsl (size - 1)) - 1)
let all_uint encoding size =
let name = Format.asprintf "uint%d" size in
all (name ^ ".min") Alcotest.int encoding 0
@ all (name ^ ".mean") Alcotest.int encoding (1 lsl (size - 1))
@ all (name ^ ".max") Alcotest.int encoding ((1 lsl size) - 1)
let all_ranged_int minimum maximum =
let encoding = ranged_int minimum maximum in
let name = Format.asprintf "ranged_int.%d" minimum in
all (name ^ ".min") Alcotest.int encoding minimum
@ all (name ^ ".mean") Alcotest.int encoding ((minimum + maximum) / 2)
@ all (name ^ ".max") Alcotest.int encoding maximum
let all_ranged_float minimum maximum =
let encoding = ranged_float minimum maximum in
let name = Format.asprintf "ranged_float.%f" minimum in
all (name ^ ".min") Alcotest.float encoding minimum
@ all (name ^ ".mean") Alcotest.float encoding ((minimum +. maximum) /. 2.)
@ all (name ^ ".max") Alcotest.float encoding maximum
let test_n_sequence () =
let test i = binary Alcotest.z z i () ; stream Alcotest.z z i () in
for i = 0 to 10_000 do
test (Z.of_int i)
done ;
for i = 100_000_000 to 100_010_000 do
test (Z.of_int i)
done
let test_z_sequence () =
let test i = binary Alcotest.z z i () ; stream Alcotest.z z i () in
for i = -10_000 to 10_000 do
test (Z.of_int i)
done ;
for i = 100_000_000 to 100_010_000 do
test (Z.of_int i)
done ;
for i = -100_000_000 downto -100_010_000 do
test (Z.of_int i)
done
let test_string_enum_boundary () =
let entries =
List.rev_map (fun x -> (string_of_int x, x)) (List.init 255 (fun i -> i))
in
let run_test cases =
List.iter
(fun (_, num) ->
let enc = string_enum cases in
json Alcotest.int enc num () ;
bson Alcotest.int enc num () ;
binary Alcotest.int enc num () ;
stream Alcotest.int enc num ())
cases
in
run_test entries ;
let entries2 = ("255", 255) :: entries in
run_test entries2 ;
run_test (("256", 256) :: entries2)
let test_bounded_string_list =
let test name ~total ~elements v =
( "bounded_string_list." ^ name,
`Quick,
binary Alcotest.(list string) (bounded_list ~total ~elements string) v )
in
[ test "a" ~total:0 ~elements:0 [];
test "b" ~total:4 ~elements:4 [""];
test "c" ~total:20 ~elements:4 [""; ""; ""; ""; ""];
test "d" ~total:21 ~elements:5 [""; ""; ""; ""; "a"];
test "e" ~total:31 ~elements:10 ["ab"; "c"; "def"; "gh"; "ijk"] ]
let tests =
all "null" Alcotest.pass null ()
@ all "empty" Alcotest.pass empty ()
@ all "constant" Alcotest.pass (constant "toto") ()
@ all_int int8 8 @ all_uint uint8 8 @ all_int int16 16 @ all_uint uint16 16
@ all_int int31 31
@ all "int32.min" Alcotest.int32 int32 Int32.min_int
@ all "int32.max" Alcotest.int32 int32 Int32.max_int
@ all "int64.min" Alcotest.int64 int64 Int64.min_int
@ all "int64.max" Alcotest.int64 int64 Int64.max_int
@ all_ranged_int 100 400 @ all_ranged_int 19000 19254
@ all_ranged_int ~-100 300
@ all_ranged_int ~-300_000_000 300_000_000
@ all "bool.true" Alcotest.bool bool true
@ all "bool.false" Alcotest.bool bool false
@ all "string" Alcotest.string string "tutu"
@ all "string.fixed" Alcotest.string (Fixed.string 4) "tutu"
@ all "string.variable" Alcotest.string Variable.string "tutu"
@ all "string.bounded1" Alcotest.string (Bounded.string 4) "tu"
@ all "string.bounded2" Alcotest.string (Bounded.string 4) "tutu"
@ all "bytes" Alcotest.bytes bytes (Bytes.of_string "titi")
@ all "bytes.fixed" Alcotest.bytes (Fixed.bytes 4) (Bytes.of_string "titi")
@ all "bytes.variable" Alcotest.bytes Variable.bytes (Bytes.of_string "titi")
@ all
"bytes.bounded1"
Alcotest.bytes
(Bounded.bytes 4)
(Bytes.of_string "tu")
@ all
"bytes.bounded2"
Alcotest.bytes
(Bounded.bytes 4)
(Bytes.of_string "tutu")
@ all "float" Alcotest.float float 42.
@ all "float.max" Alcotest.float float max_float
@ all "float.min" Alcotest.float float min_float
@ all "float.neg_zero" Alcotest.float float (-0.)
@ all "float.zero" Alcotest.float float 0.
@ all "float.infinity" Alcotest.float float infinity
@ all "float.neg_infity" Alcotest.float float neg_infinity
@ all "float.epsilon" Alcotest.float float epsilon_float
@ all "float.nan" Alcotest.float float nan
@ all_ranged_float ~-.100. 300.
@ all "n.zero" Alcotest.n n Z.zero
@ all "n.one" Alcotest.n n Z.one
@ [("n.sequence", `Quick, test_n_sequence)]
@
let rec fact i l =
if i < 1 then []
else
let l = Z.mul l (Z.of_int i) in
fact (i - 1) l @ all (Format.asprintf "n.fact.%d" i) Alcotest.n n l
in
fact 35 Z.one
@ all
"n.a"
Alcotest.n
n
(Z.of_string "123574503164821730218493275982143254986574985328")
@ all "n.b" Alcotest.n n (Z.of_string "8493275982143254986574985328")
@ all "n.c" Alcotest.n n (Z.of_string "123574503164821730218474985328")
@ all
"n.d"
Alcotest.n
n
(Z.of_string
"10000000000100000000001000003050000000060600000000000777000008")
@ all "z.zero" Alcotest.z z Z.zero
@ all "z.one" Alcotest.z z Z.one
@ [("z.sequence", `Quick, test_z_sequence)]
@
let rec fact n l =
if n < 1 then []
else
let l = Z.mul l (Z.of_int n) in
fact (n - 1) l @ all (Format.asprintf "z.fact.%d" n) Alcotest.z z l
in
fact 35 Z.one
@ all
"z.a"
Alcotest.z
z
(Z.of_string "123574503164821730218493275982143254986574985328")
@ all "z.b" Alcotest.z z (Z.of_string "8493275982143254986574985328")
@ all "z.c" Alcotest.z z (Z.of_string "123574503164821730218474985328")
@ all
"z.d"
Alcotest.z
z
(Z.of_string
"10000000000100000000001000003050000000060600000000000777000008")
@ all
"z.e"
Alcotest.z
z
(Z.of_string "-123574503164821730218493275982143254986574985328")
@ all "z.f" Alcotest.z z (Z.of_string "-8493275982143254986574985328")
@ all "z.g" Alcotest.z z (Z.of_string "-123574503164821730218474985328")
@ all
"z.h"
Alcotest.z
z
(Z.of_string
"-10000000000100000000001000003050000000060600000000000777000008")
@ all "none" Alcotest.(option string) (option string) None
@ all "some.string" Alcotest.(option string) (option string) (Some "thing")
@ all "enum" Alcotest.int enum_enc 4
@ all "obj" Alcotest.record record_obj_enc default_record
@ all
"obj.dft"
Alcotest.record
record_obj_enc
{default_record with b = false}
@ all "obj.req" Alcotest.record record_obj_enc {default_record with c = None}
@ all "tup" Alcotest.record record_tup_enc default_record
@ all
"obj.variable"
Alcotest.variable_record
variable_record_obj_enc
default_variable_record
@ all
"tup.variable"
Alcotest.variable_record
variable_record_tup_enc
default_variable_record
@ all
"obj.variable_left"
Alcotest.variable_left_record
variable_left_record_obj_enc
default_variable_left_record
@ all
"tup.variable_left"
Alcotest.variable_left_record
variable_left_record_tup_enc
default_variable_left_record
@ all "union.A" Alcotest.union union_enc (A 1)
@ all "union.B" Alcotest.union union_enc (B "2")
@ all "union.C" Alcotest.union union_enc (C 3)
@ all "union.D" Alcotest.union union_enc (D "4")
@ all "union.E" Alcotest.union union_enc E
@ all "variable_list.empty" Alcotest.(list int) (Variable.list int31) []
@ all
"variable_list"
Alcotest.(list int)
(Variable.list int31)
[1; 2; 3; 4; 5]
@ all "variable_array.empty" Alcotest.(array int) (Variable.array int31) [||]
@ all
"variable_array"
Alcotest.(array int)
(Variable.array int31)
[|1; 2; 3; 4; 5|]
@ all "list.empty" Alcotest.(list int) (list int31) []
@ all "list" Alcotest.(list int) (list int31) [1; 2; 3; 4; 5]
@ all "array.empty" Alcotest.(array int) (array int31) [||]
@ all "array" Alcotest.(array int) (array int31) [|1; 2; 3; 4; 5|]
@ all "mu_list.empty" Alcotest.(list int) (mu_list_enc int31) []
@ all "mu_list" Alcotest.(list int) (mu_list_enc int31) [1; 2; 3; 4; 5]
@ test_bounded_string_list
@ [("string_enum_boundary", `Quick, test_string_enum_boundary)]
src/lib_data_encoding/test/success.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Data_encoding.
Definition json {A B C : Type}
(ty : A) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t B)
(value : B) (function_parameter : unit) : C :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
let json := Json.construct encoding value in
let result := Json.destruct encoding json in
op_startypeminuserrorstar ty "json" % string value result).
Definition bson {A B C : Type}
(ty : A) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t B)
(value : B) (function_parameter : unit) : C :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
let json := Bson.construct encoding value in
let result := Bson.destruct encoding json in
op_startypeminuserrorstar ty "bson" % string value result).
Definition binary {A B C : Type}
(ty : A) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t B)
(value : B) (function_parameter : unit) : C :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
let bytes := Binary.to_bytes_exn encoding value in
let result := Binary.of_bytes_exn encoding string in
op_startypeminuserrorstar ty "binary" % string value result).
Definition stream {A B C : Type}
(ty : A) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t B)
(value : B) (function_parameter : unit) : C :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
let bytes := Binary.to_bytes_exn encoding value in
let len_data := String.length string in
(* ❌ For loops not handled. *)
for).
Definition all {A B C : Type}
(name : string) (ty : A)
(encoding : Tezos_data_encoding.Data_encoding.encoding B) (value : B)
: list (string * variant * (unit -> C)) :=
let stream_encoding :=
match Data_encoding.classify encoding with
| Variable => dynamic_size None encoding
| Dynamic | Fixed _ => encoding
end in
cons
((String.append name ".json" % string),
(* ❌ Variants not supported *)
variant, (json ty encoding value))
(cons
((String.append name ".bson" % string),
(* ❌ Variants not supported *)
variant, (bson ty encoding value))
(cons
((String.append name ".binary" % string),
(* ❌ Variants not supported *)
variant, (binary ty encoding value))
(cons
((String.append name ".binary_stream" % string),
(* ❌ Variants not supported *)
variant, (stream ty stream_encoding value)) []))).
Definition all_int {A : Type}
(encoding : Tezos_data_encoding.Data_encoding.encoding Z) (size : Z)
: list (string * variant * (unit -> A)) :=
let name :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "int" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "int%d" % string) size in
OCaml.Stdlib.app
(all (String.append name ".min" % string) op_startypeminuserrorstar encoding
(Z.opp (Z.shiftl 1 (Z.sub size 1))))
(OCaml.Stdlib.app
(all (String.append name ".mean" % string) op_startypeminuserrorstar
encoding 0)
(all (String.append name ".max" % string) op_startypeminuserrorstar
encoding (Z.sub (Z.shiftl 1 (Z.sub size 1)) 1))).
Definition all_uint {A : Type}
(encoding : Tezos_data_encoding.Data_encoding.encoding Z) (size : Z)
: list (string * variant * (unit -> A)) :=
let name :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "uint" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "uint%d" % string) size in
OCaml.Stdlib.app
(all (String.append name ".min" % string) op_startypeminuserrorstar encoding
0)
(OCaml.Stdlib.app
(all (String.append name ".mean" % string) op_startypeminuserrorstar
encoding (Z.shiftl 1 (Z.sub size 1)))
(all (String.append name ".max" % string) op_startypeminuserrorstar
encoding (Z.sub (Z.shiftl 1 size) 1))).
Definition all_ranged_int {A : Type} (minimum : Z) (maximum : Z)
: list (string * variant * (unit -> A)) :=
let encoding := ranged_int minimum maximum in
let name :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "ranged_int." % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "ranged_int.%d" % string)
minimum in
OCaml.Stdlib.app
(all (String.append name ".min" % string) op_startypeminuserrorstar encoding
minimum)
(OCaml.Stdlib.app
(all (String.append name ".mean" % string) op_startypeminuserrorstar
encoding (Z.div (Z.add minimum maximum) 2))
(all (String.append name ".max" % string) op_startypeminuserrorstar
encoding maximum)).
Definition all_ranged_float {A : Type} (minimum : Z) (maximum : Z)
: list (string * variant * (unit -> A)) :=
let encoding := ranged_float minimum maximum in
let name :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "ranged_float." % string
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "ranged_float.%f" % string)
minimum in
OCaml.Stdlib.app
(all (String.append name ".min" % string) op_startypeminuserrorstar encoding
minimum)
(OCaml.Stdlib.app
(all (String.append name ".mean" % string) op_startypeminuserrorstar
encoding
(Stdlib.op_divpoint (Stdlib.op_pluspoint minimum maximum)
(* ❌ Float constant 2. is approximated by the integer 2 *)
2))
(all (String.append name ".max" % string) op_startypeminuserrorstar
encoding maximum)).
Definition test_n_sequence (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let test {A : Type} (i : Z.t) : A :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := binary op_startypeminuserrorstar z i tt in
stream op_startypeminuserrorstar z i tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ For loops not handled. *)
for in
(* ❌ For loops not handled. *)
for.
Definition test_z_sequence (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let test {A : Type} (i : Z.t) : A :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := binary op_startypeminuserrorstar z i tt in
stream op_startypeminuserrorstar z i tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ For loops not handled. *)
for in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ For loops not handled. *)
for in
(* ❌ For loops not handled. *)
for.
Definition test_string_enum_boundary (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let entries :=
Stdlib.List.rev_map (fun x => ((OCaml.Stdlib.string_of_int x), x))
(Stdlib.List.init 255 (fun i => i)) in
let run_test {A : Type} (cases : list (string * A)) : unit :=
Stdlib.List.iter
(fun function_parameter =>
let '(_, num) := function_parameter in
let enc := string_enum cases in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := json op_startypeminuserrorstar enc num tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := bson op_startypeminuserrorstar enc num tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := binary op_startypeminuserrorstar enc num tt in
stream op_startypeminuserrorstar enc num tt) cases in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := run_test entries in
let entries2 := cons ("255" % string, 255) entries in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := run_test entries2 in
run_test (cons ("256" % string, 256) entries2).
Definition test_bounded_string_list {A : Type}
: list (string * variant * (unit -> A)) :=
let test {B C D E : Type} (name : string) (total : B) (elements : C) (v : D)
: string * variant * (unit -> E) :=
((String.append "bounded_string_list." % string name),
(* ❌ Variants not supported *)
variant,
(binary op_startypeminuserrorstar
(op_startypeminuserrorstar total elements string) v)) in
cons (test "a" % string 0 0 [])
(cons (test "b" % string 4 4 (cons "" % string []))
(cons
(test "c" % string 20 4
(cons "" % string
(cons "" % string
(cons "" % string (cons "" % string (cons "" % string []))))))
(cons
(test "d" % string 21 5
(cons "" % string
(cons "" % string
(cons "" % string (cons "" % string (cons "a" % string []))))))
(cons
(test "e" % string 31 10
(cons "ab" % string
(cons "c" % string
(cons "def" % string
(cons "gh" % string (cons "ijk" % string [])))))) [])))).
Definition tests : list (string * variant * (unit -> unit)) :=
OCaml.Stdlib.app (all "null" % string op_startypeminuserrorstar null tt)
(OCaml.Stdlib.app (all "empty" % string op_startypeminuserrorstar empty tt)
(OCaml.Stdlib.app
(all "constant" % string op_startypeminuserrorstar
(constant "toto" % string) tt)
(OCaml.Stdlib.app (all_int int8 8)
(OCaml.Stdlib.app (all_uint uint8 8)
(OCaml.Stdlib.app (all_int int16 16)
(OCaml.Stdlib.app (all_uint uint16 16)
(OCaml.Stdlib.app (all_int int31 31)
(OCaml.Stdlib.app
(all "int32.min" % string op_startypeminuserrorstar int32
Int32.min_int)
(OCaml.Stdlib.app
(all "int32.max" % string op_startypeminuserrorstar int32
Int32.max_int)
(OCaml.Stdlib.app
(all "int64.min" % string op_startypeminuserrorstar
int64 Int64.min_int)
(OCaml.Stdlib.app
(all "int64.max" % string op_startypeminuserrorstar
int64 Int64.max_int)
(OCaml.Stdlib.app (all_ranged_int 100 400)
(OCaml.Stdlib.app (all_ranged_int 19000 19254)
(OCaml.Stdlib.app (all_ranged_int (Z.opp 100) 300)
(OCaml.Stdlib.app
(all_ranged_int (Z.opp 300000000) 300000000)
(OCaml.Stdlib.app
(all "bool.true" % string
op_startypeminuserrorstar bool true)
(OCaml.Stdlib.app
(all "bool.false" % string
op_startypeminuserrorstar bool false)
(OCaml.Stdlib.app
(all "string" % string
op_startypeminuserrorstar string
"tutu" % string)
(OCaml.Stdlib.app
(all "string.fixed" % string
op_startypeminuserrorstar
(Fixed.string 4) "tutu" % string)
(OCaml.Stdlib.app
(all "string.variable" % string
op_startypeminuserrorstar
Variable.string "tutu" % string)
(OCaml.Stdlib.app
(all "string.bounded1" % string
op_startypeminuserrorstar
(Bounded.string 4) "tu" % string)
(OCaml.Stdlib.app
(all "string.bounded2" % string
op_startypeminuserrorstar
(Bounded.string 4)
"tutu" % string)
(OCaml.Stdlib.app
(all "bytes" % string
op_startypeminuserrorstar
bytes
(Stdlib.Bytes.of_string
"titi" % string))
(OCaml.Stdlib.app
(all "bytes.fixed" % string
op_startypeminuserrorstar
(Fixed.bytes 4)
(Stdlib.Bytes.of_string
"titi" % string))
(OCaml.Stdlib.app
(all
"bytes.variable" %
string
op_startypeminuserrorstar
Variable.bytes
(Stdlib.Bytes.of_string
"titi" % string))
(OCaml.Stdlib.app
(all
"bytes.bounded1" %
string
op_startypeminuserrorstar
(Bounded.bytes 4)
(Stdlib.Bytes.of_string
"tu" % string))
(OCaml.Stdlib.app
(all
"bytes.bounded2" %
string
op_startypeminuserrorstar
(Bounded.bytes 4)
(Stdlib.Bytes.of_string
"tutu" % string))
(OCaml.Stdlib.app
(all
"float" % string
op_startypeminuserrorstar
float
(* ❌ Float constant 42. is approximated by the integer 42 *)
42)
(OCaml.Stdlib.app
(all
"float.max" %
string
op_startypeminuserrorstar
float
Stdlib.max_float)
(OCaml.Stdlib.app
(all
"float.min" %
string
op_startypeminuserrorstar
float
Stdlib.min_float)
(OCaml.Stdlib.app
(all
"float.neg_zero"
% string
op_startypeminuserrorstar
float
(* ❌ Float constant -0. is approximated by the integer 0 *)
0)
(OCaml.Stdlib.app
(all
"float.zero"
% string
op_startypeminuserrorstar
float
(* ❌ Float constant 0. is approximated by the integer 0 *)
0)
(OCaml.Stdlib.app
(all
"float.infinity"
%
string
op_startypeminuserrorstar
float
Stdlib.infinity)
(OCaml.Stdlib.app
(all
"float.neg_infity"
%
string
op_startypeminuserrorstar
float
Stdlib.neg_infinity)
(OCaml.Stdlib.app
(all
"float.epsilon"
%
string
op_startypeminuserrorstar
float
Stdlib.epsilon_float)
(OCaml.Stdlib.app
(all
"float.nan"
%
string
op_startypeminuserrorstar
float
Stdlib.nan)
(OCaml.Stdlib.app
(all_ranged_float
(Stdlib.op_tildeminuspoint
(* ❌ Float constant 100. is approximated by the integer 100 *)
100)
(* ❌ Float constant 300. is approximated by the integer 300 *)
300)
(OCaml.Stdlib.app
(all
"n.zero"
%
string
op_startypeminuserrorstar
n
Z.zero)
(OCaml.Stdlib.app
(all
"n.one"
%
string
op_startypeminuserrorstar
n
Z.one)
(OCaml.Stdlib.app
(cons
("n.sequence"
%
string,
(* ❌ Variants not supported *)
variant,
test_n_sequence)
[])
(let
fix
fact
{A
:
Type}
(i
:
Z)
(l
:
Z.t)
: list
(string
*
variant
*
(unit
->
A)) :=
if
OCaml.Stdlib.lt
i
1
then
[]
else
let
l :=
Z.mul
l
(Z.of_int
i)
in
OCaml.Stdlib.app
(fact
(Z.sub
i
1)
l)
(all
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"n.fact."
%
string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"n.fact.%d"
%
string)
i)
op_startypeminuserrorstar
n
l)
in
OCaml.Stdlib.app
(fact
35
Z.one)
(OCaml.Stdlib.app
(all
"n.a"
%
string
op_startypeminuserrorstar
n
(Z.of_string
"123574503164821730218493275982143254986574985328"
%
string))
(OCaml.Stdlib.app
(all
"n.b"
%
string
op_startypeminuserrorstar
n
(Z.of_string
"8493275982143254986574985328"
%
string))
(OCaml.Stdlib.app
(all
"n.c"
%
string
op_startypeminuserrorstar
n
(Z.of_string
"123574503164821730218474985328"
%
string))
(OCaml.Stdlib.app
(all
"n.d"
%
string
op_startypeminuserrorstar
n
(Z.of_string
"10000000000100000000001000003050000000060600000000000777000008"
%
string))
(OCaml.Stdlib.app
(all
"z.zero"
%
string
op_startypeminuserrorstar
z
Z.zero)
(OCaml.Stdlib.app
(all
"z.one"
%
string
op_startypeminuserrorstar
z
Z.one)
(OCaml.Stdlib.app
(cons
("z.sequence"
%
string,
(* ❌ Variants not supported *)
variant,
test_z_sequence)
[])
(let
fix
fact
{A
:
Type}
(n
:
Z)
(l
:
Z.t)
: list
(string
*
variant
*
(unit
->
A)) :=
if
OCaml.Stdlib.lt
n
1
then
[]
else
let
l :=
Z.mul
l
(Z.of_int
n)
in
OCaml.Stdlib.app
(fact
(Z.sub
n
1)
l)
(all
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"z.fact."
%
string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"z.fact.%d"
%
string)
n)
op_startypeminuserrorstar
z
l)
in
OCaml.Stdlib.app
(fact
35
Z.one)
(OCaml.Stdlib.app
(all
"z.a"
%
string
op_startypeminuserrorstar
z
(Z.of_string
"123574503164821730218493275982143254986574985328"
%
string))
(OCaml.Stdlib.app
(all
"z.b"
%
string
op_startypeminuserrorstar
z
(Z.of_string
"8493275982143254986574985328"
%
string))
(OCaml.Stdlib.app
(all
"z.c"
%
string
op_startypeminuserrorstar
z
(Z.of_string
"123574503164821730218474985328"
%
string))
(OCaml.Stdlib.app
(all
"z.d"
%
string
op_startypeminuserrorstar
z
(Z.of_string
"10000000000100000000001000003050000000060600000000000777000008"
%
string))
(OCaml.Stdlib.app
(all
"z.e"
%
string
op_startypeminuserrorstar
z
(Z.of_string
"-123574503164821730218493275982143254986574985328"
%
string))
(OCaml.Stdlib.app
(all
"z.f"
%
string
op_startypeminuserrorstar
z
(Z.of_string
"-8493275982143254986574985328"
%
string))
(OCaml.Stdlib.app
(all
"z.g"
%
string
op_startypeminuserrorstar
z
(Z.of_string
"-123574503164821730218474985328"
%
string))
(OCaml.Stdlib.app
(all
"z.h"
%
string
op_startypeminuserrorstar
z
(Z.of_string
"-10000000000100000000001000003050000000060600000000000777000008"
%
string))
(OCaml.Stdlib.app
(all
"none"
%
string
op_startypeminuserrorstar
(option
string)
None)
(OCaml.Stdlib.app
(all
"some.string"
%
string
op_startypeminuserrorstar
(option
string)
(Some
"thing"
%
string))
(OCaml.Stdlib.app
(all
"enum"
%
string
op_startypeminuserrorstar
op_startypeminuserrorstar
4)
(OCaml.Stdlib.app
(all
"obj"
%
string
op_startypeminuserrorstar
op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app
(all
"obj.dft"
%
string
op_startypeminuserrorstar
op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app
(all
"obj.req"
%
string
op_startypeminuserrorstar
op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app
(all
"tup"
%
string
op_startypeminuserrorstar
op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app
(all
"obj.variable"
%
string
op_startypeminuserrorstar
op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app
(all
"tup.variable"
%
string
op_startypeminuserrorstar
op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app
(all
"obj.variable_left"
%
string
op_startypeminuserrorstar
op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app
(all
"tup.variable_left"
%
string
op_startypeminuserrorstar
op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app
(all
"union.A"
%
string
op_startypeminuserrorstar
op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app
(all
"union.B"
%
string
op_startypeminuserrorstar
op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app
(all
"union.C"
%
string
op_startypeminuserrorstar
op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app
(all
"union.D"
%
string
op_startypeminuserrorstar
op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app
(all
"union.E"
%
string
op_startypeminuserrorstar
op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app
(all
"variable_list.empty"
%
string
op_startypeminuserrorstar
(Variable.list
None
int31)
[])
(OCaml.Stdlib.app
(all
"variable_list"
%
string
op_startypeminuserrorstar
(Variable.list
None
int31)
(cons
1
(cons
2
(cons
3
(cons
4
(cons
5
[]))))))
(OCaml.Stdlib.app
(all
"variable_array.empty"
%
string
op_startypeminuserrorstar
(Variable.array
None
int31)
(* ❌ Arrays not handled. *)
[
])
(OCaml.Stdlib.app
(all
"variable_array"
%
string
op_startypeminuserrorstar
(Variable.array
None
int31)
(* ❌ Arrays not handled. *)
[
1;
2;
3;
4;
5
])
(OCaml.Stdlib.app
(all
"list.empty"
%
string
op_startypeminuserrorstar
(list
None
int31)
[])
(OCaml.Stdlib.app
(all
"list"
%
string
op_startypeminuserrorstar
(list
None
int31)
(cons
1
(cons
2
(cons
3
(cons
4
(cons
5
[]))))))
(OCaml.Stdlib.app
(all
"array.empty"
%
string
op_startypeminuserrorstar
(array
None
int31)
(* ❌ Arrays not handled. *)
[
])
(OCaml.Stdlib.app
(all
"array"
%
string
op_startypeminuserrorstar
(array
None
int31)
(* ❌ Arrays not handled. *)
[
1;
2;
3;
4;
5
])
(OCaml.Stdlib.app
(all
"mu_list.empty"
%
string
op_startypeminuserrorstar
(op_startypeminuserrorstar
int31)
[])
(OCaml.Stdlib.app
(all
"mu_list"
%
string
op_startypeminuserrorstar
(op_startypeminuserrorstar
int31)
(cons
1
(cons
2
(cons
3
(cons
4
(cons
5
[]))))))
(OCaml.Stdlib.app
test_bounded_string_list
(cons
("string_enum_boundary"
%
string,
(* ❌ Variants not supported *)
variant,
test_string_enum_boundary)
[]))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))).
src/lib_data_encoding/test/test.ml 8 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let () =
Random.init 100 ;
Alcotest.run
"tezos-data-encoding"
[ ("success", Success.tests);
("invalid_encoding", Invalid_encoding.tests);
("read_failure", Read_failure.tests);
("write_failure", Write_failure.tests);
("randomized", Randomized.tests);
("versioned", Versioned.tests) ]
src/lib_data_encoding/test/test.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations.
src/lib_data_encoding/test/test_generated.ml 202 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* NOTE: the current release of Crowbar, v0.1, is quite limited. Several
* improvements have been made to the dev version which will make it possible to
* simplify this file and increase coverage.
* For now, this is a limited test-suite. *)
let char = Crowbar.map [Crowbar.uint8] Char.chr
let string = Crowbar.bytes
(* The v0.1 of Crowbar doesn't have fixed-size string generation. When we
* update Crowbar, we can improve this generator. *)
let short_string =
let open Crowbar in
choose
[ const "";
map [char] (fun c -> String.make 1 c);
map [char; char; char; char] (fun c1 c2 c3 c4 ->
let s = Bytes.make 4 c1 in
Bytes.set s 1 c2 ;
Bytes.set s 2 c3 ;
Bytes.set s 3 c4 ;
Bytes.to_string s) ]
let short_string1 =
let open Crowbar in
choose
[ map [char] (fun c -> String.make 1 c);
map [char; char; char; char] (fun c1 c2 c3 c4 ->
let s = Bytes.make 4 c1 in
Bytes.set s 1 c2 ;
Bytes.set s 2 c3 ;
Bytes.set s 3 c4 ;
Bytes.to_string s) ]
let mbytes = Crowbar.map [Crowbar.bytes] Bytes.of_string
let short_mbytes = Crowbar.map [short_string] Bytes.of_string
let short_mbytes1 = Crowbar.map [short_string1] Bytes.of_string
(* We need to hide the type parameter of `Encoding.t` to avoid the generator
* combinator `choose` from complaining about different types. We use first
* level modules (for now) to encode existentials.
*
* An alternative is used in https://gitlab.com/gasche/fuzz-data-encoding *)
module type TESTABLE = sig
type t
val v : t
val ding : t Data_encoding.t
val pp : t Crowbar.printer
end
type testable = (module TESTABLE)
let null : testable =
( module struct
type t = unit
let v = ()
let ding = Data_encoding.null
let pp ppf () = Crowbar.pp ppf "(null)"
end )
let empty : testable =
( module struct
type t = unit
let v = ()
let ding = Data_encoding.empty
let pp ppf () = Crowbar.pp ppf "(empty)"
end )
let unit : testable =
( module struct
type t = unit
let v = ()
let ding = Data_encoding.unit
let pp ppf () = Crowbar.pp ppf "(unit)"
end )
let map_constant (s : string) : testable =
( module struct
type t = unit
let v = ()
let ding = Data_encoding.constant s
let pp ppf () = Crowbar.pp ppf "\"%s\"" s
end )
let map_int8 (i : int) : testable =
( module struct
type t = int
let v = i
let ding = Data_encoding.int8
let pp = Crowbar.pp_int
end )
let map_uint8 (i : int) : testable =
( module struct
type t = int
let v = i
let ding = Data_encoding.uint8
let pp = Crowbar.pp_int
end )
let map_int16 (i : int) : testable =
( module struct
type t = int
let v = i
let ding = Data_encoding.int16
let pp = Crowbar.pp_int
end )
let map_uint16 (i : int) : testable =
( module struct
type t = int
let v = i
let ding = Data_encoding.uint16
let pp = Crowbar.pp_int
end )
let map_int32 (i : int32) : testable =
( module struct
type t = int32
let v = i
let ding = Data_encoding.int32
let pp = Crowbar.pp_int32
end )
let map_int64 (i : int64) : testable =
( module struct
type t = int64
let v = i
let ding = Data_encoding.int64
let pp = Crowbar.pp_int64
end )
let map_range_int a b c : testable =
let (small, middle, big) =
match List.sort compare [a; b; c] with
| [small; middle; big] ->
assert (small <= middle) ;
assert (middle <= big) ;
(small, middle, big)
| _ ->
assert false
in
( module struct
type t = int
let v = middle
let ding = Data_encoding.ranged_int small big
let pp ppf i = Crowbar.pp ppf "(%d :[%d;%d])" i small big
end )
let map_range_float a b c : testable =
if compare a nan = 0 || compare b nan = 0 || compare c nan = 0 then
(* copout *)
null
else
let (small, middle, big) =
match List.sort compare [a; b; c] with
| [small; middle; big] ->
assert (small <= middle) ;
assert (middle <= big) ;
(small, middle, big)
| _ ->
assert false
in
( module struct
type t = float
let v = middle
let ding = Data_encoding.ranged_float small big
let pp ppf i = Crowbar.pp ppf "(%f :[%f;%f])" i small big
end )
let map_bool b : testable =
( module struct
type t = bool
let v = b
let ding = Data_encoding.bool
let pp = Crowbar.pp_bool
end )
let map_string s : testable =
( module struct
type t = string
let v = s
let ding = Data_encoding.string
let pp = Crowbar.pp_string
end )
let map_bytes s : testable =
( module struct
type t = Bytes.t
let v = s
let ding = Data_encoding.bytes
let pp ppf m =
if Bytes.length m > 40 then
Crowbar.pp
ppf
"@[<hv 1>%a ⦠(%d more bytes)@]"
Hex.pp
(Hex.of_bytes (Bytes.sub m 1 30))
(Bytes.length m)
else Hex.pp ppf (Hex.of_bytes m)
end )
let map_float f : testable =
( module struct
type t = float
let v = f
let ding = Data_encoding.float
let pp = Crowbar.pp_float
end )
let map_fixed_string s : testable =
( module struct
type t = string
let v = s
let ding = Data_encoding.Fixed.string (String.length s)
let pp ppf s = Crowbar.pp ppf "\"%s\"" s
end )
let map_fixed_bytes s : testable =
( module struct
type t = Bytes.t
let v = s
let ding = Data_encoding.Fixed.bytes (Bytes.length s)
let pp fmt x = Hex.pp fmt (Hex.of_bytes x)
end )
let map_variable_string s : testable =
( module struct
type t = string
let v = s
let ding = Data_encoding.Variable.string
let pp ppf s = Crowbar.pp ppf "\"%s\"" s
end )
let map_variable_bytes s : testable =
( module struct
type t = Bytes.t
let v = s
let ding = Data_encoding.Variable.bytes
let pp fmt x = Hex.pp fmt (Hex.of_bytes x)
end )
(* And now combinators *)
let dyn_if_not ding =
match Data_encoding.classify ding with
| `Fixed _ | `Dynamic ->
ding
| `Variable ->
Data_encoding.dynamic_size ding
let map_some (t : testable) : testable =
let module T = (val t) in
( module struct
type t = T.t option
let v = Some T.v
let ding =
try Data_encoding.option T.ding
with Invalid_argument _ -> Crowbar.bad_test ()
let pp ppf o =
Crowbar.pp
ppf
"@[<hv 1>%a@]"
(fun fmt v ->
match v with
| None ->
Format.fprintf fmt "None"
| Some v ->
Format.fprintf fmt "Some(%a)" T.pp v)
o
end )
let map_none (t : testable) : testable =
let module T = (val t) in
( module struct
type t = T.t option
let v = None
let ding =
try Data_encoding.option T.ding
with Invalid_argument _ -> Crowbar.bad_test ()
let pp ppf o =
Crowbar.pp
ppf
"@[<hv 1>%a@]"
(fun fmt v ->
match v with
| None ->
Format.fprintf fmt "None"
| Some v ->
Format.fprintf fmt "Some(%a)" T.pp v)
o
end )
let map_ok (t_o : testable) (t_e : testable) : testable =
let module T_O = (val t_o) in
let module T_E = (val t_e) in
( module struct
type t = (T_O.t, T_E.t) result
let v = Ok T_O.v
let ding = Data_encoding.result T_O.ding T_E.ding
let pp ppf r =
Crowbar.pp
ppf
"@[<hv 1>%a@]"
(fun fmt r ->
match r with
| Ok o ->
Format.fprintf fmt "Ok(%a)" T_O.pp o
| Error e ->
Format.fprintf fmt "Error(%a)" T_E.pp e)
r
end )
let map_error (t_o : testable) (t_e : testable) : testable =
let module T_O = (val t_o) in
let module T_E = (val t_e) in
( module struct
type t = (T_O.t, T_E.t) result
let v = Error T_E.v
let ding = Data_encoding.result T_O.ding T_E.ding
let pp ppf r =
Crowbar.pp
ppf
"@[<hv 1>%a@]"
(fun fmt r ->
match r with
| Ok o ->
Format.fprintf fmt "Ok(%a)" T_O.pp o
| Error e ->
Format.fprintf fmt "Error(%a)" T_E.pp e)
r
end )
let map_variable_list (t : testable) (ts : testable list) : testable =
let module T = (val t) in
( module struct
type t = T.t list
let ding = Data_encoding.Variable.list (dyn_if_not T.ding)
let v =
List.fold_left
(fun acc (t : testable) ->
let module T = (val t) in
(* We can get rid of this Obj when we update Crowbar *)
Obj.magic T.v :: acc)
[]
ts
let pp = Crowbar.pp_list T.pp
end )
let map_variable_array (t : testable) (ts : testable array) : testable =
let module T = (val t) in
( module struct
type t = T.t array
let ding = Data_encoding.Variable.array (dyn_if_not T.ding)
let v =
Array.of_list
(Array.fold_left
(fun acc (t : testable) ->
let module T = (val t) in
Obj.magic T.v :: acc)
[]
ts)
let pp ppf a =
if Array.length a > 40 then
Crowbar.pp
ppf
"@[<hv 1>[|%a ⦠(%d more elements)|]@]"
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ")
T.pp)
(Array.to_list (Array.sub a 0 30))
(Array.length a)
else
Crowbar.pp
ppf
"@[<hv 1>[|%a|]@]"
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ")
T.pp)
(Array.to_list a)
end )
let map_dynamic_size (t : testable) : testable =
let module T = (val t) in
( module struct
include T
let ding = Data_encoding.dynamic_size T.ding
end )
let map_tup1 (t1 : testable) : testable =
let module T1 = (val t1) in
( module struct
include T1
let ding = Data_encoding.tup1 T1.ding
let pp ppf v1 = Crowbar.pp ppf "@[<hv 1>(%a)@]" T1.pp v1
end )
let map_tup2 (t1 : testable) (t2 : testable) : testable =
let module T1 = (val t1) in
let module T2 = (val t2) in
( module struct
type t = T1.t * T2.t
let ding = Data_encoding.tup2 (dyn_if_not T1.ding) T2.ding
let v = (T1.v, T2.v)
let pp ppf (v1, v2) = Crowbar.pp ppf "@[<hv 1>(%a, %a)@]" T1.pp v1 T2.pp v2
end )
let map_tup3 (t1 : testable) (t2 : testable) (t3 : testable) : testable =
let module T1 = (val t1) in
let module T2 = (val t2) in
let module T3 = (val t3) in
( module struct
type t = T1.t * T2.t * T3.t
let ding =
Data_encoding.tup3 (dyn_if_not T1.ding) (dyn_if_not T2.ding) T3.ding
let v = (T1.v, T2.v, T3.v)
let pp ppf (v1, v2, v3) =
Crowbar.pp ppf "@[<hv 1>(%a, %a, %a)@]" T1.pp v1 T2.pp v2 T3.pp v3
end )
let map_tup4 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable) :
testable =
let module T1 = (val t1) in
let module T2 = (val t2) in
let module T3 = (val t3) in
let module T4 = (val t4) in
( module struct
type t = T1.t * T2.t * T3.t * T4.t
let ding =
Data_encoding.tup4
(dyn_if_not T1.ding)
(dyn_if_not T2.ding)
(dyn_if_not T3.ding)
T4.ding
let v = (T1.v, T2.v, T3.v, T4.v)
let pp ppf (v1, v2, v3, v4) =
Crowbar.pp
ppf
"@[<hv 1>(%a, %a, %a, %a)@]"
T1.pp
v1
T2.pp
v2
T3.pp
v3
T4.pp
v4
end )
let map_tup5 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
(t5 : testable) : testable =
let module T1 = (val t1) in
let module T2 = (val t2) in
let module T3 = (val t3) in
let module T4 = (val t4) in
let module T5 = (val t5) in
( module struct
type t = T1.t * T2.t * T3.t * T4.t * T5.t
let ding =
Data_encoding.tup5
(dyn_if_not T1.ding)
(dyn_if_not T2.ding)
(dyn_if_not T3.ding)
(dyn_if_not T4.ding)
T5.ding
let v = (T1.v, T2.v, T3.v, T4.v, T5.v)
let pp ppf (v1, v2, v3, v4, v5) =
Crowbar.pp
ppf
"@[<hv 1>(%a, %a, %a, %a, %a)@]"
T1.pp
v1
T2.pp
v2
T3.pp
v3
T4.pp
v4
T5.pp
v5
end )
let map_tup6 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
(t5 : testable) (t6 : testable) : testable =
let module T1 = (val t1) in
let module T2 = (val t2) in
let module T3 = (val t3) in
let module T4 = (val t4) in
let module T5 = (val t5) in
let module T6 = (val t6) in
( module struct
type t = T1.t * T2.t * T3.t * T4.t * T5.t * T6.t
let ding =
Data_encoding.tup6
(dyn_if_not T1.ding)
(dyn_if_not T2.ding)
(dyn_if_not T3.ding)
(dyn_if_not T4.ding)
(dyn_if_not T5.ding)
T6.ding
let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v)
let pp ppf (v1, v2, v3, v4, v5, v6) =
Crowbar.pp
ppf
"@[<hv 1>(%a, %a, %a, %a, %a, %a)@]"
T1.pp
v1
T2.pp
v2
T3.pp
v3
T4.pp
v4
T5.pp
v5
T6.pp
v6
end )
let map_tup7 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
(t5 : testable) (t6 : testable) (t7 : testable) : testable =
let module T1 = (val t1) in
let module T2 = (val t2) in
let module T3 = (val t3) in
let module T4 = (val t4) in
let module T5 = (val t5) in
let module T6 = (val t6) in
let module T7 = (val t7) in
( module struct
type t = T1.t * T2.t * T3.t * T4.t * T5.t * T6.t * T7.t
let ding =
Data_encoding.tup7
(dyn_if_not T1.ding)
(dyn_if_not T2.ding)
(dyn_if_not T3.ding)
(dyn_if_not T4.ding)
(dyn_if_not T5.ding)
(dyn_if_not T6.ding)
T7.ding
let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v, T7.v)
let pp ppf (v1, v2, v3, v4, v5, v6, v7) =
Crowbar.pp
ppf
"@[<hv 1>(%a, %a, %a, %a, %a, %a, %a)@]"
T1.pp
v1
T2.pp
v2
T3.pp
v3
T4.pp
v4
T5.pp
v5
T6.pp
v6
T7.pp
v7
end )
let map_tup8 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
(t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable) : testable
=
let module T1 = (val t1) in
let module T2 = (val t2) in
let module T3 = (val t3) in
let module T4 = (val t4) in
let module T5 = (val t5) in
let module T6 = (val t6) in
let module T7 = (val t7) in
let module T8 = (val t8) in
( module struct
type t = T1.t * T2.t * T3.t * T4.t * T5.t * T6.t * T7.t * T8.t
let ding =
Data_encoding.tup8
(dyn_if_not T1.ding)
(dyn_if_not T2.ding)
(dyn_if_not T3.ding)
(dyn_if_not T4.ding)
(dyn_if_not T5.ding)
(dyn_if_not T6.ding)
(dyn_if_not T7.ding)
T8.ding
let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v, T7.v, T8.v)
let pp ppf (v1, v2, v3, v4, v5, v6, v7, v8) =
Crowbar.pp
ppf
"@[<hv 1>(%a, %a, %a, %a, %a, %a, %a, %a)@]"
T1.pp
v1
T2.pp
v2
T3.pp
v3
T4.pp
v4
T5.pp
v5
T6.pp
v6
T7.pp
v7
T8.pp
v8
end )
let map_tup9 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
(t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable)
(t9 : testable) : testable =
let module T1 = (val t1) in
let module T2 = (val t2) in
let module T3 = (val t3) in
let module T4 = (val t4) in
let module T5 = (val t5) in
let module T6 = (val t6) in
let module T7 = (val t7) in
let module T8 = (val t8) in
let module T9 = (val t9) in
( module struct
type t = T1.t * T2.t * T3.t * T4.t * T5.t * T6.t * T7.t * T8.t * T9.t
let ding =
Data_encoding.tup9
(dyn_if_not T1.ding)
(dyn_if_not T2.ding)
(dyn_if_not T3.ding)
(dyn_if_not T4.ding)
(dyn_if_not T5.ding)
(dyn_if_not T6.ding)
(dyn_if_not T7.ding)
(dyn_if_not T8.ding)
T9.ding
let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v, T7.v, T8.v, T9.v)
let pp ppf (v1, v2, v3, v4, v5, v6, v7, v8, v9) =
Crowbar.pp
ppf
"@[<hv 1>(%a, %a, %a, %a, %a, %a, %a, %a, %a)@]"
T1.pp
v1
T2.pp
v2
T3.pp
v3
T4.pp
v4
T5.pp
v5
T6.pp
v6
T7.pp
v7
T8.pp
v8
T9.pp
v9
end )
let map_tup10 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
(t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable)
(t9 : testable) (t10 : testable) : testable =
let module T1 = (val t1) in
let module T2 = (val t2) in
let module T3 = (val t3) in
let module T4 = (val t4) in
let module T5 = (val t5) in
let module T6 = (val t6) in
let module T7 = (val t7) in
let module T8 = (val t8) in
let module T9 = (val t9) in
let module T10 = (val t10) in
( module struct
type t =
T1.t * T2.t * T3.t * T4.t * T5.t * T6.t * T7.t * T8.t * T9.t * T10.t
let ding =
Data_encoding.tup10
(dyn_if_not T1.ding)
(dyn_if_not T2.ding)
(dyn_if_not T3.ding)
(dyn_if_not T4.ding)
(dyn_if_not T5.ding)
(dyn_if_not T6.ding)
(dyn_if_not T7.ding)
(dyn_if_not T8.ding)
(dyn_if_not T9.ding)
T10.ding
let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v, T7.v, T8.v, T9.v, T10.v)
let pp ppf (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10) =
Crowbar.pp
ppf
"@[<hv 1>(%a, %a, %a, %a, %a, %a, %a, %a, %a, %a)@]"
T1.pp
v1
T2.pp
v2
T3.pp
v3
T4.pp
v4
T5.pp
v5
T6.pp
v6
T7.pp
v7
T8.pp
v8
T9.pp
v9
T10.pp
v10
end )
let map_merge_tups (t1 : testable) (t2 : testable) : testable =
let module T1 = (val t1) in
let module T2 = (val t2) in
( module struct
type t = T1.t * T2.t
let ding =
Data_encoding.merge_tups (dyn_if_not T1.ding) (dyn_if_not T2.ding)
let v = (T1.v, T2.v)
let pp ppf (v1, v2) = Crowbar.pp ppf "@[<hv 1>(%a, %a)@]" T1.pp v1 T2.pp v2
end )
let testable_printer : testable Crowbar.printer =
fun ppf (t : testable) ->
let module T = (val t) in
T.pp ppf T.v
(* helpers to construct values tester values *)
(* Generator for testable values *)
let tup_gen (tgen : testable Crowbar.gen) : testable Crowbar.gen =
let open Crowbar in
(* Stack overflow if there are more levels *)
with_printer testable_printer
@@ choose
[ map [tgen] map_tup1;
map [tgen; tgen] map_tup2;
map [tgen; tgen; tgen] map_tup3;
map [tgen; tgen; tgen; tgen] map_tup4;
map [tgen; tgen; tgen; tgen; tgen] map_tup5;
map [tgen; tgen; tgen; tgen; tgen; tgen] map_tup6 ]
let gen =
let open Crowbar in
let g : testable Crowbar.gen =
fix (fun g ->
choose
[ const null;
const empty;
const unit;
map [short_string] map_constant;
map [int8] map_int8;
map [uint8] map_uint8;
(* TODO: use newer version of crowbar to get these generators
map [int16] map_int16;
map [uint16] map_uint16;
*)
map [int32] map_int32;
map [int64] map_int64;
(* NOTE: the int encoding require ranges to be 30-bit compatible *)
map [int8; int8; int8] map_range_int;
map [float; float; float] map_range_float;
map [bool] map_bool;
map [short_string] map_string;
map [short_mbytes] map_bytes;
map [float] map_float;
map [short_string1] map_fixed_string;
map [short_mbytes1] map_fixed_bytes;
map [short_string] map_variable_string;
map [short_mbytes] map_variable_bytes;
map [g] map_some;
map [g] map_none;
map [g] map_dynamic_size;
map [g] map_tup1;
map [g; g] map_tup2;
map [g; g; g] map_tup3;
map [g; g; g; g] map_tup4;
map [g; g; g; g; g] map_tup5;
map [g; g; g; g; g; g] map_tup6;
map [g; g] (fun t1 t2 ->
map_merge_tups (map_tup1 t1) (map_tup1 t2));
map [g; g; g] (fun t1 t2 t3 ->
map_merge_tups (map_tup2 t1 t2) (map_tup1 t3));
map [g; g; g] (fun t1 t2 t3 ->
map_merge_tups (map_tup1 t1) (map_tup2 t2 t3))
(* NOTE: we cannot use lists/arrays for now. They require the
data-inside to be homogeneous (e.g., same rangedness of ranged
numbers) which we cannot guarantee right now. This can be fixed once
we update Crowbar and get access to the new `dynamic_bind` generator
combinator.
map [g; list g] map_variable_list;
map [g; list g] (fun t ts -> map_variable_array t (Array.of_list ts));
*)
])
in
with_printer testable_printer g
(* TODO: The following features are not yet tested
val string_enum : (string * 'a) list -> 'a encoding
val delayed : (unit -> 'a encoding) -> 'a encoding
val json : json encoding
val json_schema : json_schema encoding
type 'a field
val req :
?title:string -> ?description:string ->
string -> 't encoding -> 't field
val opt :
?title:string -> ?description:string ->
string -> 't encoding -> 't option field
val varopt :
?title:string -> ?description:string ->
string -> 't encoding -> 't option field
val dft :
?title:string -> ?description:string ->
string -> 't encoding -> 't -> 't field
val obj1 : 'f1 field -> 'f1 encoding
val obj2 : 'f1 field -> 'f2 field -> ('f1 * 'f2) encoding
val obj3 : 'f1 field -> 'f2 field -> 'f3 field -> ('f1 * 'f2 * 'f3) encoding
val obj4 :
val obj5 :
val obj6 :
val obj7 :
val obj8 :
val obj9 :
val obj10 :
val merge_objs : 'o1 encoding -> 'o2 encoding -> ('o1 * 'o2) encoding
val array : 'a encoding -> 'a array encoding
val list : 'a encoding -> 'a list encoding
val assoc : 'a encoding -> (string * 'a) list encoding
type 't case
type case_tag = Tag of int | Json_only
val case : case_tag -> 'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case
val union : ?tag_size:[ `Uint8 | `Uint16 ] -> 't case list -> 't encoding
*)
(* Basic functions for executing tests on a given input *)
let roundtrip_json pp ding v =
let json =
try Data_encoding.Json.construct ding v
with Invalid_argument m ->
Crowbar.fail (Format.asprintf "Cannot construct: %a (%s)" pp v m)
in
let vv =
try Data_encoding.Json.destruct ding json
with Data_encoding.Json.Cannot_destruct (_, _) ->
Crowbar.fail "Cannot destruct"
in
Crowbar.check_eq ~pp v vv
let roundtrip_binary pp ding v =
let bin =
try Data_encoding.Binary.to_bytes_exn ding v
with Data_encoding.Binary.Write_error we ->
Format.kasprintf
Crowbar.fail
"Cannot construct: %a (%a)"
pp
v
Data_encoding.Binary.pp_write_error
we
in
let vv =
try Data_encoding.Binary.of_bytes_exn ding bin
with Data_encoding.Binary.Read_error re ->
Format.kasprintf
Crowbar.fail
"Cannot destruct: %a (%a)"
pp
v
Data_encoding.Binary.pp_read_error
re
in
Crowbar.check_eq ~pp v vv
(* Setting up the actual tests *)
let test_testable_json (testable : testable) =
let module T = (val testable) in
roundtrip_json T.pp T.ding T.v
let test_testable_binary (testable : testable) =
let module T = (val testable) in
roundtrip_binary T.pp T.ding T.v
let () =
Crowbar.add_test ~name:"binary roundtrips" [gen] test_testable_binary ;
Crowbar.add_test ~name:"json roundtrips" [gen] test_testable_json ;
()
src/lib_data_encoding/test/test_generated.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition char {A : Type} : A :=
op_startypeminuserrorstar (cons op_startypeminuserrorstar []) Char.chr.
Definition string {A : Type} : A := op_startypeminuserrorstar.
Definition short_string {A : Type} : A := op_startypeminuserrorstar.
Definition short_string1 {A : Type} : A := op_startypeminuserrorstar.
Definition mbytes {A : Type} : A :=
op_startypeminuserrorstar (cons op_startypeminuserrorstar [])
Stdlib.Bytes.of_string.
Definition short_mbytes {A : Type} : A :=
op_startypeminuserrorstar (cons short_string []) Stdlib.Bytes.of_string.
Definition short_mbytes1 {A : Type} : A :=
op_startypeminuserrorstar (cons short_string1 []) Stdlib.Bytes.of_string.
Module TESTABLE.
Record signature {t : Type} := {
t := t;
v : t;
ding : Tezos_data_encoding.Data_encoding.t t;
}.
Arguments signature : clear implicits.
End TESTABLE.
Definition testable := {t : _ & TESTABLE.signature t}.
Definition null : testable :=
existT _ _
{|
TESTABLE.v := tt;
TESTABLE.ding := Data_encoding.null;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition empty : testable :=
existT _ _
{|
TESTABLE.v := tt;
TESTABLE.ding := Data_encoding.empty;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition unit : testable :=
existT _ _
{|
TESTABLE.v := tt;
TESTABLE.ding := Data_encoding.unit;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_constant (s : string) : testable :=
existT _ _
{|
TESTABLE.v := tt;
TESTABLE.ding := Data_encoding.constant s;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_int8 (i : Z) : testable :=
existT _ _
{|
TESTABLE.v := i;
TESTABLE.ding := Data_encoding.int8;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_uint8 (i : Z) : testable :=
existT _ _
{|
TESTABLE.v := i;
TESTABLE.ding := Data_encoding.uint8;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_int16 (i : Z) : testable :=
existT _ _
{|
TESTABLE.v := i;
TESTABLE.ding := Data_encoding.int16;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_uint16 (i : Z) : testable :=
existT _ _
{|
TESTABLE.v := i;
TESTABLE.ding := Data_encoding.uint16;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_int32 (i : int32) : testable :=
existT _ _
{|
TESTABLE.v := i;
TESTABLE.ding := Data_encoding.int32;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_int64 (i : int64) : testable :=
existT _ _
{|
TESTABLE.v := i;
TESTABLE.ding := Data_encoding.int64;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_range_int (a : Z) (b : Z) (c : Z) : testable :=
let '(small, middle, big) :=
match Stdlib.List.sort OCaml.Stdlib.compare (cons a (cons b (cons c [])))
with
| cons small (cons middle (cons big [])) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.le small middle) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.le middle big) in
(small, middle, big)
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
existT _ _
{|
TESTABLE.v := middle;
TESTABLE.ding := Data_encoding.ranged_int small big;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_range_float (a : Z) (b : Z) (c : Z) : testable :=
if
orb (equiv_decb (OCaml.Stdlib.compare a Stdlib.nan) 0)
(orb (equiv_decb (OCaml.Stdlib.compare b Stdlib.nan) 0)
(equiv_decb (OCaml.Stdlib.compare c Stdlib.nan) 0)) then
null
else
let '(small, middle, big) :=
match Stdlib.List.sort OCaml.Stdlib.compare (cons a (cons b (cons c [])))
with
| cons small (cons middle (cons big [])) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.le small middle) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.le middle big) in
(small, middle, big)
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
existT _ _
{|
TESTABLE.v := middle;
TESTABLE.ding := Data_encoding.ranged_float small big;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_bool (b : bool) : testable :=
existT _ _
{|
TESTABLE.v := b;
TESTABLE.ding := Data_encoding.bool;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_string (s : string) : testable :=
existT _ _
{|
TESTABLE.v := s;
TESTABLE.ding := Data_encoding.string;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_bytes (s : Stdlib.Bytes.t) : testable :=
existT _ _
{|
TESTABLE.v := s;
TESTABLE.ding := Data_encoding.bytes;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_float (f : Z) : testable :=
existT _ _
{|
TESTABLE.v := f;
TESTABLE.ding := Data_encoding.float;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_fixed_string (s : string) : testable :=
existT _ _
{|
TESTABLE.v := s;
TESTABLE.ding := Data_encoding.Fixed.string (OCaml.String.length s);
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_fixed_bytes (s : string) : testable :=
existT _ _
{|
TESTABLE.v := s;
TESTABLE.ding := Data_encoding.Fixed.bytes (String.length s);
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_variable_string (s : string) : testable :=
existT _ _
{|
TESTABLE.v := s;
TESTABLE.ding := Data_encoding.Variable.string;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_variable_bytes (s : Stdlib.Bytes.t) : testable :=
existT _ _
{|
TESTABLE.v := s;
TESTABLE.ding := Data_encoding.Variable.bytes;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition dyn_if_not {A : Type}
(ding : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding A :=
match Data_encoding.classify ding with
| Fixed _ | Dynamic => ding
| Variable => Data_encoding.dynamic_size None ding
end.
Definition map_some (t : testable) : testable :=
let T := projT2 t in
existT _ _
{|
TESTABLE.v := Some T.(TESTABLE.v);
TESTABLE.ding :=
(* ❌ Try-with are not handled *)
try (Data_encoding.option T.(TESTABLE.ding));
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_none (t : testable) : testable :=
let T := projT2 t in
existT _ _
{|
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.v := unhandled;
TESTABLE.ding :=
(* ❌ Try-with are not handled *)
try (Data_encoding.option T.(TESTABLE.ding));
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_ok (t_o : testable) (t_e : testable) : testable :=
let T_O := projT2 t_o in
let T_E := projT2 t_e in
existT _ _
{|
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.v := unhandled;
TESTABLE.ding :=
Data_encoding.result T_O.(TESTABLE.ding) T_E.(TESTABLE.ding);
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_error (t_o : testable) (t_e : testable) : testable :=
let T_O := projT2 t_o in
let T_E := projT2 t_e in
existT _ _
{|
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.v := unhandled;
TESTABLE.ding :=
Data_encoding.result T_O.(TESTABLE.ding) T_E.(TESTABLE.ding);
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_variable_list (t : testable) (ts : list testable) : testable :=
let T := projT2 t in
existT _ _
{|
TESTABLE.ding :=
Data_encoding.Variable.list None (dyn_if_not T.(TESTABLE.ding));
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.v := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_variable_array (t : testable) (ts : array testable) : testable :=
let T := projT2 t in
existT _ _
{|
TESTABLE.ding :=
Data_encoding.Variable.array None (dyn_if_not T.(TESTABLE.ding));
TESTABLE.v :=
Array.of_list
(Array.fold_left
(fun acc =>
fun t =>
let T := projT2 t in
cons (Obj.magic T.(TESTABLE.v)) acc) [] ts);
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_dynamic_size (t : testable) : testable :=
let T := projT2 t in
existT _ _
{|
(* ❌ Include is not handled inside first-class module values *)
TESTABLE._ := include;
TESTABLE.ding := Data_encoding.dynamic_size None T.(TESTABLE.ding)
|}.
Definition map_tup1 (t1 : testable) : testable :=
let T1 := projT2 t1 in
existT _ _
{|
(* ❌ Include is not handled inside first-class module values *)
TESTABLE._ := include;
TESTABLE.ding := Data_encoding.tup1 T1.(TESTABLE.ding);
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_tup2 (t1 : testable) (t2 : testable) : testable :=
let T1 := projT2 t1 in
let T2 := projT2 t2 in
existT _ _
{|
TESTABLE.ding :=
Data_encoding.tup2 (dyn_if_not T1.(TESTABLE.ding)) T2.(TESTABLE.ding);
TESTABLE.v := (T1.(TESTABLE.v), T2.(TESTABLE.v));
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_tup3 (t1 : testable) (t2 : testable) (t3 : testable)
: testable :=
let T1 := projT2 t1 in
let T2 := projT2 t2 in
let T3 := projT2 t3 in
existT _ _
{|
TESTABLE.ding :=
Data_encoding.tup3 (dyn_if_not T1.(TESTABLE.ding))
(dyn_if_not T2.(TESTABLE.ding)) T3.(TESTABLE.ding);
TESTABLE.v := (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v));
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_tup4
(t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable) : testable :=
let T1 := projT2 t1 in
let T2 := projT2 t2 in
let T3 := projT2 t3 in
let T4 := projT2 t4 in
existT _ _
{|
TESTABLE.ding :=
Data_encoding.tup4 (dyn_if_not T1.(TESTABLE.ding))
(dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
T4.(TESTABLE.ding);
TESTABLE.v :=
(T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v));
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_tup5
(t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
(t5 : testable) : testable :=
let T1 := projT2 t1 in
let T2 := projT2 t2 in
let T3 := projT2 t3 in
let T4 := projT2 t4 in
let T5 := projT2 t5 in
existT _ _
{|
TESTABLE.ding :=
Data_encoding.tup5 (dyn_if_not T1.(TESTABLE.ding))
(dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
(dyn_if_not T4.(TESTABLE.ding)) T5.(TESTABLE.ding);
TESTABLE.v :=
(T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
T5.(TESTABLE.v));
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_tup6
(t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
(t5 : testable) (t6 : testable) : testable :=
let T1 := projT2 t1 in
let T2 := projT2 t2 in
let T3 := projT2 t3 in
let T4 := projT2 t4 in
let T5 := projT2 t5 in
let T6 := projT2 t6 in
existT _ _
{|
TESTABLE.ding :=
Data_encoding.tup6 (dyn_if_not T1.(TESTABLE.ding))
(dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
(dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
T6.(TESTABLE.ding);
TESTABLE.v :=
(T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
T5.(TESTABLE.v), T6.(TESTABLE.v));
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_tup7
(t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
(t5 : testable) (t6 : testable) (t7 : testable) : testable :=
let T1 := projT2 t1 in
let T2 := projT2 t2 in
let T3 := projT2 t3 in
let T4 := projT2 t4 in
let T5 := projT2 t5 in
let T6 := projT2 t6 in
let T7 := projT2 t7 in
existT _ _
{|
TESTABLE.ding :=
Data_encoding.tup7 (dyn_if_not T1.(TESTABLE.ding))
(dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
(dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
(dyn_if_not T6.(TESTABLE.ding)) T7.(TESTABLE.ding);
TESTABLE.v :=
(T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
T5.(TESTABLE.v), T6.(TESTABLE.v), T7.(TESTABLE.v));
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_tup8
(t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
(t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable) : testable :=
let T1 := projT2 t1 in
let T2 := projT2 t2 in
let T3 := projT2 t3 in
let T4 := projT2 t4 in
let T5 := projT2 t5 in
let T6 := projT2 t6 in
let T7 := projT2 t7 in
let T8 := projT2 t8 in
existT _ _
{|
TESTABLE.ding :=
Data_encoding.tup8 (dyn_if_not T1.(TESTABLE.ding))
(dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
(dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
(dyn_if_not T6.(TESTABLE.ding)) (dyn_if_not T7.(TESTABLE.ding))
T8.(TESTABLE.ding);
TESTABLE.v :=
(T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
T5.(TESTABLE.v), T6.(TESTABLE.v), T7.(TESTABLE.v), T8.(TESTABLE.v));
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_tup9
(t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
(t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable)
(t9 : testable) : testable :=
let T1 := projT2 t1 in
let T2 := projT2 t2 in
let T3 := projT2 t3 in
let T4 := projT2 t4 in
let T5 := projT2 t5 in
let T6 := projT2 t6 in
let T7 := projT2 t7 in
let T8 := projT2 t8 in
let T9 := projT2 t9 in
existT _ _
{|
TESTABLE.ding :=
Data_encoding.tup9 (dyn_if_not T1.(TESTABLE.ding))
(dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
(dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
(dyn_if_not T6.(TESTABLE.ding)) (dyn_if_not T7.(TESTABLE.ding))
(dyn_if_not T8.(TESTABLE.ding)) T9.(TESTABLE.ding);
TESTABLE.v :=
(T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
T5.(TESTABLE.v), T6.(TESTABLE.v), T7.(TESTABLE.v), T8.(TESTABLE.v),
T9.(TESTABLE.v));
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_tup10
(t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
(t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable)
(t9 : testable) (t10 : testable) : testable :=
let T1 := projT2 t1 in
let T2 := projT2 t2 in
let T3 := projT2 t3 in
let T4 := projT2 t4 in
let T5 := projT2 t5 in
let T6 := projT2 t6 in
let T7 := projT2 t7 in
let T8 := projT2 t8 in
let T9 := projT2 t9 in
let T10 := projT2 t10 in
existT _ _
{|
TESTABLE.ding :=
Data_encoding.tup10 (dyn_if_not T1.(TESTABLE.ding))
(dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
(dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
(dyn_if_not T6.(TESTABLE.ding)) (dyn_if_not T7.(TESTABLE.ding))
(dyn_if_not T8.(TESTABLE.ding)) (dyn_if_not T9.(TESTABLE.ding))
T10.(TESTABLE.ding);
TESTABLE.v :=
(T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
T5.(TESTABLE.v), T6.(TESTABLE.v), T7.(TESTABLE.v), T8.(TESTABLE.v),
T9.(TESTABLE.v), T10.(TESTABLE.v));
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition map_merge_tups (t1 : testable) (t2 : testable) : testable :=
let T1 := projT2 t1 in
let T2 := projT2 t2 in
existT _ _
{|
TESTABLE.ding :=
Data_encoding.merge_tups (dyn_if_not T1.(TESTABLE.ding))
(dyn_if_not T2.(TESTABLE.ding));
TESTABLE.v := (T1.(TESTABLE.v), T2.(TESTABLE.v));
(* ❌ This kind of definition of value for first-class modules is not handled *)
TESTABLE.pp := unhandled
|}.
Definition tup_gen {A B : Type} (function_parameter : A) : B :=
let '_ := function_parameter in
op_startypeminuserrorstar.
Definition gen {A : Type} : A := op_startypeminuserrorstar.
Definition roundtrip_json {A B : Type}
(pp : Stdlib.Format.formatter -> A -> unit)
(ding : Tezos_data_encoding__Data_encoding.Encoding.t A) (v : A) : B :=
let json :=
(* ❌ Try-with are not handled *)
try (Data_encoding.Json.construct ding v) in
let vv :=
(* ❌ Try-with are not handled *)
try (Data_encoding.Json.destruct ding json) in
op_startypeminuserrorstar pp v vv.
Definition roundtrip_binary {A B : Type}
(pp : Stdlib.Format.formatter -> A -> unit)
(ding : Tezos_data_encoding__Data_encoding.Encoding.t A) (v : A) : B :=
let bin :=
(* ❌ Try-with are not handled *)
try (Data_encoding.Binary.to_bytes_exn ding v) in
let vv :=
(* ❌ Try-with are not handled *)
try (Data_encoding.Binary.of_bytes_exn ding bin) in
op_startypeminuserrorstar pp v vv.
Definition test_testable_json {A : Type} (testable : testable) : A :=
let T := projT2 testable in
roundtrip_json op_startypeminuserrorstar T.(TESTABLE.ding) T.(TESTABLE.v).
Definition test_testable_binary {A : Type} (testable : testable) : A :=
let T := projT2 testable in
roundtrip_binary op_startypeminuserrorstar T.(TESTABLE.ding) T.(TESTABLE.v).
src/lib_data_encoding/test/types.ml 22 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Data_encoding
type record = {a : int; b : bool; c : Z.t option; d : float}
let default_record = {a = 32; b = true; c = Some Z.one; d = 12.34}
let record_obj_enc =
conv
(fun {a; b; c; d} -> ((a, b), (c, d)))
(fun ((a, b), (c, d)) -> {a; b; c; d})
(merge_objs
(obj2 (req "a" int31) (dft "b" bool false))
(obj2 (opt "c" z) (req "d" float)))
let record_tup_enc =
conv
(fun {a; b; c; d} -> ((a, b, c), d))
(fun ((a, b, c), d) -> {a; b; c; d})
(merge_tups (tup3 int31 bool (option z)) (tup1 float))
let record_to_string {a; b; c; d} =
let c = match c with None -> "none" | Some c -> Z.to_string c in
Format.asprintf "(%d, %B, %s, %f)" a b c d
type variable_record = {p : int; q : Bytes.t}
let default_variable_record = {p = 23; q = Bytes.of_string "wwwxxyyzzz"}
let variable_record_obj_enc =
conv
(fun {p; q} -> (p, q))
(fun (p, q) -> {p; q})
(obj2 (req "p" int31) (req "q" Variable.bytes))
let variable_record_tup_enc =
conv
(fun {p; q} -> (p, q))
(fun (p, q) -> {p; q})
(tup2 int31 Variable.bytes)
let variable_record_to_string {p; q} =
Format.asprintf "(%d, %a)" p Hex.pp (Hex.of_bytes q)
type variable_left_record = {x : int; y : Bytes.t; z : int}
let default_variable_left_record =
{x = 98; y = Bytes.of_string "765"; z = 4321}
let variable_left_record_obj_enc =
conv
(fun {x; y; z} -> (x, y, z))
(fun (x, y, z) -> {x; y; z})
(obj3 (req "x" int31) (req "y" Variable.bytes) (req "z" int31))
let variable_left_record_tup_enc =
conv
(fun {x; y; z} -> (x, y, z))
(fun (x, y, z) -> {x; y; z})
(tup3 int31 Variable.bytes int31)
let variable_left_record_to_string {x; y; z} =
Format.asprintf "(%d, %a, %d)" x Hex.pp (Hex.of_bytes y) z
type union = A of int | B of string | C of int | D of string | E
let union_enc =
union
[ case
(Tag 1)
~title:"A"
int8
(function A i -> Some i | _ -> None)
(fun i -> A i);
case
(Tag 2)
~title:"B"
string
(function B s -> Some s | _ -> None)
(fun s -> B s);
case
(Tag 3)
~title:"C"
(obj1 (req "C" int8))
(function C i -> Some i | _ -> None)
(fun i -> C i);
case
(Tag 4)
~title:"D"
(obj2 (req "kind" (constant "D")) (req "data" string))
(function D s -> Some ((), s) | _ -> None)
(fun ((), s) -> D s);
case
(Tag 5)
~title:"E"
empty
(function E -> Some () | _ -> None)
(fun () -> E) ]
let mini_union_enc =
union
[ case
(Tag 1)
~title:"A"
int8
(function A i -> Some i | _ -> None)
(fun i -> A i) ]
let union_to_string = function
| A i ->
Printf.sprintf "A %d" i
| B s ->
Printf.sprintf "B %s" s
| C i ->
Printf.sprintf "C %d" i
| D s ->
Printf.sprintf "D %s" s
| E ->
"E"
let enum_enc =
string_enum
[("one", 1); ("two", 2); ("three", 3); ("four", 4); ("five", 5); ("six", 6)]
let mini_enum_enc = string_enum [("one", 1); ("two", 2)]
let mu_list_enc enc =
mu "list"
@@ fun mu_list_enc ->
union
[ case
(Tag 0)
~title:"Nil"
empty
(function [] -> Some () | _ :: _ -> None)
(fun () -> []);
case
(Tag 1)
~title:"Cons"
(obj2 (req "value" enc) (req "next" mu_list_enc))
(function x :: xs -> Some (x, xs) | [] -> None)
(fun (x, xs) -> x :: xs) ]
let bounded_list ~total ~elements enc =
check_size total (Variable.list (check_size elements enc))
module Alcotest = struct
include Alcotest
let float =
testable Fmt.float (fun f1 f2 ->
match (classify_float f1, classify_float f2) with
| (FP_nan, FP_nan) ->
true
| _ ->
f1 = f2)
let bytes =
testable
(Fmt.of_to_string (fun s ->
let (`Hex s) = Hex.of_bytes s in
s))
Bytes.equal
let z = testable (Fmt.of_to_string Z.to_string) Z.equal
let n = z
let record = testable (Fmt.of_to_string record_to_string) ( = )
let variable_record =
testable (Fmt.of_to_string variable_record_to_string) ( = )
let variable_left_record =
testable (Fmt.of_to_string variable_left_record_to_string) ( = )
let union = testable (Fmt.of_to_string union_to_string) ( = )
end
src/lib_data_encoding/test/types.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Data_encoding.
Record record := {
a : Z;
b : bool;
c : option Z.t;
d : Z }.
Definition default_record : record :=
{| a := 32; b := true; c := Some Z.one;
d :=
(* ❌ Float constant 12.34 is approximated by the integer 12 *)
12 |}.
Definition record_obj_enc : Tezos_data_encoding.Data_encoding.encoding record :=
conv
(fun function_parameter =>
let '{| a := a; b := b; c := c; d := d |} := function_parameter in
((a, b), (c, d)))
(fun function_parameter =>
let '((a, b), (c, d)) := function_parameter in
{| a := a; b := b; c := c; d := d |}) None
(merge_objs
(obj2 (req None None "a" % string int31)
(dft None None "b" % string bool false))
(obj2 (opt None None "c" % string z) (req None None "d" % string float))).
Definition record_tup_enc : Tezos_data_encoding.Data_encoding.encoding record :=
conv
(fun function_parameter =>
let '{| a := a; b := b; c := c; d := d |} := function_parameter in
((a, b, c), d))
(fun function_parameter =>
let '((a, b, c), d) := function_parameter in
{| a := a; b := b; c := c; d := d |}) None
(merge_tups (tup3 int31 bool (option z)) (tup1 float)).
Definition record_to_string (function_parameter : record) : string :=
let '{| a := a; b := b; c := c; d := d |} := function_parameter in
let c :=
match c with
| None => "none" % string
| Some c => Z.to_string c
end in
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ", " % string
(CamlinternalFormatBasics.Bool CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ", " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ", " % string
(CamlinternalFormatBasics.Float
CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))))))
"(%d, %B, %s, %f)" % string) a b c d.
Record variable_record := {
p : Z;
q : Stdlib.Bytes.t }.
Definition default_variable_record : variable_record :=
{| p := 23; q := Stdlib.Bytes.of_string "wwwxxyyzzz" % string |}.
Definition variable_record_obj_enc
: Tezos_data_encoding.Data_encoding.encoding variable_record :=
conv
(fun function_parameter =>
let '{| p := p; q := q |} := function_parameter in
(p, q))
(fun function_parameter =>
let '(p, q) := function_parameter in
{| p := p; q := q |}) None
(obj2 (req None None "p" % string int31)
(req None None "q" % string Variable.bytes)).
Definition variable_record_tup_enc
: Tezos_data_encoding.Data_encoding.encoding variable_record :=
conv
(fun function_parameter =>
let '{| p := p; q := q |} := function_parameter in
(p, q))
(fun function_parameter =>
let '(p, q) := function_parameter in
{| p := p; q := q |}) None (tup2 int31 Variable.bytes).
Definition variable_record_to_string (function_parameter : variable_record)
: string :=
let '{| p := p; q := q |} := function_parameter in
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ", " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))) "(%d, %a)" % string)
p Hex.pp (Hex.of_bytes None q).
Record variable_left_record := {
x : Z;
y : Stdlib.Bytes.t;
z : Z }.
Definition default_variable_left_record : variable_left_record :=
{| x := 98; y := Stdlib.Bytes.of_string "765" % string; z := 4321 |}.
Definition variable_left_record_obj_enc
: Tezos_data_encoding.Data_encoding.encoding variable_left_record :=
conv
(fun function_parameter =>
let '{| x := x; y := y; z := z |} := function_parameter in
(x, y, z))
(fun function_parameter =>
let '(x, y, z) := function_parameter in
{| x := x; y := y; z := z |}) None
(obj3 (req None None "x" % string int31)
(req None None "y" % string Variable.bytes)
(req None None "z" % string int31)).
Definition variable_left_record_tup_enc
: Tezos_data_encoding.Data_encoding.encoding variable_left_record :=
conv
(fun function_parameter =>
let '{| x := x; y := y; z := z |} := function_parameter in
(x, y, z))
(fun function_parameter =>
let '(x, y, z) := function_parameter in
{| x := x; y := y; z := z |}) None (tup3 int31 Variable.bytes int31).
Definition variable_left_record_to_string
(function_parameter : variable_left_record) : string :=
let '{| x := x; y := y; z := z |} := function_parameter in
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ", " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ", " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))))
"(%d, %a, %d)" % string) x Hex.pp (Hex.of_bytes None y) z.
Inductive union : Type :=
| A : Z -> union
| B : string -> union
| C : Z -> union
| D : string -> union
| E : union.
Definition union_enc : Tezos_data_encoding.Data_encoding.encoding union :=
union None
(cons
(case "A" % string None (Tezos_data_encoding.Data_encoding.Tag 1) int8
(fun function_parameter =>
match function_parameter with
| A i => Some i
| _ => None
end) (fun i => A i))
(cons
(case "B" % string None (Tezos_data_encoding.Data_encoding.Tag 2) string
(fun function_parameter =>
match function_parameter with
| B s => Some s
| _ => None
end) (fun s => B s))
(cons
(case "C" % string None (Tezos_data_encoding.Data_encoding.Tag 3)
(obj1 (req None None "C" % string int8))
(fun function_parameter =>
match function_parameter with
| C i => Some i
| _ => None
end) (fun i => C i))
(cons
(case "D" % string None (Tezos_data_encoding.Data_encoding.Tag 4)
(obj2 (req None None "kind" % string (constant "D" % string))
(req None None "data" % string string))
(fun function_parameter =>
match function_parameter with
| D s => Some (tt, s)
| _ => None
end)
(fun function_parameter =>
let '(tt, s) := function_parameter in
D s))
(cons
(case "E" % string None (Tezos_data_encoding.Data_encoding.Tag 5)
empty
(fun function_parameter =>
match function_parameter with
| E => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
E)) []))))).
Definition mini_union_enc : Tezos_data_encoding.Data_encoding.encoding union :=
union None
(cons
(case "A" % string None (Tezos_data_encoding.Data_encoding.Tag 1) int8
(fun function_parameter =>
match function_parameter with
| A i => Some i
| _ => None
end) (fun i => A i)) []).
Definition union_to_string (function_parameter : union) : string :=
match function_parameter with
| A i =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "A " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "A %d" % string) i
| B s =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "B " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "B %s" % string) s
| C i =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "C " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "C %d" % string) i
| D s =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "D " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "D %s" % string) s
| E => "E" % string
end.
Definition enum_enc : Tezos_data_encoding.Data_encoding.encoding Z :=
string_enum
(cons ("one" % string, 1)
(cons ("two" % string, 2)
(cons ("three" % string, 3)
(cons ("four" % string, 4)
(cons ("five" % string, 5) (cons ("six" % string, 6) [])))))).
Definition mini_enum_enc : Tezos_data_encoding.Data_encoding.encoding Z :=
string_enum (cons ("one" % string, 1) (cons ("two" % string, 2) [])).
Definition mu_list_enc {A : Type}
(enc : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding (list A) :=
apply
(let arg := mu "list" % string in
fun eta => arg None None eta)
(fun mu_list_enc =>
union None
(cons
(case "Nil" % string None (Tezos_data_encoding.Data_encoding.Tag 0)
empty
(fun function_parameter =>
match function_parameter with
| [] => Some tt
| cons _ _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
[]))
(cons
(case "Cons" % string None (Tezos_data_encoding.Data_encoding.Tag 1)
(obj2 (req None None "value" % string enc)
(req None None "next" % string mu_list_enc))
(fun function_parameter =>
match function_parameter with
| cons x xs => Some (x, xs)
| [] => None
end)
(fun function_parameter =>
let '(x, xs) := function_parameter in
cons x xs)) []))).
Definition bounded_list {A : Type}
(total : Z) (elements : Z)
(enc : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding (list A) :=
check_size total (Variable.list None (check_size elements enc)).
Module Alcotest.
(* ❌ Structure item `include` not handled. *)
include
Definition float {A : Type} : A :=
op_startypeminuserrorstar op_startypeminuserrorstar
(fun f1 =>
fun f2 =>
match ((Stdlib.classify_float f1), (Stdlib.classify_float f2)) with
| (Stdlib.FP_nan, Stdlib.FP_nan) => true
| _ => equiv_decb f1 f2
end).
Definition bytes {A : Type} : A :=
op_startypeminuserrorstar
(op_startypeminuserrorstar
(fun s =>
let 'Hex s := Hex.of_bytes None s in
s)) Stdlib.Bytes.equal.
Definition z {A : Type} : A :=
op_startypeminuserrorstar (op_startypeminuserrorstar Z.to_string) Z.equal.
Definition n {A : Type} : A := z.
Definition record {A : Type} : A :=
op_startypeminuserrorstar (op_startypeminuserrorstar record_to_string)
equiv_decb.
Definition variable_record {A : Type} : A :=
op_startypeminuserrorstar
(op_startypeminuserrorstar variable_record_to_string) equiv_decb.
Definition variable_left_record {A : Type} : A :=
op_startypeminuserrorstar
(op_startypeminuserrorstar variable_left_record_to_string) equiv_decb.
Definition union {A : Type} : A :=
op_startypeminuserrorstar (op_startypeminuserrorstar union_to_string)
equiv_decb.
End Alcotest.
src/lib_data_encoding/test/versioned.ml 56 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(**
Tests for the {!Data_encoding.With_version} module.
*)
(** This module is a simple example of use of {!With_version}. *)
module Documented_example = struct
(** Here we show how to {i "versionize"} a given random encoding (which
just happens to be very similar to {!Internal_event.Debug_event}). *)
(** We are going to provide successive versions of a module
implementing {!INTENDED_SIGNATURE} (which is similar to a
simplified {!Internal_event.EVENT_DEFINITION}): *)
module type INTENDED_SIGNATURE = sig
type t
val encoding : t Data_encoding.t
val pp : Format.formatter -> t -> unit
end
(** The name, once used with {!With_version.encoding}, appears in
the serialized values, it has to remain constant across versions: *)
let name = "versioned-documented-example"
(** The first version has a [(string * string) list] field. *)
module V0 = struct
type t = {message : string; attachment : (string * string) list}
(** This is the "naked" (i.e. non-versioned) encoding of version-0: *)
let encoding =
let open Data_encoding in
conv
(fun {message; attachment} -> (message, attachment))
(fun (message, attachment) -> {message; attachment})
(obj2 (req "message" string) (req "attach" (list (tup2 string string))))
end
(** The versioned implementation of {!INTENDED_SIGNATURE}: *)
module First_version : INTENDED_SIGNATURE with type t = V0.t = struct
include V0
(** The encoding with the version tagging: *)
let encoding =
Data_encoding.With_version.(encoding ~name (first_version V0.encoding))
let pp ppf {message; attachment} =
let open Format in
fprintf ppf "%s:@ %s@ [" name message ;
pp_open_box ppf 2 ;
pp_print_list
~pp_sep:(fun fmt () -> fprintf fmt ";@ ")
(fun fmt (k, v) -> fprintf fmt "%s: %S" k v)
ppf
attachment ;
pp_close_box ppf () ;
fprintf ppf "]" ;
()
end
(** In a later version we want the attachment to be any piece of
Json and not just a key-value list: *)
module V1 = struct
(** Version 1 is very similar to {!Internal_event.Debug_event}: *)
type t = {message : string; attachment : Data_encoding.Json.t}
let make ?(attach = `Null) message () = {message; attachment = attach}
(** Note the "upgrade" function which can make a {!V1.t} from a {!V0.t}: *)
let of_v0 {V0.message; attachment} =
{
message;
attachment = `O (List.map (fun (k, v) -> (k, `String v)) attachment);
}
(** Again we build first a version-free encoding: *)
let encoding =
let open Data_encoding in
conv
(fun {message; attachment} -> (message, attachment))
(fun (message, attachment) -> {message; attachment})
(obj2 (req "message" string) (req "attachment" json))
end
(** The second version exports {!V1.t} while being able to parse
(and upgrade from) {!First_version.t} values. *)
module Second_version : INTENDED_SIGNATURE with type t = V1.t = struct
include V1
(** Here is the interesting use of {!Data_encoding.With_version}: the
encoding uses both {!V0.encoding} and {!V1.encoding} and
provides {!V1.of_v0} as an upgrade function. *)
let encoding =
Data_encoding.With_version.(
encoding
~name
(first_version V0.encoding |> next_version V1.encoding V1.of_v0))
let pp ppf {message; attachment} =
let open Format in
fprintf ppf "%s:@ %s@ %a" name message Data_encoding.Json.pp attachment
end
(** This test "serializes" successively using
{!First_version.encoding} and {!Second_version.encoding}, and then
shows that the former's output can be parsed with the later. *)
let actual_test () =
let v0_thing : First_version.t =
{
V0.message = "The v0 message";
attachment = [("k1", "v1"); ("k2", "v2")];
}
in
let json_v0 =
Data_encoding.Json.construct First_version.encoding v0_thing
in
let expected_json_v0 =
`O
[ ( name ^ ".v0",
(* -> here we see how the [~name] is used. *)
`O
[ ("message", `String v0_thing.V0.message);
( "attach",
`A
(List.map
(fun (k, v) -> `A [`String k; `String v])
v0_thing.V0.attachment) ) ] ) ]
in
if json_v0 <> expected_json_v0 then
Alcotest.failf
"Json-v0: %a@ Vs@ %a"
Data_encoding.Json.pp
json_v0
Data_encoding.Json.pp
expected_json_v0 ;
(* Up to here we only used the {!First_version} module. Now the
same process with {!Second_version}: *)
let v1_thing : Second_version.t =
{
V1.message = "The v1 message";
attachment = `O [("k1", `String "v1"); ("kn", `Float 42.)];
}
in
let json_v1 =
Data_encoding.Json.construct Second_version.encoding v1_thing
in
let expected_json_v1 =
`O
[ ( name ^ ".v1",
`O
[ ("message", `String v1_thing.V1.message);
("attachment", v1_thing.V1.attachment) ] ) ]
in
if json_v1 <> expected_json_v1 then
Alcotest.failf
"Json-v1: %a@ Vs@ %a"
Data_encoding.Json.pp
json_v1
Data_encoding.Json.pp
expected_json_v1 ;
(* Now the {b interesting part}, we decode ("destruct") the JSON from
{!First_version} with {!Second_version}: *)
let v0_decoded_later : Second_version.t =
Data_encoding.Json.destruct Second_version.encoding json_v0
in
(* And we check that going through JSON is equivalent to just
calling the upgrade function directly on the {!First_version.t}
value: *)
let expected_v1 = V1.of_v0 v0_thing in
if v0_decoded_later <> expected_v1 then
Alcotest.failf
"Parsing v0 with v1: %a@ Vs@ %a"
Second_version.pp
v0_decoded_later
Second_version.pp
expected_v1 ;
()
end
(** This test builds a few successive versions of encodings and tries
out parsing/printing with successive encapsulated
versioned-encodings.
Check out ["_build/_tests/versioned.001.output"] to see how they look.
*)
let test_n_encapsulated_versions () =
let open Data_encoding in
let name = "test0" in
let version_0 = obj2 (req "left" string) (req "right" string) in
let versioned_0 = With_version.(encoding ~name @@ first_version version_0) in
let value_0 = ("v0", "k0") in
let json_0 = Json.construct versioned_0 value_0 in
Helpers.no_exception (fun () ->
let result = Json.destruct versioned_0 json_0 in
if result <> value_0 then Alcotest.failf "value-0") ;
let module Ex = struct
type v0 = string * string
type t =
| Hide : 'a Data_encoding.t * 'a With_version.t * 'a * (v0 -> 'a) -> t
end in
let make_next (Ex.Hide (enc, versioned, example, from_v0)) index =
let new_tag = Printf.sprintf "left-%d" index in
let version_n = obj2 (req new_tag string) (req "right" enc) in
let upgrade vn = ("some-random-extra-string", vn) in
let versioned_n =
With_version.(next_version version_n upgrade versioned)
in
let encoding = With_version.(encoding ~name versioned_n) in
let example_n = ("val4" ^ new_tag, example) in
let json_example_n = Json.construct encoding example_n in
Helpers.no_exception (fun () ->
let result = Json.destruct encoding json_example_n in
if result <> example_n then Alcotest.failf "value-%d" index) ;
let json_example_p =
Json.construct With_version.(encoding ~name versioned) example
in
Helpers.no_exception (fun () ->
let result = Json.destruct encoding json_example_p in
if result <> upgrade example then
Alcotest.failf "value-%d-previous-encoding" index) ;
let next_upgrade x = upgrade (from_v0 x) in
Helpers.no_exception (fun () ->
let result = Json.destruct encoding json_0 in
if result <> next_upgrade value_0 then
Alcotest.failf "value-%d-from-v0-encoding" index) ;
Format.eprintf "json_example_%d:@ %a\n%!" index Json.pp json_example_n ;
Format.eprintf
"json_example_%d-from-v0:@ %a\n%!"
index
Json.pp
(Json.construct encoding (next_upgrade value_0)) ;
Ex.Hide (version_n, versioned_n, example_n, next_upgrade)
in
let (Ex.Hide _) =
ListLabels.fold_left
(List.init 10 (( + ) 1))
~init:
(Ex.Hide
( version_0,
With_version.(first_version version_0),
value_0,
fun x -> x ))
~f:make_next
in
()
let tests =
[ ("example-test", `Quick, Documented_example.actual_test);
("test-encapsulated-versions", `Quick, test_n_encapsulated_versions) ]
src/lib_data_encoding/test/versioned.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Documented_example.
Module INTENDED_SIGNATURE.
Record signature {t : Type} := {
t := t;
encoding : Tezos_data_encoding.Data_encoding.t t;
pp : Stdlib.Format.formatter -> t -> unit;
}.
Arguments signature : clear implicits.
End INTENDED_SIGNATURE.
Definition name : string := "versioned-documented-example" % string.
Module V0.
Record t := {
message : string;
attachment : list (string * string) }.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
conv
(fun function_parameter =>
let '{| message := message; attachment := attachment |} :=
function_parameter in
(message, attachment))
(fun function_parameter =>
let '(message, attachment) := function_parameter in
{| message := message; attachment := attachment |}) None
(obj2 (req None None "message" % string string)
(req None None "attach" % string (list None (tup2 string string)))).
End V0.
(* ❌ This kind of module is not handled. *)
unhandled_module
Module V1.
Record t := {
message : string;
attachment : Tezos_data_encoding.Data_encoding.Json.t }.
Definition make (op_staroptstar : option variant) : string -> unit -> t :=
let attach :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun message =>
fun function_parameter =>
let 'tt := function_parameter in
{| message := message; attachment := attach |}.
Definition of_v0 (function_parameter : V0.t) : t :=
let '{| V0.message := message; V0.attachment := attachment |} :=
function_parameter in
{| message := message;
attachment :=
(* ❌ Variants not supported *)
variant |}.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
conv
(fun function_parameter =>
let '{| message := message; attachment := attachment |} :=
function_parameter in
(message, attachment))
(fun function_parameter =>
let '(message, attachment) := function_parameter in
{| message := message; attachment := attachment |}) None
(obj2 (req None None "message" % string string)
(req None None "attachment" % string json)).
End V1.
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition actual_test (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let v0_thing :=
{| V0.message := "The v0 message" % string;
V0.attachment :=
cons ("k1" % string, "v1" % string)
(cons ("k2" % string, "v2" % string) []) |} in
let json_v0 :=
Data_encoding.Json.construct First_version.(INTENDED_SIGNATURE.encoding)
v0_thing in
let expected_json_v0 :=
(* ❌ Variants not supported *)
variant in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb json_v0 expected_json_v0 then
op_startypeminuserrorstar "Json-v0: %a@ Vs@ %a" % string
Data_encoding.Json.pp json_v0 Data_encoding.Json.pp expected_json_v0
else
tt in
let v1_thing :=
{| V1.message := "The v1 message" % string;
V1.attachment :=
(* ❌ Variants not supported *)
variant |} in
let json_v1 :=
Data_encoding.Json.construct Second_version.(INTENDED_SIGNATURE.encoding)
v1_thing in
let expected_json_v1 :=
(* ❌ Variants not supported *)
variant in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb json_v1 expected_json_v1 then
op_startypeminuserrorstar "Json-v1: %a@ Vs@ %a" % string
Data_encoding.Json.pp json_v1 Data_encoding.Json.pp expected_json_v1
else
tt in
let v0_decoded_later :=
Data_encoding.Json.destruct Second_version.(INTENDED_SIGNATURE.encoding)
json_v0 in
let expected_v1 := V1.of_v0 v0_thing in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb v0_decoded_later expected_v1 then
op_startypeminuserrorstar "Parsing v0 with v1: %a@ Vs@ %a" % string
Second_version.(INTENDED_SIGNATURE.pp) v0_decoded_later
Second_version.(INTENDED_SIGNATURE.pp) expected_v1
else
tt in
tt.
End Documented_example.
Definition test_n_encapsulated_versions (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let name := "test0" % string in
let version_0 :=
obj2 (req None None "left" % string string)
(req None None "right" % string string) in
let versioned_0 := apply (encoding name) (first_version version_0) in
let value_0 := ("v0" % string, "k0" % string) in
let json_0 := Json.construct versioned_0 value_0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
let result := Json.destruct versioned_0 json_0 in
if nequiv_decb result value_0 then
op_startypeminuserrorstar "value-0" % string
else
tt) in
let Ex :=
(* ❌ The signature name of this module could not be found *)
existT _ _
{|
|} in
let make_next (function_parameter : Ex.t) : Z -> Ex.t :=
let 'Ex.Hide enc versioned example from_v0 := function_parameter in
fun index =>
let new_tag :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "left-" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "left-%d" % string)
index in
let version_n :=
obj2 (req None None new_tag string) (req None None "right" % string enc)
in
let upgrade {A : Type} (vn : A) : string * A :=
("some-random-extra-string" % string, vn) in
let versioned_n := next_version version_n upgrade versioned in
let encoding := encoding name versioned_n in
let example_n := ((String.append "val4" % string new_tag), example) in
let json_example_n := Json.construct encoding example_n in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
let result := Json.destruct encoding json_example_n in
if nequiv_decb result example_n then
op_startypeminuserrorstar "value-%d" % string index
else
tt) in
let json_example_p := Json.construct (encoding name versioned) example in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
let result := Json.destruct encoding json_example_p in
if nequiv_decb result (upgrade example) then
op_startypeminuserrorstar "value-%d-previous-encoding" % string
index
else
tt) in
let next_upgrade (x : Ex.v0) : string * op_dollarHide_'a :=
upgrade (from_v0 x) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
(fun function_parameter =>
let 'tt := function_parameter in
let result := Json.destruct encoding json_0 in
if nequiv_decb result (next_upgrade value_0) then
op_startypeminuserrorstar "value-%d-from-v0-encoding" % string
index
else
tt) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "json_example_" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format)))))))
"json_example_%d:@ %a
%!" % string) index Json.pp json_example_n in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "json_example_" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal "-from-v0:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format)))))))
"json_example_%d-from-v0:@ %a
%!" % string) index Json.pp
(Json.construct encoding (next_upgrade value_0)) in
Ex.Hide version_n versioned_n example_n next_upgrade in
let 'Ex.Hide _ _ _ _ :=
ListLabels.fold_left make_next
(Ex.Hide version_0 (first_version version_0) value_0 (fun x => x))
(Stdlib.List.init 10 (Z.add 1)) in
tt.
Definition tests : list (string * variant * (unit -> unit)) :=
cons
("example-test" % string,
(* ❌ Variants not supported *)
variant, Documented_example.actual_test)
(cons
("test-encapsulated-versions" % string,
(* ❌ Variants not supported *)
variant, test_n_encapsulated_versions) []).
src/lib_data_encoding/test/write_failure.ml 27 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Test expected errors while serializing data. *)
open Data_encoding
open Types
let check_raises expected f =
match f () with
| exception exn when expected exn ->
()
| exception exn ->
Alcotest.failf "Unexpected exception: %s." (Printexc.to_string exn)
| _ ->
Alcotest.failf "Expecting exception, got success."
let json ?(expected = fun _ -> true) encoding value () =
check_raises expected (fun () ->
ignore (Json.construct encoding value : Json.t))
let bson ?(expected = fun _ -> true) encoding value () =
check_raises expected (fun () ->
ignore (Bson.construct encoding value : Bson.t))
let binary ?(expected = fun _ -> true) encoding value () =
check_raises expected (fun () ->
ignore (Binary.to_bytes_exn encoding value : Bytes.t))
let all name encoding value =
[ (name ^ ".json", `Quick, json encoding value);
(name ^ ".bson", `Quick, bson encoding value);
(name ^ ".bytes", `Quick, binary encoding value) ]
let all_ranged_int minimum maximum =
let encoding = ranged_int minimum maximum in
let name = Format.asprintf "ranged_int.%d" minimum in
all (name ^ ".min") encoding (minimum - 1)
@ all (name ^ ".max") encoding (maximum + 1)
let all_ranged_float minimum maximum =
let encoding = ranged_float minimum maximum in
let name = Format.asprintf "ranged_float.%f" minimum in
all (name ^ ".min") encoding (minimum -. 1.)
@ all (name ^ ".max") encoding (maximum +. 1.)
let test_bounded_string_list =
let expected = function
| Binary_error.Write_error Size_limit_exceeded ->
true
| _ ->
false
in
let test name ~total ~elements v =
( "bounded_string_list." ^ name,
`Quick,
binary ~expected (bounded_list ~total ~elements string) v )
in
[ test "a" ~total:0 ~elements:0 [""];
test "b1" ~total:3 ~elements:4 [""];
test "b2" ~total:4 ~elements:3 [""];
test "c1" ~total:19 ~elements:4 [""; ""; ""; ""; ""];
test "c2" ~total:20 ~elements:3 [""; ""; ""; ""; ""];
test "d1" ~total:20 ~elements:5 [""; ""; ""; ""; "a"];
test "d2" ~total:21 ~elements:4 [""; ""; ""; ""; "a"];
test "e" ~total:30 ~elements:10 ["ab"; "c"; "def"; "gh"; "ijk"] ]
let tests =
all_ranged_int 100 400 @ all_ranged_int 19000 19254
@ all_ranged_int ~-100 300
@ all_ranged_int ~-300_000_000 300_000_000
@ all_ranged_float ~-.100. 300.
@ all "string.fixed" (Fixed.string 4) "turlututu"
@ all "string.bounded" (Bounded.string 4) "turlututu"
@ all "bytes.fixed" (Fixed.bytes 4) (Bytes.of_string "turlututu")
@ all "bytes.bounded" (Bounded.bytes 4) (Bytes.of_string "turlututu")
@ all "unknown_case.B" mini_union_enc (B "2")
@ all "unknown_case.E" mini_union_enc E
@ test_bounded_string_list
@ all "n" n (Z.of_string "-12")
@ []
src/lib_data_encoding/test/write_failure.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Data_encoding.
Definition check_raises {A : Type} (expected : exn -> bool) (f : unit -> A)
: unit :=
let '_ := f tt in
op_startypeminuserrorstar "Expecting exception, got success." % string.
Definition json {A : Type} (op_staroptstar : option (exn -> bool))
: (Tezos_data_encoding__Data_encoding.Encoding.t A) -> A -> unit -> unit :=
let expected :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
fun function_parameter =>
let '_ := function_parameter in
true
end in
fun encoding =>
fun value =>
fun function_parameter =>
let 'tt := function_parameter in
check_raises expected
(fun function_parameter =>
let 'tt := function_parameter in
OCaml.Stdlib.ignore (Json.construct encoding value)).
Definition bson {A : Type} (op_staroptstar : option (exn -> bool))
: (Tezos_data_encoding__Data_encoding.Encoding.t A) -> A -> unit -> unit :=
let expected :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
fun function_parameter =>
let '_ := function_parameter in
true
end in
fun encoding =>
fun value =>
fun function_parameter =>
let 'tt := function_parameter in
check_raises expected
(fun function_parameter =>
let 'tt := function_parameter in
OCaml.Stdlib.ignore (Bson.construct encoding value)).
Definition binary {A : Type} (op_staroptstar : option (exn -> bool))
: (Tezos_data_encoding__Data_encoding.Encoding.t A) -> A -> unit -> unit :=
let expected :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
fun function_parameter =>
let '_ := function_parameter in
true
end in
fun encoding =>
fun value =>
fun function_parameter =>
let 'tt := function_parameter in
check_raises expected
(fun function_parameter =>
let 'tt := function_parameter in
OCaml.Stdlib.ignore (Binary.to_bytes_exn encoding value)).
Definition all {A : Type}
(name : string) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
(value : A) : list (string * variant * (unit -> unit)) :=
cons
((String.append name ".json" % string),
(* ❌ Variants not supported *)
variant, (json None encoding value))
(cons
((String.append name ".bson" % string),
(* ❌ Variants not supported *)
variant, (bson None encoding value))
(cons
((String.append name ".bytes" % string),
(* ❌ Variants not supported *)
variant, (binary None encoding value)) [])).
Definition all_ranged_int (minimum : Z) (maximum : Z)
: list (string * variant * (unit -> unit)) :=
let encoding := ranged_int minimum maximum in
let name :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "ranged_int." % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "ranged_int.%d" % string)
minimum in
OCaml.Stdlib.app
(all (String.append name ".min" % string) encoding (Z.sub minimum 1))
(all (String.append name ".max" % string) encoding (Z.add maximum 1)).
Definition all_ranged_float (minimum : Z) (maximum : Z)
: list (string * variant * (unit -> unit)) :=
let encoding := ranged_float minimum maximum in
let name :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "ranged_float." % string
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "ranged_float.%f" % string)
minimum in
OCaml.Stdlib.app
(all (String.append name ".min" % string) encoding
(Stdlib.op_minuspoint minimum
(* ❌ Float constant 1. is approximated by the integer 1 *)
1))
(all (String.append name ".max" % string) encoding
(Stdlib.op_pluspoint maximum
(* ❌ Float constant 1. is approximated by the integer 1 *)
1)).
Definition test_bounded_string_list
: list (string * variant * (unit -> unit)) :=
let expected (function_parameter : exn) : bool :=
match function_parameter with
| Write_error Tezos_data_encoding.Binary_error.Size_limit_exceeded => true
| _ => false
end in
let test {A B C : Type} (name : string) (total : A) (elements : B) (v : C)
: string * variant * (unit -> unit) :=
((String.append "bounded_string_list." % string name),
(* ❌ Variants not supported *)
variant,
(binary (Some expected) (op_startypeminuserrorstar total elements string)
v)) in
cons (test "a" % string 0 0 (cons "" % string []))
(cons (test "b1" % string 3 4 (cons "" % string []))
(cons (test "b2" % string 4 3 (cons "" % string []))
(cons
(test "c1" % string 19 4
(cons "" % string
(cons "" % string
(cons "" % string (cons "" % string (cons "" % string []))))))
(cons
(test "c2" % string 20 3
(cons "" % string
(cons "" % string
(cons "" % string (cons "" % string (cons "" % string []))))))
(cons
(test "d1" % string 20 5
(cons "" % string
(cons "" % string
(cons "" % string (cons "" % string (cons "a" % string []))))))
(cons
(test "d2" % string 21 4
(cons "" % string
(cons "" % string
(cons "" % string
(cons "" % string (cons "a" % string []))))))
(cons
(test "e" % string 30 10
(cons "ab" % string
(cons "c" % string
(cons "def" % string
(cons "gh" % string (cons "ijk" % string [])))))) []))))))).
Definition tests : list (string * variant * (unit -> unit)) :=
OCaml.Stdlib.app (all_ranged_int 100 400)
(OCaml.Stdlib.app (all_ranged_int 19000 19254)
(OCaml.Stdlib.app (all_ranged_int (Z.opp 100) 300)
(OCaml.Stdlib.app (all_ranged_int (Z.opp 300000000) 300000000)
(OCaml.Stdlib.app
(all_ranged_float
(Stdlib.op_tildeminuspoint
(* ❌ Float constant 100. is approximated by the integer 100 *)
100)
(* ❌ Float constant 300. is approximated by the integer 300 *)
300)
(OCaml.Stdlib.app
(all "string.fixed" % string (Fixed.string 4) "turlututu" % string)
(OCaml.Stdlib.app
(all "string.bounded" % string (Bounded.string 4)
"turlututu" % string)
(OCaml.Stdlib.app
(all "bytes.fixed" % string (Fixed.bytes 4)
(Stdlib.Bytes.of_string "turlututu" % string))
(OCaml.Stdlib.app
(all "bytes.bounded" % string (Bounded.bytes 4)
(Stdlib.Bytes.of_string "turlututu" % string))
(OCaml.Stdlib.app
(all "unknown_case.B" % string op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app
(all "unknown_case.E" % string op_startypeminuserrorstar
op_startypeminuserrorstar)
(OCaml.Stdlib.app test_bounded_string_list
(OCaml.Stdlib.app
(all "n" % string n (Z.of_string "-12" % string)) [])))))))))))).
src/lib_data_encoding/tzEndian.ml success
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) open Bytes_encodings let set_int32 = set_int32_be let get_int32 = get_int32_be let set_int8 = set_int8 let get_int8 = get_int8 let set_int16 = set_int16_be let get_int16 = get_int16_be let set_int64 = set_int64_be let get_int64 = get_int64_be let get_uint8 = get_uint8 let get_uint16 = get_uint16_be let get_double buff i = Int64.float_of_bits (get_int64_be buff i) let set_double buff i v = set_int64_be buff i (Int64.bits_of_float v)
src/lib_data_encoding/tzEndian.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. Import Bytes_encodings. Definition set_int32 : string -> Z -> int32 -> unit := set_int32_be. Definition get_int32 : string -> Z -> int32 := get_int32_be. Definition set_int8 : string -> Z -> Z -> unit := set_int8. Definition get_int8 : string -> Z -> Z := get_int8. Definition set_int16 : string -> Z -> Z -> unit := set_int16_be. Definition get_int16 : string -> Z -> Z := get_int16_be. Definition set_int64 : string -> Z -> int64 -> unit := set_int64_be. Definition get_int64 : string -> Z -> int64 := get_int64_be. Definition get_uint8 : string -> Z -> Z := get_uint8. Definition get_uint16 : string -> Z -> Z := get_uint16_be. Definition get_double (buff : string) (i : Z) : Z := Int64.float_of_bits (get_int64_be buff i). Definition set_double (buff : string) (i : Z) (v : Z) : unit := set_int64_be buff i (Int64.bits_of_float v).
src/lib_data_encoding/with_version.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Encoding
let version_case enc choose wrap name nth =
case
~title:(Printf.sprintf "%s version %d" name nth)
Json_only
(obj1 (req (Printf.sprintf "%s.v%d" name nth) enc))
choose
wrap
let make_encoding ~name l =
union ~tag_size:`Uint8 (List.mapi (fun nth f -> f name nth) l)
type _ t =
| Version_0 : 'v0 encoding -> 'v0 t
| Version_S : {
previous : 'vn t;
encoding : 'vnp1 encoding;
upgrade : 'vn -> 'vnp1;
}
-> 'vnp1 t
let first_version e = Version_0 e
let next_version encoding upgrade previous =
Version_S {encoding; upgrade; previous}
let encoding : type a. name:string -> a t -> a encoding =
fun ~name version ->
match version with
| Version_0 e ->
make_encoding ~name [version_case e (fun x -> Some x) (fun x -> x)]
| Version_S {previous; encoding; upgrade} ->
let rec mk_nones :
type (* This function generates encoding cases for all the
outdated versions.
These versions are never encoded to
(hence [fun _ -> None]) but are safely decoded with
the use of the upgrade functions. *)
b.
(b -> a) -> b t -> (string -> int -> a case) list =
fun upgr -> function
| Version_0 e ->
[version_case e (fun _ -> None) (fun x -> upgr x)]
| Version_S {previous; encoding; upgrade} ->
let others = mk_nones (fun x -> upgr (upgrade x)) previous in
version_case encoding (fun _ -> None) (fun x -> upgr x) :: others
in
let nones = mk_nones upgrade previous in
let cases =
version_case encoding (fun x -> Some x) (fun x -> x) :: nones
|> List.rev
in
make_encoding ~name cases
src/lib_data_encoding/with_version.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Encoding.
Definition version_case {A B : Type}
(enc : Tezos_data_encoding.Encoding.encoding A) (choose : B -> option A)
(wrap : A -> B) (name : string) (nth : Z)
: Tezos_data_encoding.Encoding.case B :=
case
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " version " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))) "%s version %d" % string)
name nth) None Tezos_data_encoding.Encoding.Json_only
(obj1
(req None None
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ".v" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))) "%s.v%d" % string)
name nth) enc)) choose wrap.
Definition make_encoding {A B : Type}
(name : A) (l : list (A -> Z -> Tezos_data_encoding.Encoding.case B))
: Tezos_data_encoding.Encoding.encoding B :=
union
(Some
(* ❌ Variants not supported *)
variant) (Stdlib.List.mapi (fun nth => fun f => f name nth) l).
Inductive t : forall (_ : Type), Type :=
| Version_0 : forall {v0 : Type}, (Tezos_data_encoding.Encoding.encoding v0) ->
t v0
| Version_S : forall {vn vnp1 : Type}, (t vn) ->
(Tezos_data_encoding.Encoding.encoding vnp1) -> (vn -> vnp1) -> t vnp1.
Definition first_version {A : Type}
(e : Tezos_data_encoding.Encoding.encoding A) : t A := Version_0 e.
Definition next_version {A B : Type}
(encoding : Tezos_data_encoding.Encoding.encoding A) (upgrade : B -> A)
(previous : t B) : t A :=
Version_S {| previous := previous; encoding := encoding; upgrade := upgrade |}.
Definition encoding {a : Type} (name : string) (version : t a)
: Tezos_data_encoding.Encoding.encoding a :=
match version with
| Version_0 e =>
make_encoding name (cons (version_case e (fun x => Some x) (fun x => x)) [])
|
Version_S {|
previous := previous; encoding := encoding; upgrade := upgrade |} =>
let fix mk_nones {b : Type} (upgr : b -> a) (function_parameter : t b)
: list (string -> Z -> Tezos_data_encoding.Encoding.case a) :=
match function_parameter with
| Version_0 e =>
cons
(version_case e
(fun function_parameter =>
let '_ := function_parameter in
None) (fun x => upgr x)) []
|
Version_S {|
previous := previous; encoding := encoding; upgrade := upgrade |}
=>
let others := mk_nones (fun x => upgr (upgrade x)) previous in
cons
(version_case encoding
(fun function_parameter =>
let '_ := function_parameter in
None) (fun x => upgr x)) others
end in
let nones := mk_nones upgrade previous in
let cases :=
OCaml.Stdlib.reverse_apply
(cons (version_case encoding (fun x => Some x) (fun x => x)) nones)
List.rev in
make_encoding name cases
end.
src/lib_error_monad/core.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) (* Tezos Protocol Implementation - Error Monad *) (*-- Error classification ----------------------------------------------------*) include Core_maker.Make (struct let id = "" end)
src/lib_error_monad/core.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/lib_error_monad/core_maker.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* hack: forward reference from [Data_encoding_ezjsonm] *)
let json_to_string = ref (fun _ -> "")
let json_pp id encoding ppf x =
Format.pp_print_string ppf @@ !json_to_string
@@
let encoding =
Data_encoding.(merge_objs (obj1 (req "id" string)) encoding)
in
Data_encoding.Json.construct encoding (id, x)
let set_error_encoding_cache_dirty = ref (fun () -> ())
module Make (Prefix : Sig.PREFIX) : sig
include Sig.CORE
include Sig.EXT with type error := error
include Sig.WITH_WRAPPED with type error := error
end = struct
type error = ..
module type Wrapped_error_monad = sig
type unwrapped = ..
include Sig.CORE with type error := unwrapped
include Sig.EXT with type error := unwrapped
val unwrap : error -> unwrapped option
val wrap : unwrapped -> error
end
type full_error_category =
| Main of Sig.error_category
| Wrapped of (module Wrapped_error_monad)
(* the toplevel store for error kinds *)
type error_kind =
| Error_kind : {
id : string;
title : string;
description : string;
from_error : error -> 'err option;
category : full_error_category;
encoding_case : error Data_encoding.case;
pp : Format.formatter -> 'err -> unit;
}
-> error_kind
type error_info = {
category : Sig.error_category;
id : string;
title : string;
description : string;
schema : Data_encoding.json_schema;
}
let error_kinds : error_kind list ref = ref []
let get_registered_errors () : error_info list =
List.flatten
(List.map
(function
| Error_kind {id = ""; _} ->
[]
| Error_kind
{ id;
title;
description;
category = Main category;
encoding_case;
_ } ->
[ {
id;
title;
description;
category;
schema =
Data_encoding.Json.schema
(Data_encoding.union [encoding_case]);
} ]
| Error_kind {category = Wrapped (module WEM); _} ->
List.map
(fun {WEM.id; title; description; category; schema} ->
{id; title; description; category; schema})
(WEM.get_registered_errors ()))
!error_kinds)
let error_encoding_cache = ref None
let () =
let cont = !set_error_encoding_cache_dirty in
set_error_encoding_cache_dirty :=
fun () ->
cont () ;
error_encoding_cache := None
let string_of_category = function
| `Permanent ->
"permanent"
| `Temporary ->
"temporary"
| `Branch ->
"branch"
let pp_info ppf {category; id; title; description; schema} =
Format.fprintf
ppf
"@[<v 2>category : %s\n\
id : %s\n\
title : %s\n\
description : %s\n\
schema : %a@]"
(string_of_category category)
id
title
description
(Json_repr.pp (module Json_repr.Ezjsonm))
(Json_schema.to_json schema)
(* Catch all error when 'serializing' an error. *)
type error += Unclassified of string
let () =
let id = "" in
let category = Main `Temporary in
let to_error msg = Unclassified msg in
let from_error = function
| Unclassified msg ->
Some msg
| error ->
let msg = Obj.(extension_name @@ extension_constructor error) in
Some ("Unclassified error: " ^ msg ^ ". Was the error registered?")
in
let title = "Generic error" in
let description = "An unclassified error" in
let encoding_case =
let open Data_encoding in
case
Json_only
~title:"Generic error"
( def "generic_error" ~title ~description
@@ conv (fun x -> ((), x)) (fun ((), x) -> x)
@@ obj2 (req "kind" (constant "generic")) (req "error" string) )
from_error
to_error
in
let pp ppf s = Format.fprintf ppf "@[<h 0>%a@]" Format.pp_print_text s in
error_kinds :=
Error_kind
{id; title; description; from_error; category; encoding_case; pp}
:: !error_kinds
(* Catch all error when 'deserializing' an error. *)
type error += Unregistred_error of Data_encoding.json
let () =
let id = "" in
let category = Main `Temporary in
let to_error msg = Unregistred_error msg in
let from_error = function
| Unregistred_error json ->
Some json
| _ ->
None
in
let encoding_case =
let open Data_encoding in
case Json_only ~title:"Unregistred error" json from_error to_error
in
let pp ppf json =
Format.fprintf
ppf
"@[<v 2>Unregistred error:@ %a@]"
Data_encoding.Json.pp
json
in
error_kinds :=
Error_kind
{
id;
title = "";
description = "";
from_error;
category;
encoding_case;
pp;
}
:: !error_kinds
let raw_register_error_kind category ~id:name ~title ~description ?pp
encoding from_error to_error =
let name = Prefix.id ^ name in
if List.exists (fun (Error_kind {id; _}) -> name = id) !error_kinds then
invalid_arg
(Printf.sprintf "register_error_kind: duplicate error name: %s" name) ;
let encoding_case =
let open Data_encoding in
match category with
| Wrapped (module WEM) ->
let unwrap err =
match WEM.unwrap err with
| Some (WEM.Unclassified _) ->
None
| Some (WEM.Unregistred_error _) ->
Format.eprintf "What %s@." name ;
None
| res ->
res
in
let wrap err =
match err with
| WEM.Unclassified _ ->
failwith "ignore wrapped error when serializing"
| WEM.Unregistred_error _ ->
failwith "ignore wrapped error when deserializing"
| res ->
WEM.wrap res
in
case Json_only ~title:name WEM.error_encoding unwrap wrap
| Main category ->
let with_id_and_kind_encoding =
merge_objs
(obj2
(req "kind" (constant (string_of_category category)))
(req "id" (constant name)))
encoding
in
case
Json_only
~title
~description
(conv
(fun x -> (((), ()), x))
(fun (((), ()), x) -> x)
with_id_and_kind_encoding)
from_error
to_error
in
!set_error_encoding_cache_dirty () ;
error_kinds :=
Error_kind
{
id = name;
category;
title;
description;
from_error;
encoding_case;
pp = Option.unopt ~default:(json_pp name encoding) pp;
}
:: !error_kinds
let register_wrapped_error_kind (module WEM : Wrapped_error_monad) ~id ~title
~description =
raw_register_error_kind
(Wrapped (module WEM))
~id
~title
~description
~pp:WEM.pp
WEM.error_encoding
WEM.unwrap
WEM.wrap
let register_error_kind category ~id ~title ~description ?pp encoding
from_error to_error =
if not (Data_encoding.is_obj encoding) then
invalid_arg
(Printf.sprintf
"Specified encoding for \"%s%s\" is not an object, but error \
encodings must be objects."
Prefix.id
id) ;
raw_register_error_kind
(Main category)
~id
~title
~description
?pp
encoding
from_error
to_error
let error_encoding () =
match !error_encoding_cache with
| None ->
let cases =
List.map
(fun (Error_kind {encoding_case; _}) -> encoding_case)
!error_kinds
in
let union_encoding = Data_encoding.union cases in
let encoding =
let open Data_encoding in
dynamic_size
@@ splitted
~json:union_encoding
~binary:
(conv
(Json.construct union_encoding)
(Json.destruct union_encoding)
json)
in
error_encoding_cache := Some encoding ;
encoding
| Some encoding ->
encoding
let error_encoding = Data_encoding.delayed error_encoding
let json_of_error error = Data_encoding.Json.construct error_encoding error
let error_of_json json = Data_encoding.Json.destruct error_encoding json
let classify_error error =
let rec find e = function
| [] ->
`Temporary
(* assert false (\* See "Generic error" *\) *)
| Error_kind {from_error; category; _} :: rest -> (
match from_error e with
| Some _ -> (
match category with
| Main error_category ->
error_category
| Wrapped (module WEM) -> (
match WEM.unwrap e with
| Some e ->
WEM.classify_error e
| None ->
find e rest ) )
| None ->
find e rest )
in
find error !error_kinds
let pp ppf error =
let rec find = function
| [] ->
assert false (* See "Generic error" *)
| Error_kind {from_error; pp; _} :: errors -> (
match from_error error with None -> find errors | Some x -> pp ppf x )
in
find !error_kinds
end
src/lib_error_monad/core_maker.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition json_to_string
: Stdlib.ref (Tezos_data_encoding.Data_encoding.Json.json -> string) :=
Stdlib.ref
(fun function_parameter =>
let '_ := function_parameter in
"" % string).
Definition json_pp {A : Type}
(id : string) (encoding : Tezos_data_encoding.Data_encoding.encoding A)
(ppf : Stdlib.Format.formatter) (x : A) : unit :=
apply (Format.pp_print_string ppf)
(apply (Stdlib.op_exclamation json_to_string)
(let encoding :=
merge_objs (obj1 (req None None "id" % string string)) encoding in
Data_encoding.Json.construct encoding (id, x))).
Definition set_error_encoding_cache_dirty : Stdlib.ref (unit -> unit) :=
Stdlib.ref
(fun function_parameter =>
let 'tt := function_parameter in
tt).
(* ❌ Functors are not handled. *)
functor
src/lib_error_monad/error_monad.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Tezos Protocol Implementation - Error Monad *)
(*-- Error classification ----------------------------------------------------*)
type error_category = [`Branch | `Temporary | `Permanent]
include Core
include Monad
module Make (Prefix : Sig.PREFIX) : sig
include Sig.CORE
include Sig.EXT with type error := error
include Sig.WITH_WRAPPED with type error := error
end = struct
include Core_maker.Make (Prefix)
end
type error += Exn of exn
let () =
register_error_kind
`Temporary
~id:"failure"
~title:"Exception"
~description:"Exception safely wrapped in an error"
~pp:(fun ppf s -> Format.fprintf ppf "@[<h 0>%a@]" Format.pp_print_text s)
Data_encoding.(obj1 (req "msg" string))
(function
| Exn (Failure msg) ->
Some msg
| Exn exn ->
Some (Printexc.to_string exn)
| _ ->
None)
(fun msg -> Exn (Failure msg))
let generic_error fmt = Format.kasprintf (fun s -> error (Exn (Failure s))) fmt
let failwith fmt = Format.kasprintf (fun s -> fail (Exn (Failure s))) fmt
let error_exn s = Error [Exn s]
let trace_exn exn f = trace (Exn exn) f
let generic_trace fmt =
Format.kasprintf (fun str -> trace_exn (Failure str)) fmt
let record_trace_exn exn f = record_trace (Exn exn) f
let failure fmt = Format.kasprintf (fun str -> Exn (Failure str)) fmt
let pp_exn ppf exn = pp ppf (Exn exn)
type error += Canceled
let () =
register_error_kind
`Temporary
~id:"utils.Canceled"
~title:"Canceled"
~description:"Canceled"
Data_encoding.unit
(function Canceled -> Some () | _ -> None)
(fun () -> Canceled)
let () =
register_error_kind
`Temporary
~id:"canceled"
~title:"Canceled"
~description:"A promise was unexpectedly canceled"
~pp:(fun f () ->
Format.pp_print_string f "The promise was unexpectedly canceled")
Data_encoding.unit
(function Canceled -> Some () | _ -> None)
(fun () -> Canceled)
let protect ?on_error ?canceler t =
let cancellation =
match canceler with
| None ->
Lwt_utils.never_ending ()
| Some canceler ->
Lwt_canceler.cancellation canceler >>= fun () -> fail Canceled
in
let res = Lwt.pick [cancellation; Lwt.catch t (fun exn -> fail (Exn exn))] in
res
>>= function
| Ok _ ->
res
| Error err -> (
let canceled =
Option.unopt_map canceler ~default:false ~f:Lwt_canceler.canceled
in
let err = if canceled then [Canceled] else err in
match on_error with
| None ->
Lwt.return_error err
| Some on_error ->
Lwt.catch (fun () -> on_error err) (fun exn -> fail (Exn exn)) )
type error += Timeout
let () =
register_error_kind
`Temporary
~id:"utils.Timeout"
~title:"Timeout"
~description:"Timeout"
~pp:(fun f () -> Format.pp_print_string f "The request has timed out")
Data_encoding.unit
(function Timeout -> Some () | _ -> None)
(fun () -> Timeout)
let with_timeout ?(canceler = Lwt_canceler.create ()) timeout f =
let target = f canceler in
Lwt.choose [timeout; (target >|= fun _ -> ())]
>>= fun () ->
if Lwt.state target <> Lwt.Sleep then (Lwt.cancel timeout ; target)
else Lwt_canceler.cancel canceler >>= fun () -> fail Timeout
let errs_tag = Tag.def ~doc:"Errors" "errs" pp_print_error
let json_to_string = Core_maker.json_to_string
src/lib_error_monad/error_monad.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition error_category := variant.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Functors are not handled. *)
functor
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition generic_error {A B : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit (tzresult B)) : A :=
Format.kasprintf (fun s => error (Exn (OCaml.Failure s))) fmt.
Definition failwith {A B : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t (tzresult B)))
: A := Format.kasprintf (fun s => fail (Exn (OCaml.Failure s))) fmt.
Definition error_exn {A : Type} (s : exn) : sum A (list error) :=
Stdlib.Error (cons (Exn s) []).
Definition trace_exn {A : Type} (exn : exn) (f : Lwt.t (tzresult A))
: Lwt.t (tzresult A) := trace (Exn exn) f.
Definition generic_trace {A B : Type}
(fmt :
Stdlib.format4 A Stdlib.Format.formatter unit
((Lwt.t (tzresult B)) -> Lwt.t (tzresult B))) : A :=
Format.kasprintf (fun str => trace_exn (OCaml.Failure str)) fmt.
Definition record_trace_exn {A : Type} (exn : exn) (f : tzresult A)
: tzresult A := record_trace (Exn exn) f.
Definition failure {A : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit error) : A :=
Format.kasprintf (fun str => Exn (OCaml.Failure str)) fmt.
Definition pp_exn (ppf : Stdlib.Format.formatter) (exn : exn) : unit :=
pp ppf (Exn exn).
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition protect {A : Type}
(on_error : option (trace -> Lwt.t (tzresult A)))
(canceler : option Tezos_stdlib.Lwt_canceler.t)
(t : unit -> Lwt.t (tzresult A)) : Lwt.t (tzresult A) :=
let cancellation :=
match canceler with
| None => Lwt_utils.never_ending tt
| Some canceler =>
op_gtgteq (Lwt_canceler.cancellation canceler)
(fun function_parameter =>
let 'tt := function_parameter in
fail Canceled)
end in
let res :=
Lwt.pick
(cons cancellation (cons (Lwt.catch t (fun exn => fail (Exn exn))) [])) in
op_gtgteq res
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok _ => res
| Stdlib.Error err =>
let canceled := Option.unopt_map Lwt_canceler.canceled false canceler in
let err :=
if canceled then
cons Canceled []
else
err in
match on_error with
| None => Lwt.return_error err
| Some on_error =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
on_error err) (fun exn => fail (Exn exn))
end
end).
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition with_timeout {A : Type}
(op_staroptstar : option Tezos_stdlib.Lwt_canceler.t)
: (Lwt.t unit) ->
(Tezos_stdlib.Lwt_canceler.t -> Lwt.t (tzresult A)) -> Lwt.t (tzresult A) :=
let canceler :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Lwt_canceler.create tt
end in
fun timeout =>
fun f =>
let target := f canceler in
op_gtgteq
(Lwt.choose
(cons timeout
(cons
(op_gtpipeeq target
(fun function_parameter =>
let '_ := function_parameter in
tt)) [])))
(fun function_parameter =>
let 'tt := function_parameter in
if nequiv_decb (Lwt.state target) Lwt.Sleep then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt.cancel timeout in
target
else
op_gtgteq (Lwt_canceler.cancel canceler)
(fun function_parameter =>
let 'tt := function_parameter in
fail Timeout)).
Definition errs_tag : Tezos_stdlib.Tag.def trace :=
Tag.def (Some "Errors" % string) "errs" % string pp_print_error.
Definition json_to_string
: Stdlib.ref (Tezos_data_encoding.Data_encoding.json -> string) :=
Core_maker.json_to_string.
src/lib_error_monad/error_table.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
module type S = sig
type key
type 'a t
val create : int -> 'a t
val clear : 'a t -> unit
val reset : 'a t -> unit
val find_or_make :
'a t -> key -> (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t
val remove : 'a t -> key -> unit
val find_opt : 'a t -> key -> 'a tzresult Lwt.t option
val mem : 'a t -> key -> bool
val iter_s : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t
val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t
val fold : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t
val fold_promises :
(key -> 'a tzresult Lwt.t -> 'b -> 'b) -> 'a t -> 'b -> 'b
val fold_resolved : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val fold_keys : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b
val length : 'a t -> int
end
module Make (T : Hashtbl.S) : S with type key = T.key = struct
type key = T.key
type 'a t = {table : 'a tzresult Lwt.t T.t; cleaners : unit Lwt.t T.t}
let create n = {table = T.create n; cleaners = T.create n}
let clear t =
T.iter (fun _ cleaner -> Lwt.cancel cleaner) t.cleaners ;
T.iter (fun _ a -> Lwt.cancel a) t.table ;
T.clear t.cleaners ;
T.clear t.table
let reset t =
T.iter (fun _ cleaner -> Lwt.cancel cleaner) t.cleaners ;
T.iter (fun _ a -> Lwt.cancel a) t.table ;
T.reset t.cleaners ;
T.reset t.table
let find_or_make t k i =
match T.find_opt t.table k with
| Some a ->
a
| None ->
let p = i () in
T.add t.table k p ;
T.add
t.cleaners
k
( p
>>= function
| Ok _ ->
T.remove t.cleaners k ; Lwt.return_unit
| Error _ ->
T.remove t.table k ; T.remove t.cleaners k ; Lwt.return_unit ) ;
p
let remove t k =
(match T.find_opt t.cleaners k with None -> () | Some a -> Lwt.cancel a) ;
T.remove t.cleaners k ;
(match T.find_opt t.table k with None -> () | Some a -> Lwt.cancel a) ;
T.remove t.table k
let find_opt t k = T.find_opt t.table k
let mem t k = T.mem t.table k
let iter_s f t =
T.fold (fun k a acc -> (k, a) :: acc) t.table []
|> Lwt_list.iter_s (fun (k, a) ->
a >>= function Error _ -> Lwt.return_unit | Ok a -> f k a)
let iter_p f t =
T.fold (fun k a acc -> (k, a) :: acc) t.table []
|> Lwt_list.iter_p (fun (k, a) ->
a >>= function Error _ -> Lwt.return_unit | Ok a -> f k a)
let fold f t acc =
T.fold (fun k a acc -> (k, a) :: acc) t.table []
|> Lwt_list.fold_left_s
(fun acc (k, a) ->
a >>= function Error _ -> Lwt.return acc | Ok a -> f k a acc)
acc
let fold_promises f t acc = T.fold f t.table acc
let fold_resolved f t acc =
T.fold
(fun k a acc ->
match Lwt.state a with
| Lwt.Sleep | Lwt.Fail _ | Lwt.Return (Error _) ->
acc
| Lwt.Return (Ok a) ->
f k a acc)
t.table
acc
let fold_keys f t acc = T.fold (fun k _ acc -> f k acc) t.table acc
let length t = T.length t.table
end
src/lib_error_monad/error_table.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Module S.
Record signature {key t : Type} := {
key := key;
polymorphic_abstract_type;
create : forall {a : Type}, Z -> t a;
clear : forall {a : Type}, (t a) -> unit;
reset : forall {a : Type}, (t a) -> unit;
find_or_make : forall {a : Type}, (t a) ->
key ->
(unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult a)) ->
Lwt.t (Tezos_error_monad.Error_monad.tzresult a);
remove : forall {a : Type}, (t a) -> key -> unit;
find_opt : forall {a : Type}, (t a) ->
key -> option (Lwt.t (Tezos_error_monad.Error_monad.tzresult a));
mem : forall {a : Type}, (t a) -> key -> bool;
iter_s : forall {a : Type}, (key -> a -> Lwt.t unit) -> (t a) -> Lwt.t unit;
iter_p : forall {a : Type}, (key -> a -> Lwt.t unit) -> (t a) -> Lwt.t unit;
fold : forall {a b : Type}, (key -> a -> b -> Lwt.t b) ->
(t a) -> b -> Lwt.t b;
fold_promises : forall {a b : Type}, (key ->
(Lwt.t (Tezos_error_monad.Error_monad.tzresult a)) -> b -> b) ->
(t a) -> b -> b;
fold_resolved : forall {a b : Type}, (key -> a -> b -> b) -> (t a) -> b -> b;
fold_keys : forall {a b : Type}, (key -> b -> b) -> (t a) -> b -> b;
length : forall {a : Type}, (t a) -> Z;
}.
Arguments signature : clear implicits.
End S.
(* ❌ Functors are not handled. *)
functor
src/lib_error_monad/monad.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Monad_maker.Make (Core)
src/lib_error_monad/monad.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/lib_error_monad/monad_maker.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Make (Error : Sig.CORE) : Sig.MONAD with type error := Error.error =
struct
(* INVARIANT: traces are never empty, they must contain at least one error *)
type trace = Error.error list
let trace_encoding = Data_encoding.list Error.error_encoding
let pp_print_error ppf = function
| [] ->
assert false
| [error] ->
Format.fprintf ppf "@[<v 2>Error:@ %a@]@." Error.pp error
| error :: _ as errors ->
Format.fprintf
ppf
"@[<v 2>Error:@ %a,@ trace:@ %a@]@."
Error.pp
error
(Format.pp_print_list Error.pp)
(List.rev errors)
let classify_errors trace =
List.fold_left
(fun r e ->
match (r, Error.classify_error e) with
| (`Permanent, _) | (_, `Permanent) ->
`Permanent
| (`Branch, _) | (_, `Branch) ->
`Branch
| (`Temporary, `Temporary) ->
`Temporary)
`Temporary
trace
type 'a tzresult = ('a, trace) result
let result_encoding a_encoding =
let open Data_encoding in
let errors_encoding = obj1 (req "error" trace_encoding) in
let a_encoding = obj1 (req "result" a_encoding) in
union
~tag_size:`Uint8
[ case
(Tag 0)
a_encoding
~title:"Ok"
(function Ok x -> Some x | _ -> None)
(function res -> Ok res);
case
(Tag 1)
errors_encoding
~title:"Error"
(function Error x -> Some x | _ -> None)
(function [] -> assert false | _ :: _ as errs -> Error errs) ]
let ( >>= ) = Lwt.( >>= )
let return v = Lwt.return_ok v
let return_unit = Lwt.return (Ok ())
let return_none = Lwt.return (Ok None)
let return_some x = Lwt.return (Ok (Some x))
let return_nil = Lwt.return (Ok [])
let return_true = Lwt.return (Ok true)
let return_false = Lwt.return (Ok false)
let error s = Error [s]
let ok v = Ok v
let fail s = Lwt.return_error [s]
let ( >>? ) v f = match v with Error _ as err -> err | Ok v -> f v
let ( >>=? ) v f =
v >>= function Error _ as err -> Lwt.return err | Ok v -> f v
let ( >>|? ) v f = v >>=? fun v -> Lwt.return_ok (f v)
let ( >|= ) = Lwt.( >|= )
let ( >|? ) v f = v >>? fun v -> Ok (f v)
let rec map_s f l =
match l with
| [] ->
return_nil
| h :: t ->
f h >>=? fun rh -> map_s f t >>=? fun rt -> return (rh :: rt)
let mapi_s f l =
let rec mapi_s f i l =
match l with
| [] ->
return_nil
| h :: t ->
f i h
>>=? fun rh -> mapi_s f (i + 1) t >>=? fun rt -> return (rh :: rt)
in
mapi_s f 0 l
let rec rev_map_append_s acc f = function
| [] ->
return acc
| hd :: tl ->
f hd >>=? fun v -> rev_map_append_s (v :: acc) f tl
let rev_map_s f l = rev_map_append_s [] f l
let rec map_p f l =
match l with
| [] ->
return_nil
| x :: l -> (
let tx = f x and tl = map_p f l in
tx
>>= fun x ->
tl
>>= fun l ->
match (x, l) with
| (Ok x, Ok l) ->
Lwt.return_ok (x :: l)
| (Error exn1, Error exn2) ->
Lwt.return_error (exn1 @ exn2)
| (Ok _, Error exn) | (Error exn, Ok _) ->
Lwt.return_error exn )
let mapi_p f l =
let rec mapi_p f i l =
match l with
| [] ->
return_nil
| x :: l -> (
let tx = f i x and tl = mapi_p f (i + 1) l in
tx
>>= fun x ->
tl
>>= fun l ->
match (x, l) with
| (Ok x, Ok l) ->
Lwt.return_ok (x :: l)
| (Error exn1, Error exn2) ->
Lwt.return_error (exn1 @ exn2)
| (Ok _, Error exn) | (Error exn, Ok _) ->
Lwt.return_error exn )
in
mapi_p f 0 l
let rec map2_s f l1 l2 =
match (l1, l2) with
| ([], []) ->
return_nil
| (_ :: _, []) | ([], _ :: _) ->
invalid_arg "Error_monad.map2_s"
| (h1 :: t1, h2 :: t2) ->
f h1 h2 >>=? fun rh -> map2_s f t1 t2 >>=? fun rt -> return (rh :: rt)
let mapi2_s f l1 l2 =
let rec mapi2_s i f l1 l2 =
match (l1, l2) with
| ([], []) ->
return_nil
| (_ :: _, []) | ([], _ :: _) ->
invalid_arg "Error_monad.mapi2_s"
| (h1 :: t1, h2 :: t2) ->
f i h1 h2
>>=? fun rh ->
mapi2_s (i + 1) f t1 t2 >>=? fun rt -> return (rh :: rt)
in
mapi2_s 0 f l1 l2
let rec map2 f l1 l2 =
match (l1, l2) with
| ([], []) ->
Ok []
| (_ :: _, []) | ([], _ :: _) ->
invalid_arg "Error_monad.map2"
| (h1 :: t1, h2 :: t2) ->
f h1 h2 >>? fun rh -> map2 f t1 t2 >>? fun rt -> Ok (rh :: rt)
let rec filter_map_s f l =
match l with
| [] ->
return_nil
| h :: t -> (
f h
>>=? function
| None ->
filter_map_s f t
| Some rh ->
filter_map_s f t >>=? fun rt -> return (rh :: rt) )
let rec filter_map_p f l =
match l with
| [] ->
return_nil
| h :: t -> (
let th = f h and tt = filter_map_p f t in
th
>>=? function
| None -> tt | Some rh -> tt >>=? fun rt -> return (rh :: rt) )
let rec filter_s f l =
match l with
| [] ->
return_nil
| h :: t -> (
f h
>>=? function
| false ->
filter_s f t
| true ->
filter_s f t >>=? fun t -> return (h :: t) )
let rec filter_p f l =
match l with
| [] ->
return_nil
| h :: t -> (
let jh = f h and t = filter_p f t in
jh >>=? function false -> t | true -> t >>=? fun t -> return (h :: t) )
let rec iter_s f l =
match l with [] -> return_unit | h :: t -> f h >>=? fun () -> iter_s f t
let rec iter_p f l =
match l with
| [] ->
return_unit
| x :: l -> (
let tx = f x and tl = iter_p f l in
tx
>>= fun tx_res ->
tl
>>= fun tl_res ->
match (tx_res, tl_res) with
| (Ok (), Ok ()) ->
Lwt.return_ok ()
| (Error exn1, Error exn2) ->
Lwt.return_error (exn1 @ exn2)
| (Ok (), Error exn) | (Error exn, Ok ()) ->
Lwt.return_error exn )
let iteri_p f l =
let rec iteri_p i f l =
match l with
| [] ->
return_unit
| x :: l -> (
let tx = f i x and tl = iteri_p (i + 1) f l in
tx
>>= fun tx_res ->
tl
>>= fun tl_res ->
match (tx_res, tl_res) with
| (Ok (), Ok ()) ->
Lwt.return (Ok ())
| (Error exn1, Error exn2) ->
Lwt.return (Error (exn1 @ exn2))
| (Ok (), Error exn) | (Error exn, Ok ()) ->
Lwt.return (Error exn) )
in
iteri_p 0 f l
let rec iter2_p f l1 l2 =
match (l1, l2) with
| ([], []) ->
return_unit
| ([], _) | (_, []) ->
invalid_arg "Error_monad.iter2_p"
| (x1 :: l1, x2 :: l2) -> (
let tx = f x1 x2 and tl = iter2_p f l1 l2 in
tx
>>= fun tx_res ->
tl
>>= fun tl_res ->
match (tx_res, tl_res) with
| (Ok (), Ok ()) ->
Lwt.return_ok ()
| (Error exn1, Error exn2) ->
Lwt.return_error (exn1 @ exn2)
| (Ok (), Error exn) | (Error exn, Ok ()) ->
Lwt.return_error exn )
let iteri2_p f l1 l2 =
let rec iteri2_p i f l1 l2 =
match (l1, l2) with
| ([], []) ->
return_unit
| ([], _) | (_, []) ->
invalid_arg "Error_monad.iteri2_p"
| (x1 :: l1, x2 :: l2) -> (
let tx = f i x1 x2 and tl = iteri2_p (i + 1) f l1 l2 in
tx
>>= fun tx_res ->
tl
>>= fun tl_res ->
match (tx_res, tl_res) with
| (Ok (), Ok ()) ->
Lwt.return_ok ()
| (Error exn1, Error exn2) ->
Lwt.return_error (exn1 @ exn2)
| (Ok (), Error exn) | (Error exn, Ok ()) ->
Lwt.return_error exn )
in
iteri2_p 0 f l1 l2
let rec fold_left_s f init l =
match l with
| [] ->
return init
| h :: t ->
f init h >>=? fun acc -> fold_left_s f acc t
let rec fold_right_s f l init =
match l with
| [] ->
return init
| h :: t ->
fold_right_s f t init >>=? fun acc -> f h acc
let rec join = function
| [] ->
return_unit
| t :: ts -> (
t
>>= function
| Error _ as err ->
join ts >>=? fun () -> Lwt.return err
| Ok () ->
join ts )
let record_trace err result =
match result with Ok _ as res -> res | Error errs -> Error (err :: errs)
let trace err f =
f
>>= function
| Error errs -> Lwt.return_error (err :: errs) | ok -> Lwt.return ok
let record_trace_eval mk_err result =
match result with
| Ok _ as res ->
res
| Error errs ->
mk_err () >>? fun err -> Error (err :: errs)
let trace_eval mk_err f =
f
>>= function
| Error errs ->
mk_err () >>=? fun err -> Lwt.return_error (err :: errs)
| ok ->
Lwt.return ok
let fail_unless cond exn = if cond then return_unit else fail exn
let fail_when cond exn = if cond then fail exn else return_unit
let unless cond f = if cond then return_unit else f ()
let _when cond f = if cond then f () else return_unit
type Error.error += Assert_error of string * string
let () =
Error.register_error_kind
`Permanent
~id:"assertion"
~title:"Assertion failure"
~description:"A fatal assertion failed"
~pp:(fun ppf (loc, msg) ->
Format.fprintf
ppf
"Assert failure (%s)%s"
loc
(if msg = "" then "." else ": " ^ msg))
Data_encoding.(obj2 (req "loc" string) (req "msg" string))
(function Assert_error (loc, msg) -> Some (loc, msg) | _ -> None)
(fun (loc, msg) -> Assert_error (loc, msg))
let _assert b loc fmt =
if b then Format.ikfprintf (fun _ -> return_unit) Format.str_formatter fmt
else Format.kasprintf (fun msg -> fail (Assert_error (loc, msg))) fmt
end
src/lib_error_monad/monad_maker.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Functors are not handled. *) functor
src/lib_error_monad/sig.ml 13 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Categories of error *)
type error_category =
[ `Branch (** Errors that may not happen in another context *)
| `Temporary (** Errors that may not happen in a later context *)
| `Permanent (** Errors that will happen no matter the context *) ]
let string_of_category = function
| `Permanent ->
"permanent"
| `Temporary ->
"temporary"
| `Branch ->
"branch"
module type PREFIX = sig
val id : string
end
module type CORE = sig
type error = ..
val error_encoding : error Data_encoding.t
val pp : Format.formatter -> error -> unit
(** The error data type is extensible. Each module can register specialized
error serializers
[id] unique name of this error. Ex.: overflow_time_counter
[title] more readable name. Ex.: Overflow of time counter
[description] human readable description. Ex.: The time counter overflowed while computing delta increase
[pp] formatter used to pretty print additional arguments. Ex.: The time counter overflowed while computing delta increase. Previous value %d. Delta: %d
[encoder] [decoder] data encoding for this error. If the error has no value, specify Data_encoding.empty
*)
val register_error_kind :
error_category ->
id:string ->
title:string ->
description:string ->
?pp:(Format.formatter -> 'err -> unit) ->
'err Data_encoding.t ->
(error -> 'err option) ->
('err -> error) ->
unit
(** Classify an error using the registered kinds *)
val classify_error : error -> error_category
end
module type EXT = sig
type error = ..
(** Catch all error when 'serializing' an error. *)
type error +=
private
| Unclassified of string
(** Catch all error when 'deserializing' an error. *)
type error += private Unregistred_error of Data_encoding.json
(** An error serializer *)
val json_of_error : error -> Data_encoding.json
val error_of_json : Data_encoding.json -> error
(** {2 Error documentation} *)
(** Error information *)
type error_info = {
category : error_category;
id : string;
title : string;
description : string;
schema : Data_encoding.json_schema;
}
val pp_info : Format.formatter -> error_info -> unit
(** Retrieves information of registered errors *)
val get_registered_errors : unit -> error_info list
end
module type WITH_WRAPPED = sig
type error
module type Wrapped_error_monad = sig
type unwrapped = ..
include CORE with type error := unwrapped
include EXT with type error := unwrapped
val unwrap : error -> unwrapped option
val wrap : unwrapped -> error
end
val register_wrapped_error_kind :
(module Wrapped_error_monad) ->
id:string ->
title:string ->
description:string ->
unit
end
module type MONAD = sig
(** This type is meant to be substituted/constrained. The intended use is
along the following lines:
[module Foo : sig
include CORE
include MONAD with type error := error
end = struct
...
end]
See core.mli and monad.mli as examples.
*)
type error
(** A [trace] is a stack of [error]s. It is implemented as an [error list]
but such a list MUST NEVER be empty.
It is implemented as a concrete [error list] for backwards compatibility
but future improvements might modify the type or render the type
abstract. *)
type trace = error list
(* NOTE: Right now we leave this [pp_print_error] named as is. Later on we
might rename it to [pp_print_trace]. *)
val pp_print_error : Format.formatter -> trace -> unit
val trace_encoding : trace Data_encoding.t
(* NOTE: Right now we leave this [classify_errors] named as is. Later on we
might rename it to [classify_trace]. *)
val classify_errors : trace -> error_category
(** The error monad wrapper type, the error case holds a stack of
error, initialized by the first call to {!fail} and completed by
each call to {!trace} as the stack is rewinded. The most general
error is thus at the top of the error stack, going down to the
specific error that actually caused the failure. *)
type 'a tzresult = ('a, trace) result
(** A serializer for result of a given type *)
val result_encoding : 'a Data_encoding.t -> 'a tzresult Data_encoding.t
(** Sucessful result *)
val ok : 'a -> 'a tzresult
(** Sucessful return *)
val return : 'a -> 'a tzresult Lwt.t
(** Sucessful return of [()] *)
val return_unit : unit tzresult Lwt.t
(** Sucessful return of [None] *)
val return_none : 'a option tzresult Lwt.t
(** [return_some x] is a sucessful return of [Some x] *)
val return_some : 'a -> 'a option tzresult Lwt.t
(** Sucessful return of [[]] *)
val return_nil : 'a list tzresult Lwt.t
(** Sucessful return of [true] *)
val return_true : bool tzresult Lwt.t
(** Sucessful return of [false] *)
val return_false : bool tzresult Lwt.t
(** Erroneous result *)
val error : error -> 'a tzresult
(** Erroneous return *)
val fail : error -> 'a tzresult Lwt.t
(** Non-Lwt bind operator *)
val ( >>? ) : 'a tzresult -> ('a -> 'b tzresult) -> 'b tzresult
(** Bind operator *)
val ( >>=? ) :
'a tzresult Lwt.t -> ('a -> 'b tzresult Lwt.t) -> 'b tzresult Lwt.t
(** Lwt's bind reexported *)
val ( >>= ) : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t
val ( >|= ) : 'a Lwt.t -> ('a -> 'b) -> 'b Lwt.t
(** To operator *)
val ( >>|? ) : 'a tzresult Lwt.t -> ('a -> 'b) -> 'b tzresult Lwt.t
(** Non-Lwt to operator *)
val ( >|? ) : 'a tzresult -> ('a -> 'b) -> 'b tzresult
(** Enrich an error report (or do nothing on a successful result) manually *)
val record_trace : error -> 'a tzresult -> 'a tzresult
(** Automatically enrich error reporting on stack rewind *)
val trace : error -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
(** Same as record_trace, for unevaluated error *)
val record_trace_eval :
(unit -> error tzresult) -> 'a tzresult -> 'a tzresult
(** Same as trace, for unevaluated Lwt error *)
val trace_eval :
(unit -> error tzresult Lwt.t) -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t
(** Erroneous return on failed assertion *)
val fail_unless : bool -> error -> unit tzresult Lwt.t
val fail_when : bool -> error -> unit tzresult Lwt.t
val unless : bool -> (unit -> unit tzresult Lwt.t) -> unit tzresult Lwt.t
val _when : bool -> (unit -> unit tzresult Lwt.t) -> unit tzresult Lwt.t
(* Usage: [_assert cond __LOC__ "<fmt>" ...] *)
val _assert :
bool ->
string ->
('a, Format.formatter, unit, unit tzresult Lwt.t) format4 ->
'a
(** {2 In-monad list iterators} *)
(** A {!List.iter} in the monad *)
val iter_s : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t
val iter_p : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t
val iteri_p :
(int -> 'a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t
val iter2_p :
('a -> 'b -> unit tzresult Lwt.t) ->
'a list ->
'b list ->
unit tzresult Lwt.t
val iteri2_p :
(int -> 'a -> 'b -> unit tzresult Lwt.t) ->
'a list ->
'b list ->
unit tzresult Lwt.t
(** A {!List.map} in the monad *)
val map_s : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
val rev_map_s :
('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
val map_p : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
val mapi_s :
(int -> 'a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
val mapi_p :
(int -> 'a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
(** A {!List.map2} in the monad *)
val map2 :
('a -> 'b -> 'c tzresult) -> 'a list -> 'b list -> 'c list tzresult
val map2_s :
('a -> 'b -> 'c tzresult Lwt.t) ->
'a list ->
'b list ->
'c list tzresult Lwt.t
val mapi2_s :
(int -> 'a -> 'b -> 'c tzresult Lwt.t) ->
'a list ->
'b list ->
'c list tzresult Lwt.t
(** A {!List.filter_map} in the monad *)
val filter_map_s :
('a -> 'b option tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
val filter_map_p :
('a -> 'b option tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
(** A {!List.filter} in the monad *)
val filter_s :
('a -> bool tzresult Lwt.t) -> 'a list -> 'a list tzresult Lwt.t
val filter_p :
('a -> bool tzresult Lwt.t) -> 'a list -> 'a list tzresult Lwt.t
(** A {!List.fold_left} in the monad *)
val fold_left_s :
('a -> 'b -> 'a tzresult Lwt.t) -> 'a -> 'b list -> 'a tzresult Lwt.t
(** A {!List.fold_right} in the monad *)
val fold_right_s :
('a -> 'b -> 'b tzresult Lwt.t) -> 'a list -> 'b -> 'b tzresult Lwt.t
(** A {!Lwt.join} in the monad *)
val join : unit tzresult Lwt.t list -> unit tzresult Lwt.t
end
src/lib_error_monad/sig.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition error_category := variant.
Definition string_of_category (function_parameter : variant) : string :=
match function_parameter with
| Permanent => "permanent" % string
| Temporary => "temporary" % string
| Branch => "branch" % string
end.
Module PREFIX.
Record signature := {
id : string;
}.
End PREFIX.
Module CORE.
Record signature {error : Type} := {
error := error;
error_encoding : Tezos_data_encoding.Data_encoding.t error;
pp : Stdlib.Format.formatter -> error -> unit;
register_error_kind : forall {err : Type}, error_category ->
string ->
string ->
string ->
(option (Stdlib.Format.formatter -> err -> unit)) ->
(Tezos_data_encoding.Data_encoding.t err) ->
(error -> option err) -> (err -> error) -> unit;
classify_error : error -> error_category;
}.
Arguments signature : clear implicits.
End CORE.
Module EXT.
Record signature {error error_info : Type} := {
error := error;
extensible_type;
extensible_type;
json_of_error : error -> Tezos_data_encoding.Data_encoding.json;
error_of_json : Tezos_data_encoding.Data_encoding.json -> error;
error_info := error_info;
pp_info : Stdlib.Format.formatter -> error_info -> unit;
get_registered_errors : unit -> list error_info;
}.
Arguments signature : clear implicits.
End EXT.
Module WITH_WRAPPED.
Record signature {error : Type} := {
error := error;
module_type;
register_wrapped_error_kind : {'(unwrapped, error_info) : _ &
Wrapped_error_monad.signature unwrapped error_info} ->
string -> string -> string -> unit;
}.
Arguments signature : clear implicits.
End WITH_WRAPPED.
Module MONAD.
Record signature {error : Type} := {
error := error;
trace := list error;
pp_print_error : Stdlib.Format.formatter -> trace -> unit;
trace_encoding : Tezos_data_encoding.Data_encoding.t trace;
classify_errors : trace -> error_category;
tzresult (a : Type) := sum a trace;
result_encoding : forall {a : Type}, (Tezos_data_encoding.Data_encoding.t a)
-> Tezos_data_encoding.Data_encoding.t (tzresult a);
ok : forall {a : Type}, a -> tzresult a;
_return : forall {a : Type}, a -> Lwt.t (tzresult a);
return_unit : Lwt.t (tzresult unit);
return_none : forall {a : Type}, Lwt.t (tzresult (option a));
return_some : forall {a : Type}, a -> Lwt.t (tzresult (option a));
return_nil : forall {a : Type}, Lwt.t (tzresult (list a));
return_true : Lwt.t (tzresult bool);
return_false : Lwt.t (tzresult bool);
error : forall {a : Type}, error -> tzresult a;
fail : forall {a : Type}, error -> Lwt.t (tzresult a);
op_gtgtquestion : forall {a b : Type}, (tzresult a) ->
(a -> tzresult b) -> tzresult b;
op_gtgteqquestion : forall {a b : Type}, (Lwt.t (tzresult a)) ->
(a -> Lwt.t (tzresult b)) -> Lwt.t (tzresult b);
op_gtgteq : forall {a b : Type}, (Lwt.t a) -> (a -> Lwt.t b) -> Lwt.t b;
op_gtpipeeq : forall {a b : Type}, (Lwt.t a) -> (a -> b) -> Lwt.t b;
op_gtgtpipequestion : forall {a b : Type}, (Lwt.t (tzresult a)) ->
(a -> b) -> Lwt.t (tzresult b);
op_gtpipequestion : forall {a b : Type}, (tzresult a) ->
(a -> b) -> tzresult b;
record_trace : forall {a : Type}, error -> (tzresult a) -> tzresult a;
trace : forall {b : Type}, error ->
(Lwt.t (tzresult b)) -> Lwt.t (tzresult b);
record_trace_eval : forall {a : Type}, (unit -> tzresult error) ->
(tzresult a) -> tzresult a;
trace_eval : forall {b : Type}, (unit -> Lwt.t (tzresult error)) ->
(Lwt.t (tzresult b)) -> Lwt.t (tzresult b);
fail_unless : bool -> error -> Lwt.t (tzresult unit);
fail_when : bool -> error -> Lwt.t (tzresult unit);
unless : bool -> (unit -> Lwt.t (tzresult unit)) -> Lwt.t (tzresult unit);
_when : bool -> (unit -> Lwt.t (tzresult unit)) -> Lwt.t (tzresult unit);
_assert : forall {a : Type}, bool ->
string ->
(Stdlib.format4 a Stdlib.Format.formatter unit (Lwt.t (tzresult unit)))
-> a;
iter_s : forall {a : Type}, (a -> Lwt.t (tzresult unit)) ->
(list a) -> Lwt.t (tzresult unit);
iter_p : forall {a : Type}, (a -> Lwt.t (tzresult unit)) ->
(list a) -> Lwt.t (tzresult unit);
iteri_p : forall {a : Type}, (Z -> a -> Lwt.t (tzresult unit)) ->
(list a) -> Lwt.t (tzresult unit);
iter2_p : forall {a b : Type}, (a -> b -> Lwt.t (tzresult unit)) ->
(list a) -> (list b) -> Lwt.t (tzresult unit);
iteri2_p : forall {a b : Type}, (Z -> a -> b -> Lwt.t (tzresult unit)) ->
(list a) -> (list b) -> Lwt.t (tzresult unit);
map_s : forall {a b : Type}, (a -> Lwt.t (tzresult b)) ->
(list a) -> Lwt.t (tzresult (list b));
rev_map_s : forall {a b : Type}, (a -> Lwt.t (tzresult b)) ->
(list a) -> Lwt.t (tzresult (list b));
map_p : forall {a b : Type}, (a -> Lwt.t (tzresult b)) ->
(list a) -> Lwt.t (tzresult (list b));
mapi_s : forall {a b : Type}, (Z -> a -> Lwt.t (tzresult b)) ->
(list a) -> Lwt.t (tzresult (list b));
mapi_p : forall {a b : Type}, (Z -> a -> Lwt.t (tzresult b)) ->
(list a) -> Lwt.t (tzresult (list b));
map2 : forall {a b c : Type}, (a -> b -> tzresult c) ->
(list a) -> (list b) -> tzresult (list c);
map2_s : forall {a b c : Type}, (a -> b -> Lwt.t (tzresult c)) ->
(list a) -> (list b) -> Lwt.t (tzresult (list c));
mapi2_s : forall {a b c : Type}, (Z -> a -> b -> Lwt.t (tzresult c)) ->
(list a) -> (list b) -> Lwt.t (tzresult (list c));
filter_map_s : forall {a b : Type}, (a -> Lwt.t (tzresult (option b))) ->
(list a) -> Lwt.t (tzresult (list b));
filter_map_p : forall {a b : Type}, (a -> Lwt.t (tzresult (option b))) ->
(list a) -> Lwt.t (tzresult (list b));
filter_s : forall {a : Type}, (a -> Lwt.t (tzresult bool)) ->
(list a) -> Lwt.t (tzresult (list a));
filter_p : forall {a : Type}, (a -> Lwt.t (tzresult bool)) ->
(list a) -> Lwt.t (tzresult (list a));
fold_left_s : forall {a b : Type}, (a -> b -> Lwt.t (tzresult a)) ->
a -> (list b) -> Lwt.t (tzresult a);
fold_right_s : forall {a b : Type}, (a -> b -> Lwt.t (tzresult b)) ->
(list a) -> b -> Lwt.t (tzresult b);
join : (list (Lwt.t (tzresult unit))) -> Lwt.t (tzresult unit);
}.
Arguments signature : clear implicits.
End MONAD.
src/lib_error_monad/test/assert.ml success
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) let fail expected given msg = Format.kasprintf failwith "@[%s@ expected: %s@ got: %s@]" msg expected given let fail_msg fmt = Format.kasprintf (fail "" "") fmt let default_printer _ = "" let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y = if not (eq x y) then fail (prn x) (prn y) msg
src/lib_error_monad/test/assert.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition fail {A : Type} (expected : string) (given : string) (msg : string)
: A :=
Format.kasprintf OCaml.Stdlib.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "expected: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "got: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[%s@ expected: %s@ got: %s@]" % string) msg expected given.
Definition fail_msg {A B : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
Format.kasprintf (fail "" % string "" % string) fmt.
Definition default_printer {A : Type} (function_parameter : A) : string :=
let '_ := function_parameter in
"" % string.
Definition equal {A : Type} (op_staroptstar : option (A -> A -> bool))
: (option (A -> string)) -> (option string) -> A -> A -> unit :=
let eq :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => equiv_decb
end in
fun op_staroptstar =>
let prn :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_printer
end in
fun op_staroptstar =>
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
fun y =>
if negb (eq x y) then
fail (prn x) (prn y) msg
else
tt.
src/lib_error_monad/test/test_error_tables.ml 37 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Lwt.Infix
module IntErrorTable = Error_table.Make (Hashtbl.Make (struct
type t = int
let equal x y = x = y
let hash x = x
end))
let test_add_remove _ _ =
let t = IntErrorTable.create 2 in
IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0)
>>= function
| Error _ ->
Assert.fail "Ok 0" "Error _" "find_or_make"
| Ok n -> (
if not (n = 0) then
Assert.fail "Ok 0" (Format.asprintf "Ok %d" n) "find_or_make"
else
match IntErrorTable.find_opt t 0 with
| None ->
Assert.fail "Some (Ok 0)" "None" "find_opt"
| Some p -> (
p
>>= function
| Error _ ->
Assert.fail "Some (Ok 0)" "Some (Error _)" "find_opt"
| Ok n ->
if not (n = 0) then
Assert.fail
"Some (Ok 0)"
(Format.asprintf "Some (Ok %d)" n)
"find_opt"
else (
IntErrorTable.remove t 0 ;
match IntErrorTable.find_opt t 0 with
| Some _ ->
Assert.fail "None" "Some _" "remove;find_opt"
| None ->
Lwt.return_unit ) ) )
let test_add_add _ _ =
let t = IntErrorTable.create 2 in
IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0)
>>= fun _ ->
IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 1)
>>= fun _ ->
match IntErrorTable.find_opt t 0 with
| None ->
Assert.fail "Some (Ok 0)" "None" "find_opt"
| Some p -> (
p
>>= function
| Error _ ->
Assert.fail "Some (Ok 0)" "Some (Error _)" "find_opt"
| Ok n ->
if not (n = 0) then
Assert.fail
"Some (Ok 0)"
(Format.asprintf "Some (Ok %d)" n)
"find_opt"
else Lwt.return_unit )
let test_length _ _ =
let t = IntErrorTable.create 2 in
IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0)
>>= fun _ ->
IntErrorTable.find_or_make t 1 (fun () -> Error_monad.return 1)
>>= fun _ ->
IntErrorTable.find_or_make t 2 (fun () -> Error_monad.return 2)
>>= fun _ ->
IntErrorTable.find_or_make t 3 (fun () -> Error_monad.return 3)
>>= fun _ ->
let l = IntErrorTable.length t in
if not (l = 4) then Assert.fail "4" (Format.asprintf "%d" l) "length"
else Lwt.return_unit
let test_self_clean _ _ =
let t = IntErrorTable.create 2 in
IntErrorTable.find_or_make t 0 (fun () -> Lwt.return (Ok 0))
>>= fun _ ->
IntErrorTable.find_or_make t 1 (fun () -> Lwt.return (Error []))
>>= fun _ ->
IntErrorTable.find_or_make t 2 (fun () -> Lwt.return (Error []))
>>= fun _ ->
IntErrorTable.find_or_make t 3 (fun () -> Lwt.return (Ok 3))
>>= fun _ ->
IntErrorTable.find_or_make t 4 (fun () -> Lwt.return (Ok 4))
>>= fun _ ->
IntErrorTable.find_or_make t 5 (fun () -> Lwt.return (Error []))
>>= fun _ ->
let l = IntErrorTable.length t in
if not (l = 3) then Assert.fail "3" (Format.asprintf "%d" l) "length"
else Lwt.return_unit
let test_order _ _ =
let t = IntErrorTable.create 2 in
let (wter, wker) = Lwt.task () in
let world = ref [] in
(* PROMISE A *)
let p_a =
IntErrorTable.find_or_make t 0 (fun () ->
wter
>>= fun r ->
world := "a_inner" :: !world ;
Lwt.return r)
>>= fun r_a ->
world := "a_outer" :: !world ;
Lwt.return r_a
in
Lwt_main.yield ()
>>= fun () ->
(* PROMISE B *)
let p_b =
IntErrorTable.find_or_make t 0 (fun () ->
world := "b_inner" :: !world ;
Lwt.return (Ok 1024))
>>= fun r_b ->
world := "b_outer" :: !world ;
Lwt.return r_b
in
Lwt_main.yield ()
>>= fun () ->
(* Wake up A *)
Lwt.wakeup wker (Ok 0) ;
(* Check that both A and B get expected results *)
p_a
>>= (function
| Error _ ->
Assert.fail "Ok 0" "Error _" "find_or_make(a)"
| Ok n ->
if not (n = 0) then
Assert.fail "Ok 0" (Format.asprintf "Ok %d" n) "find_or_make(a)"
else Lwt.return_unit)
>>= fun () ->
p_b
>>= (function
| Error _ ->
Assert.fail "Ok 0" "Error _" "find_or_make(b)"
| Ok n ->
if not (n = 0) then
Assert.fail "Ok 0" (Format.asprintf "Ok %d" n) "find_or_make(b)"
else Lwt.return_unit)
>>= fun () ->
(* Check that the `world` record is as expected *)
match !world with
| ["b_outer"; "a_outer"; "a_inner"] | ["a_outer"; "b_outer"; "a_inner"] ->
Lwt.return ()
| world ->
Assert.fail
"[outers;a_inner]"
Format.(asprintf "[%a]" (pp_print_list pp_print_string) world)
"world"
let tests =
[ Alcotest_lwt.test_case "add_remove" `Quick test_add_remove;
Alcotest_lwt.test_case "add_add" `Quick test_add_add;
Alcotest_lwt.test_case "length" `Quick test_length;
Alcotest_lwt.test_case "self_clean" `Quick test_length;
Alcotest_lwt.test_case "order" `Quick test_order ]
let () = Alcotest.run "error_tables" [("error_tables", tests)]
src/lib_error_monad/test/test_error_tables.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition test_add_remove {A B : Type} (function_parameter : A)
: B -> Lwt.t unit :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
let t := IntErrorTable.create 2 in
op_gtgteq
(IntErrorTable.find_or_make t 0
(fun function_parameter =>
let 'tt := function_parameter in
Error_monad._return 0))
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ =>
op_startypeminuserrorstar "Ok 0" % string "Error _" % string
"find_or_make" % string
| Stdlib.Ok n =>
if negb (equiv_decb n 0) then
op_startypeminuserrorstar "Ok 0" % string
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Ok " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "Ok %d" % string)
n) "find_or_make" % string
else
match IntErrorTable.find_opt t 0 with
| None =>
op_startypeminuserrorstar "Some (Ok 0)" % string "None" % string
"find_opt" % string
| Some p =>
op_gtgteq p
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ =>
op_startypeminuserrorstar "Some (Ok 0)" % string
"Some (Error _)" % string "find_opt" % string
| Stdlib.Ok n =>
if negb (equiv_decb n 0) then
op_startypeminuserrorstar "Some (Ok 0)" % string
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Some (Ok " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))
"Some (Ok %d)" % string) n) "find_opt" % string
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := IntErrorTable.remove t 0 in
match IntErrorTable.find_opt t 0 with
| Some _ =>
op_startypeminuserrorstar "None" % string
"Some _" % string "remove;find_opt" % string
| None => Lwt.return_unit
end
end)
end
end).
Definition test_add_add {A B : Type} (function_parameter : A)
: B -> Lwt.t unit :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
let t := IntErrorTable.create 2 in
op_gtgteq
(IntErrorTable.find_or_make t 0
(fun function_parameter =>
let 'tt := function_parameter in
Error_monad._return 0))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(IntErrorTable.find_or_make t 0
(fun function_parameter =>
let 'tt := function_parameter in
Error_monad._return 1))
(fun function_parameter =>
let '_ := function_parameter in
match IntErrorTable.find_opt t 0 with
| None =>
op_startypeminuserrorstar "Some (Ok 0)" % string "None" % string
"find_opt" % string
| Some p =>
op_gtgteq p
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ =>
op_startypeminuserrorstar "Some (Ok 0)" % string
"Some (Error _)" % string "find_opt" % string
| Stdlib.Ok n =>
if negb (equiv_decb n 0) then
op_startypeminuserrorstar "Some (Ok 0)" % string
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Some (Ok " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))
"Some (Ok %d)" % string) n) "find_opt" % string
else
Lwt.return_unit
end)
end)).
Definition test_length {A B : Type} (function_parameter : A)
: B -> Lwt.t unit :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
let t := IntErrorTable.create 2 in
op_gtgteq
(IntErrorTable.find_or_make t 0
(fun function_parameter =>
let 'tt := function_parameter in
Error_monad._return 0))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(IntErrorTable.find_or_make t 1
(fun function_parameter =>
let 'tt := function_parameter in
Error_monad._return 1))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(IntErrorTable.find_or_make t 2
(fun function_parameter =>
let 'tt := function_parameter in
Error_monad._return 2))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(IntErrorTable.find_or_make t 3
(fun function_parameter =>
let 'tt := function_parameter in
Error_monad._return 3))
(fun function_parameter =>
let '_ := function_parameter in
let l := IntErrorTable.length t in
if negb (equiv_decb l 4) then
op_startypeminuserrorstar "4" % string
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)
"%d" % string) l) "length" % string
else
Lwt.return_unit)))).
Definition test_self_clean {A B : Type} (function_parameter : A)
: B -> Lwt.t unit :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
let t := IntErrorTable.create 2 in
op_gtgteq
(IntErrorTable.find_or_make t 0
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return (Stdlib.Ok 0)))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(IntErrorTable.find_or_make t 1
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return (Stdlib.Error [])))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(IntErrorTable.find_or_make t 2
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return (Stdlib.Error [])))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(IntErrorTable.find_or_make t 3
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return (Stdlib.Ok 3)))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(IntErrorTable.find_or_make t 4
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return (Stdlib.Ok 4)))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(IntErrorTable.find_or_make t 5
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return (Stdlib.Error [])))
(fun function_parameter =>
let '_ := function_parameter in
let l := IntErrorTable.length t in
if negb (equiv_decb l 3) then
op_startypeminuserrorstar "3" % string
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)
"%d" % string) l) "length" % string
else
Lwt.return_unit)))))).
Definition test_order {A B : Type} (function_parameter : A) : B -> Lwt.t unit :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
let t := IntErrorTable.create 2 in
let '(wter, wker) := Lwt.task tt in
let world := Stdlib.ref [] in
let p_a :=
op_gtgteq
(IntErrorTable.find_or_make t 0
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq wter
(fun r =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq world
(cons "a_inner" % string (Stdlib.op_exclamation world)) in
Lwt._return r)))
(fun r_a =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq world
(cons "a_outer" % string (Stdlib.op_exclamation world)) in
Lwt._return r_a) in
op_gtgteq (op_startypeminuserrorstar tt)
(fun function_parameter =>
let 'tt := function_parameter in
let p_b :=
op_gtgteq
(IntErrorTable.find_or_make t 0
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq world
(cons "b_inner" % string (Stdlib.op_exclamation world)) in
Lwt._return (Stdlib.Ok 1024)))
(fun r_b =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq world
(cons "b_outer" % string (Stdlib.op_exclamation world)) in
Lwt._return r_b) in
op_gtgteq (op_startypeminuserrorstar tt)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt.wakeup wker (Stdlib.Ok 0) in
op_gtgteq
(op_gtgteq p_a
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ =>
op_startypeminuserrorstar "Ok 0" % string "Error _" % string
"find_or_make(a)" % string
| Stdlib.Ok n =>
if negb (equiv_decb n 0) then
op_startypeminuserrorstar "Ok 0" % string
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Ok " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"Ok %d" % string) n) "find_or_make(a)" % string
else
Lwt.return_unit
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtgteq p_b
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ =>
op_startypeminuserrorstar "Ok 0" % string
"Error _" % string "find_or_make(b)" % string
| Stdlib.Ok n =>
if negb (equiv_decb n 0) then
op_startypeminuserrorstar "Ok 0" % string
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Ok " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"Ok %d" % string) n) "find_or_make(b)" % string
else
Lwt.return_unit
end))
(fun function_parameter =>
let 'tt := function_parameter in
match Stdlib.op_exclamation world with
|
cons "b_outer" % string
(cons "a_outer" % string (cons "a_inner" % string [])) |
cons "a_outer" % string
(cons "b_outer" % string (cons "a_inner" % string []))
=> Lwt._return tt
| world =>
op_startypeminuserrorstar "[outers;a_inner]" % string
(asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"]" % char
CamlinternalFormatBasics.End_of_format)))
"[%a]" % string)
(pp_print_list None pp_print_string) world)
"world" % string
end)))).
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "add_remove" % string
(* ❌ Variants not supported *)
variant test_add_remove)
(cons
(op_startypeminuserrorstar "add_add" % string
(* ❌ Variants not supported *)
variant test_add_add)
(cons
(op_startypeminuserrorstar "length" % string
(* ❌ Variants not supported *)
variant test_length)
(cons
(op_startypeminuserrorstar "self_clean" % string
(* ❌ Variants not supported *)
variant test_length)
(cons
(op_startypeminuserrorstar "order" % string
(* ❌ Variants not supported *)
variant test_order) [])))).
src/lib_micheline/micheline.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type annot = string list
type ('l, 'p) node =
| Int of 'l * Z.t
| String of 'l * string
| Bytes of 'l * Bytes.t
| Prim of 'l * 'p * ('l, 'p) node list * annot
| Seq of 'l * ('l, 'p) node list
type canonical_location = int
type 'p canonical = Canonical of (canonical_location, 'p) node
let canonical_location_encoding =
let open Data_encoding in
def
"micheline.location"
~title:"Canonical location in a Micheline expression"
~description:
"The location of a node in a Micheline expression tree in prefix order, \
with zero being the root and adding one for every basic node, sequence \
and primitive application."
@@ int31
let location = function
| Int (loc, _) ->
loc
| String (loc, _) ->
loc
| Bytes (loc, _) ->
loc
| Seq (loc, _) ->
loc
| Prim (loc, _, _, _) ->
loc
let annotations = function
| Int (_, _) ->
[]
| String (_, _) ->
[]
| Bytes (_, _) ->
[]
| Seq (_, _) ->
[]
| Prim (_, _, _, annots) ->
annots
let root (Canonical expr) = expr
let strip_locations root =
let id =
let id = ref (-1) in
fun () -> incr id ; !id
in
let rec strip_locations l =
let id = id () in
match l with
| Int (_, v) ->
Int (id, v)
| String (_, v) ->
String (id, v)
| Bytes (_, v) ->
Bytes (id, v)
| Seq (_, seq) ->
Seq (id, List.map strip_locations seq)
| Prim (_, name, seq, annots) ->
Prim (id, name, List.map strip_locations seq, annots)
in
Canonical (strip_locations root)
let extract_locations root =
let id =
let id = ref (-1) in
fun () -> incr id ; !id
in
let loc_table = ref [] in
let rec strip_locations l =
let id = id () in
match l with
| Int (loc, v) ->
loc_table := (id, loc) :: !loc_table ;
Int (id, v)
| String (loc, v) ->
loc_table := (id, loc) :: !loc_table ;
String (id, v)
| Bytes (loc, v) ->
loc_table := (id, loc) :: !loc_table ;
Bytes (id, v)
| Seq (loc, seq) ->
loc_table := (id, loc) :: !loc_table ;
Seq (id, List.map strip_locations seq)
| Prim (loc, name, seq, annots) ->
loc_table := (id, loc) :: !loc_table ;
Prim (id, name, List.map strip_locations seq, annots)
in
let stripped = strip_locations root in
(Canonical stripped, List.rev !loc_table)
let inject_locations lookup (Canonical root) =
let rec inject_locations l =
match l with
| Int (loc, v) ->
Int (lookup loc, v)
| String (loc, v) ->
String (lookup loc, v)
| Bytes (loc, v) ->
Bytes (lookup loc, v)
| Seq (loc, seq) ->
Seq (lookup loc, List.map inject_locations seq)
| Prim (loc, name, seq, annots) ->
Prim (lookup loc, name, List.map inject_locations seq, annots)
in
inject_locations root
let map f (Canonical expr) =
let rec map_node f = function
| (Int _ | String _ | Bytes _) as node ->
node
| Seq (loc, seq) ->
Seq (loc, List.map (map_node f) seq)
| Prim (loc, name, seq, annots) ->
Prim (loc, f name, List.map (map_node f) seq, annots)
in
Canonical (map_node f expr)
let rec map_node fl fp = function
| Int (loc, v) ->
Int (fl loc, v)
| String (loc, v) ->
String (fl loc, v)
| Bytes (loc, v) ->
Bytes (fl loc, v)
| Seq (loc, seq) ->
Seq (fl loc, List.map (map_node fl fp) seq)
| Prim (loc, name, seq, annots) ->
Prim (fl loc, fp name, List.map (map_node fl fp) seq, annots)
type semantics = V0 | V1
let internal_canonical_encoding ~semantics ~variant prim_encoding =
let open Data_encoding in
let int_encoding = obj1 (req "int" z) in
let string_encoding = obj1 (req "string" string) in
let bytes_encoding = obj1 (req "bytes" bytes) in
let int_encoding tag =
case
tag
int_encoding
~title:"Int"
(function Int (_, v) -> Some v | _ -> None)
(fun v -> Int (0, v))
in
let string_encoding tag =
case
tag
string_encoding
~title:"String"
(function String (_, v) -> Some v | _ -> None)
(fun v -> String (0, v))
in
let bytes_encoding tag =
case
tag
bytes_encoding
~title:"Bytes"
(function Bytes (_, v) -> Some v | _ -> None)
(fun v -> Bytes (0, v))
in
let seq_encoding tag expr_encoding =
case
tag
(list expr_encoding)
~title:"Sequence"
(function Seq (_, v) -> Some v | _ -> None)
(fun args -> Seq (0, args))
in
let annots_encoding =
let split s =
if s = "" && semantics <> V0 then []
else
let annots = String.split_on_char ' ' s in
List.iter
(fun a ->
if String.length a > 255 then failwith "Oversized annotation")
annots ;
if String.concat " " annots <> s then
failwith
"Invalid annotation string, must be a sequence of valid \
annotations with spaces" ;
annots
in
splitted
~json:(list (Bounded.string 255))
~binary:(conv (String.concat " ") split string)
in
let application_encoding tag expr_encoding =
case
tag
~title:"Generic prim (any number of args with or without annot)"
(obj3
(req "prim" prim_encoding)
(dft "args" (list expr_encoding) [])
(dft "annots" annots_encoding []))
(function
| Prim (_, prim, args, annots) -> Some (prim, args, annots) | _ -> None)
(fun (prim, args, annots) -> Prim (0, prim, args, annots))
in
let node_encoding =
mu
("micheline." ^ variant ^ ".expression")
(fun expr_encoding ->
splitted
~json:
(union
~tag_size:`Uint8
[ int_encoding Json_only;
string_encoding Json_only;
bytes_encoding Json_only;
seq_encoding Json_only expr_encoding;
application_encoding Json_only expr_encoding ])
~binary:
(union
~tag_size:`Uint8
[ int_encoding (Tag 0);
string_encoding (Tag 1);
seq_encoding (Tag 2) expr_encoding;
(* No args, no annot *)
case
(Tag 3)
~title:"Prim (no args, annot)"
(obj1 (req "prim" prim_encoding))
(function Prim (_, v, [], []) -> Some v | _ -> None)
(fun v -> Prim (0, v, [], []));
(* No args, with annots *)
case
(Tag 4)
~title:"Prim (no args + annot)"
(obj2
(req "prim" prim_encoding)
(req "annots" annots_encoding))
(function
| Prim (_, v, [], annots) -> Some (v, annots) | _ -> None)
(function (prim, annots) -> Prim (0, prim, [], annots));
(* Single arg, no annot *)
case
(Tag 5)
~title:"Prim (1 arg, no annot)"
(obj2 (req "prim" prim_encoding) (req "arg" expr_encoding))
(function
| Prim (_, v, [arg], []) -> Some (v, arg) | _ -> None)
(function (prim, arg) -> Prim (0, prim, [arg], []));
(* Single arg, with annot *)
case
(Tag 6)
~title:"Prim (1 arg + annot)"
(obj3
(req "prim" prim_encoding)
(req "arg" expr_encoding)
(req "annots" annots_encoding))
(function
| Prim (_, prim, [arg], annots) ->
Some (prim, arg, annots)
| _ ->
None)
(fun (prim, arg, annots) -> Prim (0, prim, [arg], annots));
(* Two args, no annot *)
case
(Tag 7)
~title:"Prim (2 args, no annot)"
(obj3
(req "prim" prim_encoding)
(req "arg1" expr_encoding)
(req "arg2" expr_encoding))
(function
| Prim (_, prim, [arg1; arg2], []) ->
Some (prim, arg1, arg2)
| _ ->
None)
(fun (prim, arg1, arg2) -> Prim (0, prim, [arg1; arg2], []));
(* Two args, with annots *)
case
(Tag 8)
~title:"Prim (2 args + annot)"
(obj4
(req "prim" prim_encoding)
(req "arg1" expr_encoding)
(req "arg2" expr_encoding)
(req "annots" annots_encoding))
(function
| Prim (_, prim, [arg1; arg2], annots) ->
Some (prim, arg1, arg2, annots)
| _ ->
None)
(fun (prim, arg1, arg2, annots) ->
Prim (0, prim, [arg1; arg2], annots));
(* General case *)
application_encoding (Tag 9) expr_encoding;
bytes_encoding (Tag 10) ]))
in
conv
(function Canonical node -> node)
(fun node -> strip_locations node)
node_encoding
let canonical_encoding ~variant prim_encoding =
internal_canonical_encoding ~semantics:V1 ~variant prim_encoding
let canonical_encoding_v1 ~variant prim_encoding =
internal_canonical_encoding ~semantics:V1 ~variant prim_encoding
let canonical_encoding_v0 ~variant prim_encoding =
internal_canonical_encoding ~semantics:V0 ~variant prim_encoding
let table_encoding ~variant location_encoding prim_encoding =
let open Data_encoding in
conv
(fun node ->
let (canon, assoc) = extract_locations node in
let (_, table) = List.split assoc in
(canon, table))
(fun (canon, table) ->
let table = Array.of_list table in
inject_locations (fun i -> table.(i)) canon)
(obj2
(req "expression" (canonical_encoding ~variant prim_encoding))
(req "locations" (list location_encoding)))
let erased_encoding ~variant default_location prim_encoding =
let open Data_encoding in
conv
(fun node -> strip_locations node)
(fun canon -> inject_locations (fun _ -> default_location) canon)
(canonical_encoding ~variant prim_encoding)
src/lib_micheline/micheline.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition annot := list string.
Inductive node (l p : Type) : Type :=
| Int : l -> Z.t -> node l p
| String : l -> string -> node l p
| Bytes : l -> Stdlib.Bytes.t -> node l p
| Prim : l -> p -> (list (node l p)) -> annot -> node l p
| Seq : l -> (list (node l p)) -> node l p.
Arguments Int {_ _}.
Arguments String {_ _}.
Arguments Bytes {_ _}.
Arguments Prim {_ _}.
Arguments Seq {_ _}.
Definition canonical_location := Z.
Inductive canonical (p : Type) : Type :=
| Canonical : (node canonical_location p) -> canonical p.
Arguments Canonical {_}.
Definition canonical_location_encoding
: Tezos_data_encoding.Data_encoding.encoding Z :=
apply
(def "micheline.location" % string
(Some "Canonical location in a Micheline expression" % string)
(Some
"The location of a node in a Micheline expression tree in prefix order, with zero being the root and adding one for every basic node, sequence and primitive application."
% string)) int31.
Definition location {A B : Type} (function_parameter : node A B) : A :=
match function_parameter with
| Int loc _ => loc
| String loc _ => loc
| Bytes loc _ => loc
| Seq loc _ => loc
| Prim loc _ _ _ => loc
end.
Definition annotations {A B : Type} (function_parameter : node A B) : annot :=
match function_parameter with
| Int _ _ => []
| String _ _ => []
| Bytes _ _ => []
| Seq _ _ => []
| Prim _ _ _ annots => annots
end.
Definition root {A : Type} (function_parameter : canonical A)
: node canonical_location A :=
let 'Canonical expr := function_parameter in
expr.
Definition strip_locations {A B : Type} (root : node A B) : canonical B :=
let id :=
let id := Stdlib.ref (-1) in
fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.incr id in
Stdlib.op_exclamation id in
let fix strip_locations {C D : Type} (l : node C D) : node Z D :=
let id := id tt in
match l with
| Int _ v => Int id v
| String _ v => String id v
| Bytes _ v => Bytes id v
| Seq _ seq => Seq id (List.map strip_locations seq)
| Prim _ name seq annots =>
Prim id name (List.map strip_locations seq) annots
end in
Canonical (strip_locations root).
Definition extract_locations {A B : Type} (root : node A B)
: (canonical B) * (list (Z * A)) :=
let id :=
let id := Stdlib.ref (-1) in
fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.incr id in
Stdlib.op_exclamation id in
let loc_table := Stdlib.ref [] in
let fix strip_locations {C : Type} (l : node A C) : node Z C :=
let id := id tt in
match l with
| Int loc v =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq loc_table
(cons (id, loc) (Stdlib.op_exclamation loc_table)) in
Int id v
| String loc v =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq loc_table
(cons (id, loc) (Stdlib.op_exclamation loc_table)) in
String id v
| Bytes loc v =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq loc_table
(cons (id, loc) (Stdlib.op_exclamation loc_table)) in
Bytes id v
| Seq loc seq =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq loc_table
(cons (id, loc) (Stdlib.op_exclamation loc_table)) in
Seq id (List.map strip_locations seq)
| Prim loc name seq annots =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq loc_table
(cons (id, loc) (Stdlib.op_exclamation loc_table)) in
Prim id name (List.map strip_locations seq) annots
end in
let stripped := strip_locations root in
((Canonical stripped), (List.rev (Stdlib.op_exclamation loc_table))).
Definition inject_locations {A B : Type}
(lookup : canonical_location -> A) (function_parameter : canonical B)
: node A B :=
let 'Canonical root := function_parameter in
let fix inject_locations {C : Type} (l : node canonical_location C)
: node A C :=
match l with
| Int loc v => Int (lookup loc) v
| String loc v => String (lookup loc) v
| Bytes loc v => Bytes (lookup loc) v
| Seq loc seq => Seq (lookup loc) (List.map inject_locations seq)
| Prim loc name seq annots =>
Prim (lookup loc) name (List.map inject_locations seq) annots
end in
inject_locations root.
Definition map {A B : Type} (f : A -> B) (function_parameter : canonical A)
: canonical B :=
let 'Canonical expr := function_parameter in
let fix map_node {C D E : Type} (f : C -> D) (function_parameter : node E C)
: node E D :=
match function_parameter with
| (Int _ _ | String _ _ | Bytes _ _) as node => node
| Seq loc seq => Seq loc (List.map (map_node f) seq)
| Prim loc name seq annots =>
Prim loc (f name) (List.map (map_node f) seq) annots
end in
Canonical (map_node f expr).
Fixpoint map_node {A B C D : Type}
(fl : A -> B) (fp : C -> D) (function_parameter : node A C) : node B D :=
match function_parameter with
| Int loc v => Int (fl loc) v
| String loc v => String (fl loc) v
| Bytes loc v => Bytes (fl loc) v
| Seq loc seq => Seq (fl loc) (List.map (map_node fl fp) seq)
| Prim loc name seq annots =>
Prim (fl loc) (fp name) (List.map (map_node fl fp) seq) annots
end.
Inductive semantics : Type :=
| V0 : semantics
| V1 : semantics.
Definition internal_canonical_encoding {A : Type}
(semantics : semantics) (variant : string)
(prim_encoding : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding (canonical A) :=
let int_encoding := obj1 (req None None "int" % string z) in
let string_encoding := obj1 (req None None "string" % string string) in
let bytes_encoding := obj1 (req None None "bytes" % string bytes) in
let int_encoding {B : Type} (tag : Tezos_data_encoding.Data_encoding.case_tag)
: Tezos_data_encoding.Data_encoding.case (node Z B) :=
case "Int" % string None tag int_encoding
(fun function_parameter =>
match function_parameter with
| Int _ v => Some v
| _ => None
end) (fun v => Int 0 v) in
let string_encoding {B : Type}
(tag : Tezos_data_encoding.Data_encoding.case_tag)
: Tezos_data_encoding.Data_encoding.case (node Z B) :=
case "String" % string None tag string_encoding
(fun function_parameter =>
match function_parameter with
| String _ v => Some v
| _ => None
end) (fun v => String 0 v) in
let bytes_encoding {B : Type}
(tag : Tezos_data_encoding.Data_encoding.case_tag)
: Tezos_data_encoding.Data_encoding.case (node Z B) :=
case "Bytes" % string None tag bytes_encoding
(fun function_parameter =>
match function_parameter with
| Bytes _ v => Some v
| _ => None
end) (fun v => Bytes 0 v) in
let seq_encoding {B : Type}
(tag : Tezos_data_encoding.Data_encoding.case_tag) (expr_encoding :
Tezos_data_encoding.Data_encoding.encoding (node Z B))
: Tezos_data_encoding.Data_encoding.case (node Z B) :=
case "Sequence" % string None tag (list None expr_encoding)
(fun function_parameter =>
match function_parameter with
| Seq _ v => Some v
| _ => None
end) (fun args => Seq 0 args) in
let annots_encoding :=
let split (s : string) : list string :=
if andb (equiv_decb s "" % string) (nequiv_decb semantics V0) then
[]
else
let annots := Stdlib.String.split_on_char " " % char s in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.List.iter
(fun a =>
if OCaml.Stdlib.gt (OCaml.String.length a) 255 then
OCaml.Stdlib.failwith "Oversized annotation" % string
else
tt) annots in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb (Stdlib.String.concat " " % string annots) s then
OCaml.Stdlib.failwith
"Invalid annotation string, must be a sequence of valid annotations with spaces"
% string
else
tt in
annots in
splitted (list None (Bounded.string 255))
(conv (Stdlib.String.concat " " % string) split None string) in
let application_encoding
(tag : Tezos_data_encoding.Data_encoding.case_tag) (expr_encoding :
Tezos_data_encoding.Data_encoding.encoding (node Z A))
: Tezos_data_encoding.Data_encoding.case (node Z A) :=
case "Generic prim (any number of args with or without annot)" % string None
tag
(obj3 (req None None "prim" % string prim_encoding)
(dft None None "args" % string (list None expr_encoding) [])
(dft None None "annots" % string annots_encoding []))
(fun function_parameter =>
match function_parameter with
| Prim _ prim args annots => Some (prim, args, annots)
| _ => None
end)
(fun function_parameter =>
let '(prim, args, annots) := function_parameter in
Prim 0 prim args annots) in
let node_encoding :=
mu
(String.append "micheline." % string
(String.append variant ".expression" % string)) None None
(fun expr_encoding =>
splitted
(union
(Some
(* ❌ Variants not supported *)
variant)
(cons (int_encoding Tezos_data_encoding.Data_encoding.Json_only)
(cons
(string_encoding Tezos_data_encoding.Data_encoding.Json_only)
(cons
(bytes_encoding Tezos_data_encoding.Data_encoding.Json_only)
(cons
(seq_encoding Tezos_data_encoding.Data_encoding.Json_only
expr_encoding)
(cons
(application_encoding
Tezos_data_encoding.Data_encoding.Json_only
expr_encoding) []))))))
(union
(Some
(* ❌ Variants not supported *)
variant)
(cons (int_encoding (Tezos_data_encoding.Data_encoding.Tag 0))
(cons (string_encoding (Tezos_data_encoding.Data_encoding.Tag 1))
(cons
(seq_encoding (Tezos_data_encoding.Data_encoding.Tag 2)
expr_encoding)
(cons
(case "Prim (no args, annot)" % string None
(Tezos_data_encoding.Data_encoding.Tag 3)
(obj1 (req None None "prim" % string prim_encoding))
(fun function_parameter =>
match function_parameter with
| Prim _ v [] [] => Some v
| _ => None
end) (fun v => Prim 0 v [] []))
(cons
(case "Prim (no args + annot)" % string None
(Tezos_data_encoding.Data_encoding.Tag 4)
(obj2 (req None None "prim" % string prim_encoding)
(req None None "annots" % string annots_encoding))
(fun function_parameter =>
match function_parameter with
| Prim _ v [] annots => Some (v, annots)
| _ => None
end)
(fun function_parameter =>
let '(prim, annots) := function_parameter in
Prim 0 prim [] annots))
(cons
(case "Prim (1 arg, no annot)" % string None
(Tezos_data_encoding.Data_encoding.Tag 5)
(obj2 (req None None "prim" % string prim_encoding)
(req None None "arg" % string expr_encoding))
(fun function_parameter =>
match function_parameter with
| Prim _ v (cons arg []) [] => Some (v, arg)
| _ => None
end)
(fun function_parameter =>
let '(prim, arg) := function_parameter in
Prim 0 prim (cons arg []) []))
(cons
(case "Prim (1 arg + annot)" % string None
(Tezos_data_encoding.Data_encoding.Tag 6)
(obj3 (req None None "prim" % string prim_encoding)
(req None None "arg" % string expr_encoding)
(req None None "annots" % string annots_encoding))
(fun function_parameter =>
match function_parameter with
| Prim _ prim (cons arg []) annots =>
Some (prim, arg, annots)
| _ => None
end)
(fun function_parameter =>
let '(prim, arg, annots) := function_parameter in
Prim 0 prim (cons arg []) annots))
(cons
(case "Prim (2 args, no annot)" % string None
(Tezos_data_encoding.Data_encoding.Tag 7)
(obj3
(req None None "prim" % string prim_encoding)
(req None None "arg1" % string expr_encoding)
(req None None "arg2" % string expr_encoding))
(fun function_parameter =>
match function_parameter with
| Prim _ prim (cons arg1 (cons arg2 [])) [] =>
Some (prim, arg1, arg2)
| _ => None
end)
(fun function_parameter =>
let '(prim, arg1, arg2) := function_parameter in
Prim 0 prim (cons arg1 (cons arg2 [])) []))
(cons
(case "Prim (2 args + annot)" % string None
(Tezos_data_encoding.Data_encoding.Tag 8)
(obj4
(req None None "prim" % string prim_encoding)
(req None None "arg1" % string expr_encoding)
(req None None "arg2" % string expr_encoding)
(req None None "annots" % string
annots_encoding))
(fun function_parameter =>
match function_parameter with
|
Prim _ prim (cons arg1 (cons arg2 []))
annots => Some (prim, arg1, arg2, annots)
| _ => None
end)
(fun function_parameter =>
let '(prim, arg1, arg2, annots) :=
function_parameter in
Prim 0 prim (cons arg1 (cons arg2 [])) annots))
(cons
(application_encoding
(Tezos_data_encoding.Data_encoding.Tag 9)
expr_encoding)
(cons
(bytes_encoding
(Tezos_data_encoding.Data_encoding.Tag 10))
[]))))))))))))) in
conv
(fun function_parameter =>
let 'Canonical node := function_parameter in
node) (fun node => strip_locations node) None node_encoding.
Definition canonical_encoding {A : Type}
(variant : string)
(prim_encoding : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding (canonical A) :=
internal_canonical_encoding V1 variant prim_encoding.
Definition canonical_encoding_v1 {A : Type}
(variant : string)
(prim_encoding : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding (canonical A) :=
internal_canonical_encoding V1 variant prim_encoding.
Definition canonical_encoding_v0 {A : Type}
(variant : string)
(prim_encoding : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding.Data_encoding.encoding (canonical A) :=
internal_canonical_encoding V0 variant prim_encoding.
Definition table_encoding {A B : Type}
(variant : string)
(location_encoding : Tezos_data_encoding.Data_encoding.encoding A)
(prim_encoding : Tezos_data_encoding.Data_encoding.encoding B)
: Tezos_data_encoding.Data_encoding.encoding (node A B) :=
conv
(fun node =>
let '(canon, assoc) := extract_locations node in
let '(_, table) := Stdlib.List.split assoc in
(canon, table))
(fun function_parameter =>
let '(canon, table) := function_parameter in
let table := Array.of_list table in
inject_locations (fun i => Array.get table i) canon) None
(obj2
(req None None "expression" % string
(canonical_encoding variant prim_encoding))
(req None None "locations" % string (list None location_encoding))).
Definition erased_encoding {A B : Type}
(variant : string) (default_location : A)
(prim_encoding : Tezos_data_encoding.Data_encoding.encoding B)
: Tezos_data_encoding.Data_encoding.encoding (node A B) :=
conv (fun node => strip_locations node)
(fun canon =>
inject_locations
(fun function_parameter =>
let '_ := function_parameter in
default_location) canon) None
(canonical_encoding variant prim_encoding).
src/lib_micheline/micheline_parser.ml 90 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
open Micheline
type 'a parsing_result = 'a * error list
type point = {point : int; byte : int; line : int; column : int}
let point_zero = {point = 0; byte = 0; line = 0; column = 0}
let point_encoding =
let open Data_encoding in
conv
(fun {line; column; point; byte} -> (line, column, point, byte))
(fun (line, column, point, byte) -> {line; column; point; byte})
(obj4
(req "line" uint16)
(req "column" uint16)
(req "point" uint16)
(req "byte" uint16))
type location = {start : point; stop : point}
let location_zero = {start = point_zero; stop = point_zero}
let location_encoding =
let open Data_encoding in
conv
(fun {start; stop} -> (start, stop))
(fun (start, stop) -> {start; stop})
(obj2 (req "start" point_encoding) (req "stop" point_encoding))
type token_value =
| String of string
| Bytes of string
| Int of string
| Ident of string
| Annot of string
| Comment of string
| Eol_comment of string
| Semi
| Open_paren
| Close_paren
| Open_brace
| Close_brace
let token_value_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"String"
(obj1 (req "string" string))
(function String s -> Some s | _ -> None)
(fun s -> String s);
case
(Tag 1)
~title:"Int"
(obj1 (req "int" string))
(function Int s -> Some s | _ -> None)
(fun s -> Int s);
case
(Tag 2)
~title:"Annot"
(obj1 (req "annot" string))
(function Annot s -> Some s | _ -> None)
(fun s -> Annot s);
case
(Tag 3)
~title:"Comment"
(obj2 (req "comment" string) (dft "end_of_line" bool false))
(function
| Comment s ->
Some (s, false)
| Eol_comment s ->
Some (s, true)
| _ ->
None)
(function (s, false) -> Comment s | (s, true) -> Eol_comment s);
case
(Tag 4)
~title:"Punctuation"
(obj1
(req
"punctuation"
(string_enum
[ ("(", Open_paren);
(")", Close_paren);
("{", Open_brace);
("}", Close_brace);
(";", Semi) ])))
(fun t -> Some t)
(fun t -> t);
case
(Tag 5)
~title:"Bytes"
(obj1 (req "bytes" string))
(function Bytes s -> Some s | _ -> None)
(fun s -> Bytes s) ]
type token = {token : token_value; loc : location}
let max_annot_length = 255
type error += Invalid_utf8_sequence of point * string
type error += Unexpected_character of point * string
type error += Undefined_escape_sequence of point * string
type error += Missing_break_after_number of point
type error += Unterminated_string of location
type error += Unterminated_integer of location
type error += Odd_lengthed_bytes of location
type error += Unterminated_comment of location
type error += Annotation_length of location
let tokenize source =
let decoder = Uutf.decoder ~encoding:`UTF_8 (`String source) in
let here () =
{
point = Uutf.decoder_count decoder;
byte = Uutf.decoder_byte_count decoder;
line = Uutf.decoder_line decoder;
column = Uutf.decoder_col decoder;
}
in
let tok start stop token = {loc = {start; stop}; token} in
let stack = ref [] in
let errors = ref [] in
let rec next () =
match !stack with
| charloc :: charlocs ->
stack := charlocs ;
charloc
| [] -> (
let loc = here () in
match Uutf.decode decoder with
| `Await ->
assert false
| `Malformed s ->
errors := Invalid_utf8_sequence (loc, s) :: !errors ;
next ()
| (`Uchar _ | `End) as other ->
(other, loc) )
in
let back charloc = stack := charloc :: !stack in
let uchar_to_char c =
if Uchar.is_char c then Some (Uchar.to_char c) else None
in
let allowed_ident_char c =
match uchar_to_char c with
| Some ('a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9') ->
true
| Some _ | None ->
false
in
let allowed_annot_char c =
match uchar_to_char c with
| Some ('a' .. 'z' | 'A' .. 'Z' | '_' | '.' | '%' | '@' | '0' .. '9') ->
true
| Some _ | None ->
false
in
let rec skip acc =
match next () with
| (`End, _) ->
List.rev acc
| (`Uchar c, start) -> (
match uchar_to_char c with
| Some ('a' .. 'z' | 'A' .. 'Z') ->
ident acc start (fun s _ -> Ident s)
| Some ('@' | ':' | '$' | '&' | '%' | '!' | '?') ->
annot acc start (fun str stop ->
if String.length str > max_annot_length then
errors := Annotation_length {start; stop} :: !errors ;
Annot str)
| Some '-' -> (
match next () with
| (`End, stop) ->
errors := Unterminated_integer {start; stop} :: !errors ;
List.rev acc
| (`Uchar c, stop) as first -> (
match uchar_to_char c with
| Some '0' ->
base acc start
| Some '1' .. '9' ->
integer acc start
| Some _ | None ->
errors := Unterminated_integer {start; stop} :: !errors ;
back first ;
skip acc ) )
| Some '0' ->
base acc start
| Some '1' .. '9' ->
integer acc start
| Some (' ' | '\n') ->
skip acc
| Some ';' ->
skip (tok start (here ()) Semi :: acc)
| Some '{' ->
skip (tok start (here ()) Open_brace :: acc)
| Some '}' ->
skip (tok start (here ()) Close_brace :: acc)
| Some '(' ->
skip (tok start (here ()) Open_paren :: acc)
| Some ')' ->
skip (tok start (here ()) Close_paren :: acc)
| Some '"' ->
string acc [] start
| Some '#' ->
eol_comment acc start
| Some '/' -> (
match next () with
| (`Uchar c, _) when Uchar.equal c (Uchar.of_char '*') ->
comment acc start 0
| ((`Uchar _ | `End), _) as charloc ->
errors := Unexpected_character (start, "/") :: !errors ;
back charloc ;
skip acc )
| Some _ | None ->
let byte = Uutf.decoder_byte_count decoder in
let s = String.sub source start.byte (byte - start.byte) in
errors := Unexpected_character (start, s) :: !errors ;
skip acc )
and base acc start =
match next () with
| (`Uchar c, stop) as charloc -> (
match uchar_to_char c with
| Some '0' .. '9' ->
integer acc start
| Some 'x' ->
bytes acc start
| Some ('a' .. 'w' | 'y' | 'z' | 'A' .. 'Z') ->
errors := Missing_break_after_number stop :: !errors ;
back charloc ;
skip (tok start stop (Int "0") :: acc)
| Some _ | None ->
back charloc ;
skip (tok start stop (Int "0") :: acc) )
| (_, stop) as other ->
back other ;
skip (tok start stop (Int "0") :: acc)
and integer acc start =
let tok stop =
let value = String.sub source start.byte (stop.byte - start.byte) in
tok start stop (Int value)
in
match next () with
| (`Uchar c, stop) as charloc -> (
let missing_break () =
errors := Missing_break_after_number stop :: !errors ;
back charloc ;
skip (tok stop :: acc)
in
match Uchar.to_char c with
| '0' .. '9' ->
integer acc start
| 'a' .. 'z' | 'A' .. 'Z' ->
missing_break ()
| _ ->
back charloc ;
skip (tok stop :: acc) )
| (`End, stop) as other ->
back other ;
skip (tok stop :: acc)
and bytes acc start =
let tok stop =
let value = String.sub source start.byte (stop.byte - start.byte) in
tok start stop (Bytes value)
in
match next () with
| (`Uchar c, stop) as charloc -> (
let missing_break () =
errors := Missing_break_after_number stop :: !errors ;
back charloc ;
skip (tok stop :: acc)
in
match Uchar.to_char c with
| '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' ->
bytes acc start
| 'g' .. 'z' | 'G' .. 'Z' ->
missing_break ()
| _ ->
back charloc ;
skip (tok stop :: acc) )
| (`End, stop) as other ->
back other ;
skip (tok stop :: acc)
and string acc sacc start =
let tok () =
tok start (here ()) (String (String.concat "" (List.rev sacc)))
in
match next () with
| (`End, stop) ->
errors := Unterminated_string {start; stop} :: !errors ;
skip (tok () :: acc)
| (`Uchar c, stop) -> (
match uchar_to_char c with
| Some '"' ->
skip (tok () :: acc)
| Some ('\n' | '\r') ->
errors := Unterminated_string {start; stop} :: !errors ;
skip (tok () :: acc)
| Some '\\' -> (
match next () with
| (`End, stop) ->
errors := Unterminated_string {start; stop} :: !errors ;
skip (tok () :: acc)
| (`Uchar c, loc) -> (
match uchar_to_char c with
| Some '"' ->
string acc ("\"" :: sacc) start
| Some 'r' ->
string acc ("\r" :: sacc) start
| Some 'n' ->
string acc ("\n" :: sacc) start
| Some 't' ->
string acc ("\t" :: sacc) start
| Some 'b' ->
string acc ("\b" :: sacc) start
| Some '\\' ->
string acc ("\\" :: sacc) start
| Some _ | None ->
let byte = Uutf.decoder_byte_count decoder in
let s = String.sub source loc.byte (byte - loc.byte) in
errors := Undefined_escape_sequence (loc, s) :: !errors ;
string acc sacc start ) )
| Some _ | None ->
let byte = Uutf.decoder_byte_count decoder in
let s = String.sub source stop.byte (byte - stop.byte) in
string acc (s :: sacc) start )
and generic_ident allow_char acc start (ret : string -> point -> token_value)
=
let tok stop =
let name = String.sub source start.byte (stop.byte - start.byte) in
tok start stop (ret name stop)
in
match next () with
| (`Uchar c, stop) as charloc ->
if allow_char c then generic_ident allow_char acc start ret
else (
back charloc ;
skip (tok stop :: acc) )
| (_, stop) as other ->
back other ;
skip (tok stop :: acc)
and ident acc start ret = generic_ident allowed_ident_char acc start ret
and annot acc start ret = generic_ident allowed_annot_char acc start ret
and comment acc start lvl =
match next () with
| (`End, stop) ->
errors := Unterminated_comment {start; stop} :: !errors ;
let text = String.sub source start.byte (stop.byte - start.byte) in
skip (tok start stop (Comment text) :: acc)
| (`Uchar c, _) -> (
match uchar_to_char c with
| Some '*' -> (
match next () with
| (`Uchar c, _) when Uchar.equal c (Uchar.of_char '/') ->
if lvl = 0 then
let stop = here () in
let text =
String.sub source start.byte (stop.byte - start.byte)
in
skip (tok start stop (Comment text) :: acc)
else comment acc start (lvl - 1)
| other ->
back other ; comment acc start lvl )
| Some '/' -> (
match next () with
| (`Uchar c, _) when Uchar.equal c (Uchar.of_char '*') ->
comment acc start (lvl + 1)
| other ->
back other ; comment acc start lvl )
| Some _ | None ->
comment acc start lvl )
and eol_comment acc start =
let tok stop =
let text = String.sub source start.byte (stop.byte - start.byte) in
tok start stop (Eol_comment text)
in
match next () with
| (`Uchar c, stop) -> (
match uchar_to_char c with
| Some '\n' ->
skip (tok stop :: acc)
| Some _ | None ->
eol_comment acc start )
| (_, stop) as other ->
back other ;
skip (tok stop :: acc)
in
let tokens = skip [] in
(tokens, List.rev !errors)
type node = (location, string) Micheline.node
let node_encoding =
Micheline.table_encoding
~variant:"generic"
location_encoding
Data_encoding.string
(* Beginning of a sequence of consecutive primitives *)
let min_point : node list -> point = function
| [] ->
point_zero
| Int ({start; _}, _) :: _
| String ({start; _}, _) :: _
| Bytes ({start; _}, _) :: _
| Prim ({start; _}, _, _, _) :: _
| Seq ({start; _}, _) :: _ ->
start
(* End of a sequence of consecutive primitives *)
let rec max_point : node list -> point = function
| [] ->
point_zero
| _ :: (_ :: _ as rest) ->
max_point rest
| [Int ({stop; _}, _)]
| [String ({stop; _}, _)]
| [Bytes ({stop; _}, _)]
| [Prim ({stop; _}, _, _, _)]
| [Seq ({stop; _}, _)] ->
stop
(* An item in the parser's state stack.
Not every value of type [mode list] is a valid parsing context.
It must respect the following additional invariants.
- a state stack always ends in [Toplevel _],
- [Toplevel _] does not appear anywhere else,
- [Unwrapped _] cannot appear directly on top of [Wrapped _],
- [Wrapped _] cannot appear directly on top of [Sequence _],
- [Wrapped _] cannot appear directly on top of [Sequence _]. *)
type mode =
| Toplevel of node list
| Expression of node option
| Sequence of token * node list
| Unwrapped of location * string * node list * string list
| Wrapped of token * string * node list * string list
(* Enter a new parsing state. *)
let push_mode mode stack = mode :: stack
(* Leave a parsing state. *)
let pop_mode = function [] -> assert false | _ :: rest -> rest
(* Usually after a [pop_mode], jump back into the previous parsing
state, injecting the current reduction (insert the just parsed item
of a sequence or argument of a primitive application). *)
let fill_mode result = function
| [] ->
assert false
| Expression _ :: _ :: _ ->
assert false
| [Expression (Some _)] ->
assert false
| Toplevel _ :: _ :: _ ->
assert false
| [Expression None] ->
[Expression (Some result)]
| [Toplevel exprs] ->
[Toplevel (result :: exprs)]
| Sequence (token, exprs) :: rest ->
Sequence (token, result :: exprs) :: rest
| Wrapped (token, name, exprs, annot) :: rest ->
Wrapped (token, name, result :: exprs, annot) :: rest
| Unwrapped (start, name, exprs, annot) :: rest ->
Unwrapped (start, name, result :: exprs, annot) :: rest
type error += Unclosed of token
type error += Unexpected of token
type error += Extra of token
type error += Misaligned of node
type error += Empty
let rec annots = function
| {token = Annot annot; _} :: rest ->
let (annots, rest) = annots rest in
(annot :: annots, rest)
| rest ->
([], rest)
let rec parse ?(check = true) errors tokens stack =
(* Two steps:
- 1. parse without checking indentation [parse]
- 2. check indentation [check] (inlined in 1) *)
match (stack, tokens) with
(* Start by preventing all absurd cases, so now the pattern
matching exhaustivity can tell us that we treater all
possible tokens for all possible valid states. *)
| ([], _)
| ([Wrapped _], _)
| ([Unwrapped _], _)
| (Unwrapped _ :: Unwrapped _ :: _, _)
| (Unwrapped _ :: Wrapped _ :: _, _)
| (Toplevel _ :: _ :: _, _)
| (Expression _ :: _ :: _, _) ->
assert false
(* Return *)
| (Expression (Some result) :: _, []) ->
([result], List.rev errors)
| (Expression (Some _) :: _, token :: rem) ->
let errors = Unexpected token :: errors in
parse ~check errors rem (* skip *) stack
| (Expression None :: _, []) ->
let errors = Empty :: errors in
let ghost = {start = point_zero; stop = point_zero} in
([Seq (ghost, [])], List.rev errors)
| ([Toplevel [(Seq (_, exprs) as expr)]], []) ->
let errors =
if check then do_check ~toplevel:false errors expr else errors
in
(exprs, List.rev errors)
| ([Toplevel exprs], []) ->
let exprs = List.rev exprs in
let loc = {start = min_point exprs; stop = max_point exprs} in
let expr = Seq (loc, exprs) in
let errors =
if check then do_check ~toplevel:true errors expr else errors
in
(exprs, List.rev errors)
(* Ignore comments *)
| (_, {token = Eol_comment _ | Comment _; _} :: rest) ->
parse ~check errors rest stack
| ( (Expression None | Sequence _ | Toplevel _) :: _,
({token = Int _ | String _ | Bytes _; _} as token)
:: {token = Eol_comment _ | Comment _; _} :: rest )
| ( (Wrapped _ | Unwrapped _) :: _,
({token = Open_paren; _} as token)
:: {token = Eol_comment _ | Comment _; _} :: rest ) ->
parse ~check errors (token :: rest) stack
(* Erroneous states *)
| ( (Wrapped _ | Unwrapped _) :: _,
({token = Open_paren; _} as token)
:: {token = Open_paren | Open_brace; _} :: rem )
| ( Unwrapped _ :: Expression _ :: _,
({token = Semi | Close_brace | Close_paren; _} as token) :: rem )
| ( Expression None :: _,
({token = Semi | Close_brace | Close_paren | Open_paren; _} as token)
:: rem ) ->
let errors = Unexpected token :: errors in
parse ~check errors rem (* skip *) stack
| ( (Sequence _ | Toplevel _) :: _,
({token = Semi; _} as valid) :: ({token = Semi; _} as token) :: rem ) ->
let errors = Extra token :: errors in
parse ~check errors ((* skip *) valid :: rem) stack
| ( (Wrapped _ | Unwrapped _) :: _,
{token = Open_paren; _}
:: ( {token = Int _ | String _ | Bytes _ | Annot _ | Close_paren; _} as
token )
:: rem )
| ( (Expression None | Sequence _ | Toplevel _) :: _,
{token = Int _ | String _ | Bytes _; _}
:: ( { token =
( Ident _
| Int _
| String _
| Bytes _
| Annot _
| Close_paren
| Open_paren
| Open_brace );
_ } as token )
:: rem )
| ( Unwrapped (_, _, _, _) :: Toplevel _ :: _,
({token = Close_brace; _} as token) :: rem )
| (Unwrapped (_, _, _, _) :: _, ({token = Close_paren; _} as token) :: rem)
| ([Toplevel _], ({token = Close_paren; _} as token) :: rem)
| ([Toplevel _], ({token = Open_paren; _} as token) :: rem)
| ([Toplevel _], ({token = Close_brace; _} as token) :: rem)
| (Sequence _ :: _, ({token = Open_paren; _} as token) :: rem)
| (Sequence _ :: _, ({token = Close_paren; _} as token) :: rem)
| ( (Wrapped _ | Unwrapped _) :: _,
({token = Open_paren; _} as token)
:: (({token = Close_brace | Semi; _} :: _ | []) as rem) )
| (_, ({token = Annot _; _} as token) :: rem) ->
let errors = Unexpected token :: errors in
parse ~check errors rem (* skip *) stack
| (Wrapped (token, _, _, _) :: _, ([] | {token = Close_brace | Semi; _} :: _))
->
let errors = Unclosed token :: errors in
let fake = {token with token = Close_paren} in
let tokens = (* insert *) fake :: tokens in
parse ~check errors tokens stack
| ((Sequence (token, _) :: _ | Unwrapped _ :: Sequence (token, _) :: _), [])
->
let errors = Unclosed token :: errors in
let fake = {token with token = Close_brace} in
let tokens = (* insert *) fake :: tokens in
parse ~check errors tokens stack
(* Valid states *)
| ( (Toplevel _ | Sequence (_, _)) :: _,
{token = Ident name; loc} :: ({token = Annot _; _} :: _ as rest) ) ->
let (annots, rest) = annots rest in
let mode = Unwrapped (loc, name, [], annots) in
parse ~check errors rest (push_mode mode stack)
| ( (Expression None | Toplevel _ | Sequence (_, _)) :: _,
{token = Ident name; loc} :: rest ) ->
let mode = Unwrapped (loc, name, [], []) in
parse ~check errors rest (push_mode mode stack)
| ((Unwrapped _ | Wrapped _) :: _, {token = Int value; loc} :: rest)
| ( (Expression None | Sequence _ | Toplevel _) :: _,
{token = Int value; loc}
:: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) ->
let expr : node = Int (loc, Z.of_string value) in
let errors =
if check then do_check ~toplevel:false errors expr else errors
in
parse ~check errors rest (fill_mode expr stack)
| ((Unwrapped _ | Wrapped _) :: _, {token = String contents; loc} :: rest)
| ( (Expression None | Sequence _ | Toplevel _) :: _,
{token = String contents; loc}
:: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) ->
let expr : node = String (loc, contents) in
let errors =
if check then do_check ~toplevel:false errors expr else errors
in
parse ~check errors rest (fill_mode expr stack)
| ((Unwrapped _ | Wrapped _) :: _, {token = Bytes contents; loc} :: rest)
| ( (Expression None | Sequence _ | Toplevel _) :: _,
{token = Bytes contents; loc}
:: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) ->
let (errors, contents) =
if String.length contents mod 2 <> 0 then
(Odd_lengthed_bytes loc :: errors, contents ^ "0")
else (errors, contents)
in
let bytes =
Hex.to_bytes
(`Hex (String.sub contents 2 (String.length contents - 2)))
in
let expr : node = Bytes (loc, bytes) in
let errors =
if check then do_check ~toplevel:false errors expr else errors
in
parse ~check errors rest (fill_mode expr stack)
| ( Sequence ({loc = {start; _}; _}, exprs) :: _,
{token = Close_brace; loc = {stop; _}} :: rest ) ->
let exprs = List.rev exprs in
let expr = Micheline.Seq ({start; stop}, exprs) in
let errors =
if check then do_check ~toplevel:false errors expr else errors
in
parse ~check errors rest (fill_mode expr (pop_mode stack))
| ((Sequence _ | Toplevel _) :: _, {token = Semi; _} :: rest) ->
parse ~check errors rest stack
| ( Unwrapped ({start; stop}, name, exprs, annot) :: Expression _ :: _,
([] as rest) )
| ( Unwrapped ({start; stop}, name, exprs, annot) :: Toplevel _ :: _,
(({token = Semi; _} :: _ | []) as rest) )
| ( Unwrapped ({start; stop}, name, exprs, annot) :: Sequence _ :: _,
({token = Close_brace | Semi; _} :: _ as rest) )
| ( Wrapped ({loc = {start; stop}; _}, name, exprs, annot) :: _,
{token = Close_paren; _} :: rest ) ->
let exprs = List.rev exprs in
let stop = if exprs = [] then stop else max_point exprs in
let expr = Micheline.Prim ({start; stop}, name, exprs, annot) in
let errors =
if check then do_check ~toplevel:false errors expr else errors
in
parse ~check errors rest (fill_mode expr (pop_mode stack))
| ( (Wrapped _ | Unwrapped _) :: _,
({token = Open_paren; _} as token)
:: {token = Ident name; _} :: ({token = Annot _; _} :: _ as rest) ) ->
let (annots, rest) = annots rest in
let mode = Wrapped (token, name, [], annots) in
parse ~check errors rest (push_mode mode stack)
| ( (Wrapped _ | Unwrapped _) :: _,
({token = Open_paren; _} as token) :: {token = Ident name; _} :: rest )
->
let mode = Wrapped (token, name, [], []) in
parse ~check errors rest (push_mode mode stack)
| ((Wrapped _ | Unwrapped _) :: _, {token = Ident name; loc} :: rest) ->
let expr = Micheline.Prim (loc, name, [], []) in
let errors =
if check then do_check ~toplevel:false errors expr else errors
in
parse ~check errors rest (fill_mode expr stack)
| ( (Wrapped _ | Unwrapped _ | Toplevel _ | Sequence _ | Expression None) :: _,
({token = Open_brace; _} as token) :: rest ) ->
let mode = Sequence (token, []) in
parse ~check errors rest (push_mode mode stack)
(* indentation checker *)
and do_check ?(toplevel = false) errors = function
| Seq ({start; stop}, []) as expr ->
if start.column >= stop.column then Misaligned expr :: errors else errors
| ( Prim ({start; stop}, _, first :: rest, _)
| Seq ({start; stop}, first :: rest) ) as expr ->
let {column = first_column; line = first_line; _} = min_point [first] in
if start.column >= stop.column then Misaligned expr :: errors
else if (not toplevel) && start.column >= first_column then
Misaligned expr :: errors
else
(* In a sequence or in the arguments of a primitive, we
require all items to be aligned, but we relax the rule to
allow consecutive items to be writtem on the same line. *)
let rec in_line_or_aligned prev_start_line errors = function
| [] ->
errors
| expr :: rest ->
let {column; line = start_line; _} = min_point [expr] in
let {line = stop_line; _} = max_point [expr] in
let errors =
if stop_line <> prev_start_line && column <> first_column then
Misaligned expr :: errors
else errors
in
in_line_or_aligned start_line errors rest
in
in_line_or_aligned first_line errors rest
| Prim (_, _, [], _) | String _ | Int _ | Bytes _ ->
errors
let parse_expression ?check tokens =
let result =
match tokens with
| ({token = Open_paren; _} as token)
:: {token = Ident name; _} :: {token = Annot annot; _} :: rest ->
let (annots, rest) = annots rest in
let mode = Wrapped (token, name, [], annot :: annots) in
parse ?check [] rest [mode; Expression None]
| ({token = Open_paren; _} as token) :: {token = Ident name; _} :: rest ->
let mode = Wrapped (token, name, [], []) in
parse ?check [] rest [mode; Expression None]
| _ ->
parse ?check [] tokens [Expression None]
in
match result with
| ([single], errors) ->
(single, errors)
| _ ->
assert false
let parse_toplevel ?check tokens = parse ?check [] tokens [Toplevel []]
let print_point ppf {line; column; _} =
Format.fprintf ppf "At line %d character %d" line column
let print_token_kind ppf = function
| Open_paren | Close_paren ->
Format.fprintf ppf "parenthesis"
| Open_brace | Close_brace ->
Format.fprintf ppf "curly brace"
| String _ ->
Format.fprintf ppf "string constant"
| Bytes _ ->
Format.fprintf ppf "bytes constant"
| Int _ ->
Format.fprintf ppf "integer constant"
| Ident _ ->
Format.fprintf ppf "identifier"
| Annot _ ->
Format.fprintf ppf "annotation"
| Comment _ | Eol_comment _ ->
Format.fprintf ppf "comment"
| Semi ->
Format.fprintf ppf "semi colon"
let print_location ppf loc =
if loc.start.line = loc.stop.line then
if loc.start.column = loc.stop.column then
Format.fprintf
ppf
"At line %d character %d"
loc.start.line
loc.start.column
else
Format.fprintf
ppf
"At line %d characters %d to %d"
loc.start.line
loc.start.column
loc.stop.column
else
Format.fprintf
ppf
"From line %d character %d to line %d character %d"
loc.start.line
loc.start.column
loc.stop.line
loc.stop.column
let no_parsing_error (ast, errors) =
match errors with [] -> ok ast | errors -> Error errors
let () =
register_error_kind
`Permanent
~id:"micheline.parse_error.invalid_utf8_sequence"
~title:"Micheline parser error: invalid UTF-8 sequence"
~description:
"While parsing a piece of Micheline source, a sequence of bytes that is \
not valid UTF-8 was encountered."
~pp:(fun ppf (point, str) ->
Format.fprintf ppf "%a, invalid UTF-8 sequence %S" print_point point str)
Data_encoding.(obj2 (req "point" point_encoding) (req "sequence" string))
(function
| Invalid_utf8_sequence (point, str) -> Some (point, str) | _ -> None)
(fun (point, str) -> Invalid_utf8_sequence (point, str)) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.unexpected_character"
~title:"Micheline parser error: unexpected character"
~description:
"While parsing a piece of Micheline source, an unexpected character was \
encountered."
~pp:(fun ppf (point, str) ->
Format.fprintf ppf "%a, unexpected character %s" print_point point str)
Data_encoding.(obj2 (req "point" point_encoding) (req "character" string))
(function
| Unexpected_character (point, str) -> Some (point, str) | _ -> None)
(fun (point, str) -> Unexpected_character (point, str)) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.undefined_escape_sequence"
~title:"Micheline parser error: undefined escape sequence"
~description:
"While parsing a piece of Micheline source, an unexpected escape \
sequence was encountered in a string."
~pp:(fun ppf (point, str) ->
Format.fprintf
ppf
"%a, undefined escape sequence \"%s\""
print_point
point
str)
Data_encoding.(obj2 (req "point" point_encoding) (req "sequence" string))
(function
| Undefined_escape_sequence (point, str) -> Some (point, str) | _ -> None)
(fun (point, str) -> Undefined_escape_sequence (point, str)) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.missing_break_after_number"
~title:"Micheline parser error: missing break after number"
~description:
"While parsing a piece of Micheline source, a number was not visually \
separated from its follower token, leading to misreadability."
~pp:(fun ppf point ->
Format.fprintf ppf "%a, missing break after number" print_point point)
Data_encoding.(obj1 (req "point" point_encoding))
(function Missing_break_after_number point -> Some point | _ -> None)
(fun point -> Missing_break_after_number point) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.unterminated_string"
~title:"Micheline parser error: unterminated string"
~description:
"While parsing a piece of Micheline source, a string was not terminated."
~pp:(fun ppf loc ->
Format.fprintf ppf "%a, unterminated string" print_location loc)
Data_encoding.(obj1 (req "location" location_encoding))
(function Unterminated_string loc -> Some loc | _ -> None)
(fun loc -> Unterminated_string loc) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.unterminated_integer"
~title:"Micheline parser error: unterminated integer"
~description:
"While parsing a piece of Micheline source, an integer was not \
terminated."
~pp:(fun ppf loc ->
Format.fprintf ppf "%a, unterminated integer" print_location loc)
Data_encoding.(obj1 (req "location" location_encoding))
(function Unterminated_integer loc -> Some loc | _ -> None)
(fun loc -> Unterminated_integer loc) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.odd_lengthed_bytes"
~title:"Micheline parser error: odd lengthed bytes"
~description:
"While parsing a piece of Micheline source, the length of a byte \
sequence (0x...) was not a multiple of two, leaving a trailing half \
byte."
~pp:(fun ppf loc ->
Format.fprintf ppf "%a, odd_lengthed bytes" print_location loc)
Data_encoding.(obj1 (req "location" location_encoding))
(function Odd_lengthed_bytes loc -> Some loc | _ -> None)
(fun loc -> Odd_lengthed_bytes loc) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.unterminated_comment"
~title:"Micheline parser error: unterminated comment"
~description:
"While parsing a piece of Micheline source, a commentX was not \
terminated."
~pp:(fun ppf loc ->
Format.fprintf ppf "%a, unterminated comment" print_location loc)
Data_encoding.(obj1 (req "location" location_encoding))
(function Unterminated_comment loc -> Some loc | _ -> None)
(fun loc -> Unterminated_comment loc) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.annotation_exceeds_max_length"
~title:"Micheline parser error: annotation exceeds max length"
~description:
(Format.sprintf
"While parsing a piece of Micheline source, an annotation exceeded \
the maximum length (%d)."
max_annot_length)
~pp:(fun ppf loc ->
Format.fprintf
ppf
"%a, annotation exceeded maximum length (%d chars)"
print_location
loc
max_annot_length)
Data_encoding.(obj1 (req "location" location_encoding))
(function Annotation_length loc -> Some loc | _ -> None)
(fun loc -> Annotation_length loc) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.unclosed_token"
~title:"Micheline parser error: unclosed token"
~description:
"While parsing a piece of Micheline source, a parenthesis or a brace \
was unclosed."
~pp:(fun ppf (loc, token) ->
Format.fprintf
ppf
"%a, unclosed %a"
print_location
loc
print_token_kind
token)
Data_encoding.(
obj2
(req "location" location_encoding)
(req "token" token_value_encoding))
(function Unclosed {loc; token} -> Some (loc, token) | _ -> None)
(fun (loc, token) -> Unclosed {loc; token}) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.unexpected_token"
~title:"Micheline parser error: unexpected token"
~description:
"While parsing a piece of Micheline source, an unexpected token was \
encountered."
~pp:(fun ppf (loc, token) ->
Format.fprintf
ppf
"%a, unexpected %a"
print_location
loc
print_token_kind
token)
Data_encoding.(
obj2
(req "location" location_encoding)
(req "token" token_value_encoding))
(function Unexpected {loc; token} -> Some (loc, token) | _ -> None)
(fun (loc, token) -> Unexpected {loc; token}) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.extra_token"
~title:"Micheline parser error: extra token"
~description:
"While parsing a piece of Micheline source, an extra semi colon or \
parenthesis was encountered."
~pp:(fun ppf (loc, token) ->
Format.fprintf
ppf
"%a, extra %a"
print_location
loc
print_token_kind
token)
Data_encoding.(
obj2
(req "location" location_encoding)
(req "token" token_value_encoding))
(function Extra {loc; token} -> Some (loc, token) | _ -> None)
(fun (loc, token) -> Extra {loc; token}) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.misaligned_node"
~title:"Micheline parser error: misaligned node"
~description:
"While parsing a piece of Micheline source, an expression was not \
aligned with its siblings of the same mother application or sequence."
~pp:(fun ppf node ->
Format.fprintf
ppf
"%a, misaligned expression"
print_location
(location node))
Data_encoding.(obj1 (req "expression" node_encoding))
(function Misaligned node -> Some node | _ -> None)
(fun node -> Misaligned node) ;
register_error_kind
`Permanent
~id:"micheline.parse_error.empty_expression"
~title:"Micheline parser error: empty_expression"
~description:
"Tried to interpret an empty piece or Micheline source as a single \
expression."
~pp:(fun ppf () -> Format.fprintf ppf "empty expression")
Data_encoding.empty
(function Empty -> Some () | _ -> None)
(fun () -> Empty)
src/lib_micheline/micheline_parser.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Import Micheline.
Definition parsing_result (a : Type) :=
a * (list Tezos_error_monad.Error_monad.error).
Record point := {
point : Z;
byte : Z;
line : Z;
column : Z }.
Definition point_zero : point :=
{| point := 0; byte := 0; line := 0; column := 0 |}.
Definition point_encoding : Tezos_data_encoding.Data_encoding.encoding point :=
conv
(fun function_parameter =>
let '{| point := point; byte := byte; line := line; column := column |} :=
function_parameter in
(line, column, point, byte))
(fun function_parameter =>
let '(line, column, point, byte) := function_parameter in
{| point := point; byte := byte; line := line; column := column |}) None
(obj4 (req None None "line" % string uint16)
(req None None "column" % string uint16)
(req None None "point" % string uint16)
(req None None "byte" % string uint16)).
Record location := {
start : point;
stop : point }.
Definition location_zero : location :=
{| start := point_zero; stop := point_zero |}.
Definition location_encoding
: Tezos_data_encoding.Data_encoding.encoding location :=
conv
(fun function_parameter =>
let '{| start := start; stop := stop |} := function_parameter in
(start, stop))
(fun function_parameter =>
let '(start, stop) := function_parameter in
{| start := start; stop := stop |}) None
(obj2 (req None None "start" % string point_encoding)
(req None None "stop" % string point_encoding)).
Inductive token_value : Type :=
| String : string -> token_value
| Bytes : string -> token_value
| Int : string -> token_value
| Ident : string -> token_value
| Annot : string -> token_value
| Comment : string -> token_value
| Eol_comment : string -> token_value
| Semi : token_value
| Open_paren : token_value
| Close_paren : token_value
| Open_brace : token_value
| Close_brace : token_value.
Definition token_value_encoding
: Tezos_data_encoding.Data_encoding.encoding token_value :=
union None
(cons
(case "String" % string None (Tezos_data_encoding.Data_encoding.Tag 0)
(obj1 (req None None "string" % string string))
(fun function_parameter =>
match function_parameter with
| String s => Some s
| _ => None
end) (fun s => String s))
(cons
(case "Int" % string None (Tezos_data_encoding.Data_encoding.Tag 1)
(obj1 (req None None "int" % string string))
(fun function_parameter =>
match function_parameter with
| Int s => Some s
| _ => None
end) (fun s => Int s))
(cons
(case "Annot" % string None (Tezos_data_encoding.Data_encoding.Tag 2)
(obj1 (req None None "annot" % string string))
(fun function_parameter =>
match function_parameter with
| Annot s => Some s
| _ => None
end) (fun s => Annot s))
(cons
(case "Comment" % string None
(Tezos_data_encoding.Data_encoding.Tag 3)
(obj2 (req None None "comment" % string string)
(dft None None "end_of_line" % string bool false))
(fun function_parameter =>
match function_parameter with
| Comment s => Some (s, false)
| Eol_comment s => Some (s, true)
| _ => None
end)
(fun function_parameter =>
match function_parameter with
| (s, false) => Comment s
| (s, true) => Eol_comment s
end))
(cons
(case "Punctuation" % string None
(Tezos_data_encoding.Data_encoding.Tag 4)
(obj1
(req None None "punctuation" % string
(string_enum
(cons ("(" % string, Open_paren)
(cons (")" % string, Close_paren)
(cons ("{" % string, Open_brace)
(cons ("}" % string, Close_brace)
(cons (";" % string, Semi) []))))))))
(fun t => Some t) (fun t => t))
(cons
(case "Bytes" % string None
(Tezos_data_encoding.Data_encoding.Tag 5)
(obj1 (req None None "bytes" % string string))
(fun function_parameter =>
match function_parameter with
| Bytes s => Some s
| _ => None
end) (fun s => Bytes s)) [])))))).
Record token := {
token : token_value;
loc : location }.
Definition max_annot_length : Z := 255.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition tokenize (source : string)
: (list token) * (list Tezos_error_monad.Error_monad.error) :=
let decoder :=
Uutf.decoder None
(Some
(* ❌ Variants not supported *)
variant)
(* ❌ Variants not supported *)
variant in
let here (function_parameter : unit) : point :=
let 'tt := function_parameter in
{| point := Uutf.decoder_count decoder;
byte := Uutf.decoder_byte_count decoder;
line := Uutf.decoder_line decoder; column := Uutf.decoder_col decoder |}
in
let tok (start : point) (stop : point) (token : token_value) : token :=
{| token := token; loc := {| start := start; stop := stop |} |} in
let stack := Stdlib.ref [] in
let errors := Stdlib.ref [] in
let fix next (function_parameter : unit) : variant * point :=
let 'tt := function_parameter in
match Stdlib.op_exclamation stack with
| cons charloc charlocs =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq stack charlocs in
charloc
| [] =>
let loc := here tt in
match Uutf.decode decoder with
| Await =>
(* ❌ Assert instruction is not handled. *)
assert false
| Malformed s =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq errors
(cons (Tezos_error_monad.Error_monad.Invalid_utf8_sequence loc s)
(Stdlib.op_exclamation errors)) in
next tt
| (Uchar _ | End) as other => (other, loc)
end
end in
let back (charloc : variant * point) : unit :=
Stdlib.op_coloneq stack (cons charloc (Stdlib.op_exclamation stack)) in
let uchar_to_char (c : Stdlib.Uchar.t) : option ascii :=
if Uchar.is_char c then
Some (Uchar.to_char c)
else
None in
let allowed_ident_char (c : Stdlib.Uchar.t) : bool :=
match uchar_to_char c with
|
Some
("a" % char |
"b" % char |
"c" % char |
"d" % char |
"e" % char |
"f" % char |
"g" % char |
"h" % char |
"i" % char |
"j" % char |
"k" % char |
"l" % char |
"m" % char |
"n" % char |
"o" % char |
"p" % char |
"q" % char |
"r" % char |
"s" % char |
"t" % char |
"u" % char |
"v" % char |
"w" % char |
"x" % char |
"y" % char | "z" % char
|
"A" % char |
"B" % char |
"C" % char |
"D" % char |
"E" % char |
"F" % char |
"G" % char |
"H" % char |
"I" % char |
"J" % char |
"K" % char |
"L" % char |
"M" % char |
"N" % char |
"O" % char |
"P" % char |
"Q" % char |
"R" % char |
"S" % char |
"T" % char |
"U" % char |
"V" % char |
"W" % char |
"X" % char |
"Y" % char |
"Z" % char |
"_" % char |
"0" % char |
"1" % char |
"2" % char |
"3" % char |
"4" % char |
"5" % char |
"6" % char | "7" % char | "8" % char | "9" % char) => true
| Some _ | None => false
end in
let allowed_annot_char (c : Stdlib.Uchar.t) : bool :=
match uchar_to_char c with
|
Some
("a" % char |
"b" % char |
"c" % char |
"d" % char |
"e" % char |
"f" % char |
"g" % char |
"h" % char |
"i" % char |
"j" % char |
"k" % char |
"l" % char |
"m" % char |
"n" % char |
"o" % char |
"p" % char |
"q" % char |
"r" % char |
"s" % char |
"t" % char |
"u" % char |
"v" % char |
"w" % char |
"x" % char |
"y" % char | "z" % char
|
"A" % char |
"B" % char |
"C" % char |
"D" % char |
"E" % char |
"F" % char |
"G" % char |
"H" % char |
"I" % char |
"J" % char |
"K" % char |
"L" % char |
"M" % char |
"N" % char |
"O" % char |
"P" % char |
"Q" % char |
"R" % char |
"S" % char |
"T" % char |
"U" % char |
"V" % char |
"W" % char |
"X" % char |
"Y" % char |
"Z" % char |
"_" % char | "." % char | "%" % char | "@" % char |
"0" % char |
"1" % char |
"2" % char |
"3" % char |
"4" % char |
"5" % char |
"6" % char | "7" % char | "8" % char | "9" % char) => true
| Some _ | None => false
end in
let fix skip (acc : list token) : list token :=
match next tt with
| (End, _) => List.rev acc
| (Uchar c, start) =>
match uchar_to_char c with
|
Some
("a" % char |
"b" % char |
"c" % char |
"d" % char |
"e" % char |
"f" % char |
"g" % char |
"h" % char |
"i" % char |
"j" % char |
"k" % char |
"l" % char |
"m" % char |
"n" % char |
"o" % char |
"p" % char |
"q" % char |
"r" % char |
"s" % char |
"t" % char |
"u" % char |
"v" % char |
"w" % char |
"x" % char |
"y" % char |
"z" % char |
"A" % char |
"B" % char |
"C" % char |
"D" % char |
"E" % char |
"F" % char |
"G" % char |
"H" % char |
"I" % char |
"J" % char |
"K" % char |
"L" % char |
"M" % char |
"N" % char |
"O" % char |
"P" % char |
"Q" % char |
"R" % char |
"S" % char |
"T" % char |
"U" % char |
"V" % char |
"W" % char |
"X" % char |
"Y" % char |
"Z" % char) =>
ident acc start
(fun s =>
fun function_parameter =>
let '_ := function_parameter in
Ident s)
|
Some
("@" % char | ":" % char | "$" % char | "&" % char | "%" % char |
"!" % char | "?" % char) =>
annot acc start
(fun str =>
fun stop =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt (OCaml.String.length str) max_annot_length
then
Stdlib.op_coloneq errors
(cons
(Tezos_error_monad.Error_monad.Annotation_length
{| start := start; stop := stop |})
(Stdlib.op_exclamation errors))
else
tt in
Annot str)
| Some "-" % char =>
match next tt with
| (End, stop) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq errors
(cons
(Tezos_error_monad.Error_monad.Unterminated_integer
{| start := start; stop := stop |})
(Stdlib.op_exclamation errors)) in
List.rev acc
| (Uchar c, stop) as first =>
match uchar_to_char c with
| Some "0" % char => base acc start
|
Some
("1" % char |
"2" % char |
"3" % char |
"4" % char |
"5" % char |
"6" % char | "7" % char | "8" % char | "9" % char) =>
integer acc start
| Some _ | None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq errors
(cons
(Tezos_error_monad.Error_monad.Unterminated_integer
{| start := start; stop := stop |})
(Stdlib.op_exclamation errors)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back first in
skip acc
end
end
| Some "0" % char => base acc start
|
Some
("1" % char |
"2" % char |
"3" % char |
"4" % char |
"5" % char | "6" % char | "7" % char | "8" % char | "9" % char)
=> integer acc start
| Some (" " % char | "010" % char) => skip acc
| Some ";" % char => skip (cons (tok start (here tt) Semi) acc)
| Some "{" % char => skip (cons (tok start (here tt) Open_brace) acc)
| Some "}" % char => skip (cons (tok start (here tt) Close_brace) acc)
| Some "(" % char => skip (cons (tok start (here tt) Open_paren) acc)
| Some ")" % char => skip (cons (tok start (here tt) Close_paren) acc)
| Some """" % char => string acc [] start
| Some "#" % char => eol_comment acc start
| Some "/" % char =>
match next tt with
| (Uchar c, _) => comment acc start 0
| (Uchar _ | End, _) as charloc =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq errors
(cons
(Tezos_error_monad.Error_monad.Unexpected_character start
"/" % string) (Stdlib.op_exclamation errors)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back charloc in
skip acc
end
| Some _ | None =>
let byte := Uutf.decoder_byte_count decoder in
let s := Stdlib.String.sub source (byte start) (Z.sub byte (byte start))
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq errors
(cons (Tezos_error_monad.Error_monad.Unexpected_character start s)
(Stdlib.op_exclamation errors)) in
skip acc
end
end
with base (acc : list token) (start : point) : list token :=
match next tt with
| (Uchar c, stop) as charloc =>
match uchar_to_char c with
|
Some
("0" % char |
"1" % char |
"2" % char |
"3" % char |
"4" % char |
"5" % char |
"6" % char | "7" % char | "8" % char | "9" % char) =>
integer acc start
| Some "x" % char => string acc start
|
Some
("a" % char |
"b" % char |
"c" % char |
"d" % char |
"e" % char |
"f" % char |
"g" % char |
"h" % char |
"i" % char |
"j" % char |
"k" % char |
"l" % char |
"m" % char |
"n" % char |
"o" % char |
"p" % char |
"q" % char |
"r" % char |
"s" % char |
"t" % char |
"u" % char |
"v" % char | "w" % char |
"y" % char | "z" % char |
"A" % char |
"B" % char |
"C" % char |
"D" % char |
"E" % char |
"F" % char |
"G" % char |
"H" % char |
"I" % char |
"J" % char |
"K" % char |
"L" % char |
"M" % char |
"N" % char |
"O" % char |
"P" % char |
"Q" % char |
"R" % char |
"S" % char |
"T" % char |
"U" % char |
"V" % char |
"W" % char |
"X" % char |
"Y" % char |
"Z" % char) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq errors
(cons
(Tezos_error_monad.Error_monad.Missing_break_after_number stop)
(Stdlib.op_exclamation errors)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back charloc in
skip (cons (tok start stop (Int "0" % string)) acc)
| Some _ | None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back charloc in
skip (cons (tok start stop (Int "0" % string)) acc)
end
| (_, stop) as other =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back other in
skip (cons (tok start stop (Int "0" % string)) acc)
end
with integer (acc : list token) (start : point) : list token :=
let tok (stop : point) : token :=
let value :=
Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
in
tok start stop (Int value) in
match next tt with
| (Uchar c, stop) as charloc =>
let missing_break (function_parameter : unit) : list token :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq errors
(cons
(Tezos_error_monad.Error_monad.Missing_break_after_number stop)
(Stdlib.op_exclamation errors)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back charloc in
skip (cons (tok stop) acc) in
match Uchar.to_char c with
|
"0" % char |
"1" % char |
"2" % char |
"3" % char |
"4" % char |
"5" % char | "6" % char | "7" % char | "8" % char | "9" % char
=> integer acc start
|
"a" % char |
"b" % char |
"c" % char |
"d" % char |
"e" % char |
"f" % char |
"g" % char |
"h" % char |
"i" % char |
"j" % char |
"k" % char |
"l" % char |
"m" % char |
"n" % char |
"o" % char |
"p" % char |
"q" % char |
"r" % char |
"s" % char |
"t" % char |
"u" % char |
"v" % char |
"w" % char |
"x" % char |
"y" % char | "z" % char
|
"A" % char |
"B" % char |
"C" % char |
"D" % char |
"E" % char |
"F" % char |
"G" % char |
"H" % char |
"I" % char |
"J" % char |
"K" % char |
"L" % char |
"M" % char |
"N" % char |
"O" % char |
"P" % char |
"Q" % char |
"R" % char |
"S" % char |
"T" % char |
"U" % char |
"V" % char |
"W" % char |
"X" % char |
"Y" % char |
"Z" % char =>
missing_break tt
| _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back charloc in
skip (cons (tok stop) acc)
end
| (End, stop) as other =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back other in
skip (cons (tok stop) acc)
end
with bytes (acc : list token) (start : point) : list token :=
let tok (stop : point) : token :=
let value :=
Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
in
tok start stop (Bytes value) in
match next tt with
| (Uchar c, stop) as charloc =>
let missing_break (function_parameter : unit) : list token :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq errors
(cons
(Tezos_error_monad.Error_monad.Missing_break_after_number stop)
(Stdlib.op_exclamation errors)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back charloc in
skip (cons (tok stop) acc) in
match Uchar.to_char c with
|
"0" % char |
"1" % char |
"2" % char |
"3" % char |
"4" % char |
"5" % char | "6" % char | "7" % char | "8" % char | "9" % char
|
"a" % char |
"b" % char | "c" % char | "d" % char | "e" % char | "f" % char |
"A" % char |
"B" % char | "C" % char | "D" % char | "E" % char | "F" % char =>
string acc start
|
"g" % char |
"h" % char |
"i" % char |
"j" % char |
"k" % char |
"l" % char |
"m" % char |
"n" % char |
"o" % char |
"p" % char |
"q" % char |
"r" % char |
"s" % char |
"t" % char |
"u" % char |
"v" % char |
"w" % char |
"x" % char | "y" % char | "z" % char |
"G" % char |
"H" % char |
"I" % char |
"J" % char |
"K" % char |
"L" % char |
"M" % char |
"N" % char |
"O" % char |
"P" % char |
"Q" % char |
"R" % char |
"S" % char |
"T" % char |
"U" % char |
"V" % char |
"W" % char |
"X" % char | "Y" % char | "Z" % char
=> missing_break tt
| _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back charloc in
skip (cons (tok stop) acc)
end
| (End, stop) as other =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back other in
skip (cons (tok stop) acc)
end
with string (acc : list token) (sacc : list string) (start : point)
: list token :=
let tok (function_parameter : unit) : token :=
let 'tt := function_parameter in
tok start (here tt)
(String (Stdlib.String.concat "" % string (List.rev sacc))) in
match next tt with
| (End, stop) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq errors
(cons
(Tezos_error_monad.Error_monad.Unterminated_string
{| start := start; stop := stop |}) (Stdlib.op_exclamation errors))
in
skip (cons (tok tt) acc)
| (Uchar c, stop) =>
match uchar_to_char c with
| Some """" % char => skip (cons (tok tt) acc)
| Some ("010" % char | "013" % char) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq errors
(cons
(Tezos_error_monad.Error_monad.Unterminated_string
{| start := start; stop := stop |})
(Stdlib.op_exclamation errors)) in
skip (cons (tok tt) acc)
| Some "\" % char =>
match next tt with
| (End, stop) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq errors
(cons
(Tezos_error_monad.Error_monad.Unterminated_string
{| start := start; stop := stop |})
(Stdlib.op_exclamation errors)) in
skip (cons (tok tt) acc)
| (Uchar c, loc) =>
match uchar_to_char c with
| Some """" % char => string acc (cons """" % string sacc) start
| Some "r" % char => string acc (cons "
" % string sacc) start
| Some "n" % char => string acc (cons "
" % string sacc) start
| Some "t" % char => string acc (cons " " % string sacc) start
| Some "b" % char => string acc (cons "" % string sacc) start
| Some "\" % char => string acc (cons "\" % string sacc) start
| Some _ | None =>
let byte := Uutf.decoder_byte_count decoder in
let s := Stdlib.String.sub source (byte loc) (Z.sub byte (byte loc))
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq errors
(cons
(Tezos_error_monad.Error_monad.Undefined_escape_sequence loc s)
(Stdlib.op_exclamation errors)) in
string acc sacc start
end
end
| Some _ | None =>
let byte := Uutf.decoder_byte_count decoder in
let s := Stdlib.String.sub source (byte stop) (Z.sub byte (byte stop))
in
string acc (cons s sacc) start
end
end
with generic_ident
(allow_char : Stdlib.Uchar.t -> bool) (acc : list token) (start : point)
(ret : string -> point -> token_value) : list token :=
let tok (stop : point) : token :=
let name :=
Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
in
tok start stop (ret name stop) in
match next tt with
| (Uchar c, stop) as charloc =>
if allow_char c then
generic_ident allow_char acc start ret
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back charloc in
skip (cons (tok stop) acc)
| (_, stop) as other =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back other in
skip (cons (tok stop) acc)
end
with ident
(acc : list token) (start : point) (ret : string -> point -> token_value)
: list token :=
generic_ident allowed_ident_char acc start ret
with annot
(acc : list token) (start : point) (ret : string -> point -> token_value)
: list token :=
generic_ident allowed_annot_char acc start ret
with comment (acc : list token) (start : point) (lvl : Z) : list token :=
match next tt with
| (End, stop) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq errors
(cons
(Tezos_error_monad.Error_monad.Unterminated_comment
{| start := start; stop := stop |}) (Stdlib.op_exclamation errors))
in
let text :=
Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
in
skip (cons (tok start stop (Comment text)) acc)
| (Uchar c, _) =>
match uchar_to_char c with
| Some "*" % char =>
match next tt with
| (Uchar c, _) =>
if equiv_decb lvl 0 then
let stop := here tt in
let text :=
Stdlib.String.sub source (byte start)
(Z.sub (byte stop) (byte start)) in
skip (cons (tok start stop (Comment text)) acc)
else
comment acc start (Z.sub lvl 1)
| other =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back other in
comment acc start lvl
end
| Some "/" % char =>
match next tt with
| (Uchar c, _) => comment acc start (Z.add lvl 1)
| other =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back other in
comment acc start lvl
end
| Some _ | None => comment acc start lvl
end
end
with eol_comment (acc : list token) (start : point) : list token :=
let tok (stop : point) : token :=
let text :=
Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
in
tok start stop (Eol_comment text) in
match next tt with
| (Uchar c, stop) =>
match uchar_to_char c with
| Some "010" % char => skip (cons (tok stop) acc)
| Some _ | None => eol_comment acc start
end
| (_, stop) as other =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := back other in
skip (cons (tok stop) acc)
end in
let tokens := skip [] in
(tokens, (List.rev (Stdlib.op_exclamation errors))).
Definition node := Tezos_micheline.Micheline.node location string.
Definition node_encoding
: Tezos_data_encoding.Data_encoding.encoding
(Tezos_micheline.Micheline.node location string) :=
Micheline.table_encoding "generic" % string location_encoding
Data_encoding.string.
Definition min_point (function_parameter : list node) : point :=
match function_parameter with
| [] => point_zero
|
cons (Tezos_micheline.Micheline.Int {| start := start |} _) _ |
cons (Tezos_micheline.Micheline.String {| start := start |} _) _ |
cons (Tezos_micheline.Micheline.Bytes {| start := start |} _) _ |
cons (Tezos_micheline.Micheline.Prim {| start := start |} _ _ _) _ |
cons (Tezos_micheline.Micheline.Seq {| start := start |} _) _ => start
end.
Fixpoint max_point (function_parameter : list node) : point :=
match function_parameter with
| [] => point_zero
| cons _ ((cons _ _) as rest) => max_point rest
|
cons (Tezos_micheline.Micheline.Int {| stop := stop |} _) [] |
cons (Tezos_micheline.Micheline.String {| stop := stop |} _) [] |
cons (Tezos_micheline.Micheline.Bytes {| stop := stop |} _) [] |
cons (Tezos_micheline.Micheline.Prim {| stop := stop |} _ _ _) [] |
cons (Tezos_micheline.Micheline.Seq {| stop := stop |} _) [] => stop
end.
Inductive mode : Type :=
| Toplevel : (list node) -> mode
| Expression : (option node) -> mode
| Sequence : token -> (list node) -> mode
| Unwrapped : location -> string -> (list node) -> (list string) -> mode
| Wrapped : token -> string -> (list node) -> (list string) -> mode.
Definition push_mode {A : Type} (mode : A) (stack : list A) : list A :=
cons mode stack.
Definition pop_mode {A : Type} (function_parameter : list A) : list A :=
match function_parameter with
| [] =>
(* ❌ Assert instruction is not handled. *)
assert false
| cons _ rest => rest
end.
Definition fill_mode (result : node) (function_parameter : list mode)
: list mode :=
match function_parameter with
| [] =>
(* ❌ Assert instruction is not handled. *)
assert false
| cons (Expression _) (cons _ _) =>
(* ❌ Assert instruction is not handled. *)
assert false
| cons (Expression (Some _)) [] =>
(* ❌ Assert instruction is not handled. *)
assert false
| cons (Toplevel _) (cons _ _) =>
(* ❌ Assert instruction is not handled. *)
assert false
| cons (Expression None) [] => cons (Expression (Some result)) []
| cons (Toplevel exprs) [] => cons (Toplevel (cons result exprs)) []
| cons (Sequence token exprs) rest =>
cons (Sequence token (cons result exprs)) rest
| cons (Wrapped token name exprs annot) rest =>
cons (Wrapped token name (cons result exprs) annot) rest
| cons (Unwrapped start name exprs annot) rest =>
cons (Unwrapped start name (cons result exprs) annot) rest
end.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Fixpoint annots (function_parameter : list token)
: (list string) * (list token) :=
match function_parameter with
| cons {| token := Annot annot |} rest =>
let '(annots, rest) := annots rest in
((cons annot annots), rest)
| rest => ([], rest)
end.
Fixpoint parse (op_staroptstar : option bool)
: (list Tezos_error_monad.Error_monad.error) ->
(list token) ->
(list mode) -> (list node) * (list Tezos_error_monad.Error_monad.error) :=
let check :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun errors =>
fun tokens =>
fun stack =>
match (stack, tokens) with
|
([], _) | (cons (Wrapped _ _ _ _) [], _) |
(cons (Unwrapped _ _ _ _) [], _) |
(cons (Unwrapped _ _ _ _) (cons (Unwrapped _ _ _ _) _), _) |
(cons (Unwrapped _ _ _ _) (cons (Wrapped _ _ _ _) _), _) |
(cons (Toplevel _) (cons _ _), _) |
(cons (Expression _) (cons _ _), _) =>
(* ❌ Assert instruction is not handled. *)
assert false
| (cons (Expression (Some result)) _, []) =>
((cons result []), (List.rev errors))
| (cons (Expression (Some _)) _, cons token rem) =>
let errors :=
cons (Tezos_error_monad.Error_monad.Unexpected token) errors in
parse (Some check) errors rem stack
| (cons (Expression None) _, []) =>
let errors := cons Tezos_error_monad.Error_monad.Empty errors in
let ghost := {| start := point_zero; stop := point_zero |} in
((cons (Tezos_micheline.Micheline.Seq ghost []) []), (List.rev errors))
|
(cons
(Toplevel
(cons ((Tezos_micheline.Micheline.Seq _ exprs) as expr) [])) [],
[]) =>
let errors :=
if check then
do_check (Some false) errors expr
else
errors in
(exprs, (List.rev errors))
| (cons (Toplevel exprs) [], []) =>
let exprs := List.rev exprs in
let loc := {| start := min_point exprs; stop := max_point exprs |} in
let expr := Tezos_micheline.Micheline.Seq loc exprs in
let errors :=
if check then
do_check (Some true) errors expr
else
errors in
(exprs, (List.rev errors))
| (_, cons {| token := Eol_comment _ | Comment _ |} rest) =>
parse (Some check) errors rest stack
|
(cons (Expression None | Sequence _ _ | Toplevel _) _,
cons ({| token := Int _ | String _ | Bytes _ |} as token)
(cons {| token := Eol_comment _ | Comment _ |} rest)) |
(cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
cons ({| token := Open_paren |} as token)
(cons {| token := Eol_comment _ | Comment _ |} rest)) =>
parse (Some check) errors (cons token rest) stack
|
(cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
cons ({| token := Open_paren |} as token)
(cons {| token := Open_paren | Open_brace |} rem)) |
(cons (Unwrapped _ _ _ _) (cons (Expression _) _),
cons ({| token := Semi | Close_brace | Close_paren |} as token)
rem) |
(cons (Expression None) _,
cons
({| token := Semi | Close_brace | Close_paren | Open_paren |} as
token) rem) =>
let errors :=
cons (Tezos_error_monad.Error_monad.Unexpected token) errors in
parse (Some check) errors rem stack
|
(cons (Sequence _ _ | Toplevel _) _,
cons ({| token := Semi |} as valid)
(cons ({| token := Semi |} as token) rem)) =>
let errors := cons (Tezos_error_monad.Error_monad.Extra token) errors
in
parse (Some check) errors (cons valid rem) stack
|
(cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
cons {| token := Open_paren |}
(cons
({|
token := Int _ | String _ | Bytes _ | Annot _ | Close_paren
|} as token) rem)) |
(cons (Expression None | Sequence _ _ | Toplevel _) _,
cons {| token := Int _ | String _ | Bytes _ |}
(cons
({|
token :=
Ident _ | Int _ | String _ | Bytes _ | Annot _ |
Close_paren | Open_paren | Open_brace
|} as token) rem)) |
(cons (Unwrapped _ _ _ _) (cons (Toplevel _) _),
cons ({| token := Close_brace |} as token) rem) |
(cons (Unwrapped _ _ _ _) _,
cons ({| token := Close_paren |} as token) rem) |
(cons (Toplevel _) [],
cons ({| token := Close_paren |} as token) rem) |
(cons (Toplevel _) [], cons ({| token := Open_paren |} as token) rem)
|
(cons (Toplevel _) [],
cons ({| token := Close_brace |} as token) rem) |
(cons (Sequence _ _) _,
cons ({| token := Open_paren |} as token) rem) |
(cons (Sequence _ _) _,
cons ({| token := Close_paren |} as token) rem) |
(cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
cons ({| token := Open_paren |} as token)
((cons {| token := Close_brace | Semi |} _ | []) as rem)) |
(_, cons ({| token := Annot _ |} as token) rem) =>
let errors :=
cons (Tezos_error_monad.Error_monad.Unexpected token) errors in
parse (Some check) errors rem stack
|
(cons (Wrapped token _ _ _) _,
[] | cons {| token := Close_brace | Semi |} _) =>
let errors :=
cons (Tezos_error_monad.Error_monad.Unclosed token) errors in
let fake :=
(* ❌ Record substitution not handled *)
record_substitution in
let tokens := cons fake tokens in
parse (Some check) errors tokens stack
|
(cons (Sequence token _) _ |
cons (Unwrapped _ _ _ _) (cons (Sequence token _) _), []) =>
let errors :=
cons (Tezos_error_monad.Error_monad.Unclosed token) errors in
let fake :=
(* ❌ Record substitution not handled *)
record_substitution in
let tokens := cons fake tokens in
parse (Some check) errors tokens stack
|
(cons (Toplevel _ | Sequence _ _) _,
cons {| token := Ident name; loc := loc |}
((cons {| token := Annot _ |} _) as rest)) =>
let '(annots, rest) := annots rest in
let mode := Unwrapped loc name [] annots in
parse (Some check) errors rest (push_mode mode stack)
|
(cons (Expression None | Toplevel _ | Sequence _ _) _,
cons {| token := Ident name; loc := loc |} rest) =>
let mode := Unwrapped loc name [] [] in
parse (Some check) errors rest (push_mode mode stack)
|
(cons (Unwrapped _ _ _ _ | Wrapped _ _ _ _) _,
cons {| token := Int value; loc := loc |} rest) |
(cons (Expression None | Sequence _ _ | Toplevel _) _,
cons {| token := Int value; loc := loc |}
(([] | cons {| token := Semi | Close_brace |} _) as rest)) =>
let expr := Tezos_micheline.Micheline.Int loc (Z.of_string value) in
let errors :=
if check then
do_check (Some false) errors expr
else
errors in
parse (Some check) errors rest (fill_mode expr stack)
|
(cons (Unwrapped _ _ _ _ | Wrapped _ _ _ _) _,
cons {| token := String contents; loc := loc |} rest) |
(cons (Expression None | Sequence _ _ | Toplevel _) _,
cons {| token := String contents; loc := loc |}
(([] | cons {| token := Semi | Close_brace |} _) as rest)) =>
let expr := Tezos_micheline.Micheline.String loc contents in
let errors :=
if check then
do_check (Some false) errors expr
else
errors in
parse (Some check) errors rest (fill_mode expr stack)
|
(cons (Unwrapped _ _ _ _ | Wrapped _ _ _ _) _,
cons {| token := Bytes contents; loc := loc |} rest) |
(cons (Expression None | Sequence _ _ | Toplevel _) _,
cons {| token := Bytes contents; loc := loc |}
(([] | cons {| token := Semi | Close_brace |} _) as rest)) =>
let '(errors, contents) :=
if nequiv_decb (Z.modulo (OCaml.String.length contents) 2) 0 then
((cons (Tezos_error_monad.Error_monad.Odd_lengthed_bytes loc)
errors), (String.append contents "0" % string))
else
(errors, contents) in
let bytes :=
Hex.to_bytes
(* ❌ Variants not supported *)
variant in
let expr := Tezos_micheline.Micheline.Bytes loc string in
let errors :=
if check then
do_check (Some false) errors expr
else
errors in
parse (Some check) errors rest (fill_mode expr stack)
|
(cons (Sequence {| loc := {| start := start |} |} exprs) _,
cons {| token := Close_brace; loc := {| stop := stop |} |} rest) =>
let exprs := List.rev exprs in
let expr :=
Tezos_micheline.Micheline.Seq {| start := start; stop := stop |}
exprs in
let errors :=
if check then
do_check (Some false) errors expr
else
errors in
parse (Some check) errors rest (fill_mode expr (pop_mode stack))
| (cons (Sequence _ _ | Toplevel _) _, cons {| token := Semi |} rest) =>
parse (Some check) errors rest stack
|
(cons (Unwrapped {| start := start; stop := stop |} name exprs annot)
(cons (Expression _) _), [] as rest) |
(cons
(Unwrapped {| start := start; stop := stop |} name exprs annot)
(cons (Toplevel _) _), (cons {| token := Semi |} _ | []) as rest)
|
(cons
(Unwrapped {| start := start; stop := stop |} name exprs annot)
(cons (Sequence _ _) _),
(cons {| token := Close_brace | Semi |} _) as rest) |
(cons
(Wrapped {| loc := {| start := start; stop := stop |} |} name
exprs annot) _, cons {| token := Close_paren |} rest) =>
let exprs := List.rev exprs in
let stop :=
if equiv_decb exprs [] then
stop
else
max_point exprs in
let expr :=
Tezos_micheline.Micheline.Prim {| start := start; stop := stop |}
name exprs annot in
let errors :=
if check then
do_check (Some false) errors expr
else
errors in
parse (Some check) errors rest (fill_mode expr (pop_mode stack))
|
(cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
cons ({| token := Open_paren |} as token)
(cons {| token := Ident name |}
((cons {| token := Annot _ |} _) as rest))) =>
let '(annots, rest) := annots rest in
let mode := Wrapped token name [] annots in
parse (Some check) errors rest (push_mode mode stack)
|
(cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
cons ({| token := Open_paren |} as token)
(cons {| token := Ident name |} rest)) =>
let mode := Wrapped token name [] [] in
parse (Some check) errors rest (push_mode mode stack)
|
(cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
cons {| token := Ident name; loc := loc |} rest) =>
let expr := Tezos_micheline.Micheline.Prim loc name [] [] in
let errors :=
if check then
do_check (Some false) errors expr
else
errors in
parse (Some check) errors rest (fill_mode expr stack)
|
(cons
(Wrapped _ _ _ _ | Unwrapped _ _ _ _ | Toplevel _ | Sequence _ _ |
Expression None) _, cons ({| token := Open_brace |} as token) rest)
=>
let mode := Sequence token [] in
parse (Some check) errors rest (push_mode mode stack)
end
with do_check (op_staroptstar : option bool)
: (list Tezos_error_monad.Error_monad.error) ->
(Tezos_micheline.Micheline.node location string) ->
list Tezos_error_monad.Error_monad.error :=
let toplevel :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun errors =>
fun function_parameter =>
match function_parameter with
|
(Tezos_micheline.Micheline.Seq {| start := start; stop := stop |} []) as
expr =>
if OCaml.Stdlib.ge (column start) (column stop) then
cons (Tezos_error_monad.Error_monad.Misaligned expr) errors
else
errors
|
(Tezos_micheline.Micheline.Prim {| start := start; stop := stop |} _
(cons first rest) _ |
Tezos_micheline.Micheline.Seq {| start := start; stop := stop |}
(cons first rest)) as expr =>
let '{| line := first_line; column := first_column |} :=
min_point (cons first []) in
if OCaml.Stdlib.ge (column start) (column stop) then
cons (Tezos_error_monad.Error_monad.Misaligned expr) errors
else
if andb (negb toplevel) (OCaml.Stdlib.ge (column start) first_column)
then
cons (Tezos_error_monad.Error_monad.Misaligned expr) errors
else
let fix in_line_or_aligned
(prev_start_line : Z) (errors :
list Tezos_error_monad.Error_monad.error) (function_parameter :
list node) : list Tezos_error_monad.Error_monad.error :=
match function_parameter with
| [] => errors
| cons expr rest =>
let '{| line := start_line; column := column |} :=
min_point (cons expr []) in
let '{| line := stop_line |} := max_point (cons expr []) in
let errors :=
if
andb (nequiv_decb stop_line prev_start_line)
(nequiv_decb column first_column) then
cons (Tezos_error_monad.Error_monad.Misaligned expr) errors
else
errors in
in_line_or_aligned start_line errors rest
end in
in_line_or_aligned first_line errors rest
|
Tezos_micheline.Micheline.Prim _ _ [] _ |
Tezos_micheline.Micheline.String _ _ |
Tezos_micheline.Micheline.Int _ _ |
Tezos_micheline.Micheline.Bytes _ _ => errors
end.
Definition parse_expression (check : option bool) (tokens : list token)
: node * (list Tezos_error_monad.Error_monad.error) :=
let result :=
match tokens with
|
cons ({| token := Open_paren |} as token)
(cons {| token := Ident name |} (cons {| token := Annot annot |} rest))
=>
let '(annots, rest) := annots rest in
let mode := Wrapped token name [] (cons annot annots) in
parse check [] rest (cons mode (cons (Expression None) []))
|
cons ({| token := Open_paren |} as token)
(cons {| token := Ident name |} rest) =>
let mode := Wrapped token name [] [] in
parse check [] rest (cons mode (cons (Expression None) []))
| _ => parse check [] tokens (cons (Expression None) [])
end in
match result with
| (cons single [], errors) => (single, errors)
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end.
Definition parse_toplevel (check : option bool) (tokens : list token)
: (list node) * (list Tezos_error_monad.Error_monad.error) :=
parse check [] tokens (cons (Toplevel []) []).
Definition print_point
(ppf : Stdlib.Format.formatter) (function_parameter : point) : unit :=
let '{| line := line; column := column |} := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "At line " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " character " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))))
"At line %d character %d" % string) line column.
Definition print_token_kind
(ppf : Stdlib.Format.formatter) (function_parameter : token_value) : unit :=
match function_parameter with
| Open_paren | Close_paren =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "parenthesis" % string
CamlinternalFormatBasics.End_of_format) "parenthesis" % string)
| Open_brace | Close_brace =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "curly brace" % string
CamlinternalFormatBasics.End_of_format) "curly brace" % string)
| String _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "string constant" % string
CamlinternalFormatBasics.End_of_format) "string constant" % string)
| Bytes _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "bytes constant" % string
CamlinternalFormatBasics.End_of_format) "bytes constant" % string)
| Int _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "integer constant" % string
CamlinternalFormatBasics.End_of_format) "integer constant" % string)
| Ident _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "identifier" % string
CamlinternalFormatBasics.End_of_format) "identifier" % string)
| Annot _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "annotation" % string
CamlinternalFormatBasics.End_of_format) "annotation" % string)
| Comment _ | Eol_comment _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "comment" % string
CamlinternalFormatBasics.End_of_format) "comment" % string)
| Semi =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "semi colon" % string
CamlinternalFormatBasics.End_of_format) "semi colon" % string)
end.
Definition print_location (ppf : Stdlib.Format.formatter) (loc : location)
: unit :=
if equiv_decb (line (start loc)) (line (stop loc)) then
if equiv_decb (column (start loc)) (column (stop loc)) then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "At line " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " character " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))))
"At line %d character %d" % string) (line (start loc))
(column (start loc))
else
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "At line " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " characters " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " to " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))))))
"At line %d characters %d to %d" % string) (line (start loc))
(column (start loc)) (column (stop loc))
else
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "From line " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " character " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " to line " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" character " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))))))))
"From line %d character %d to line %d character %d" % string)
(line (start loc)) (column (start loc)) (line (stop loc))
(column (stop loc)).
Definition no_parsing_error {A : Type}
(function_parameter : A * Tezos_error_monad.Error_monad.trace)
: Tezos_error_monad.Error_monad.tzresult A :=
let '(ast, errors) := function_parameter in
match errors with
| [] => ok ast
| errors => Stdlib.Error errors
end.
src/lib_micheline/micheline_printer.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Micheline
type location = {comment : string option}
type node = (location, string) Micheline.node
let printable ?(comment = fun _ -> None) map_prim expr =
let map_loc loc = {comment = comment loc} in
map_node map_loc map_prim (root expr)
let print_comment ppf text =
Format.fprintf ppf "/* @[<h>%a@] */" Format.pp_print_text text
let print_string ppf text =
Format.fprintf ppf "\"" ;
String.iter
(function
| '"' ->
Format.fprintf ppf "\\\""
| '\n' ->
Format.fprintf ppf "\\n"
| '\r' ->
Format.fprintf ppf "\\r"
| '\b' ->
Format.fprintf ppf "\\b"
| '\t' ->
Format.fprintf ppf "\\t"
| '\\' ->
Format.fprintf ppf "\\\\"
| c ->
Format.fprintf ppf "%c" c)
text ;
Format.fprintf ppf "\""
let print_annotations =
Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_string
let preformat root =
let preformat_loc = function
| {comment = None} ->
(false, 0)
| {comment = Some text} ->
(String.contains text '\n', String.length text + 1)
in
let preformat_annots = function
| [] ->
0
| annots ->
String.length (String.concat " " annots) + 2
in
let rec preformat_expr = function
| Int (loc, value) ->
let (cml, csz) = preformat_loc loc in
Int ((cml, String.length (Z.to_string value) + csz, loc), value)
| String (loc, value) ->
let (cml, csz) = preformat_loc loc in
String ((cml, String.length value + csz, loc), value)
| Bytes (loc, value) ->
let (cml, csz) = preformat_loc loc in
Bytes ((cml, (Bytes.length value * 2) + 2 + csz, loc), value)
| Prim (loc, name, items, annots) ->
let (cml, csz) = preformat_loc loc in
let asz = preformat_annots annots in
let items = List.map preformat_expr items in
let (ml, sz) =
List.fold_left
(fun (tml, tsz) e ->
let (ml, sz, _) = location e in
(tml || ml, tsz + 1 + sz))
(cml, String.length name + csz + asz)
items
in
Prim ((ml, sz, loc), name, items, annots)
| Seq (loc, items) ->
let (cml, csz) = preformat_loc loc in
let items = List.map preformat_expr items in
let (ml, sz) =
List.fold_left
(fun (tml, tsz) e ->
let (ml, sz, _) = location e in
(tml || ml, tsz + 3 + sz))
(cml, 4 + csz)
items
in
Seq ((ml, sz, loc), items)
in
preformat_expr root
let rec print_expr_unwrapped ppf = function
| Prim ((ml, s, {comment}), name, args, annot) ->
let name =
match annot with
| [] ->
name
| annots ->
Format.asprintf "%s @[<h>%a@]" name print_annotations annots
in
if (not ml) && s < 80 then (
if args = [] then Format.fprintf ppf "%s" name
else
Format.fprintf
ppf
"@[<h>%s %a@]"
name
(Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
args ;
match comment with
| None ->
()
| Some text ->
Format.fprintf ppf "@ /* %s */" text )
else (
if args = [] then Format.fprintf ppf "%s" name
else if String.length name <= 4 then
Format.fprintf
ppf
"%s @[<v 0>%a@]"
name
(Format.pp_print_list print_expr)
args
else
Format.fprintf
ppf
"@[<v 2>%s@,%a@]"
name
(Format.pp_print_list print_expr)
args ;
match comment with
| None ->
()
| Some comment ->
Format.fprintf ppf "@ %a" print_comment comment )
| Int ((_, _, {comment}), value) -> (
match comment with
| None ->
Format.fprintf ppf "%s" (Z.to_string value)
| Some comment ->
Format.fprintf ppf "%s@ %a" (Z.to_string value) print_comment comment )
| String ((_, _, {comment}), value) -> (
match comment with
| None ->
print_string ppf value
| Some comment ->
Format.fprintf ppf "%a@ %a" print_string value print_comment comment )
| Bytes ((_, _, {comment}), value) -> (
match comment with
| None ->
Format.fprintf ppf "0x%a" Hex.pp (Hex.of_bytes value)
| Some comment ->
Format.fprintf
ppf
"0x%a@ %a"
Hex.pp
(Hex.of_bytes value)
print_comment
comment )
| Seq ((_, _, {comment = None}), []) ->
Format.fprintf ppf "{}"
| Seq ((ml, s, {comment}), items) ->
if (not ml) && s < 80 then Format.fprintf ppf "{ @[<h 0>"
else Format.fprintf ppf "{ @[<v 0>" ;
( match (comment, items) with
| (None, _) ->
()
| (Some comment, []) ->
Format.fprintf ppf "%a" print_comment comment
| (Some comment, _) ->
Format.fprintf ppf "%a@ " print_comment comment ) ;
Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf " ;@ ")
print_expr_unwrapped
ppf
items ;
Format.fprintf ppf "@] }"
and print_expr ppf = function
| (Prim (_, _, _ :: _, _) | Prim (_, _, [], _ :: _)) as expr ->
Format.fprintf ppf "(%a)" print_expr_unwrapped expr
| expr ->
print_expr_unwrapped ppf expr
let with_unbounded_formatter ppf f x =
let buf = Buffer.create 10000 in
let sppf = Format.formatter_of_buffer buf in
Format.pp_set_margin sppf 199999 ;
Format.pp_set_max_indent sppf 99999 ;
Format.pp_set_max_boxes sppf 99999 ;
f sppf x ;
Format.fprintf sppf "%!" ;
let lines = String.split_on_char '\n' (Buffer.contents buf) in
Format.pp_print_list
~pp_sep:Format.pp_force_newline
Format.pp_print_string
ppf
lines
let print_expr_unwrapped ppf expr =
with_unbounded_formatter ppf print_expr_unwrapped (preformat expr)
let print_expr ppf expr =
with_unbounded_formatter ppf print_expr (preformat expr)
src/lib_micheline/micheline_printer.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Micheline.
Record location := {
comment : option string }.
Definition node := Tezos_micheline.Micheline.node location string.
Definition printable {A B : Type}
(op_staroptstar :
option (Tezos_micheline.Micheline.canonical_location -> option string))
: (A -> B) ->
(Tezos_micheline.Micheline.canonical A) ->
Tezos_micheline.Micheline.node location B :=
let comment :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
fun function_parameter =>
let '_ := function_parameter in
None
end in
fun map_prim =>
fun expr =>
let map_loc (loc : Tezos_micheline.Micheline.canonical_location)
: location :=
{| comment := comment loc |} in
map_node map_loc map_prim (root expr).
Definition print_comment (ppf : Stdlib.Format.formatter) (text : string)
: unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "/* " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<h>" % string
CamlinternalFormatBasics.End_of_format) "<h>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.String_literal " */" % string
CamlinternalFormatBasics.End_of_format)))))
"/* @[<h>%a@] */" % string) Format.pp_print_text text.
Definition print_string (ppf : Stdlib.Format.formatter) (text : string)
: unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal """" % char
CamlinternalFormatBasics.End_of_format) """" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.String.iter
(fun function_parameter =>
match function_parameter with
| """" % char =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "\""" % string
CamlinternalFormatBasics.End_of_format) "\""" % string)
| "010" % char =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "\n" % string
CamlinternalFormatBasics.End_of_format) "\n" % string)
| "013" % char =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "\r" % string
CamlinternalFormatBasics.End_of_format) "\r" % string)
| "008" % char =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "\b" % string
CamlinternalFormatBasics.End_of_format) "\b" % string)
| "009" % char =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "\t" % string
CamlinternalFormatBasics.End_of_format) "\t" % string)
| "\" % char =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "\\" % string
CamlinternalFormatBasics.End_of_format) "\\" % string)
| c =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char
CamlinternalFormatBasics.End_of_format) "%c" % string) c
end) text in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal """" % char
CamlinternalFormatBasics.End_of_format) """" % string).
Definition print_annotations
: Stdlib.Format.formatter -> (list string) -> unit :=
Format.pp_print_list (Some Format.pp_print_space) Format.pp_print_string.
Definition preformat (root : Tezos_micheline.Micheline.node location string)
: Tezos_micheline.Micheline.node (bool * Z * location) string :=
let preformat_loc (function_parameter : location) : bool * Z :=
match function_parameter with
| {| comment := None |} => (false, 0)
| {| comment := Some text |} =>
((Stdlib.String.contains text "010" % char),
(Z.add (OCaml.String.length text) 1))
end in
let preformat_annots (function_parameter : list string) : Z :=
match function_parameter with
| [] => 0
| annots =>
Z.add (OCaml.String.length (Stdlib.String.concat " " % string annots)) 2
end in
let fix preformat_expr
(function_parameter : Tezos_micheline.Micheline.node location string)
: Tezos_micheline.Micheline.node (bool * Z * location) string :=
match function_parameter with
| Tezos_micheline.Micheline.Int loc value =>
let '(cml, csz) := preformat_loc loc in
Tezos_micheline.Micheline.Int
(cml, (Z.add (OCaml.String.length (Z.to_string value)) csz), loc) value
| Tezos_micheline.Micheline.String loc value =>
let '(cml, csz) := preformat_loc loc in
Tezos_micheline.Micheline.String
(cml, (Z.add (OCaml.String.length value) csz), loc) value
| Tezos_micheline.Micheline.Bytes loc value =>
let '(cml, csz) := preformat_loc loc in
Tezos_micheline.Micheline.Bytes
(cml, (Z.add (Z.add (Z.mul (String.length value) 2) 2) csz), loc) value
| Tezos_micheline.Micheline.Prim loc name items annots =>
let '(cml, csz) := preformat_loc loc in
let asz := preformat_annots annots in
let items := List.map preformat_expr items in
let '(ml, sz) :=
Stdlib.List.fold_left
(fun function_parameter =>
let '(tml, tsz) := function_parameter in
fun e =>
let '(ml, sz, _) := location e in
((orb tml ml), (Z.add (Z.add tsz 1) sz)))
(cml, (Z.add (Z.add (OCaml.String.length name) csz) asz)) items in
Tezos_micheline.Micheline.Prim (ml, sz, loc) name items annots
| Tezos_micheline.Micheline.Seq loc items =>
let '(cml, csz) := preformat_loc loc in
let items := List.map preformat_expr items in
let '(ml, sz) :=
Stdlib.List.fold_left
(fun function_parameter =>
let '(tml, tsz) := function_parameter in
fun e =>
let '(ml, sz, _) := location e in
((orb tml ml), (Z.add (Z.add tsz 3) sz))) (cml, (Z.add 4 csz))
items in
Tezos_micheline.Micheline.Seq (ml, sz, loc) items
end in
preformat_expr root.
Fixpoint print_expr_unwrapped
(ppf : Stdlib.Format.formatter)
(function_parameter :
Tezos_micheline.Micheline.node (bool * Z * location) string) : unit :=
match function_parameter with
|
Tezos_micheline.Micheline.Prim (ml, s, {| comment := comment |}) name args
annot =>
let name :=
match annot with
| [] => name
| annots =>
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<h>" % string
CamlinternalFormatBasics.End_of_format) "<h>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"%s @[<h>%a@]" % string) name print_annotations annots
end in
if andb (negb ml) (OCaml.Stdlib.lt s 80) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if equiv_decb args [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) name
else
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<h>" % string
CamlinternalFormatBasics.End_of_format) "<h>" % string))
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<h>%s %a@]" % string) name
(Format.pp_print_list (Some Format.pp_print_space) print_expr) args
in
match comment with
| None => tt
| Some text =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "/* " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " */" % string
CamlinternalFormatBasics.End_of_format))))
"@ /* %s */" % string) text
end
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if equiv_decb args [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) name
else
if OCaml.Stdlib.le (OCaml.String.length name) 4 then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"%s @[<v 0>%a@]" % string) name
(Format.pp_print_list None print_expr) args
else
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>%s@,%a@]" % string) name
(Format.pp_print_list None print_expr) args in
match comment with
| None => tt
| Some comment =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "@ %a" % string)
print_comment comment
end
| Tezos_micheline.Micheline.Int (_, _, {| comment := comment |}) value =>
match comment with
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
(Z.to_string value)
| Some comment =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))) "%s@ %a" % string)
(Z.to_string value) print_comment comment
end
| Tezos_micheline.Micheline.String (_, _, {| comment := comment |}) value =>
match comment with
| None => print_string ppf value
| Some comment =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))) "%a@ %a" % string)
print_string value print_comment comment
end
| Tezos_micheline.Micheline.Bytes (_, _, {| comment := comment |}) value =>
match comment with
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "0x" % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "0x%a" % string) Hex.pp
(Hex.of_bytes None value)
| Some comment =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "0x" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))) "0x%a@ %a" % string)
Hex.pp (Hex.of_bytes None value) print_comment comment
end
| Tezos_micheline.Micheline.Seq (_, _, {| comment := None |}) [] =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "{}" % string
CamlinternalFormatBasics.End_of_format) "{}" % string)
| Tezos_micheline.Micheline.Seq (ml, s, {| comment := comment |}) items =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if andb (negb ml) (OCaml.Stdlib.lt s 80) then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "{ " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<h 0>" % string
CamlinternalFormatBasics.End_of_format) "<h 0>" % string))
CamlinternalFormatBasics.End_of_format)) "{ @[<h 0>" % string)
else
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "{ " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
CamlinternalFormatBasics.End_of_format)) "{ @[<v 0>" % string)
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match (comment, items) with
| (None, _) => tt
| (Some comment, []) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
print_comment comment
| (Some comment, _) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
CamlinternalFormatBasics.End_of_format)) "%a@ " % string)
print_comment comment
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal " ;" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
CamlinternalFormatBasics.End_of_format)) " ;@ " % string)))
print_expr_unwrapped ppf items in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.String_literal " }" % string
CamlinternalFormatBasics.End_of_format)) "@] }" % string)
end
with print_expr
(ppf : Stdlib.Format.formatter)
(function_parameter :
Tezos_micheline.Micheline.node (bool * Z * location) string) : unit :=
match function_parameter with
|
(Tezos_micheline.Micheline.Prim _ _ (cons _ _) _ |
Tezos_micheline.Micheline.Prim _ _ [] (cons _ _)) as expr =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))) "(%a)" % string)
print_expr_unwrapped expr
| expr => print_expr_unwrapped ppf expr
end.
Definition with_unbounded_formatter {A : Type}
(ppf : Stdlib.Format.formatter) (f : Stdlib.Format.formatter -> A -> unit)
(x : A) : unit :=
let buf := Buffer.create 10000 in
let sppf := Format.formatter_of_buffer buf in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_set_margin sppf 199999 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_set_max_indent sppf 99999 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Format.pp_set_max_boxes sppf 99999 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := f sppf x in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf sppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format)
"%!" % string) in
let lines := Stdlib.String.split_on_char "010" % char (Buffer.contents buf) in
Format.pp_print_list (Some Format.pp_force_newline) Format.pp_print_string ppf
lines.
Definition print_expr_unwrapped
(ppf : Stdlib.Format.formatter)
(expr : Tezos_micheline.Micheline.node location string) : unit :=
with_unbounded_formatter ppf print_expr_unwrapped (preformat expr).
Definition print_expr
(ppf : Stdlib.Format.formatter)
(expr : Tezos_micheline.Micheline.node location string) : unit :=
with_unbounded_formatter ppf print_expr (preformat expr).
src/lib_micheline/test/assert.ml success
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Mini compatibility layer to avoid circular dependency *)
module Compat = struct
let failwith fmt = Format.kasprintf (fun s -> Lwt.return_error s) fmt
let return_unit = Lwt.return_ok ()
let ( >>= ) = Lwt.bind
let ( >>=? ) v f =
v >>= function Error _ as err -> Lwt.return err | Ok v -> f v
let rec iter2_p f l1 l2 =
match (l1, l2) with
| ([], []) ->
return_unit
| ([], _) | (_, []) ->
invalid_arg "Error_monad.iter2_p"
| (x1 :: l1, x2 :: l2) -> (
let tx = f x1 x2 and tl = iter2_p f l1 l2 in
tx
>>= fun tx_res ->
tl
>>= fun tl_res ->
match (tx_res, tl_res) with
| (Ok (), Ok ()) ->
Lwt.return_ok ()
| (Error exn1, Error exn2) ->
failwith "%s -- %s" exn1 exn2
| (Ok (), Error exn) | (Error exn, Ok ()) ->
Lwt.return_error exn )
end
open Compat
let fail loc printer given expected msg =
failwith
"@[<v 2> On %s : %s@ @[Given:\t%a@]@ @[Expected:\t%a@]@]"
loc
msg
printer
given
printer
expected
let default_printer fmt _ = Format.fprintf fmt ""
let equal ~loc ?(eq = ( = )) ?(printer = default_printer) ?(msg = "") given
expected =
if not (eq given expected) then fail loc printer given expected msg
else return_unit
let not_equal ~loc ?(eq = ( = )) ?(printer = default_printer) ?(msg = "") given
expected =
if eq given expected then fail loc printer given expected msg
else return_unit
let pp_tokens fmt tokens =
let token_value_printer fmt token_value =
Format.fprintf
fmt
"@[%s@]"
(let open Micheline_parser in
match token_value with
| String s ->
Format.sprintf "String %S" s
| Bytes s ->
Format.sprintf "Bytes %S" s
| Int s ->
Format.sprintf "Int %S" s
| Ident s ->
Format.sprintf "Ident %S" s
| Annot s ->
Format.sprintf "Annot %S" s
| Comment s ->
Format.sprintf "Comment %S" s
| Eol_comment s ->
Format.sprintf "Eol_comment %S" s
| Semi ->
Format.sprintf "Semi"
| Open_paren ->
Format.sprintf "Open_paren"
| Close_paren ->
Format.sprintf "Close_paren"
| Open_brace ->
Format.sprintf "Open_brace"
| Close_brace ->
Format.sprintf "Close_brace")
in
Format.fprintf fmt "%a" (Format.pp_print_list token_value_printer) tokens
let equal_tokens ~loc given expected =
equal
~loc
~eq:( = )
~printer:pp_tokens
~msg:"Tokens are not equal"
given
expected
let not_equal_tokens ~loc given expected =
not_equal
~loc
~eq:( = )
~printer:pp_tokens
~msg:"Tokens are equal"
given
expected
src/lib_micheline/test/assert.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Compat.
Definition failwith {A B : Type}
(fmt :
Stdlib.format4 A Stdlib.Format.formatter unit
(Lwt.t (Result.result B string))) : A :=
Format.kasprintf (fun s => Lwt.return_error s) fmt.
Definition return_unit {A : Type} : Lwt.t (Result.result unit A) :=
Lwt.return_ok tt.
Definition op_gtgteq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
Lwt.bind.
Definition op_gtgteqquestion {A B C : Type}
(v : Lwt.t (sum A B)) (f : A -> Lwt.t (sum C B)) : Lwt.t (sum C B) :=
op_gtgteq v
(fun function_parameter =>
match function_parameter with
| (Stdlib.Error _) as err => Lwt._return err
| Stdlib.Ok v => f v
end).
Fixpoint iter2_p {A B : Type}
(f : A -> B -> Lwt.t (sum unit string)) (l1 : list A) (l2 : list B)
: Lwt.t (Result.result unit string) :=
match (l1, l2) with
| ([], []) => return_unit
| ([], _) | (_, []) =>
OCaml.Stdlib.invalid_arg "Error_monad.iter2_p" % string
| (cons x1 l1, cons x2 l2) =>
let tx : Lwt.t (sum unit string) :=
f x1 x2
with tl : Lwt.t (Result.result unit string) :=
iter2_p f l1 l2 in
op_gtgteq tx
(fun tx_res =>
op_gtgteq tl
(fun tl_res =>
match (tx_res, tl_res) with
| (Stdlib.Ok tt, Stdlib.Ok tt) => Lwt.return_ok tt
| (Stdlib.Error exn1, Stdlib.Error exn2) =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " -- " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"%s -- %s" % string) exn1 exn2
|
(Stdlib.Ok tt, Stdlib.Error exn) |
(Stdlib.Error exn, Stdlib.Ok tt) => Lwt.return_error exn
end))
end.
End Compat.
Import Compat.
Definition fail {A B : Type}
(loc : string) (printer : Stdlib.Format.formatter -> A -> unit) (given : A)
(expected : A) (msg : string) : Lwt.t (Result.result B string) :=
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal " On " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " : " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal "Given: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.String_literal
"Expected: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))))
"@[<v 2> On %s : %s@ @[Given: %a@]@ @[Expected: %a@]@]" % string) loc msg
printer given printer expected.
Definition default_printer {A : Type}
(fmt : Stdlib.Format.formatter) (function_parameter : A) : unit :=
let '_ := function_parameter in
Format.fprintf fmt
(CamlinternalFormatBasics.Format CamlinternalFormatBasics.End_of_format
"" % string).
Definition equal {A : Type}
(loc : string) (op_staroptstar : option (A -> A -> bool))
: (option (Stdlib.Format.formatter -> A -> unit)) ->
(option string) -> A -> A -> Lwt.t (Result.result unit string) :=
let eq :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => equiv_decb
end in
fun op_staroptstar =>
let printer :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_printer
end in
fun op_staroptstar =>
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun given =>
fun expected =>
if negb (eq given expected) then
fail loc printer given expected msg
else
return_unit.
Definition not_equal {A : Type}
(loc : string) (op_staroptstar : option (A -> A -> bool))
: (option (Stdlib.Format.formatter -> A -> unit)) ->
(option string) -> A -> A -> Lwt.t (Result.result unit string) :=
let eq :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => equiv_decb
end in
fun op_staroptstar =>
let printer :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_printer
end in
fun op_staroptstar =>
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun given =>
fun expected =>
if eq given expected then
fail loc printer given expected msg
else
return_unit.
Definition pp_tokens
(fmt : Stdlib.Format.formatter)
(tokens : list Tezos_micheline.Micheline_parser.token_value) : unit :=
let token_value_printer
(fmt : Stdlib.Format.formatter) (token_value :
Tezos_micheline.Micheline_parser.token_value) : unit :=
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))) "@[%s@]" % string)
match token_value with
| Tezos_micheline.Micheline_parser.String s =>
Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "String " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "String %S" % string) s
| Tezos_micheline.Micheline_parser.Bytes s =>
Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Bytes " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "Bytes %S" % string) s
| Tezos_micheline.Micheline_parser.Int s =>
Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Int " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "Int %S" % string) s
| Tezos_micheline.Micheline_parser.Ident s =>
Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Ident " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "Ident %S" % string) s
| Tezos_micheline.Micheline_parser.Annot s =>
Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Annot " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "Annot %S" % string) s
| Tezos_micheline.Micheline_parser.Comment s =>
Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Comment " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "Comment %S" % string)
s
| Tezos_micheline.Micheline_parser.Eol_comment s =>
Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Eol_comment " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Eol_comment %S" % string) s
| Tezos_micheline.Micheline_parser.Semi =>
Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Semi" % string
CamlinternalFormatBasics.End_of_format) "Semi" % string)
| Tezos_micheline.Micheline_parser.Open_paren =>
Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Open_paren" % string
CamlinternalFormatBasics.End_of_format) "Open_paren" % string)
| Tezos_micheline.Micheline_parser.Close_paren =>
Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Close_paren" % string
CamlinternalFormatBasics.End_of_format) "Close_paren" % string)
| Tezos_micheline.Micheline_parser.Open_brace =>
Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Open_brace" % string
CamlinternalFormatBasics.End_of_format) "Open_brace" % string)
| Tezos_micheline.Micheline_parser.Close_brace =>
Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Close_brace" % string
CamlinternalFormatBasics.End_of_format) "Close_brace" % string)
end in
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) (Format.pp_print_list None token_value_printer) tokens.
Definition equal_tokens
(loc : string) (given : list Tezos_micheline.Micheline_parser.token_value)
(expected : list Tezos_micheline.Micheline_parser.token_value)
: Lwt.t (Result.result unit string) :=
equal loc (Some equiv_decb) (Some pp_tokens)
(Some "Tokens are not equal" % string) given expected.
Definition not_equal_tokens
(loc : string) (given : list Tezos_micheline.Micheline_parser.token_value)
(expected : list Tezos_micheline.Micheline_parser.token_value)
: Lwt.t (Result.result unit string) :=
not_equal loc (Some equiv_decb) (Some pp_tokens)
(Some "Tokens are equal" % string) given expected.
src/lib_micheline/test/test_parser.ml 343 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(****************************************************************************)
(* Token value *)
(****************************************************************************)
open Assert.Compat
let assert_tokenize ~loc given expected =
match Micheline_parser.tokenize given with
| (tokens, []) ->
let tokens_got = List.map (fun x -> x.Micheline_parser.token) tokens in
Assert.equal_tokens ~loc tokens_got expected
| (_, _) ->
failwith "%s - Cannot tokenize %s" loc given
let assert_tokenize_error ~loc given expected =
match Micheline_parser.tokenize given with
| (tokens, []) ->
let tokens_got = List.map (fun x -> x.Micheline_parser.token) tokens in
Assert.not_equal_tokens ~loc tokens_got expected
| (_, _) ->
return_unit
let test_tokenize_basic () =
(* String *)
assert_tokenize ~loc:__LOC__ "\"abc\"" [String "abc"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "\"abc\t\"" [String "abc\t"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "\"abc\b\"" [String "abc\b"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "\"abc\\n\"" [String "abc\n"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "\"abc\\r\"" [String "abc\r"]
>>=? fun () ->
(*fail*)
assert_tokenize_error ~loc:__LOC__ "\"abc\n\"" [String "abc\n"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "\"abc\\\"" [String "abc\\"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "\"abc\"" [String "abc\n"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "\"abc\r\"" [String "abc\r"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "abc\r" [String "abc\r"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "\"abc\"\r" [String "abc\r"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "\"abc" [String "abc"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "abc\"" [String "abc"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "\"\"\"" [String ""]
>>=? fun () ->
(* Bytes *)
assert_tokenize ~loc:__LOC__ "0xabc" [Bytes "0xabc"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "0x" [Bytes "0x"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "0x1" [Bytes "0x1"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "xabc" [Bytes "xabc"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "1xabc" [Bytes "1xabc"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "1c" [Bytes "1c"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "0c" [Bytes "0c"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "0xx" [Bytes "0xx"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "0b" [Bytes "0b"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "0xg" [Bytes "0xg"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "0X" [Bytes "0X"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "1x" [Bytes "1x"]
>>=? fun () ->
(* Int *)
assert_tokenize ~loc:__LOC__ "10" [Int "10"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "0" [Int "0"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "00" [Int "00"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "001" [Int "001"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "-0" [Int "0"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "-1" [Int "-1"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "1" [Int "1"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "-10" [Int "-10"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ ".1000" [Int ".1000"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "10_00" [Int "10_00"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "1,000" [Int "1,000"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "1000.000" [Int "1000.000"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "-0" [Int "-0"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "--0" [Int "0"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "+0" [Int "0"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "a" [Int "a"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "0a" [Int "0a"]
>>=? fun () ->
(* Ident *)
assert_tokenize ~loc:__LOC__ "string" [Ident "string"]
>>=? fun () ->
(* Annotation *)
assert_tokenize ~loc:__LOC__ "@my_pair" [Annot "@my_pair"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "@@my_pair" [Annot "@@my_pair"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "$t" [Annot "$t"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "&t" [Annot "&t"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ ":t" [Annot ":t"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ ":_" [Annot ":_"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ ":0" [Annot ":0"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ ":%" [Annot ":%"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ ":%%" [Annot ":%%"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ ":%@" [Annot ":%@"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ ":%@_" [Annot ":%@_"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ ":%@_0" [Annot ":%@_0"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "%from" [Annot "%from"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "%@from" [Annot "%@from"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "%from_a" [Annot "%from_a"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "%from.a" [Annot "%from.a"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "%From.a" [Annot "%From.a"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "%0From.a" [Annot "%0From.a"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "?t" [Annot "?t"]
>>=? fun () ->
(*fail*)
assert_tokenize_error ~loc:__LOC__ "??t" [Annot "??t"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "&&t" [Annot "&&t"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "$$t" [Annot "$$t"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "_from" [Annot "_from"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ ".from" [Annot ".from"]
>>=? fun () ->
(*NOTE: the cases below fail because ':' is used in the middle of the
annotation. *)
assert_tokenize_error ~loc:__LOC__ "%:from" [Annot "%:from"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "%:@from" [Annot "%:@from"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "::t" [Annot "::t"]
>>=? fun () ->
(* Comment *)
assert_tokenize ~loc:__LOC__ "/*\"/**/\"*/" [Comment "/*\"/**/\"*/"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "/* /* /* */ */ */" [Comment "/* /* /* */ */ */"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "/*parse 1" [Comment "/*parse 1"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "parse 1*/" [Comment "parse 1*/"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "/* */*/" [Comment "/* */*/"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "/*/* */" [Comment "/*/* */"]
>>=? fun () ->
(* EOL *)
assert_tokenize ~loc:__LOC__ "#Access" [Eol_comment "#Access"]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "##Access" [Eol_comment "##Access"]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "?Access" [Eol_comment "?Access"]
>>=? fun () ->
(* SKIP *)
assert_tokenize ~loc:__LOC__ ";" [Semi]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "{" [Open_brace]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "}" [Close_brace]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "(" [Open_paren]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ ")" [Close_paren]
>>=? fun () ->
(*fail*)
assert_tokenize_error ~loc:__LOC__ "{" [Semi]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ ";" [Open_brace]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "}" [Open_brace]
>>=? fun () ->
assert_tokenize_error ~loc:__LOC__ "(" [Close_paren]
>>=? fun () -> assert_tokenize_error ~loc:__LOC__ ")" [Open_paren]
(*********************)
(* One line contracts *)
let test_one_line_contract () =
assert_tokenize
~loc:__LOC__
"(option int)"
[Open_paren; Ident "option"; Ident "int"; Close_paren]
>>=? fun () ->
assert_tokenize
~loc:__LOC__
"DIP {ADD}"
[Ident "DIP"; Open_brace; Ident "ADD"; Close_brace]
>>=? fun () ->
assert_tokenize
~loc:__LOC__
"parameter int;"
[Ident "parameter"; Ident "int"; Semi]
>>=? fun () ->
assert_tokenize
~loc:__LOC__
"PUSH string \"abc\";"
[Ident "PUSH"; Ident "string"; String "abc"; Semi]
>>=? fun () ->
assert_tokenize ~loc:__LOC__ "DROP; SWAP" [Ident "DROP"; Semi; Ident "SWAP"]
>>=? fun () ->
(* NOTE: the cases below do not fail because we only do tokenization. *)
assert_tokenize ~loc:__LOC__ "DIP {ADD" [Ident "DIP"; Open_brace; Ident "ADD"]
>>=? fun () ->
assert_tokenize
~loc:__LOC__
"(option int"
[Open_paren; Ident "option"; Ident "int"]
>>=? fun () ->
assert_tokenize
~loc:__LOC__
"parameter int}"
[Ident "parameter"; Ident "int"; Close_brace]
>>=? fun () ->
assert_tokenize
~loc:__LOC__
"}{}{}{"
[Close_brace; Open_brace; Close_brace; Open_brace; Close_brace; Open_brace]
(*********************************)
(* Conditional contracts *)
let test_condition_contract () =
assert_tokenize
~loc:__LOC__
"parameter (or string (option int));storage unit;return string;code \
{CAR;IF_LEFT{}{IF_NONE {FAIL}{PUSH int 0; CMPGT; IF {FAIL}{PUSH string \
\"\"}}};UNIT; SWAP; PAIR}"
[ Ident "parameter";
Open_paren;
Ident "or";
Ident "string";
Open_paren;
Ident "option";
Ident "int";
Close_paren;
Close_paren;
Semi;
Ident "storage";
Ident "unit";
Semi;
Ident "return";
Ident "string";
Semi;
Ident "code";
Open_brace;
Ident "CAR";
Semi;
Ident "IF_LEFT";
Open_brace;
Close_brace;
Open_brace;
Ident "IF_NONE";
Open_brace;
Ident "FAIL";
Close_brace;
Open_brace;
Ident "PUSH";
Ident "int";
Int "0";
Semi;
Ident "CMPGT";
Semi;
Ident "IF";
Open_brace;
Ident "FAIL";
Close_brace;
Open_brace;
Ident "PUSH";
Ident "string";
String "";
Close_brace;
Close_brace;
Close_brace;
Semi;
Ident "UNIT";
Semi;
Ident "SWAP";
Semi;
Ident "PAIR";
Close_brace ]
>>=? fun () ->
(* NOTE: the cases below do not fail because we only do tokenization. *)
assert_tokenize
~loc:__LOC__
"parameter (or string (option int);"
[ Ident "parameter";
Open_paren;
Ident "or";
Ident "string";
Open_paren;
Ident "option";
Ident "int";
Close_paren;
Semi ]
>>=? fun () ->
assert_tokenize
~loc:__LOC__
"parameter (or)"
[Ident "parameter"; Open_paren; Ident "or"; Close_paren]
>>=? fun () ->
assert_tokenize_error
~loc:__LOC__
"parameter (or"
[Ident "parameter"; Open_paren; Ident "or"; Close_paren]
(****************************************************************************)
(* Top-level parsing tests *)
(****************************************************************************)
let assert_toplevel_parsing ~loc source expected =
match Micheline_parser.tokenize source with
| (_, _ :: _) ->
failwith "%s - Cannot tokenize %s" loc source
| (tokens, []) -> (
match Micheline_parser.parse_toplevel tokens with
| (_, _ :: _) ->
failwith "%s - Cannot parse_toplevel %s" loc source
| (ast, []) ->
let ast = List.map Micheline.strip_locations ast in
let expected = List.map Micheline.strip_locations expected in
Assert.equal ~loc (List.length ast) (List.length expected)
>>=? fun () ->
iter2_p (Assert.equal ~loc) ast expected >>=? fun () -> return_unit )
let assert_toplevel_parsing_error ~loc source expected =
match Micheline_parser.tokenize source with
| (_, _ :: _) ->
return_unit
| (tokens, []) -> (
match Micheline_parser.parse_toplevel tokens with
| (_, _ :: _) ->
return_unit
| (ast, []) ->
let ast = List.map Micheline.strip_locations ast in
let expected = List.map Micheline.strip_locations expected in
Assert.equal ~loc (List.length ast) (List.length expected)
>>=? fun () -> iter2_p (Assert.not_equal ~loc) ast expected )
let test_basic_parsing () =
assert_toplevel_parsing
~loc:__LOC__
"parameter unit;"
[Prim ((), "parameter", [Prim ((), "unit", [], [])], [])]
>>=? fun () ->
(* Sequence *)
assert_toplevel_parsing
~loc:__LOC__
"code {}"
[Prim ((), "code", [Seq ((), [])], [])]
>>=? fun () ->
(* Int *)
assert_toplevel_parsing
~loc:__LOC__
"PUSH int 100"
[Prim ((), "PUSH", [Prim ((), "int", [], []); Int ((), Z.of_int 100)], [])]
>>=? fun () ->
(*NOTE: this case doesn't fail because we don't type check *)
assert_toplevel_parsing
~loc:__LOC__
"PUSH string 100"
[ Prim
((), "PUSH", [Prim ((), "string", [], []); Int ((), Z.of_int 100)], [])
]
>>=? fun () ->
assert_toplevel_parsing_error
~loc:__LOC__
"PUSH int 100_000"
[ Prim
( (),
"PUSH",
[Prim ((), "string", [], []); Int ((), Z.of_int 100_000)],
[] ) ]
>>=? fun () ->
assert_toplevel_parsing_error
~loc:__LOC__
"PUSH int 100"
[Prim ((), "PUSH", [Prim ((), "int", [], []); Int ((), Z.of_int 1000)], [])]
>>=? fun () ->
assert_toplevel_parsing_error
~loc:__LOC__
"PUSH int 100"
[ Prim
((), "PUSH", [Prim ((), "string", [], []); Int ((), Z.of_int 100)], [])
]
>>=? fun () ->
assert_toplevel_parsing_error
~loc:__LOC__
"PUSH int \"100\""
[ Prim
((), "PUSH", [Prim ((), "string", [], []); Int ((), Z.of_int 100)], [])
]
>>=? fun () ->
(* String *)
assert_toplevel_parsing
~loc:__LOC__
"Pair False \"abc\""
[Prim ((), "Pair", [Prim ((), "False", [], []); String ((), "abc")], [])]
>>=? fun () ->
assert_toplevel_parsing_error
~loc:__LOC__
"Pair False \"ab\""
[Prim ((), "Pair", [Prim ((), "False", [], []); String ((), "abc")], [])]
>>=? fun () ->
assert_toplevel_parsing_error
~loc:__LOC__
"Pair False abc\""
[Prim ((), "Pair", [Prim ((), "False", [], []); String ((), "abc")], [])]
>>=? fun () ->
(* annotations *)
assert_toplevel_parsing
~loc:__LOC__
"NIL @annot string; #comment\n"
[Prim ((), "NIL", [Prim ((), "string", [], [])], ["@annot"])]
>>=? fun () ->
assert_toplevel_parsing_error
~loc:__LOC__
"NIL @annot string; #comment\n"
[Prim ((), "NIL", [Prim ((), "string", [], [])], [])]
>>=? fun () ->
assert_toplevel_parsing
~loc:__LOC__
"IF_NONE {FAIL} {}"
[ Prim
( (),
"IF_NONE",
[Seq ((), [Prim ((), "FAIL", [], [])]); Seq ((), [])],
[] ) ]
>>=? fun () ->
assert_toplevel_parsing
~loc:__LOC__
"PUSH (map int bool) (Map (Item 100 False))"
[ Prim
( (),
"PUSH",
[ Prim
( (),
"map",
[Prim ((), "int", [], []); Prim ((), "bool", [], [])],
[] );
Prim
( (),
"Map",
[ Prim
( (),
"Item",
[Int ((), Z.of_int 100); Prim ((), "False", [], [])],
[] ) ],
[] ) ],
[] ) ]
>>=? fun () ->
assert_toplevel_parsing
~loc:__LOC__
"LAMDA @name int int {}"
[ Prim
( (),
"LAMDA",
[Prim ((), "int", [], []); Prim ((), "int", [], []); Seq ((), [])],
["@name"] ) ]
>>=? fun () ->
assert_toplevel_parsing
~loc:__LOC__
"code {DUP @test; DROP}"
[ Prim
( (),
"code",
[ Seq
((), [Prim ((), "DUP", [], ["@test"]); Prim ((), "DROP", [], [])])
],
[] ) ]
let test_condition_contract_parsing () =
assert_toplevel_parsing
~loc:__LOC__
"parameter unit;return unit;storage tez; #How much you have to send me \n\
code {CDR; DUP;AMOUNT; CMPLT;IF {FAIL}}"
[ Prim ((), "parameter", [Prim ((), "unit", [], [])], []);
Prim ((), "return", [Prim ((), "unit", [], [])], []);
Prim ((), "storage", [Prim ((), "tez", [], [])], []);
Prim
( (),
"code",
[ Seq
( (),
[ Prim ((), "CDR", [], []);
Prim ((), "DUP", [], []);
Prim ((), "AMOUNT", [], []);
Prim ((), "CMPLT", [], []);
Prim ((), "IF", [Seq ((), [Prim ((), "FAIL", [], [])])], [])
] ) ],
[] ) ]
let test_list_append_parsing () =
assert_toplevel_parsing
~loc:__LOC__
"parameter (pair (list int)(list int));return (list int);storage \
unit;code { CAR; DUP; DIP{CDR}; CAR;NIL int; SWAP;LAMDA (pair int (list \
int))(list int){DUP; CAR; DIP {CDR}; CONS};REDUCE;LAMDA (pair int (list \
int))(list int){DUP; CAR; DIP{CDR}; CONS};UNIT; SWAP; PAIR}"
[ Prim
( (),
"parameter",
[ Prim
( (),
"pair",
[ Prim ((), "list", [Prim ((), "int", [], [])], []);
Prim ((), "list", [Prim ((), "int", [], [])], []) ],
[] ) ],
[] );
Prim
((), "return", [Prim ((), "list", [Prim ((), "int", [], [])], [])], []);
Prim ((), "storage", [Prim ((), "unit", [], [])], []);
Prim
( (),
"code",
[ Seq
( (),
[ Prim ((), "CAR", [], []);
Prim ((), "DUP", [], []);
Prim ((), "DIP", [Seq ((), [Prim ((), "CDR", [], [])])], []);
Prim ((), "CAR", [], []);
Prim ((), "NIL", [Prim ((), "int", [], [])], []);
Prim ((), "SWAP", [], []);
Prim
( (),
"LAMDA",
[ Prim
( (),
"pair",
[ Prim ((), "int", [], []);
Prim ((), "list", [Prim ((), "int", [], [])], [])
],
[] );
Prim ((), "list", [Prim ((), "int", [], [])], []);
Seq
( (),
[ Prim ((), "DUP", [], []);
Prim ((), "CAR", [], []);
Prim
( (),
"DIP",
[Seq ((), [Prim ((), "CDR", [], [])])],
[] );
Prim ((), "CONS", [], []) ] ) ],
[] );
Prim ((), "REDUCE", [], []);
Prim
( (),
"LAMDA",
[ Prim
( (),
"pair",
[ Prim ((), "int", [], []);
Prim ((), "list", [Prim ((), "int", [], [])], [])
],
[] );
Prim ((), "list", [Prim ((), "int", [], [])], []);
Seq
( (),
[ Prim ((), "DUP", [], []);
Prim ((), "CAR", [], []);
Prim
( (),
"DIP",
[Seq ((), [Prim ((), "CDR", [], [])])],
[] );
Prim ((), "CONS", [], []) ] ) ],
[] );
Prim ((), "UNIT", [], []);
Prim ((), "SWAP", [], []);
Prim ((), "PAIR", [], []) ] ) ],
[] ) ]
(****************************************************************************)
(* Expression parsing tests *)
(****************************************************************************)
let assert_expression_parsing ~loc source expected =
match Micheline_parser.tokenize source with
| (_, _ :: _) ->
failwith "%s - Cannot tokenize %s" loc source
| (tokens, []) -> (
match Micheline_parser.parse_expression tokens with
| (_, _ :: _) ->
failwith "%s - Cannot parse_expression %s" loc source
| (ast, []) ->
let ast = Micheline.strip_locations ast in
let expected = Micheline.strip_locations expected in
Assert.equal ~loc ast expected )
let test_parses_expression () =
(* String *)
assert_expression_parsing
~loc:__LOC__
"Pair False \"abc\""
(Prim ((), "Pair", [Prim ((), "False", [], []); String ((), "abc")], []))
>>=? fun () ->
(* Int *)
assert_expression_parsing
~loc:__LOC__
"Item 100"
(Prim ((), "Item", [Int ((), Z.of_int 100)], []))
>>=? fun () ->
(* Sequence *)
assert_expression_parsing ~loc:__LOC__ "{}" (Seq ((), []))
(****************************************************************************)
let tests =
[ ("tokenize", fun _ -> test_tokenize_basic ());
("test one line contract", fun _ -> test_one_line_contract ());
("test_condition_contract", fun _ -> test_condition_contract ());
("test_basic_parsing", fun _ -> test_basic_parsing ());
( "test_condition_contract_parsing",
fun _ -> test_condition_contract_parsing () );
("test_list_append_parsing", fun _ -> test_list_append_parsing ());
("test_parses_expression", fun _ -> test_parses_expression ()) ]
let wrap (n, f) =
Alcotest_lwt.test_case n `Quick (fun _ () ->
f ()
>>= function Ok () -> Lwt.return_unit | Error err -> Lwt.fail_with err)
let () =
Alcotest.run
~argv:[|""|]
"tezos-lib-micheline"
[("micheline", List.map wrap tests)]
src/lib_micheline/test/test_parser.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition assert_tokenize {A B C : Type}
(loc : A) (given : string) (expected : B) : C :=
match Micheline_parser.tokenize given with
| (tokens, []) =>
let tokens_got := List.map (fun x => Micheline_parser.token x) tokens in
op_startypeminuserrorstar loc tokens_got expected
| (_, _) => OCaml.Stdlib.failwith "%s - Cannot tokenize %s" % string loc given
end.
Definition assert_tokenize_error {A B C : Type}
(loc : A) (given : string) (expected : B) : C :=
match Micheline_parser.tokenize given with
| (tokens, []) =>
let tokens_got := List.map (fun x => Micheline_parser.token x) tokens in
op_startypeminuserrorstar loc tokens_got expected
| (_, _) => op_startypeminuserrorstar
end.
Definition test_tokenize_basic {A : Type} (function_parameter : unit) : A :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__ """abc""" % string
(cons op_startypeminuserrorstar []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__ """abc """ % string
(cons op_startypeminuserrorstar []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__ """abc""" % string
(cons op_startypeminuserrorstar []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__ """abc\n""" % string
(cons op_startypeminuserrorstar []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__ """abc\r""" % string
(cons op_startypeminuserrorstar []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize_error Stdlib.__LOC__
"""abc
""" % string
(cons op_startypeminuserrorstar []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize_error Stdlib.__LOC__
"""abc\""" % string
(cons op_startypeminuserrorstar []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize_error Stdlib.__LOC__
"""abc""" % string
(cons op_startypeminuserrorstar []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize_error Stdlib.__LOC__
"""abc
""" % string
(cons op_startypeminuserrorstar []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize_error Stdlib.__LOC__
"abc
" % string
(cons op_startypeminuserrorstar []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__ """abc""
" % string
(cons op_startypeminuserrorstar []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"""abc" % string
(cons
op_startypeminuserrorstar []))
(fun function_parameter =>
let 'tt := function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"abc""" % string
(cons
op_startypeminuserrorstar
[]))
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"""""""" % string
(cons
op_startypeminuserrorstar
[]))
(fun function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"0xabc" % string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"0x" % string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"0x1" %
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"xabc"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"1xabc"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"1c"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"0c"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"0xx"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"0b"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"0xg"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"0X"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"1x"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"10"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"0"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"00"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"001"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"-0"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"-1"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"1"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"-10"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
".1000"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"10_00"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"1,000"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"1000.000"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"-0"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"--0"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"+0"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"a"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"0a"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"string"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"@my_pair"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"@@my_pair"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"$t"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"&t"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
":t"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
":_"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
":0"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
":%"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
":%%"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
":%@"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
":%@_"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
":%@_0"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"%from"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"%@from"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"%from_a"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"%from.a"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"%From.a"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"%0From.a"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"?t"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"??t"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"&&t"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"$$t"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"_from"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
".from"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"%:from"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"%:@from"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"::t"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"/*""/**/""*/"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"/* /* /* */ */ */"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"/*parse 1"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"parse 1*/"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"/* */*/"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"/*/* */"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"#Access"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"##Access"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"?Access"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
";"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"{"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"}"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
"("
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize
Stdlib.__LOC__
")"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"{"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
";"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"}"
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_tokenize_error
Stdlib.__LOC__
"("
%
string
(cons
op_startypeminuserrorstar
[]))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
assert_tokenize_error
Stdlib.__LOC__
")"
%
string
(cons
op_startypeminuserrorstar
[])))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))).
Definition test_one_line_contract {A : Type} (function_parameter : unit) : A :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__ "(option int)" % string
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar (cons op_startypeminuserrorstar [])))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__ "DIP {ADD}" % string
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar [])))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__ "parameter int;" % string
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar []))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__ "PUSH string ""abc"";" % string
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar [])))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__ "DROP; SWAP" % string
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar []))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__ "DIP {ADD" % string
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar []))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__
"(option int" % string
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar []))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__
"parameter int}" % string
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar []))))
(fun function_parameter =>
let 'tt := function_parameter in
assert_tokenize Stdlib.__LOC__
"}{}{}{" % string
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar [])))))))))))))).
Definition test_condition_contract {A : Type} (function_parameter : unit) : A :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__
"parameter (or string (option int));storage unit;return string;code {CAR;IF_LEFT{}{IF_NONE {FAIL}{PUSH int 0; CMPGT; IF {FAIL}{PUSH string """"}}};UNIT; SWAP; PAIR}"
% string
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
(cons
op_startypeminuserrorstar
[]))))))))))))))))))))))))))))))))))))))))))))))))))))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__
"parameter (or string (option int);" % string
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar []))))))))))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_tokenize Stdlib.__LOC__ "parameter (or)" % string
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar [])))))
(fun function_parameter =>
let 'tt := function_parameter in
assert_tokenize_error Stdlib.__LOC__ "parameter (or" % string
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar []))))))).
Definition assert_toplevel_parsing {A B C D : Type}
(loc : A) (source : string)
(expected : list (Tezos_micheline.Micheline.node B C)) : D :=
match Micheline_parser.tokenize source with
| (_, cons _ _) =>
OCaml.Stdlib.failwith "%s - Cannot tokenize %s" % string loc source
| (tokens, []) =>
match Micheline_parser.parse_toplevel None tokens with
| (_, cons _ _) =>
OCaml.Stdlib.failwith "%s - Cannot parse_toplevel %s" % string loc source
| (ast, []) =>
let ast := List.map Micheline.strip_locations ast in
let expected := List.map Micheline.strip_locations expected in
op_startypeminuserrorstar
(op_startypeminuserrorstar loc (OCaml.List.length ast)
(OCaml.List.length expected))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar (op_startypeminuserrorstar loc) ast
expected)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar))
end
end.
Definition assert_toplevel_parsing_error {A B C D : Type}
(loc : A) (source : string)
(expected : list (Tezos_micheline.Micheline.node B C)) : D :=
match Micheline_parser.tokenize source with
| (_, cons _ _) => op_startypeminuserrorstar
| (tokens, []) =>
match Micheline_parser.parse_toplevel None tokens with
| (_, cons _ _) => op_startypeminuserrorstar
| (ast, []) =>
let ast := List.map Micheline.strip_locations ast in
let expected := List.map Micheline.strip_locations expected in
op_startypeminuserrorstar
(op_startypeminuserrorstar loc (OCaml.List.length ast)
(OCaml.List.length expected))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (op_startypeminuserrorstar loc) ast expected)
end
end.
Definition test_basic_parsing {A : Type} (function_parameter : unit) : A :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_toplevel_parsing Stdlib.__LOC__ "parameter unit;" % string
(cons
(Tezos_micheline.Micheline.Prim tt "parameter" % string
(cons (Tezos_micheline.Micheline.Prim tt "unit" % string [] []) []) [])
[]))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_toplevel_parsing Stdlib.__LOC__ "code {}" % string
(cons
(Tezos_micheline.Micheline.Prim tt "code" % string
(cons (Tezos_micheline.Micheline.Seq tt []) []) []) []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_toplevel_parsing Stdlib.__LOC__ "PUSH int 100" % string
(cons
(Tezos_micheline.Micheline.Prim tt "PUSH" % string
(cons (Tezos_micheline.Micheline.Prim tt "int" % string [] [])
(cons (Tezos_micheline.Micheline.Int tt (Z.of_int 100)) []))
[]) []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_toplevel_parsing Stdlib.__LOC__
"PUSH string 100" % string
(cons
(Tezos_micheline.Micheline.Prim tt "PUSH" % string
(cons
(Tezos_micheline.Micheline.Prim tt "string" % string []
[])
(cons (Tezos_micheline.Micheline.Int tt (Z.of_int 100))
[])) []) []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_toplevel_parsing_error Stdlib.__LOC__
"PUSH int 100_000" % string
(cons
(Tezos_micheline.Micheline.Prim tt "PUSH" % string
(cons
(Tezos_micheline.Micheline.Prim tt "string" % string
[] [])
(cons
(Tezos_micheline.Micheline.Int tt
(Z.of_int 100000)) [])) []) []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_toplevel_parsing_error Stdlib.__LOC__
"PUSH int 100" % string
(cons
(Tezos_micheline.Micheline.Prim tt "PUSH" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"int" % string [] [])
(cons
(Tezos_micheline.Micheline.Int tt
(Z.of_int 1000)) [])) []) []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_toplevel_parsing_error Stdlib.__LOC__
"PUSH int 100" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"PUSH" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"string" % string [] [])
(cons
(Tezos_micheline.Micheline.Int tt
(Z.of_int 100)) [])) []) []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_toplevel_parsing_error Stdlib.__LOC__
"PUSH int ""100""" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"PUSH" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"string" % string [] [])
(cons
(Tezos_micheline.Micheline.Int tt
(Z.of_int 100)) [])) []) []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_toplevel_parsing Stdlib.__LOC__
"Pair False ""abc""" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"Pair" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"False" % string [] [])
(cons
(Tezos_micheline.Micheline.String
tt "abc" % string) [])) []) []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_toplevel_parsing_error
Stdlib.__LOC__
"Pair False ""ab""" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"Pair" % string
(cons
(Tezos_micheline.Micheline.Prim
tt "False" % string [] [])
(cons
(Tezos_micheline.Micheline.String
tt "abc" % string) [])) [])
[]))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_toplevel_parsing_error
Stdlib.__LOC__
"Pair False abc""" % string
(cons
(Tezos_micheline.Micheline.Prim
tt "Pair" % string
(cons
(Tezos_micheline.Micheline.Prim
tt "False" % string [] [])
(cons
(Tezos_micheline.Micheline.String
tt "abc" % string) []))
[]) []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_toplevel_parsing
Stdlib.__LOC__
"NIL @annot string; #comment
"
% string
(cons
(Tezos_micheline.Micheline.Prim
tt "NIL" % string
(cons
(Tezos_micheline.Micheline.Prim
tt "string" % string
[] []) [])
(cons "@annot" % string []))
[]))
(fun function_parameter =>
let 'tt := function_parameter
in
op_startypeminuserrorstar
(assert_toplevel_parsing_error
Stdlib.__LOC__
"NIL @annot string; #comment
"
% string
(cons
(Tezos_micheline.Micheline.Prim
tt "NIL" % string
(cons
(Tezos_micheline.Micheline.Prim
tt
"string" % string
[] []) []) []) []))
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
(assert_toplevel_parsing
Stdlib.__LOC__
"IF_NONE {FAIL} {}" %
string
(cons
(Tezos_micheline.Micheline.Prim
tt
"IF_NONE" % string
(cons
(Tezos_micheline.Micheline.Seq
tt
(cons
(Tezos_micheline.Micheline.Prim
tt
"FAIL" %
string
[] []) []))
(cons
(Tezos_micheline.Micheline.Seq
tt []) []))
[]) []))
(fun function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_toplevel_parsing
Stdlib.__LOC__
"PUSH (map int bool) (Map (Item 100 False))"
% string
(cons
(Tezos_micheline.Micheline.Prim
tt
"PUSH" %
string
(cons
(Tezos_micheline.Micheline.Prim
tt
"map" %
string
(cons
(Tezos_micheline.Micheline.Prim
tt
"int"
%
string
[] [])
(cons
(Tezos_micheline.Micheline.Prim
tt
"bool"
%
string
[]
[])
[]))
[])
(cons
(Tezos_micheline.Micheline.Prim
tt
"Map" %
string
(cons
(Tezos_micheline.Micheline.Prim
tt
"Item"
%
string
(cons
(Tezos_micheline.Micheline.Int
tt
(Z.of_int
100))
(cons
(Tezos_micheline.Micheline.Prim
tt
"False"
%
string
[]
[])
[]))
[])
[]) [])
[])) [])
[]))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
(assert_toplevel_parsing
Stdlib.__LOC__
"LAMDA @name int int {}"
% string
(cons
(Tezos_micheline.Micheline.Prim
tt
"LAMDA" %
string
(cons
(Tezos_micheline.Micheline.Prim
tt
"int"
%
string
[] [])
(cons
(Tezos_micheline.Micheline.Prim
tt
"int"
%
string
[]
[])
(cons
(Tezos_micheline.Micheline.Seq
tt
[])
[])))
(cons
"@name"
%
string
[])) []))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
assert_toplevel_parsing
Stdlib.__LOC__
"code {DUP @test; DROP}"
% string
(cons
(Tezos_micheline.Micheline.Prim
tt
"code" %
string
(cons
(Tezos_micheline.Micheline.Seq
tt
(cons
(Tezos_micheline.Micheline.Prim
tt
"DUP"
%
string
[]
(cons
"@test"
%
string
[]))
(cons
(Tezos_micheline.Micheline.Prim
tt
"DROP"
%
string
[]
[])
[])))
[]) [])
[]))))))))))))))))).
Definition test_condition_contract_parsing {A : Type}
(function_parameter : unit) : A :=
let 'tt := function_parameter in
assert_toplevel_parsing Stdlib.__LOC__
"parameter unit;return unit;storage tez; #How much you have to send me
code {CDR; DUP;AMOUNT; CMPLT;IF {FAIL}}"
% string
(cons
(Tezos_micheline.Micheline.Prim tt "parameter" % string
(cons (Tezos_micheline.Micheline.Prim tt "unit" % string [] []) []) [])
(cons
(Tezos_micheline.Micheline.Prim tt "return" % string
(cons (Tezos_micheline.Micheline.Prim tt "unit" % string [] []) []) [])
(cons
(Tezos_micheline.Micheline.Prim tt "storage" % string
(cons (Tezos_micheline.Micheline.Prim tt "tez" % string [] []) [])
[])
(cons
(Tezos_micheline.Micheline.Prim tt "code" % string
(cons
(Tezos_micheline.Micheline.Seq tt
(cons (Tezos_micheline.Micheline.Prim tt "CDR" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim tt "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim tt "AMOUNT" % string []
[])
(cons
(Tezos_micheline.Micheline.Prim tt "CMPLT" % string []
[])
(cons
(Tezos_micheline.Micheline.Prim tt "IF" % string
(cons
(Tezos_micheline.Micheline.Seq tt
(cons
(Tezos_micheline.Micheline.Prim tt
"FAIL" % string [] []) [])) []) []) []))))))
[]) []) [])))).
Definition test_list_append_parsing {A : Type} (function_parameter : unit)
: A :=
let 'tt := function_parameter in
assert_toplevel_parsing Stdlib.__LOC__
"parameter (pair (list int)(list int));return (list int);storage unit;code { CAR; DUP; DIP{CDR}; CAR;NIL int; SWAP;LAMDA (pair int (list int))(list int){DUP; CAR; DIP {CDR}; CONS};REDUCE;LAMDA (pair int (list int))(list int){DUP; CAR; DIP{CDR}; CONS};UNIT; SWAP; PAIR}"
% string
(cons
(Tezos_micheline.Micheline.Prim tt "parameter" % string
(cons
(Tezos_micheline.Micheline.Prim tt "pair" % string
(cons
(Tezos_micheline.Micheline.Prim tt "list" % string
(cons (Tezos_micheline.Micheline.Prim tt "int" % string [] [])
[]) [])
(cons
(Tezos_micheline.Micheline.Prim tt "list" % string
(cons (Tezos_micheline.Micheline.Prim tt "int" % string [] [])
[]) []) [])) []) []) [])
(cons
(Tezos_micheline.Micheline.Prim tt "return" % string
(cons
(Tezos_micheline.Micheline.Prim tt "list" % string
(cons (Tezos_micheline.Micheline.Prim tt "int" % string [] []) [])
[]) []) [])
(cons
(Tezos_micheline.Micheline.Prim tt "storage" % string
(cons (Tezos_micheline.Micheline.Prim tt "unit" % string [] []) [])
[])
(cons
(Tezos_micheline.Micheline.Prim tt "code" % string
(cons
(Tezos_micheline.Micheline.Seq tt
(cons (Tezos_micheline.Micheline.Prim tt "CAR" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim tt "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim tt "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq tt
(cons
(Tezos_micheline.Micheline.Prim tt
"CDR" % string [] []) [])) []) [])
(cons
(Tezos_micheline.Micheline.Prim tt "CAR" % string []
[])
(cons
(Tezos_micheline.Micheline.Prim tt "NIL" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"int" % string [] []) []) [])
(cons
(Tezos_micheline.Micheline.Prim tt "SWAP" % string
[] [])
(cons
(Tezos_micheline.Micheline.Prim tt
"LAMDA" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"pair" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"int" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim tt
"list" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"int" % string [] []) []) []) []))
[])
(cons
(Tezos_micheline.Micheline.Prim tt
"list" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"int" % string [] []) []) [])
(cons
(Tezos_micheline.Micheline.Seq tt
(cons
(Tezos_micheline.Micheline.Prim tt
"DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim tt
"CAR" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim
tt "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq
tt
(cons
(Tezos_micheline.Micheline.Prim
tt "CDR" % string []
[]) [])) []) [])
(cons
(Tezos_micheline.Micheline.Prim
tt "CONS" % string [] []) [])))))
[]))) [])
(cons
(Tezos_micheline.Micheline.Prim tt
"REDUCE" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim tt
"LAMDA" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"pair" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"int" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim tt
"list" % string
(cons
(Tezos_micheline.Micheline.Prim
tt "int" % string [] []) [])
[]) [])) [])
(cons
(Tezos_micheline.Micheline.Prim tt
"list" % string
(cons
(Tezos_micheline.Micheline.Prim tt
"int" % string [] []) []) [])
(cons
(Tezos_micheline.Micheline.Seq tt
(cons
(Tezos_micheline.Micheline.Prim
tt "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim
tt "CAR" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim
tt "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq
tt
(cons
(Tezos_micheline.Micheline.Prim
tt "CDR" % string
[] []) [])) []) [])
(cons
(Tezos_micheline.Micheline.Prim
tt "CONS" % string [] [])
[]))))) []))) [])
(cons
(Tezos_micheline.Micheline.Prim tt
"UNIT" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim tt
"SWAP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim tt
"PAIR" % string [] []) [])))))))))))))
[]) []) [])))).
Definition assert_expression_parsing {A B C D : Type}
(loc : A) (source : string) (expected : Tezos_micheline.Micheline.node B C)
: D :=
match Micheline_parser.tokenize source with
| (_, cons _ _) =>
OCaml.Stdlib.failwith "%s - Cannot tokenize %s" % string loc source
| (tokens, []) =>
match Micheline_parser.parse_expression None tokens with
| (_, cons _ _) =>
OCaml.Stdlib.failwith "%s - Cannot parse_expression %s" % string loc
source
| (ast, []) =>
let ast := Micheline.strip_locations ast in
let expected := Micheline.strip_locations expected in
op_startypeminuserrorstar loc ast expected
end
end.
Definition test_parses_expression {A : Type} (function_parameter : unit) : A :=
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_expression_parsing Stdlib.__LOC__ "Pair False ""abc""" % string
(Tezos_micheline.Micheline.Prim tt "Pair" % string
(cons (Tezos_micheline.Micheline.Prim tt "False" % string [] [])
(cons (Tezos_micheline.Micheline.String tt "abc" % string) [])) []))
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
(assert_expression_parsing Stdlib.__LOC__ "Item 100" % string
(Tezos_micheline.Micheline.Prim tt "Item" % string
(cons (Tezos_micheline.Micheline.Int tt (Z.of_int 100)) []) []))
(fun function_parameter =>
let 'tt := function_parameter in
assert_expression_parsing Stdlib.__LOC__ "{}" % string
(Tezos_micheline.Micheline.Seq tt []))).
Definition tests {A B : Type} : list (string * (A -> B)) :=
cons
("tokenize" % string,
(fun function_parameter =>
let '_ := function_parameter in
test_tokenize_basic tt))
(cons
("test one line contract" % string,
(fun function_parameter =>
let '_ := function_parameter in
test_one_line_contract tt))
(cons
("test_condition_contract" % string,
(fun function_parameter =>
let '_ := function_parameter in
test_condition_contract tt))
(cons
("test_basic_parsing" % string,
(fun function_parameter =>
let '_ := function_parameter in
test_basic_parsing tt))
(cons
("test_condition_contract_parsing" % string,
(fun function_parameter =>
let '_ := function_parameter in
test_condition_contract_parsing tt))
(cons
("test_list_append_parsing" % string,
(fun function_parameter =>
let '_ := function_parameter in
test_list_append_parsing tt))
(cons
("test_parses_expression" % string,
(fun function_parameter =>
let '_ := function_parameter in
test_parses_expression tt)) [])))))).
Definition wrap {A B C : Type} (function_parameter : A * (unit -> B)) : C :=
let '(n, f) := function_parameter in
op_startypeminuserrorstar n
(* ❌ Variants not supported *)
variant
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar (f tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error err => Lwt.fail_with err
end)).
src/lib_p2p/p2p.ml 42 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make (struct
let name = "p2p"
end)
type 'peer_meta peer_meta_config = 'peer_meta P2p_pool.peer_meta_config = {
peer_meta_encoding : 'peer_meta Data_encoding.t;
peer_meta_initial : unit -> 'peer_meta;
score : 'peer_meta -> float;
}
type 'conn_meta conn_meta_config = 'conn_meta P2p_socket.metadata_config = {
conn_meta_encoding : 'conn_meta Data_encoding.t;
conn_meta_value : P2p_peer.Id.t -> 'conn_meta;
private_node : 'conn_meta -> bool;
}
type 'msg app_message_encoding = 'msg P2p_message.encoding =
| Encoding : {
tag : int;
title : string;
encoding : 'a Data_encoding.t;
wrap : 'a -> 'msg;
unwrap : 'msg -> 'a option;
max_length : int option;
}
-> 'msg app_message_encoding
type 'msg message_config = 'msg P2p_connect_handler.message_config = {
encoding : 'msg app_message_encoding list;
chain_name : Distributed_db_version.name;
distributed_db_versions : Distributed_db_version.t list;
}
type config = {
listening_port : P2p_addr.port option;
listening_addr : P2p_addr.t option;
discovery_port : P2p_addr.port option;
discovery_addr : Ipaddr.V4.t option;
trusted_points : P2p_point.Id.t list;
peers_file : string;
private_mode : bool;
identity : P2p_identity.t;
proof_of_work_target : Crypto_box.target;
disable_mempool : bool;
trust_discovered_peers : bool;
disable_testchain : bool;
greylisting_config : P2p_point_state.Info.greylisting_config;
}
type limits = {
connection_timeout : Time.System.Span.t;
authentication_timeout : Time.System.Span.t;
greylist_timeout : Time.System.Span.t;
maintenance_idle_time : Time.System.Span.t;
min_connections : int;
expected_connections : int;
max_connections : int;
backlog : int;
max_incoming_connections : int;
max_download_speed : int option;
max_upload_speed : int option;
read_buffer_size : int;
read_queue_size : int option;
write_queue_size : int option;
incoming_app_message_queue_size : int option;
incoming_message_queue_size : int option;
outgoing_message_queue_size : int option;
known_peer_ids_history_size : int;
(* TODO: remove these two fields *)
known_points_history_size : int;
max_known_peer_ids : (int * int) option;
max_known_points : (int * int) option;
swap_linger : Time.System.Span.t;
binary_chunks_size : int option;
}
let create_scheduler limits =
let max_upload_speed = Option.map limits.max_upload_speed ~f:(( * ) 1024) in
let max_download_speed =
Option.map limits.max_upload_speed ~f:(( * ) 1024)
in
P2p_io_scheduler.create
~read_buffer_size:limits.read_buffer_size
?max_upload_speed
?max_download_speed
?read_queue_size:limits.read_queue_size
?write_queue_size:limits.write_queue_size
()
let create_connection_pool config limits meta_cfg log triggers =
let pool_cfg =
{
P2p_pool.identity = config.identity;
trusted_points = config.trusted_points;
peers_file = config.peers_file;
private_mode = config.private_mode;
max_known_points = limits.max_known_points;
max_known_peer_ids = limits.max_known_peer_ids;
}
in
P2p_pool.create pool_cfg meta_cfg ~log triggers
let create_connect_handler config limits pool msg_cfg conn_meta_cfg io_sched
triggers log answerer =
let connect_handler_cfg =
{
P2p_connect_handler.identity = config.identity;
proof_of_work_target = config.proof_of_work_target;
listening_port = config.listening_port;
private_mode = config.private_mode;
greylisting_config = config.greylisting_config;
min_connections = limits.min_connections;
max_connections = limits.max_connections;
max_incoming_connections = limits.max_incoming_connections;
connection_timeout = limits.connection_timeout;
authentication_timeout = limits.authentication_timeout;
incoming_app_message_queue_size = limits.incoming_app_message_queue_size;
incoming_message_queue_size = limits.incoming_message_queue_size;
outgoing_message_queue_size = limits.outgoing_message_queue_size;
binary_chunks_size = limits.binary_chunks_size;
}
in
P2p_connect_handler.create
connect_handler_cfg
pool
msg_cfg
conn_meta_cfg
io_sched
triggers
~log
~answerer
let may_create_discovery_worker _limits config pool =
match
(config.listening_port, config.discovery_port, config.discovery_addr)
with
| (Some listening_port, Some discovery_port, Some discovery_addr) ->
Some
(P2p_discovery.create
pool
config.identity.peer_id
~listening_port
~discovery_port
~discovery_addr
~trust_discovered_peers:config.trust_discovered_peers)
| (_, _, _) ->
None
let create_maintenance_worker limits pool connect_handler config triggers log =
let maintenance_config =
{
P2p_maintenance.maintenance_idle_time = limits.maintenance_idle_time;
greylist_timeout = limits.greylist_timeout;
private_mode = config.private_mode;
min_connections = limits.min_connections;
max_connections = limits.max_connections;
expected_connections = limits.max_connections;
}
in
let discovery = may_create_discovery_worker limits config pool in
P2p_maintenance.create
?discovery
maintenance_config
pool
connect_handler
triggers
~log
let may_create_welcome_worker config limits connect_handler =
match config.listening_port with
| None ->
Lwt.return_none
| Some port ->
P2p_welcome.create
~backlog:limits.backlog
connect_handler
?addr:config.listening_addr
port
>>= fun w -> Lwt.return_some w
type ('msg, 'peer_meta, 'conn_meta) connection =
('msg, 'peer_meta, 'conn_meta) P2p_conn.t
module Real = struct
type ('msg, 'peer_meta, 'conn_meta) net = {
config : config;
limits : limits;
io_sched : P2p_io_scheduler.t;
pool : ('msg, 'peer_meta, 'conn_meta) P2p_pool.t;
connect_handler : ('msg, 'peer_meta, 'conn_meta) P2p_connect_handler.t;
maintenance : ('msg, 'peer_meta, 'conn_meta) P2p_maintenance.t;
welcome : P2p_welcome.t option;
watcher : P2p_connection.P2p_event.t Lwt_watcher.input;
triggers : P2p_trigger.t;
}
let create ~config ~limits meta_cfg msg_cfg conn_meta_cfg =
let io_sched = create_scheduler limits in
let watcher = Lwt_watcher.create_input () in
let log event = Lwt_watcher.notify watcher event in
let triggers = P2p_trigger.create () in
create_connection_pool config limits meta_cfg log triggers
>>= fun pool ->
(* There is a mutual recursion between an answerer and connect_handler,
for the default answerer. Because of the swap request mechanism, the
default answerer needs to initiate new connections using the
[P2p_connect_hander.connect] callback. *)
let rec answerer =
lazy
( if config.private_mode then P2p_protocol.create_private ()
else
let connect =
P2p_connect_handler.connect (Lazy.force connect_handler)
in
let proto_conf =
{
P2p_protocol.swap_linger = limits.swap_linger;
pool;
log;
connect;
latest_accepted_swap = Ptime.epoch;
latest_successful_swap = Ptime.epoch;
}
in
P2p_protocol.create_default proto_conf )
and connect_handler =
lazy
(create_connect_handler
config
limits
pool
msg_cfg
conn_meta_cfg
io_sched
triggers
log
answerer)
in
let connect_handler = Lazy.force connect_handler in
let maintenance =
create_maintenance_worker limits pool connect_handler config triggers log
in
may_create_welcome_worker config limits connect_handler
>>= fun welcome ->
return
{
config;
limits;
io_sched;
pool;
connect_handler;
maintenance;
welcome;
watcher;
triggers;
}
let peer_id {config; _} = config.identity.peer_id
let maintain {maintenance; _} () = P2p_maintenance.maintain maintenance
let activate t () =
log_info "activate" ;
(match t.welcome with None -> () | Some w -> P2p_welcome.activate w) ;
P2p_maintenance.activate t.maintenance ;
()
let roll _net () = Lwt.return_unit (* TODO implement *)
(* returns when all workers have shutted down in the opposite
creation order. *)
let shutdown net () =
lwt_log_notice "Shutting down the p2p's welcome worker..."
>>= fun () ->
Lwt_utils.may ~f:P2p_welcome.shutdown net.welcome
>>= fun () ->
lwt_log_notice "Shutting down the p2p's network maintenance worker..."
>>= fun () ->
P2p_maintenance.shutdown net.maintenance
>>= fun () ->
lwt_log_notice "Shutting down the p2p connection pool..."
>>= fun () ->
P2p_pool.destroy net.pool
>>= fun () ->
lwt_log_notice "Shutting down the p2p connection handler..."
>>= fun () ->
P2p_connect_handler.destroy net.connect_handler
>>= fun () ->
lwt_log_notice "Shutting down the p2p scheduler..."
>>= fun () -> P2p_io_scheduler.shutdown ~timeout:3.0 net.io_sched
let connections {pool; _} () =
P2p_pool.Connection.fold pool ~init:[] ~f:(fun _peer_id c acc -> c :: acc)
let find_connection {pool; _} peer_id =
P2p_pool.Connection.find_by_peer_id pool peer_id
let disconnect ?wait conn = P2p_conn.disconnect ?wait conn
let connection_info _net conn = P2p_conn.info conn
let connection_local_metadata _net conn = P2p_conn.local_metadata conn
let connection_remote_metadata _net conn = P2p_conn.remote_metadata conn
let connection_stat _net conn = P2p_conn.stat conn
let global_stat {connect_handler; _} () =
P2p_connect_handler.stat connect_handler
let set_peer_metadata {pool; _} conn meta =
P2p_pool.Peers.set_peer_metadata pool conn meta
let get_peer_metadata {pool; _} conn =
P2p_pool.Peers.get_peer_metadata pool conn
let recv _net conn =
P2p_conn.read conn
>>=? fun msg ->
lwt_debug
"message read from %a"
P2p_peer.Id.pp
(P2p_conn.info conn).peer_id
>>= fun () -> return msg
let rec recv_any net () =
let pipes =
P2p_pool.Connection.fold net.pool ~init:[] ~f:(fun _peer_id conn acc ->
( P2p_conn.is_readable conn
>>= function
| Ok () ->
Lwt.return_some conn
| Error _ ->
Lwt_utils.never_ending () )
:: acc)
in
Lwt.pick
( ( P2p_trigger.wait_new_connection net.triggers
>>= fun () -> Lwt.return_none )
:: pipes )
>>= function
| None ->
recv_any net ()
| Some conn -> (
P2p_conn.read conn
>>= function
| Ok msg ->
lwt_debug
"message read from %a"
P2p_peer.Id.pp
(P2p_conn.info conn).peer_id
>>= fun () -> Lwt.return (conn, msg)
| Error _ ->
lwt_debug
"error reading message from %a"
P2p_peer.Id.pp
(P2p_conn.info conn).peer_id
>>= fun () -> Lwt_unix.yield () >>= fun () -> recv_any net () )
let send _net conn m =
P2p_conn.write conn m
>>= function
| Ok () ->
lwt_debug
"message sent to %a"
P2p_peer.Id.pp
(P2p_conn.info conn).peer_id
>>= fun () -> return_unit
| Error err ->
lwt_debug
"error sending message from %a: %a"
P2p_peer.Id.pp
(P2p_conn.info conn).peer_id
pp_print_error
err
>>= fun () -> Lwt.return_error err
let try_send _net conn v =
match P2p_conn.write_now conn v with
| Ok v ->
debug
"message trysent to %a"
P2p_peer.Id.pp
(P2p_conn.info conn).peer_id ;
v
| Error err ->
debug
"error trysending message to %a@ %a"
P2p_peer.Id.pp
(P2p_conn.info conn).peer_id
pp_print_error
err ;
false
let broadcast {pool; _} msg =
P2p_peer.Table.iter
(fun _peer_id peer_info ->
match P2p_peer_state.get peer_info with
| Running {data = conn; _} ->
(* Silently discards Error P2p_errors.Connection_closed in case
the pipe is closed. Shouldn't happen because
- no race conditions (no Lwt)
- the peer state is Running. *)
ignore (P2p_conn.write_now conn msg : bool tzresult)
| _ ->
())
(P2p_pool.connected_peer_ids pool) ;
debug "message broadcasted"
let fold_connections {pool; _} ~init ~f =
P2p_pool.Connection.fold pool ~init ~f
let iter_connections {pool; _} f =
P2p_pool.Connection.fold pool ~init:() ~f:(fun gid conn () -> f gid conn)
let on_new_connection {connect_handler; _} f =
P2p_connect_handler.on_new_connection connect_handler f
end
module Fake = struct
let id = P2p_identity.generate (Crypto_box.make_target 0.)
let empty_stat =
{
P2p_stat.total_sent = 0L;
total_recv = 0L;
current_inflow = 0;
current_outflow = 0;
}
let connection_info announced_version faked_metadata =
{
P2p_connection.Info.incoming = false;
peer_id = id.peer_id;
id_point = (Ipaddr.V6.unspecified, None);
remote_socket_port = 0;
announced_version;
local_metadata = faked_metadata;
remote_metadata = faked_metadata;
private_node = false;
}
end
type ('msg, 'peer_meta, 'conn_meta) t = {
announced_version : Network_version.t;
peer_id : P2p_peer.Id.t;
maintain : unit -> unit Lwt.t;
roll : unit -> unit Lwt.t;
shutdown : unit -> unit Lwt.t;
connections : unit -> ('msg, 'peer_meta, 'conn_meta) connection list;
find_connection :
P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection option;
disconnect :
?wait:bool -> ('msg, 'peer_meta, 'conn_meta) connection -> unit Lwt.t;
connection_info :
('msg, 'peer_meta, 'conn_meta) connection ->
'conn_meta P2p_connection.Info.t;
connection_local_metadata :
('msg, 'peer_meta, 'conn_meta) connection -> 'conn_meta;
connection_remote_metadata :
('msg, 'peer_meta, 'conn_meta) connection -> 'conn_meta;
connection_stat : ('msg, 'peer_meta, 'conn_meta) connection -> P2p_stat.t;
global_stat : unit -> P2p_stat.t;
get_peer_metadata : P2p_peer.Id.t -> 'peer_meta;
set_peer_metadata : P2p_peer.Id.t -> 'peer_meta -> unit;
recv : ('msg, 'peer_meta, 'conn_meta) connection -> 'msg tzresult Lwt.t;
recv_any : unit -> (('msg, 'peer_meta, 'conn_meta) connection * 'msg) Lwt.t;
send :
('msg, 'peer_meta, 'conn_meta) connection -> 'msg -> unit tzresult Lwt.t;
try_send : ('msg, 'peer_meta, 'conn_meta) connection -> 'msg -> bool;
broadcast : 'msg -> unit;
pool : ('msg, 'peer_meta, 'conn_meta) P2p_pool.t option;
connect_handler :
('msg, 'peer_meta, 'conn_meta) P2p_connect_handler.t option;
fold_connections :
'a. init:'a ->
f:(P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> 'a -> 'a) ->
'a;
iter_connections :
(P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> unit) ->
unit;
on_new_connection :
(P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> unit) ->
unit;
activate : unit -> unit;
watcher : P2p_connection.P2p_event.t Lwt_watcher.input;
}
type ('msg, 'peer_meta, 'conn_meta) net = ('msg, 'peer_meta, 'conn_meta) t
let announced_version net = net.announced_version
let pool net = net.pool
let connect_handler net = net.connect_handler
let check_limits =
let fail_1 v orig =
if not (Ptime.Span.compare v Ptime.Span.zero <= 0) then return_unit
else
Error_monad.failwith
"value of option %S cannot be negative or null@."
orig
in
let fail_2 v orig =
if not (v < 0) then return_unit
else Error_monad.failwith "value of option %S cannot be negative@." orig
in
fun c ->
fail_1 c.authentication_timeout "authentication-timeout"
>>=? fun () ->
fail_2 c.min_connections "min-connections"
>>=? fun () ->
fail_2 c.expected_connections "expected-connections"
>>=? fun () ->
fail_2 c.max_connections "max-connections"
>>=? fun () ->
fail_2 c.max_incoming_connections "max-incoming-connections"
>>=? fun () ->
fail_2 c.read_buffer_size "read-buffer-size"
>>=? fun () ->
fail_2 c.known_peer_ids_history_size "known-peer-ids-history-size"
>>=? fun () ->
fail_2 c.known_points_history_size "known-points-history-size"
>>=? fun () ->
fail_1 c.swap_linger "swap-linger"
>>=? fun () ->
( match c.binary_chunks_size with
| None ->
return_unit
| Some size ->
P2p_socket.check_binary_chunks_size size )
>>=? fun () -> return_unit
let create ~config ~limits peer_cfg conn_cfg msg_cfg =
check_limits limits
>>=? fun () ->
Real.create ~config ~limits peer_cfg msg_cfg conn_cfg
>>=? fun net ->
return
{
announced_version =
Network_version.announced
~chain_name:msg_cfg.chain_name
~distributed_db_versions:msg_cfg.distributed_db_versions
~p2p_versions:P2p_version.supported;
peer_id = Real.peer_id net;
maintain = Real.maintain net;
roll = Real.roll net;
shutdown = Real.shutdown net;
connections = Real.connections net;
find_connection = Real.find_connection net;
disconnect = Real.disconnect;
connection_info = Real.connection_info net;
connection_local_metadata = Real.connection_local_metadata net;
connection_remote_metadata = Real.connection_remote_metadata net;
connection_stat = Real.connection_stat net;
global_stat = Real.global_stat net;
get_peer_metadata = Real.get_peer_metadata net;
set_peer_metadata = Real.set_peer_metadata net;
recv = Real.recv net;
recv_any = Real.recv_any net;
send = Real.send net;
try_send = Real.try_send net;
broadcast = Real.broadcast net;
pool = Some net.pool;
connect_handler = Some net.connect_handler;
fold_connections = (fun ~init ~f -> Real.fold_connections net ~init ~f);
iter_connections = Real.iter_connections net;
on_new_connection = Real.on_new_connection net;
activate = Real.activate net;
watcher = net.Real.watcher;
}
let activate t =
log_info "activate P2P layer !" ;
t.activate ()
let faked_network (msg_cfg : 'msg message_config) peer_cfg faked_metadata =
let announced_version =
Network_version.announced
~chain_name:msg_cfg.chain_name
~distributed_db_versions:msg_cfg.distributed_db_versions
~p2p_versions:P2p_version.supported
in
{
announced_version;
peer_id = Fake.id.peer_id;
maintain = Lwt.return;
roll = Lwt.return;
shutdown = Lwt.return;
connections = (fun () -> []);
find_connection = (fun _ -> None);
disconnect = (fun ?wait:_ _ -> Lwt.return_unit);
connection_info =
(fun _ -> Fake.connection_info announced_version faked_metadata);
connection_local_metadata = (fun _ -> faked_metadata);
connection_remote_metadata = (fun _ -> faked_metadata);
connection_stat = (fun _ -> Fake.empty_stat);
global_stat = (fun () -> Fake.empty_stat);
get_peer_metadata = (fun _ -> peer_cfg.peer_meta_initial ());
set_peer_metadata = (fun _ _ -> ());
recv = (fun _ -> Lwt_utils.never_ending ());
recv_any = (fun () -> Lwt_utils.never_ending ());
send = (fun _ _ -> fail P2p_errors.Connection_closed);
try_send = (fun _ _ -> false);
fold_connections = (fun ~init ~f:_ -> init);
iter_connections = (fun _f -> ());
on_new_connection = (fun _f -> ());
broadcast = ignore;
pool = None;
connect_handler = None;
activate = (fun _ -> ());
watcher = Lwt_watcher.create_input ();
}
let peer_id net = net.peer_id
let maintain net = net.maintain ()
let roll net = net.roll ()
let shutdown net = net.shutdown ()
let connections net = net.connections ()
let disconnect net = net.disconnect
let find_connection net = net.find_connection
let connection_info net = net.connection_info
let connection_local_metadata net = net.connection_local_metadata
let connection_remote_metadata net = net.connection_remote_metadata
let connection_stat net = net.connection_stat
let global_stat net = net.global_stat ()
let get_peer_metadata net = net.get_peer_metadata
let set_peer_metadata net = net.set_peer_metadata
let recv net = net.recv
let recv_any net = net.recv_any ()
let send net = net.send
let try_send net = net.try_send
let broadcast net = net.broadcast
let fold_connections net = net.fold_connections
let iter_connections net = net.iter_connections
let on_new_connection net = net.on_new_connection
let greylist_addr net addr =
Option.iter net.pool ~f:(fun pool -> P2p_pool.greylist_addr pool addr)
let greylist_peer net peer_id =
Option.iter net.pool ~f:(fun pool -> P2p_pool.greylist_peer pool peer_id)
let watcher net = Lwt_watcher.create_stream net.watcher
src/lib_p2p/p2p.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Record peer_meta_config {peer_meta : Type} := {
peer_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t peer_meta;
peer_meta_initial : unit -> peer_meta;
score : peer_meta -> Z }.
Arguments peer_meta_config : clear implicits.
Record conn_meta_config {conn_meta : Type} := {
conn_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t conn_meta;
conn_meta_value : Tezos_base__TzPervasives.P2p_peer.Id.t -> conn_meta;
private_node : conn_meta -> bool }.
Arguments conn_meta_config : clear implicits.
Inductive app_message_encoding (msg : Type) : Type :=
| Encoding : forall {a : Type}, Z -> string ->
(Tezos_base__TzPervasives.Data_encoding.t a) -> (a -> msg) ->
(msg -> option a) -> (option Z) -> app_message_encoding msg.
Arguments Encoding {_}.
Record message_config {msg : Type} := {
encoding : list (app_message_encoding msg);
chain_name : Tezos_base__TzPervasives.Distributed_db_version.name;
distributed_db_versions :
list Tezos_base__TzPervasives.Distributed_db_version.t }.
Arguments message_config : clear implicits.
Record config := {
listening_port : option Tezos_base__TzPervasives.P2p_addr.port;
listening_addr : option Tezos_base__TzPervasives.P2p_addr.t;
discovery_port : option Tezos_base__TzPervasives.P2p_addr.port;
discovery_addr : option Ipaddr.V4.t;
trusted_points : list Tezos_base__TzPervasives.P2p_point.Id.t;
peers_file : string;
private_mode : bool;
identity : Tezos_base__TzPervasives.P2p_identity.t;
proof_of_work_target : Tezos_base__TzPervasives.Crypto_box.target;
disable_mempool : bool;
trust_discovered_peers : bool;
disable_testchain : bool;
greylisting_config : Tezos_p2p.P2p_point_state.Info.greylisting_config }.
Record limits := {
connection_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
authentication_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
greylist_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
maintenance_idle_time : Tezos_base__TzPervasives.Time.System.Span.t;
min_connections : Z;
expected_connections : Z;
max_connections : Z;
backlog : Z;
max_incoming_connections : Z;
max_download_speed : option Z;
max_upload_speed : option Z;
read_buffer_size : Z;
read_queue_size : option Z;
write_queue_size : option Z;
incoming_app_message_queue_size : option Z;
incoming_message_queue_size : option Z;
outgoing_message_queue_size : option Z;
known_peer_ids_history_size : Z;
known_points_history_size : Z;
max_known_peer_ids : option (Z * Z);
max_known_points : option (Z * Z);
swap_linger : Tezos_base__TzPervasives.Time.System.Span.t;
binary_chunks_size : option Z }.
Definition create_scheduler (limits : limits) : Tezos_p2p.P2p_io_scheduler.t :=
let max_upload_speed := Option.map (Z.mul 1024) (max_upload_speed limits) in
let max_download_speed := Option.map (Z.mul 1024) (max_upload_speed limits) in
P2p_io_scheduler.create max_upload_speed max_download_speed
(read_queue_size limits) (write_queue_size limits) (read_buffer_size limits)
tt.
Definition create_connection_pool {A B C : Type}
(config : config) (limits : limits)
(meta_cfg : Tezos_p2p.P2p_pool.peer_meta_config A)
(log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit)
(triggers : Tezos_p2p.P2p_trigger.t) : Lwt.t (Tezos_p2p.P2p_pool.t B A C) :=
let pool_cfg :=
{| P2p_pool.identity := identity config;
P2p_pool.trusted_points := trusted_points config;
P2p_pool.peers_file := peers_file config;
P2p_pool.private_mode := private_mode config;
P2p_pool.max_known_points := max_known_points limits;
P2p_pool.max_known_peer_ids := max_known_peer_ids limits |} in
P2p_pool.create pool_cfg meta_cfg triggers log.
Definition create_connect_handler {A B C : Type}
(config : config) (limits : limits) (pool : Tezos_p2p.P2p_pool.t A B C)
(msg_cfg : Tezos_p2p.P2p_connect_handler.message_config A)
(conn_meta_cfg : Tezos_p2p.P2p_socket.metadata_config C)
(io_sched : Tezos_p2p.P2p_io_scheduler.t) (triggers : Tezos_p2p.P2p_trigger.t)
(log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit)
(answerer : Stdlib.Lazy.t (Tezos_p2p.P2p_answerer.t A))
: Tezos_p2p.P2p_connect_handler.t A B C :=
let connect_handler_cfg :=
{|
P2p_connect_handler.incoming_app_message_queue_size :=
incoming_app_message_queue_size limits;
P2p_connect_handler.private_mode := private_mode config;
P2p_connect_handler.min_connections := min_connections limits;
P2p_connect_handler.max_connections := max_connections limits;
P2p_connect_handler.max_incoming_connections :=
max_incoming_connections limits;
P2p_connect_handler.incoming_message_queue_size :=
incoming_message_queue_size limits;
P2p_connect_handler.outgoing_message_queue_size :=
outgoing_message_queue_size limits;
P2p_connect_handler.binary_chunks_size := binary_chunks_size limits;
P2p_connect_handler.identity := identity config;
P2p_connect_handler.connection_timeout := connection_timeout limits;
P2p_connect_handler.authentication_timeout :=
authentication_timeout limits;
P2p_connect_handler.greylisting_config := greylisting_config config;
P2p_connect_handler.proof_of_work_target := proof_of_work_target config;
P2p_connect_handler.listening_port := listening_port config |} in
P2p_connect_handler.create None connect_handler_cfg pool msg_cfg conn_meta_cfg
io_sched triggers log answerer.
Definition may_create_discovery_worker {A B C D : Type}
(_limits : A) (config : config) (pool : Tezos_p2p.P2p_pool.t B C D)
: option Tezos_p2p.P2p_discovery.t :=
match
((listening_port config), (discovery_port config), (discovery_addr config))
with
| (Some listening_port, Some discovery_port, Some discovery_addr) =>
Some
(P2p_discovery.create listening_port discovery_port discovery_addr
(trust_discovered_peers config) pool (peer_id (identity config)))
| (_, _, _) => None
end.
Definition create_maintenance_worker {A B C : Type}
(limits : limits) (pool : Tezos_p2p.P2p_pool.t A B C)
(connect_handler : Tezos_p2p.P2p_connect_handler.t A B C) (config : config)
(triggers : Tezos_p2p.P2p_trigger.t)
(log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit)
: Tezos_p2p.P2p_maintenance.t A B C :=
let maintenance_config :=
{| P2p_maintenance.maintenance_idle_time := maintenance_idle_time limits;
P2p_maintenance.greylist_timeout := greylist_timeout limits;
P2p_maintenance.private_mode := private_mode config;
P2p_maintenance.min_connections := min_connections limits;
P2p_maintenance.max_connections := max_connections limits;
P2p_maintenance.expected_connections := max_connections limits |} in
let discovery := may_create_discovery_worker limits config pool in
P2p_maintenance.create discovery maintenance_config pool connect_handler
triggers log.
Definition may_create_welcome_worker {A B C : Type}
(config : config) (limits : limits)
(connect_handler : Tezos_p2p.P2p_connect_handler.t A B C)
: Lwt.t (option Tezos_p2p.P2p_welcome.t) :=
match listening_port config with
| None => Lwt.return_none
| Some port =>
op_gtgteq
(P2p_welcome.create (listening_addr config) (backlog limits)
connect_handler port) (fun w => Lwt.return_some w)
end.
Definition connection (msg peer_meta conn_meta : Type) :=
Tezos_p2p.P2p_conn.t msg peer_meta conn_meta.
Module Real.
Record net {msg peer_meta conn_meta : Type} := {
config : config;
limits : limits;
io_sched : Tezos_p2p.P2p_io_scheduler.t;
pool : Tezos_p2p.P2p_pool.t msg peer_meta conn_meta;
connect_handler : Tezos_p2p.P2p_connect_handler.t msg peer_meta conn_meta;
maintenance : Tezos_p2p.P2p_maintenance.t msg peer_meta conn_meta;
welcome : option Tezos_p2p.P2p_welcome.t;
watcher :
Tezos_stdlib.Lwt_watcher.input
Tezos_base__TzPervasives.P2p_connection.P2p_event.t;
triggers : Tezos_p2p.P2p_trigger.t }.
Arguments net : clear implicits.
Definition create {A B C : Type}
(config : config) (limits : limits)
(meta_cfg : Tezos_p2p.P2p_pool.peer_meta_config A)
(msg_cfg : Tezos_p2p.P2p_connect_handler.message_config B)
(conn_meta_cfg : Tezos_p2p.P2p_socket.metadata_config C)
: Lwt.t (Tezos_base__TzPervasives.tzresult (net B A C)) :=
let io_sched := create_scheduler limits in
let watcher := Lwt_watcher.create_input tt in
let log (event : Tezos_base__TzPervasives.P2p_connection.P2p_event.t)
: unit :=
Lwt_watcher.notify watcher event in
let triggers := P2p_trigger.create tt in
op_gtgteq (create_connection_pool config limits meta_cfg log triggers)
(fun pool =>
let fix answerer : Stdlib.Lazy.t (Tezos_p2p.P2p_answerer.t B) :=
(* ❌ Lazy expressions are not handled *)
lazy
(if private_mode config then
P2p_protocol.create_private tt
else
let connect :=
P2p_connect_handler.connect None (Lazy.force connect_handler) in
let proto_conf :=
{| P2p_protocol.swap_linger := swap_linger limits;
P2p_protocol.pool := pool; P2p_protocol.log := log;
P2p_protocol.connect := connect;
P2p_protocol.latest_accepted_swap := Ptime.epoch;
P2p_protocol.latest_successful_swap := Ptime.epoch |} in
P2p_protocol.create_default proto_conf)
with connect_handler
: Stdlib.Lazy.t (Tezos_p2p.P2p_connect_handler.t B A C) :=
(* ❌ Lazy expressions are not handled *)
lazy
(create_connect_handler config limits pool msg_cfg conn_meta_cfg
io_sched triggers log answerer) in
let connect_handler := Lazy.force connect_handler in
let maintenance :=
create_maintenance_worker limits pool connect_handler config triggers
log in
op_gtgteq (may_create_welcome_worker config limits connect_handler)
(fun welcome =>
_return
{| config := config; limits := limits; io_sched := io_sched;
pool := pool; connect_handler := connect_handler;
maintenance := maintenance; welcome := welcome;
watcher := watcher; triggers := triggers |})).
Definition peer_id {A B C : Type} (function_parameter : net A B C)
: Tezos_base.P2p_peer.Id.t :=
let '{| config := config |} := function_parameter in
peer_id (identity config).
Definition maintain {A B C : Type} (function_parameter : net A B C)
: unit -> Lwt.t unit :=
let '{| maintenance := maintenance |} := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
P2p_maintenance.maintain maintenance.
Definition activate {A B C : Type} (t : net A B C) (function_parameter : unit)
: unit :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "activate" % string
CamlinternalFormatBasics.End_of_format) "activate" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match welcome t with
| None => tt
| Some w => P2p_welcome.activate w
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_maintenance.activate (maintenance t) in
tt.
Definition roll {A : Type} (_net : A) (function_parameter : unit)
: Lwt.t unit :=
let 'tt := function_parameter in
Lwt.return_unit.
Definition shutdown {A B C : Type}
(net : net A B C) (function_parameter : unit) : Lwt.t unit :=
let 'tt := function_parameter in
op_gtgteq
(lwt_log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down the p2p's welcome worker..." % string
CamlinternalFormatBasics.End_of_format)
"Shutting down the p2p's welcome worker..." % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_utils.may P2p_welcome.shutdown (welcome net))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down the p2p's network maintenance worker..." %
string CamlinternalFormatBasics.End_of_format)
"Shutting down the p2p's network maintenance worker..." %
string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_maintenance.shutdown (maintenance net))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down the p2p connection pool..." % string
CamlinternalFormatBasics.End_of_format)
"Shutting down the p2p connection pool..." % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_pool.destroy (pool net))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down the p2p connection handler..."
% string
CamlinternalFormatBasics.End_of_format)
"Shutting down the p2p connection handler..."
% string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(P2p_connect_handler.destroy
(connect_handler net))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down the p2p scheduler..."
% string
CamlinternalFormatBasics.End_of_format)
"Shutting down the p2p scheduler..." %
string))
(fun function_parameter =>
let 'tt := function_parameter in
P2p_io_scheduler.shutdown
(Some
(* ❌ Float constant 3.0 is approximated by the integer 3 *)
3) (io_sched net)))))))))).
Definition connections {A B C : Type} (function_parameter : net A B C)
: unit -> list (Tezos_p2p.P2p_conn.t A B C) :=
let '{| pool := pool |} := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
P2p_pool.Connection.fold pool []
(fun _peer_id => fun c => fun acc => cons c acc).
Definition find_connection {A B C : Type} (function_parameter : net A B C)
: Tezos_base__TzPervasives.P2p_peer.Id.t ->
option (Tezos_p2p.P2p_conn.t A B C) :=
let '{| pool := pool |} := function_parameter in
fun peer_id => P2p_pool.Connection.find_by_peer_id pool peer_id.
Definition disconnect {A B C : Type}
(wait : option bool) (conn : Tezos_p2p.P2p_conn.t A B C) : Lwt.t unit :=
P2p_conn.disconnect wait conn.
Definition connection_info {A B C D : Type}
(_net : A) (conn : Tezos_p2p.P2p_conn.t B C D)
: Tezos_base__TzPervasives.P2p_connection.Info.t D := P2p_conn.info conn.
Definition connection_local_metadata {A B C D : Type}
(_net : A) (conn : Tezos_p2p.P2p_conn.t B C D) : D :=
P2p_conn.local_metadata conn.
Definition connection_remote_metadata {A B C D : Type}
(_net : A) (conn : Tezos_p2p.P2p_conn.t B C D) : D :=
P2p_conn.remote_metadata conn.
Definition connection_stat {A B C D : Type}
(_net : A) (conn : Tezos_p2p.P2p_conn.t B C D)
: Tezos_base__TzPervasives.P2p_stat.t := P2p_conn.stat conn.
Definition global_stat {A B C : Type} (function_parameter : net A B C)
: unit -> Tezos_base__TzPervasives.P2p_stat.t :=
let '{| connect_handler := connect_handler |} := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
P2p_connect_handler.stat connect_handler.
Definition set_peer_metadata {A B C : Type} (function_parameter : net A B C)
: Tezos_base__TzPervasives.P2p_peer.Id.t -> B -> unit :=
let '{| pool := pool |} := function_parameter in
fun conn => fun meta => P2p_pool.Peers.set_peer_metadata pool conn meta.
Definition get_peer_metadata {A B C : Type} (function_parameter : net A B C)
: Tezos_base__TzPervasives.P2p_peer.Id.t -> B :=
let '{| pool := pool |} := function_parameter in
fun conn => P2p_pool.Peers.get_peer_metadata pool conn.
Definition recv {A B C D : Type}
(_net : A) (conn : Tezos_p2p.P2p_conn.t B C D)
: Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
op_gtgteqquestion (P2p_conn.read conn)
(fun msg =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"message read from " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"message read from %a" % string) P2p_peer.Id.pp
(peer_id (P2p_conn.info conn)))
(fun function_parameter =>
let 'tt := function_parameter in
_return msg)).
Fixpoint recv_any {A B C : Type} (net : net A B C) (function_parameter : unit)
: Lwt.t ((Tezos_p2p.P2p_conn.t A B C) * A) :=
let 'tt := function_parameter in
let pipes :=
P2p_pool.Connection.fold (pool net) []
(fun _peer_id =>
fun conn =>
fun acc =>
cons
(op_gtgteq (P2p_conn.is_readable conn)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_some conn
| Stdlib.Error _ => Lwt_utils.never_ending tt
end)) acc) in
op_gtgteq
(Lwt.pick
(cons
(op_gtgteq (P2p_trigger.wait_new_connection (triggers net))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_none)) pipes))
(fun function_parameter =>
match function_parameter with
| None => recv_any net tt
| Some conn =>
op_gtgteq (P2p_conn.read conn)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok msg =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"message read from " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"message read from %a" % string) P2p_peer.Id.pp
(peer_id (P2p_conn.info conn)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return (conn, msg))
| Stdlib.Error _ =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"error reading message from " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"error reading message from %a" % string) P2p_peer.Id.pp
(peer_id (P2p_conn.info conn)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_unix.yield tt)
(fun function_parameter =>
let 'tt := function_parameter in
recv_any net tt))
end)
end).
Definition send {A B C D : Type}
(_net : A) (conn : Tezos_p2p.P2p_conn.t B C D) (m : B)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (P2p_conn.write conn m)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"message sent to " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"message sent to %a" % string) P2p_peer.Id.pp
(peer_id (P2p_conn.info conn)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error err =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"error sending message from " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"error sending message from %a: %a" % string) P2p_peer.Id.pp
(peer_id (P2p_conn.info conn)) pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_error err)
end).
Definition try_send {A B C D : Type}
(_net : A) (conn : Tezos_p2p.P2p_conn.t B C D) (v : B) : bool :=
match P2p_conn.write_now conn v with
| Stdlib.Ok v =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"message trysent to " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"message trysent to %a" % string) P2p_peer.Id.pp
(peer_id (P2p_conn.info conn)) in
v
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"error trysending message to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"error trysending message to %a@ %a" % string) P2p_peer.Id.pp
(peer_id (P2p_conn.info conn)) pp_print_error err in
false
end.
Definition broadcast {A B C : Type} (function_parameter : net A B C)
: A -> unit :=
let '{| pool := pool |} := function_parameter in
fun msg =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
P2p_peer.Table.iter
(fun _peer_id =>
fun peer_info =>
match P2p_peer_state.get peer_info with
| Tezos_p2p.P2p_peer_state.Running {| data := conn |} =>
OCaml.Stdlib.ignore (P2p_conn.write_now conn msg)
| _ => tt
end) (P2p_pool.connected_peer_ids pool) in
debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"message broadcasted" % string
CamlinternalFormatBasics.End_of_format)
"message broadcasted" % string).
Definition fold_connections {A B C D : Type} (function_parameter : net A B C)
: D ->
(Tezos_base__TzPervasives.P2p_peer.Id.t ->
(Tezos_p2p.P2p_conn.t A B C) -> D -> D) -> D :=
let '{| pool := pool |} := function_parameter in
fun init => fun f => P2p_pool.Connection.fold pool init f.
Definition iter_connections {A B C : Type} (function_parameter : net A B C)
: (Tezos_base__TzPervasives.P2p_peer.Id.t ->
(Tezos_p2p.P2p_conn.t A B C) -> unit) -> unit :=
let '{| pool := pool |} := function_parameter in
fun f =>
P2p_pool.Connection.fold pool tt
(fun gid =>
fun conn =>
fun function_parameter =>
let 'tt := function_parameter in
f gid conn).
Definition on_new_connection {A B C : Type} (function_parameter : net A B C)
: (Tezos_base__TzPervasives.P2p_peer.Id.t ->
(Tezos_p2p.P2p_conn.t A B C) -> unit) -> unit :=
let '{| connect_handler := connect_handler |} := function_parameter in
fun f => P2p_connect_handler.on_new_connection connect_handler f.
End Real.
Module Fake.
Definition id : Tezos_base__TzPervasives.P2p_identity.t :=
P2p_identity.generate
(Crypto_box.make_target
(* ❌ Float constant 0. is approximated by the integer 0 *)
0).
Definition empty_stat : Tezos_base__TzPervasives.P2p_stat.t :=
{|
P2p_stat.total_sent :=
(* ❌ Constant of type int64 is converted to int *)
0;
P2p_stat.total_recv :=
(* ❌ Constant of type int64 is converted to int *)
0; P2p_stat.current_inflow := 0; P2p_stat.current_outflow := 0 |}.
Definition connection_info {A : Type}
(announced_version : Tezos_base.Network_version.t) (faked_metadata : A)
: Tezos_base__TzPervasives.P2p_connection.Info.t A :=
{| P2p_connection.Info.incoming := false;
P2p_connection.Info.peer_id := peer_id id;
P2p_connection.Info.id_point := (Ipaddr.V6.unspecified, None);
P2p_connection.Info.remote_socket_port := 0;
P2p_connection.Info.announced_version := announced_version;
P2p_connection.Info.private_node := false;
P2p_connection.Info.local_metadata := faked_metadata;
P2p_connection.Info.remote_metadata := faked_metadata |}.
End Fake.
Record t {msg peer_meta conn_meta : Type} := {
announced_version : Tezos_base__TzPervasives.Network_version.t;
peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
maintain : unit -> Lwt.t unit;
roll : unit -> Lwt.t unit;
shutdown : unit -> Lwt.t unit;
connections : unit -> list (connection msg peer_meta conn_meta);
find_connection :
Tezos_base__TzPervasives.P2p_peer.Id.t ->
option (connection msg peer_meta conn_meta);
disconnect :
(option bool) -> (connection msg peer_meta conn_meta) -> Lwt.t unit;
connection_info :
(connection msg peer_meta conn_meta) ->
Tezos_base__TzPervasives.P2p_connection.Info.t conn_meta;
connection_local_metadata : (connection msg peer_meta conn_meta) -> conn_meta;
connection_remote_metadata : (connection msg peer_meta conn_meta) -> conn_meta;
connection_stat :
(connection msg peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_stat.t;
global_stat : unit -> Tezos_base__TzPervasives.P2p_stat.t;
get_peer_metadata : Tezos_base__TzPervasives.P2p_peer.Id.t -> peer_meta;
set_peer_metadata :
Tezos_base__TzPervasives.P2p_peer.Id.t -> peer_meta -> unit;
recv :
(connection msg peer_meta conn_meta) ->
Lwt.t (Tezos_base__TzPervasives.tzresult msg);
recv_any : unit -> Lwt.t ((connection msg peer_meta conn_meta) * msg);
send :
(connection msg peer_meta conn_meta) ->
msg -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
try_send : (connection msg peer_meta conn_meta) -> msg -> bool;
broadcast : msg -> unit;
pool : option (Tezos_p2p.P2p_pool.t msg peer_meta conn_meta);
connect_handler :
option (Tezos_p2p.P2p_connect_handler.t msg peer_meta conn_meta);
fold_connections :
(a ->
(Tezos_base__TzPervasives.P2p_peer.Id.t ->
(connection msg peer_meta conn_meta) -> a -> a) -> a) * (a);
iter_connections :
(Tezos_base__TzPervasives.P2p_peer.Id.t ->
(connection msg peer_meta conn_meta) -> unit) -> unit;
on_new_connection :
(Tezos_base__TzPervasives.P2p_peer.Id.t ->
(connection msg peer_meta conn_meta) -> unit) -> unit;
activate : unit -> unit;
watcher :
Tezos_stdlib.Lwt_watcher.input
Tezos_base__TzPervasives.P2p_connection.P2p_event.t }.
Arguments t : clear implicits.
Definition net (msg peer_meta conn_meta : Type) := t msg peer_meta conn_meta.
Definition announced_version {A B C : Type} (net : t A B C)
: Tezos_base__TzPervasives.Network_version.t := announced_version net.
Definition pool {A B C : Type} (net : t A B C)
: option (Tezos_p2p.P2p_pool.t A B C) := pool net.
Definition connect_handler {A B C : Type} (net : t A B C)
: option (Tezos_p2p.P2p_connect_handler.t A B C) := connect_handler net.
Definition check_limits
: limits -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let fail_1 (v : Ptime.span) (orig : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if negb (OCaml.Stdlib.le (Ptime.Span.compare v Ptime.Span.zero) 0) then
return_unit
else
Error_monad.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "value of option " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" cannot be negative or null" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"value of option %S cannot be negative or null@." % string) orig in
let fail_2 (v : Z) (orig : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if negb (OCaml.Stdlib.lt v 0) then
return_unit
else
Error_monad.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "value of option " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" cannot be negative" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"value of option %S cannot be negative@." % string) orig in
fun c =>
op_gtgteqquestion
(fail_1 (authentication_timeout c) "authentication-timeout" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_2 (min_connections c) "min-connections" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_2 (expected_connections c) "expected-connections" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_2 (max_connections c) "max-connections" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_2 (max_incoming_connections c)
"max-incoming-connections" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_2 (read_buffer_size c)
"read-buffer-size" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_2 (known_peer_ids_history_size c)
"known-peer-ids-history-size" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_2 (known_points_history_size c)
"known-points-history-size" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_1 (swap_linger c)
"swap-linger" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
match binary_chunks_size c with
| None => return_unit
| Some size =>
P2p_socket.check_binary_chunks_size
size
end
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))))))))).
Definition create {A B C : Type}
(config : config) (limits : limits)
(peer_cfg : Tezos_p2p.P2p_pool.peer_meta_config A)
(conn_cfg : Tezos_p2p.P2p_socket.metadata_config B)
(msg_cfg : Tezos_p2p.P2p_connect_handler.message_config C)
: Lwt.t (Tezos_base__TzPervasives.tzresult (t C A B)) :=
op_gtgteqquestion (check_limits limits)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Real.create config limits peer_cfg msg_cfg conn_cfg)
(fun net =>
_return
{|
announced_version :=
Network_version.announced (chain_name msg_cfg)
(distributed_db_versions msg_cfg) P2p_version.supported;
peer_id := Real.peer_id net; maintain := Real.maintain net;
roll := Real.roll net; shutdown := Real.shutdown net;
connections := Real.connections net;
find_connection := Real.find_connection net;
disconnect := Real.disconnect;
connection_info := Real.connection_info net;
connection_local_metadata := Real.connection_local_metadata net;
connection_remote_metadata := Real.connection_remote_metadata net;
connection_stat := Real.connection_stat net;
global_stat := Real.global_stat net;
get_peer_metadata := Real.get_peer_metadata net;
set_peer_metadata := Real.set_peer_metadata net;
recv := Real.recv net; recv_any := Real.recv_any net;
send := Real.send net; try_send := Real.try_send net;
broadcast := Real.broadcast net; pool := Some (pool net);
connect_handler := Some (connect_handler net);
fold_connections :=
fun init => fun f => Real.fold_connections net init f;
iter_connections := Real.iter_connections net;
on_new_connection := Real.on_new_connection net;
activate := Real.activate net; watcher := Real.watcher net |})).
Definition activate {A B C : Type} (t : t A B C) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "activate P2P layer !" % string
CamlinternalFormatBasics.End_of_format)
"activate P2P layer !" % string) in
(activate t) tt.
Definition faked_network {B C D msg : Type}
(msg_cfg : message_config msg) (peer_cfg : peer_meta_config B)
(faked_metadata : C) : t D B C :=
let announced_version :=
Network_version.announced (chain_name msg_cfg)
(distributed_db_versions msg_cfg) P2p_version.supported in
{| announced_version := announced_version; peer_id := peer_id Fake.id;
maintain := Lwt._return; roll := Lwt._return; shutdown := Lwt._return;
connections :=
fun function_parameter =>
let 'tt := function_parameter in
[];
find_connection :=
fun function_parameter =>
let '_ := function_parameter in
None;
disconnect :=
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit;
connection_info :=
fun function_parameter =>
let '_ := function_parameter in
Fake.connection_info announced_version faked_metadata;
connection_local_metadata :=
fun function_parameter =>
let '_ := function_parameter in
faked_metadata;
connection_remote_metadata :=
fun function_parameter =>
let '_ := function_parameter in
faked_metadata;
connection_stat :=
fun function_parameter =>
let '_ := function_parameter in
Fake.empty_stat;
global_stat :=
fun function_parameter =>
let 'tt := function_parameter in
Fake.empty_stat;
get_peer_metadata :=
fun function_parameter =>
let '_ := function_parameter in
(peer_meta_initial peer_cfg) tt;
set_peer_metadata :=
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
tt;
recv :=
fun function_parameter =>
let '_ := function_parameter in
Lwt_utils.never_ending tt;
recv_any :=
fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils.never_ending tt;
send :=
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fail Tezos_base__TzPervasives.Connection_closed;
try_send :=
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
false; broadcast := OCaml.Stdlib.ignore; pool := None;
connect_handler := None;
fold_connections :=
fun init =>
fun function_parameter =>
let '_ := function_parameter in
init; iter_connections := fun _f => tt;
on_new_connection := fun _f => tt;
activate :=
fun function_parameter =>
let '_ := function_parameter in
tt; watcher := Lwt_watcher.create_input tt |}.
Definition peer_id {A B C : Type} (net : t A B C)
: Tezos_base__TzPervasives.P2p_peer.Id.t := peer_id net.
Definition maintain {A B C : Type} (net : t A B C) : Lwt.t unit :=
(maintain net) tt.
Definition roll {A B C : Type} (net : t A B C) : Lwt.t unit := (roll net) tt.
Definition shutdown {A B C : Type} (net : t A B C) : Lwt.t unit :=
(shutdown net) tt.
Definition connections {A B C : Type} (net : t A B C)
: list (connection A B C) := (connections net) tt.
Definition disconnect {A B C : Type} (net : t A B C)
: (option bool) -> (connection A B C) -> Lwt.t unit := disconnect net.
Definition find_connection {A B C : Type} (net : t A B C)
: Tezos_base__TzPervasives.P2p_peer.Id.t -> option (connection A B C) :=
find_connection net.
Definition connection_info {A B C : Type} (net : t A B C)
: (connection A B C) -> Tezos_base__TzPervasives.P2p_connection.Info.t C :=
connection_info net.
Definition connection_local_metadata {A B C : Type} (net : t A B C)
: (connection A B C) -> C := connection_local_metadata net.
Definition connection_remote_metadata {A B C : Type} (net : t A B C)
: (connection A B C) -> C := connection_remote_metadata net.
Definition connection_stat {A B C : Type} (net : t A B C)
: (connection A B C) -> Tezos_base__TzPervasives.P2p_stat.t :=
connection_stat net.
Definition global_stat {A B C : Type} (net : t A B C)
: Tezos_base__TzPervasives.P2p_stat.t := (global_stat net) tt.
Definition get_peer_metadata {A B C : Type} (net : t A B C)
: Tezos_base__TzPervasives.P2p_peer.Id.t -> B := get_peer_metadata net.
Definition set_peer_metadata {A B C : Type} (net : t A B C)
: Tezos_base__TzPervasives.P2p_peer.Id.t -> B -> unit := set_peer_metadata net.
Definition recv {A B C : Type} (net : t A B C)
: (connection A B C) -> Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
recv net.
Definition recv_any {A B C : Type} (net : t A B C)
: Lwt.t ((connection A B C) * A) := (recv_any net) tt.
Definition send {A B C : Type} (net : t A B C)
: (connection A B C) -> A -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
send net.
Definition try_send {A B C : Type} (net : t A B C)
: (connection A B C) -> A -> bool := try_send net.
Definition broadcast {A B C : Type} (net : t A B C) : A -> unit := broadcast net.
Definition fold_connections {A B C D : Type} (net : t A B C)
: D ->
(Tezos_base__TzPervasives.P2p_peer.Id.t -> (connection A B C) -> D -> D) ->
D := fold_connections net.
Definition iter_connections {A B C : Type} (net : t A B C)
: (Tezos_base__TzPervasives.P2p_peer.Id.t -> (connection A B C) -> unit) ->
unit := iter_connections net.
Definition on_new_connection {A B C : Type} (net : t A B C)
: (Tezos_base__TzPervasives.P2p_peer.Id.t -> (connection A B C) -> unit) ->
unit := on_new_connection net.
Definition greylist_addr {A B C : Type}
(net : t A B C) (addr : Tezos_base__TzPervasives.P2p_addr.t) : unit :=
Option.iter (fun pool => P2p_pool.greylist_addr pool addr) (pool net).
Definition greylist_peer {A B C : Type}
(net : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
Option.iter (fun pool => P2p_pool.greylist_peer pool peer_id) (pool net).
Definition watcher {A B C : Type} (net : t A B C)
: (Lwt_stream.t Tezos_base__TzPervasives.P2p_connection.P2p_event.t) *
Tezos_stdlib.Lwt_watcher.stopper := Lwt_watcher.create_stream (watcher net).
src/lib_p2p/p2p_acl.ml 23 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module PeerRing = Ring.MakeTable (struct
include P2p_peer.Id
end)
module PatriciaTree (V : HashPtree.Value) = struct
module Size = struct
let size = 128
end
module Bits = HashPtree.Bits (Size)
module M = HashPtree.Make_BE_sized (V) (Size)
type t = M.t
let empty = M.empty
(* take into consideration the fact that the int64
* returned by Ipaddr.V6.to_int64 is signed *)
let z_of_bytes i =
let i = Z.of_int64 i in
Z.(if i < zero then i + (of_int 2 ** 64) else i)
let z_of_ipv6 ip =
let (hi_x, lo_x) = Ipaddr.V6.to_int64 ip in
let hi = z_of_bytes hi_x in
let lo = z_of_bytes lo_x in
Z.((hi lsl 64) + lo)
let key_of_ipv6 ip = Bits.of_z (z_of_ipv6 ip)
let z_mask_of_ipv6_prefix p =
let ip = Ipaddr.V6.Prefix.network p in
let len = Ipaddr.V6.Prefix.bits p in
(z_of_ipv6 ip, Z.( lsl ) Z.one (128 - len))
let key_mask_of_ipv6_prefix p =
let (z, m) = z_mask_of_ipv6_prefix p in
(Bits.of_z z, Bits.of_z m)
let z_to_ipv6 z =
(* assumes z is a 128 bit value *)
let hi_z = Z.(z asr 64) in
let hi =
if Z.(hi_z >= of_int 2 ** 63) then
(* If overflows int64, then returns the bit equivalent
representation (which is negative) *)
Int64.add 0x8000000000000000L Z.(to_int64 (hi_z - (of_int 2 ** 63)))
else Z.(to_int64 hi_z)
in
let lo = Z.(to_int64 (z mod pow ~$2 64)) in
Ipaddr.V6.of_int64 (hi, lo)
let remove key t = M.remove (key_of_ipv6 key) t
let remove_prefix prefix t =
let (key, mask) = key_mask_of_ipv6_prefix prefix in
M.remove_prefix key mask t
let add_prefix prefix value t =
let (key, mask) = key_mask_of_ipv6_prefix prefix in
M.add (fun _ v -> v) ~key ~value ~mask t
let add key value t =
let key = key_of_ipv6 key in
M.add (fun _ v -> v) ~key ~value t
let mem key t = M.mem (key_of_ipv6 key) t
let key_mask_to_prefix key mask =
let len =
if Bits.(equal mask zero) then 0
else 128 - Z.trailing_zeros (Bits.to_z mask)
in
Ipaddr.V6.Prefix.make len (z_to_ipv6 (Bits.to_z key))
let fold f t acc =
let f key mask value acc =
let prefix = key_mask_to_prefix key mask in
f prefix value acc
in
M.fold f t acc
let pp ppf t =
let lst = fold (fun p _ l -> p :: l) t [] in
Format.fprintf
ppf
"@[<2>[%a]@]"
Format.(
pp_print_list
~pp_sep:(fun ppf () -> fprintf ppf ";@ ")
Ipaddr.V6.Prefix.pp)
lst
end
(* patricia trees using IpV6 addresses as keys *)
module IpSet = struct
include PatriciaTree (Time.System)
let remove_old t ~older_than =
let module MI = struct
type result = Time.System.t
let default = Ptime.max
let map _t _key value = value
let reduce _t left right = Time.System.(min left right)
end in
let module MR = M.Map_Reduce (MI) in
MR.filter (fun addtime -> Time.System.(older_than <= addtime)) t
end
module IpTable = Hashtbl.Make (struct
type t = Ipaddr.V6.t
let hash = Hashtbl.hash
let equal x y = Ipaddr.V6.compare x y = 0
end)
type t = {
mutable greylist_ips : IpSet.t;
greylist_peers : PeerRing.t;
banned_ips : unit IpTable.t;
banned_peers : unit P2p_peer.Table.t;
}
let create size =
{
greylist_ips = IpSet.empty;
greylist_peers = PeerRing.create size;
banned_ips = IpTable.create 53;
banned_peers = P2p_peer.Table.create 53;
}
(* check if an ip is banned. priority is for static blacklist, then
in the greylist *)
let banned_addr acl addr =
IpTable.mem acl.banned_ips addr || IpSet.mem addr acl.greylist_ips
let unban_addr acl addr =
IpTable.remove acl.banned_ips addr ;
acl.greylist_ips <- IpSet.remove addr acl.greylist_ips
(* Check is the peer_id is in the banned ring. It might be possible that
a peer ID that is not banned, but its ip address is. *)
let banned_peer acl peer_id =
P2p_peer.Table.mem acl.banned_peers peer_id
|| PeerRing.mem acl.greylist_peers peer_id
let unban_peer acl peer_id =
P2p_peer.Table.remove acl.banned_peers peer_id ;
PeerRing.remove acl.greylist_peers peer_id
let clear acl =
acl.greylist_ips <- IpSet.empty ;
P2p_peer.Table.clear acl.banned_peers ;
IpTable.clear acl.banned_ips ;
PeerRing.clear acl.greylist_peers
module IPGreylist = struct
let add acl addr time =
acl.greylist_ips <- IpSet.add addr time acl.greylist_ips
let mem acl addr = IpSet.mem addr acl.greylist_ips
(* The GC operation works only on the address set. Peers are removed
from the ring in a round-robin fashion. If a address is removed
by the GC from the acl.greylist set, it could potentially
persist in the acl.peers set until more peers are banned. *)
let remove_old acl ~older_than =
acl.greylist_ips <- IpSet.remove_old acl.greylist_ips ~older_than
let encoding = Data_encoding.(list P2p_addr.encoding)
end
module IPBlacklist = struct
let add acl addr = IpTable.add acl.banned_ips addr ()
let mem acl addr = IpTable.mem acl.banned_ips addr
end
module PeerBlacklist = struct
let add acl addr = P2p_peer.Table.add acl.banned_peers addr ()
let mem acl addr = P2p_peer.Table.mem acl.banned_peers addr
end
module PeerGreylist = struct
let add acl peer_id = PeerRing.add acl.greylist_peers peer_id
let mem acl peer_id = PeerRing.mem acl.greylist_peers peer_id
end
src/lib_p2p/p2p_acl.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Functors are not handled. *)
functor
Module IpSet.
(* ❌ Structure item `include` not handled. *)
include
Definition remove_old
(t : M.t) (older_than : Tezos_base__TzPervasives.Time.System.t) : M.t :=
let MI :=
existT _ unit
{|
M.Map_Reduce.default := Ptime.max;
(* ❌ This kind of definition of value for first-class modules is not handled *)
M.Map_Reduce.map := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
M.Map_Reduce.reduce := unhandled
|} in
let MR :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
MR.filter (fun addtime => op_lteq older_than addtime) t.
End IpSet.
(* ❌ Applications of functors are not handled. *)
functor_application
Record t := {
greylist_ips : IpSet.t;
greylist_peers : PeerRing.t;
banned_ips : IpTable.t unit;
banned_peers : Tezos_base__TzPervasives.P2p_peer.Table.t unit }.
Definition create (size : Z) : t :=
{| greylist_ips := IpSet.empty; greylist_peers := PeerRing.create size;
banned_ips := IpTable.create 53; banned_peers := P2p_peer.Table.create 53 |}.
Definition banned_addr (acl : t) (addr : IpTable.key) : bool :=
orb (IpTable.mem (banned_ips acl) addr) (IpSet.mem addr (greylist_ips acl)).
Definition unban_addr (acl : t) (addr : IpTable.key) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := IpTable.remove (banned_ips acl) addr in
(* ❌ Set record field not handled. *)
set_record_field acl "greylist_ips" % string
(IpSet.remove addr (greylist_ips acl)).
Definition banned_peer
(acl : t) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key) : bool :=
orb (P2p_peer.Table.mem (banned_peers acl) peer_id)
(PeerRing.mem (greylist_peers acl) peer_id).
Definition unban_peer
(acl : t) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_peer.Table.remove (banned_peers acl) peer_id in
PeerRing.remove (greylist_peers acl) peer_id.
Definition clear (acl : t) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field acl "greylist_ips" % string IpSet.empty in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_peer.Table.clear (banned_peers acl) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := IpTable.clear (banned_ips acl) in
PeerRing.clear (greylist_peers acl).
Module IPGreylist.
Definition add (acl : t) (addr : Ipaddr.V6.t) (time : IpSet.M.value) : unit :=
(* ❌ Set record field not handled. *)
set_record_field acl "greylist_ips" % string
(IpSet.add addr time (greylist_ips acl)).
Definition mem (acl : t) (addr : Ipaddr.V6.t) : bool :=
IpSet.mem addr (greylist_ips acl).
Definition remove_old
(acl : t) (older_than : Tezos_base__TzPervasives.Time.System.t) : unit :=
(* ❌ Set record field not handled. *)
set_record_field acl "greylist_ips" % string
(IpSet.remove_old (greylist_ips acl) older_than).
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
(list Tezos_base__TzPervasives.P2p_addr.t) := list None P2p_addr.encoding.
End IPGreylist.
Module IPBlacklist.
Definition add (acl : t) (addr : IpTable.key) : unit :=
IpTable.add (banned_ips acl) addr tt.
Definition mem (acl : t) (addr : IpTable.key) : bool :=
IpTable.mem (banned_ips acl) addr.
End IPBlacklist.
Module PeerBlacklist.
Definition add (acl : t) (addr : Tezos_base__TzPervasives.P2p_peer.Table.key)
: unit := P2p_peer.Table.add (banned_peers acl) addr tt.
Definition mem (acl : t) (addr : Tezos_base__TzPervasives.P2p_peer.Table.key)
: bool := P2p_peer.Table.mem (banned_peers acl) addr.
End PeerBlacklist.
Module PeerGreylist.
Definition add (acl : t) (peer_id : PeerRing.v) : unit :=
PeerRing.add (greylist_peers acl) peer_id.
Definition mem (acl : t) (peer_id : PeerRing.v) : bool :=
PeerRing.mem (greylist_peers acl) peer_id.
End PeerGreylist.
src/lib_p2p/p2p_answerer.ml 6 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** An [Answerer.t] is a set of callback functions, parameterized by
[conn_info] record. The [conn_info] records contains values useful
for the callback functions to perfom their task, and known after
the connection is set up.
The callback functions are called when the node receives `P2p_messages.t`
messages. The parameters are the values carried by the message, and
a [request_info] record that contains values pertaining to the connection
that may change during the life of the connection. *)
type 'msg conn_info = {
peer_id : P2p_peer.Id.t;
is_private : bool;
write_swap_ack : P2p_point.Id.t -> P2p_peer.Id.t -> bool tzresult;
messages : (int * 'msg) Lwt_pipe.t;
}
type request_info = {
last_sent_swap_request : (Time.System.t * P2p_peer.Id.t) option;
}
type 'msg callback = {
bootstrap : request_info -> P2p_point.Id.t list Lwt.t;
advertise : request_info -> P2p_point.Id.t list -> unit Lwt.t;
message : request_info -> int -> 'msg -> unit Lwt.t;
swap_request : request_info -> P2p_point.Id.t -> P2p_peer.Id.t -> unit Lwt.t;
swap_ack : request_info -> P2p_point.Id.t -> P2p_peer.Id.t -> unit Lwt.t;
}
type 'msg t = 'msg conn_info -> 'msg callback
src/lib_p2p/p2p_answerer.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record conn_info {msg : Type} := {
peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
is_private : bool;
write_swap_ack :
Tezos_base__TzPervasives.P2p_point.Id.t ->
Tezos_base__TzPervasives.P2p_peer.Id.t ->
Tezos_base__TzPervasives.tzresult bool;
messages : Tezos_stdlib.Lwt_pipe.t (Z * msg) }.
Arguments conn_info : clear implicits.
Record request_info := {
last_sent_swap_request :
option
(Tezos_base__TzPervasives.Time.System.t *
Tezos_base__TzPervasives.P2p_peer.Id.t) }.
Record callback {msg : Type} := {
bootstrap :
request_info -> Lwt.t (list Tezos_base__TzPervasives.P2p_point.Id.t);
advertise :
request_info -> (list Tezos_base__TzPervasives.P2p_point.Id.t) -> Lwt.t unit;
message : request_info -> Z -> msg -> Lwt.t unit;
swap_request :
request_info ->
Tezos_base__TzPervasives.P2p_point.Id.t ->
Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit;
swap_ack :
request_info ->
Tezos_base__TzPervasives.P2p_point.Id.t ->
Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit }.
Arguments callback : clear implicits.
Definition t (msg : Type) := (conn_info msg) -> callback msg.
src/lib_p2p/p2p_conn.ml 21 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make (struct
let name = "p2p.conn"
end)
type ('msg, 'peer, 'conn) t = {
canceler : Lwt_canceler.t;
messages : (int * 'msg) Lwt_pipe.t;
conn : ('msg P2p_message.t, 'conn) P2p_socket.t;
peer_info : (('msg, 'peer, 'conn) t, 'peer, 'conn) P2p_peer_state.Info.t;
point_info : ('msg, 'peer, 'conn) t P2p_point_state.Info.t option;
negotiated_version : Network_version.t;
mutable last_sent_swap_request : (Time.System.t * P2p_peer.Id.t) option;
mutable wait_close : bool;
mutable worker : unit Lwt.t option;
peer_id : P2p_peer.Id.t;
trusted_node : bool;
private_node : bool;
}
let rec worker_loop (t : ('msg, 'peer, 'conn) t) callback =
let open P2p_answerer in
let request_info =
P2p_answerer.{last_sent_swap_request = t.last_sent_swap_request}
in
Lwt_unix.yield ()
>>= fun () ->
protect ~canceler:t.canceler (fun () -> P2p_socket.read t.conn)
>>= function
| Ok (_, Bootstrap) -> (
(* callback.bootstrap will return an empty list if the node
is in private mode *)
callback.bootstrap request_info
>>= function
| [] ->
worker_loop t callback
| points -> (
match P2p_socket.write_now t.conn (Advertise points) with
| Ok _sent ->
(* if not sent then ?? TODO count dropped message ?? *)
worker_loop t callback
| Error _ ->
Lwt_canceler.cancel t.canceler >>= fun () -> Lwt.return_unit ) )
| Ok (_, Advertise points) ->
(* callback.advertise will ignore the points if the node is
in private mode *)
callback.advertise request_info points
>>= fun () -> worker_loop t callback
| Ok (_, Swap_request (point, peer)) ->
callback.swap_request request_info point peer
>>= fun () -> worker_loop t callback
| Ok (_, Swap_ack (point, peer)) ->
callback.swap_ack request_info point peer
>>= fun () -> worker_loop t callback
| Ok (size, Message msg) ->
callback.message request_info size msg
>>= fun () -> worker_loop t callback
| Ok (_, Disconnect) | Error (P2p_errors.Connection_closed :: _) ->
Lwt_canceler.cancel t.canceler >>= fun () -> Lwt.return_unit
| Error (P2p_errors.Decoding_error :: _) ->
(* TODO: Penalize peer... *)
Lwt_canceler.cancel t.canceler >>= fun () -> Lwt.return_unit
| Error (Canceled :: _) ->
Lwt.return_unit
| Error err ->
lwt_log_error
"@[Answerer unexpected error:@ %a@]"
Error_monad.pp_print_error
err
>>= fun () ->
Lwt_canceler.cancel t.canceler >>= fun () -> Lwt.return_unit
let shutdown t =
match t.worker with
| None ->
Lwt.return_unit
| Some w ->
Lwt_canceler.cancel t.canceler >>= fun () -> w
let write_swap_ack t point peer_id =
P2p_socket.write_now t.conn (Swap_request (point, peer_id))
let create conn point_info peer_info messages canceler callback
negotiated_version =
let private_node = P2p_socket.private_node conn in
let trusted_node =
P2p_peer_state.Info.trusted peer_info
|| Option.unopt_map
~default:false
~f:P2p_point_state.Info.trusted
point_info
in
let peer_id = peer_info |> P2p_peer_state.Info.peer_id in
let t =
{
conn;
point_info;
peer_info;
messages;
canceler;
wait_close = false;
last_sent_swap_request = None;
negotiated_version;
worker = None;
peer_id;
private_node;
trusted_node;
}
in
let conn_info =
P2p_answerer.
{
peer_id = t.peer_info |> P2p_peer_state.Info.peer_id;
is_private = P2p_socket.private_node t.conn;
write_swap_ack = write_swap_ack t;
messages;
}
in
t.worker <-
Some
(Lwt_utils.worker
"answerer"
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> worker_loop t (callback conn_info))
~cancel:(fun () -> Lwt_canceler.cancel t.canceler)) ;
t
let pipe_exn_handler = function
| Lwt_pipe.Closed ->
fail P2p_errors.Connection_closed
| _ ->
assert false
(* see [Lwt_pipe.pop] *)
let read t =
Lwt.catch
(fun () ->
Lwt_pipe.pop t.messages
>>= fun (s, msg) ->
lwt_debug
"%d bytes message popped from queue %a\027[0m"
s
P2p_peer.Id.pp
(P2p_socket.info t.conn).peer_id
>>= fun () -> return msg)
pipe_exn_handler
let is_readable t =
Lwt.catch
(fun () -> Lwt_pipe.values_available t.messages >>= return)
pipe_exn_handler
let write t msg = P2p_socket.write t.conn (Message msg)
let write_sync t msg = P2p_socket.write_sync t.conn (Message msg)
let raw_write_sync t buf = P2p_socket.raw_write_sync t.conn buf
let write_now t msg = P2p_socket.write_now t.conn (Message msg)
let write_swap_request t point peer_id =
t.last_sent_swap_request <- Some (Systime_os.now (), peer_id) ;
P2p_socket.write_now t.conn (Swap_request (point, peer_id))
let write_bootstrap t = P2p_socket.write_now t.conn Bootstrap
let stat t = P2p_socket.stat t.conn
let info t = P2p_socket.info t.conn
let local_metadata t = P2p_socket.local_metadata t.conn
let remote_metadata t = P2p_socket.remote_metadata t.conn
let disconnect ?(wait = false) t =
t.wait_close <- wait ;
shutdown t
let close t = P2p_socket.close ~wait:t.wait_close t.conn
let equal_sock t t' = P2p_socket.equal t.conn t'.conn
let private_node t = t.private_node
let peer_id t = t.peer_id
let trusted_node t = t.trusted_node
src/lib_p2p/p2p_conn.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Record t {msg peer conn : Type} := {
canceler : Tezos_stdlib.Lwt_canceler.t;
messages : Tezos_stdlib.Lwt_pipe.t (Z * msg);
conn : Tezos_p2p.P2p_socket.t (Tezos_p2p.P2p_message.t msg) conn;
peer_info : Tezos_p2p.P2p_peer_state.Info.t (t msg peer conn) peer conn;
point_info : option (Tezos_p2p.P2p_point_state.Info.t (t msg peer conn));
negotiated_version : Tezos_base__TzPervasives.Network_version.t;
last_sent_swap_request :
option
(Tezos_base__TzPervasives.Time.System.t *
Tezos_base__TzPervasives.P2p_peer.Id.t);
wait_close : bool;
worker : option (Lwt.t unit);
peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
trusted_node : bool;
private_node : bool }.
Arguments t : clear implicits.
Fixpoint worker_loop {conn msg peer : Type}
(t : t msg peer conn) (callback : Tezos_p2p.P2p_answerer.callback msg)
: Lwt.t unit :=
let request_info := {| last_sent_swap_request := last_sent_swap_request t |}
in
op_gtgteq (Lwt_unix.yield tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(protect None (Some (canceler t))
(fun function_parameter =>
let 'tt := function_parameter in
P2p_socket.read (conn t)))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok (_, Tezos_p2p.P2p_message.Bootstrap) =>
op_gtgteq ((bootstrap callback) request_info)
(fun function_parameter =>
match function_parameter with
| [] => worker_loop t callback
| points =>
match
P2p_socket.write_now (conn t)
(Tezos_p2p.P2p_message.Advertise points) with
| Stdlib.Ok _sent => worker_loop t callback
| Stdlib.Error _ =>
op_gtgteq (Lwt_canceler.cancel (canceler t))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_unit)
end
end)
| Stdlib.Ok (_, Tezos_p2p.P2p_message.Advertise points) =>
op_gtgteq ((advertise callback) request_info points)
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop t callback)
| Stdlib.Ok (_, Tezos_p2p.P2p_message.Swap_request point peer) =>
op_gtgteq ((swap_request callback) request_info point peer)
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop t callback)
| Stdlib.Ok (_, Tezos_p2p.P2p_message.Swap_ack point peer) =>
op_gtgteq ((swap_ack callback) request_info point peer)
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop t callback)
| Stdlib.Ok (size, Tezos_p2p.P2p_message.Message msg) =>
op_gtgteq ((message callback) request_info size msg)
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop t callback)
|
Stdlib.Ok (_, Tezos_p2p.P2p_message.Disconnect) |
Stdlib.Error (cons Tezos_base__TzPervasives.Connection_closed _)
=>
op_gtgteq (Lwt_canceler.cancel (canceler t))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_unit)
| Stdlib.Error (cons Tezos_base__TzPervasives.Decoding_error _) =>
op_gtgteq (Lwt_canceler.cancel (canceler t))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_unit)
| Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) =>
Lwt.return_unit
| Stdlib.Error err =>
op_gtgteq
(lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Answerer unexpected error:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Answerer unexpected error:@ %a@]" % string)
Error_monad.pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_canceler.cancel (canceler t))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_unit))
end)).
Definition shutdown {A B C : Type} (t : t A B C) : Lwt.t unit :=
match worker t with
| None => Lwt.return_unit
| Some w =>
op_gtgteq (Lwt_canceler.cancel (canceler t))
(fun function_parameter =>
let 'tt := function_parameter in
w)
end.
Definition write_swap_ack {A B C : Type}
(t : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Id.t)
(peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
: Tezos_base__TzPervasives.tzresult bool :=
P2p_socket.write_now (conn t)
(Tezos_p2p.P2p_message.Swap_request point peer_id).
Definition create {A B C : Type}
(conn : Tezos_p2p.P2p_socket.t (Tezos_p2p.P2p_message.t A) B)
(point_info : option (Tezos_p2p.P2p_point_state.Info.t (t A C B)))
(peer_info : Tezos_p2p.P2p_peer_state.Info.peer_info (t A C B) C B)
(messages : Tezos_stdlib.Lwt_pipe.t (Z * A))
(canceler : Tezos_stdlib.Lwt_canceler.t)
(callback :
(Tezos_p2p.P2p_answerer.conn_info A) -> Tezos_p2p.P2p_answerer.callback A)
(negotiated_version : Tezos_base__TzPervasives.Network_version.t) : t A C B :=
let private_node := P2p_socket.private_node conn in
let trusted_node :=
orb (P2p_peer_state.Info.trusted peer_info)
(Option.unopt_map P2p_point_state.Info.trusted false point_info) in
let peer_id :=
OCaml.Stdlib.reverse_apply peer_info P2p_peer_state.Info.peer_id in
let t :=
{| canceler := canceler; messages := messages; conn := conn;
peer_info := peer_info; point_info := point_info;
negotiated_version := negotiated_version; last_sent_swap_request := None;
wait_close := false; worker := None; peer_id := peer_id;
trusted_node := trusted_node; private_node := private_node |} in
let conn_info :=
{|
peer_id :=
OCaml.Stdlib.reverse_apply (peer_info t) P2p_peer_state.Info.peer_id;
is_private := P2p_socket.private_node (conn t);
write_swap_ack := write_swap_ack t; messages := messages |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field t "worker" % string
(Some
(Lwt_utils.worker "answerer" % string
Internal_event.Lwt_worker_event.on_event
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop t (callback conn_info))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler t)))) in
t.
Definition pipe_exn_handler {A : Type} (function_parameter : exn)
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
match function_parameter with
| Closed => fail Tezos_base__TzPervasives.Connection_closed
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end.
Definition read {A B C : Type} (t : t A B C)
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_pipe.pop (messages t))
(fun function_parameter =>
let '(s, msg) := function_parameter in
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" bytes message popped from queue " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "[0m" % string
CamlinternalFormatBasics.End_of_format))))
"%d bytes message popped from queue %a[0m" % string) s
P2p_peer.Id.pp (peer_id (P2p_socket.info (conn t))))
(fun function_parameter =>
let 'tt := function_parameter in
_return msg))) pipe_exn_handler.
Definition is_readable {A B C : Type} (t : t A B C)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_pipe.values_available (messages t)) _return)
pipe_exn_handler.
Definition write {A B C : Type} (t : t A B C) (msg : A)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
P2p_socket.write (conn t) (Tezos_p2p.P2p_message.Message msg).
Definition write_sync {A B C : Type} (t : t A B C) (msg : A)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
P2p_socket.write_sync (conn t) (Tezos_p2p.P2p_message.Message msg).
Definition raw_write_sync {A B C : Type} (t : t A B C) (buf : Stdlib.Bytes.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
P2p_socket.raw_write_sync (conn t) buf.
Definition write_now {A B C : Type} (t : t A B C) (msg : A)
: Tezos_base__TzPervasives.tzresult bool :=
P2p_socket.write_now (conn t) (Tezos_p2p.P2p_message.Message msg).
Definition write_swap_request {A B C : Type}
(t : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Id.t)
(peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
: Tezos_base__TzPervasives.tzresult bool :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field t "last_sent_swap_request" % string
(Some ((Systime_os.now tt), peer_id)) in
P2p_socket.write_now (conn t)
(Tezos_p2p.P2p_message.Swap_request point peer_id).
Definition write_bootstrap {A B C : Type} (t : t A B C)
: Tezos_base__TzPervasives.tzresult bool :=
P2p_socket.write_now (conn t) Tezos_p2p.P2p_message.Bootstrap.
Definition stat {A B C : Type} (t : t A B C)
: Tezos_base__TzPervasives.P2p_stat.t := P2p_socket.stat (conn t).
Definition info {A B C : Type} (t : t A B C)
: Tezos_base__TzPervasives.P2p_connection.Info.t C := P2p_socket.info (conn t).
Definition local_metadata {A B C : Type} (t : t A B C) : C :=
P2p_socket.local_metadata (conn t).
Definition remote_metadata {A B C : Type} (t : t A B C) : C :=
P2p_socket.remote_metadata (conn t).
Definition disconnect {A B C : Type} (op_staroptstar : option bool)
: (t A B C) -> Lwt.t unit :=
let wait :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun t =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field t "wait_close" % string wait in
shutdown t.
Definition close {A B C : Type} (t : t A B C) : Lwt.t unit :=
P2p_socket.close (Some (wait_close t)) (conn t).
Definition equal_sock {A B C D E : Type} (t : t A B C) (t' : t D E C) : bool :=
P2p_socket.equal (conn t) (conn t').
Definition private_node {A B C : Type} (t : t A B C) : bool := private_node t.
Definition peer_id {A B C : Type} (t : t A B C)
: Tezos_base__TzPervasives.P2p_peer.Id.t := peer_id t.
Definition trusted_node {A B C : Type} (t : t A B C) : bool := trusted_node t.
src/lib_p2p/p2p_connect_handler.ml 91 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make (struct
let name = "p2p.connect_handler"
end)
type 'msg message_config = {
encoding : 'msg P2p_message.encoding list;
chain_name : Distributed_db_version.name;
distributed_db_versions : Distributed_db_version.t list;
}
type config = {
incoming_app_message_queue_size : int option;
private_mode : bool;
min_connections : int;
max_connections : int;
max_incoming_connections : int;
incoming_message_queue_size : int option;
outgoing_message_queue_size : int option;
binary_chunks_size : int option;
identity : P2p_identity.t;
connection_timeout : Time.System.Span.t;
authentication_timeout : Time.System.Span.t;
greylisting_config : P2p_point_state.Info.greylisting_config;
proof_of_work_target : Crypto_box.target;
listening_port : P2p_addr.port option;
}
type ('msg, 'peer_meta, 'conn_meta) t = {
config : config;
pool : ('msg, 'peer_meta, 'conn_meta) P2p_pool.t;
log : P2p_connection.P2p_event.t -> unit;
triggers : P2p_trigger.t;
io_sched : P2p_io_scheduler.t;
announced_version : Network_version.t;
conn_meta_config : 'conn_meta P2p_socket.metadata_config;
message_config : 'msg message_config;
custom_p2p_versions : P2p_version.t list;
encoding : 'msg P2p_message.t Data_encoding.t;
incoming : Lwt_canceler.t P2p_point.Table.t;
mutable new_connection_hook :
(P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) P2p_conn.t -> unit) list;
answerer : 'msg P2p_answerer.t Lazy.t;
}
let create ?(p2p_versions = P2p_version.supported) config pool message_config
conn_meta_config io_sched triggers ~log ~answerer =
{
config;
conn_meta_config;
message_config;
announced_version =
Network_version.announced
~chain_name:message_config.chain_name
~distributed_db_versions:message_config.distributed_db_versions
~p2p_versions;
custom_p2p_versions = p2p_versions;
incoming = P2p_point.Table.create 53;
io_sched;
encoding = P2p_message.encoding message_config.encoding;
triggers;
new_connection_hook = [];
log;
pool;
answerer;
}
let create_connection t p2p_conn id_point point_info peer_info
negotiated_version =
let peer_id = P2p_peer_state.Info.peer_id peer_info in
let canceler = Lwt_canceler.create () in
let size =
Option.map t.config.incoming_app_message_queue_size ~f:(fun qs ->
( qs,
fun (size, _) ->
(Sys.word_size / 8 * 11) + size + Lwt_pipe.push_overhead ))
in
let messages = Lwt_pipe.create ?size () in
let conn =
P2p_conn.create
p2p_conn
point_info
peer_info
messages
canceler
(Lazy.force t.answerer)
negotiated_version
in
let conn_meta = P2p_socket.remote_metadata p2p_conn in
Option.iter point_info ~f:(fun point_info ->
let point = P2p_point_state.Info.point point_info in
P2p_point_state.set_running point_info peer_id conn ;
P2p_pool.Points.add_connected t.pool point point_info) ;
t.log (Connection_established (id_point, peer_id)) ;
P2p_peer_state.set_running peer_info id_point conn conn_meta ;
P2p_pool.Peers.add_connected t.pool peer_id peer_info ;
P2p_trigger.broadcast_new_connection t.triggers ;
Lwt_canceler.on_cancel canceler (fun () ->
lwt_debug
"Disconnect: %a (%a)"
P2p_peer.Id.pp
peer_id
P2p_connection.Id.pp
id_point
>>= fun () ->
Option.iter
~f:(P2p_point_state.set_disconnected t.config.greylisting_config)
point_info ;
t.log (Disconnection peer_id) ;
P2p_peer_state.set_disconnected peer_info ;
Option.iter point_info ~f:(fun point_info ->
P2p_pool.Points.remove_connected t.pool point_info) ;
P2p_pool.Peers.remove_connected t.pool peer_id ;
if t.config.max_connections <= P2p_pool.active_connections t.pool then (
P2p_trigger.broadcast_too_many_connections t.triggers ;
t.log Too_many_connections ) ;
Lwt_pipe.close messages ;
P2p_conn.close conn) ;
List.iter (fun f -> f peer_id conn) t.new_connection_hook ;
if P2p_pool.active_connections t.pool < t.config.min_connections then (
P2p_trigger.broadcast_too_few_connections t.triggers ;
t.log Too_few_connections ) ;
conn
let may_register_my_id_point pool = function
| [P2p_errors.Myself (addr, Some port)] ->
P2p_pool.add_to_id_points pool (addr, port)
| _ ->
()
let raw_authenticate t ?point_info canceler fd point =
let incoming = point_info = None in
lwt_debug
"authenticate: %a%s"
P2p_point.Id.pp
point
(if incoming then " incoming" else "")
>>= fun () ->
protect
~canceler
(fun () ->
P2p_socket.authenticate
~canceler
~proof_of_work_target:t.config.proof_of_work_target
~incoming
fd
point
?listening_port:t.config.listening_port
t.config.identity
t.announced_version
t.conn_meta_config)
~on_error:(fun err ->
( match err with
| [Canceled] ->
(* Currently only on time out *)
lwt_debug
"authenticate: %a%s -> canceled"
P2p_point.Id.pp
point
(if incoming then " incoming" else "")
| err ->
(* Authentication incorrect! Temp ban the offending points/peers *)
List.iter
(function
| P2p_errors.Not_enough_proof_of_work _
| P2p_errors.Invalid_auth
| P2p_errors.Decipher_error
| P2p_errors.Invalid_message_size
| P2p_errors.Encoding_error
| P2p_errors.Decoding_error
| P2p_errors.Invalid_chunks_size _ ->
P2p_pool.greylist_addr t.pool (fst point)
| _ ->
())
err ;
lwt_debug
"@[authenticate: %a%s -> failed@ %a@]"
P2p_point.Id.pp
point
(if incoming then " incoming" else "")
pp_print_error
err )
>>= fun () ->
may_register_my_id_point t.pool err ;
t.log (Authentication_failed point) ;
if incoming then P2p_point.Table.remove t.incoming point
else
Option.iter
~f:(P2p_point_state.set_disconnected t.config.greylisting_config)
point_info ;
Lwt.return_error err)
>>=? fun (info, auth_fd) ->
(* Authentication correct! *)
lwt_debug
"authenticate: %a -> auth %a"
P2p_point.Id.pp
point
P2p_peer.Id.pp
info.peer_id
>>= fun () ->
fail_when
(P2p_pool.Peers.banned t.pool info.peer_id)
(P2p_errors.Peer_banned info.peer_id)
>>=? fun () ->
let remote_point_info =
match info.id_point with
| (addr, Some port) ->
P2p_pool.register_new_point t.pool (addr, port)
| _ ->
None
in
let connection_point_info =
match (point_info, remote_point_info) with
| (None, None) ->
None
| ((Some _ as point_info), _) | (_, (Some _ as point_info)) ->
point_info
in
let peer_info = P2p_pool.register_peer t.pool info.peer_id in
let acceptable_version =
Network_version.select
~chain_name:t.message_config.chain_name
~distributed_db_versions:t.message_config.distributed_db_versions
~p2p_versions:t.custom_p2p_versions
info.announced_version
in
let acceptable_point =
Option.unopt_map
connection_point_info
~default:(not t.config.private_mode)
~f:(fun connection_point_info ->
match P2p_point_state.get connection_point_info with
| Requested _ ->
not incoming
| Disconnected ->
let unexpected =
t.config.private_mode
&& not (P2p_point_state.Info.trusted connection_point_info)
in
if unexpected then
warn
"[private node] incoming connection from untrused peer \
rejected!" ;
not unexpected
| Accepted _ | Running _ ->
false)
in
let acceptable_peer_id =
match P2p_peer_state.get peer_info with
| Accepted _ ->
(* TODO: in some circumstances cancel and accept... *)
false
| Running _ ->
false
| Disconnected ->
true
in
(* To Verify : the thread must ? not be interrupted between
point removal from incoming and point registration into
active connection to prevent flooding attack.
incoming_connections + active_connection must reflect/dominate
the actual number of ongoing connections.
On the other hand, if we wait too long for Ack, we will reject
incoming connections, thus giving an entry point for dos attack
by giving late Nack.
*)
if incoming then P2p_point.Table.remove t.incoming point ;
Option.iter connection_point_info ~f:(fun point_info ->
(* set the point to private or not, depending on the [info] gethered
during authentication *)
P2p_point_state.set_private point_info info.private_node) ;
match acceptable_version with
| Some version when acceptable_peer_id && acceptable_point ->
t.log (Accepting_request (point, info.id_point, info.peer_id)) ;
Option.iter connection_point_info ~f:(fun point_info ->
P2p_point_state.set_accepted point_info info.peer_id canceler) ;
P2p_peer_state.set_accepted peer_info info.id_point canceler ;
lwt_debug
"authenticate: %a -> accept %a"
P2p_point.Id.pp
point
P2p_peer.Id.pp
info.peer_id
>>= fun () ->
protect
~canceler
(fun () ->
P2p_socket.accept
?incoming_message_queue_size:t.config.incoming_message_queue_size
?outgoing_message_queue_size:t.config.outgoing_message_queue_size
?binary_chunks_size:t.config.binary_chunks_size
~canceler
auth_fd
t.encoding
>>=? fun conn ->
lwt_debug
"authenticate: %a -> Connected %a"
P2p_point.Id.pp
point
P2p_peer.Id.pp
info.peer_id
>>= fun () -> return conn)
~on_error:(fun err ->
if incoming then
t.log
(Request_rejected (point, Some (info.id_point, info.peer_id))) ;
lwt_debug
"authenticate: %a -> rejected %a"
P2p_point.Id.pp
point
P2p_peer.Id.pp
info.peer_id
>>= fun () ->
Option.iter
connection_point_info
~f:(P2p_point_state.set_disconnected t.config.greylisting_config) ;
P2p_peer_state.set_disconnected peer_info ;
Lwt.return_error err)
>>=? fun conn ->
let id_point =
match
(info.id_point, Option.map ~f:P2p_point_state.Info.point point_info)
with
| ((addr, _), Some (_, port)) ->
(addr, Some port)
| (id_point, None) ->
id_point
in
return
(create_connection
t
conn
id_point
connection_point_info
peer_info
version)
| _ -> (
t.log (Rejecting_request (point, info.id_point, info.peer_id)) ;
lwt_debug
"authenticate: %a -> kick %a point: %B peer_id: %B"
P2p_point.Id.pp
point
P2p_peer.Id.pp
info.peer_id
acceptable_point
acceptable_peer_id
>>= fun () ->
P2p_socket.kick auth_fd
>>= fun () ->
if not incoming then
Option.iter
~f:(P2p_point_state.set_disconnected t.config.greylisting_config)
point_info
(* FIXME P2p_peer_state.set_disconnected ~requested:true peer_info ; *) ;
match acceptable_version with
| None ->
lwt_debug
"No common protocol@.(chains: local %a - remote \
%a)@.(db_versions: local [%a] - remote %a)@.(p2p_versions: local \
[%a] - remote %a)"
Distributed_db_version.pp_name
t.message_config.chain_name
Distributed_db_version.pp_name
info.announced_version.chain_name
(Format.pp_print_list Distributed_db_version.pp)
t.message_config.distributed_db_versions
Distributed_db_version.pp
info.announced_version.distributed_db_version
(Format.pp_print_list P2p_version.pp)
t.custom_p2p_versions
P2p_version.pp
info.announced_version.p2p_version
>>= fun () ->
fail
(P2p_errors.Rejected_no_common_protocol
{announced = info.announced_version})
| Some _ ->
fail (P2p_errors.Rejected info.peer_id) )
let authenticate t ?point_info canceler fd point =
let fd = P2p_io_scheduler.register t.io_sched fd in
raw_authenticate t ?point_info canceler fd point
>>= function
| Ok connection ->
return connection
| Error _ as err ->
P2p_io_scheduler.close fd >>=? fun () -> Lwt.return err
let accept t fd point =
t.log (Incoming_connection point) ;
let max_active_conns = t.config.max_connections + Random.int 2 in
if
t.config.max_incoming_connections <= P2p_point.Table.length t.incoming
|| max_active_conns <= P2p_pool.active_connections t.pool
(* silently ignore banned points *)
|| P2p_pool.Points.banned t.pool point
then Lwt.async (fun () -> P2p_fd.close fd)
else
let canceler = Lwt_canceler.create () in
P2p_point.Table.add t.incoming point canceler ;
Lwt.async (fun () ->
with_timeout
~canceler
(Systime_os.sleep t.config.authentication_timeout)
(fun canceler -> authenticate t canceler fd point))
let fail_unless_disconnected_point point_info =
match P2p_point_state.get point_info with
| Disconnected ->
return_unit
| Requested _ | Accepted _ ->
fail P2p_errors.Pending_connection
| Running _ ->
fail P2p_errors.Connected
let connect ?timeout t point =
fail_when
(P2p_pool.Points.banned t.pool point)
(P2p_errors.Point_banned point)
>>=? fun () ->
let timeout = Option.unopt ~default:t.config.connection_timeout timeout in
fail_unless
(P2p_pool.active_connections t.pool <= t.config.max_connections)
P2p_errors.Too_many_connections
>>=? fun () ->
let canceler = Lwt_canceler.create () in
with_timeout ~canceler (Systime_os.sleep timeout) (fun canceler ->
let point_info = P2p_pool.register_point t.pool point in
let ((addr, port) as point) = P2p_point_state.Info.point point_info in
fail_unless
((not t.config.private_mode) || P2p_point_state.Info.trusted point_info)
P2p_errors.Private_mode
>>=? fun () ->
fail_unless_disconnected_point point_info
>>=? fun () ->
P2p_point_state.set_requested point_info canceler ;
let fd = P2p_fd.socket PF_INET6 SOCK_STREAM 0 in
let uaddr =
Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port)
in
lwt_debug "connect: %a" P2p_point.Id.pp point
>>= fun () ->
protect
~canceler
(fun () ->
t.log (Outgoing_connection point) ;
P2p_fd.connect fd uaddr >>= fun () -> return_unit)
~on_error:(fun err ->
lwt_debug "connect: %a -> disconnect" P2p_point.Id.pp point
>>= fun () ->
P2p_point_state.set_disconnected
t.config.greylisting_config
point_info ;
P2p_fd.close fd
>>= fun () ->
match err with
| [Exn (Unix.Unix_error (Unix.ECONNREFUSED, _, _))] ->
fail P2p_errors.Connection_refused
| err ->
Lwt.return_error err)
>>=? fun () ->
lwt_debug "connect: %a -> authenticate" P2p_point.Id.pp point
>>= fun () -> authenticate t ~point_info canceler fd point)
let stat t = P2p_io_scheduler.global_stat t.io_sched
let on_new_connection t f = t.new_connection_hook <- f :: t.new_connection_hook
let destroy t =
P2p_point.Table.fold
(fun _point canceler acc -> Lwt_canceler.cancel canceler >>= fun () -> acc)
t.incoming
Lwt.return_unit
src/lib_p2p/p2p_connect_handler.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Record message_config {msg : Type} := {
encoding : list (Tezos_p2p.P2p_message.encoding msg);
chain_name : Tezos_base__TzPervasives.Distributed_db_version.name;
distributed_db_versions :
list Tezos_base__TzPervasives.Distributed_db_version.t }.
Arguments message_config : clear implicits.
Record config := {
incoming_app_message_queue_size : option Z;
private_mode : bool;
min_connections : Z;
max_connections : Z;
max_incoming_connections : Z;
incoming_message_queue_size : option Z;
outgoing_message_queue_size : option Z;
binary_chunks_size : option Z;
identity : Tezos_base__TzPervasives.P2p_identity.t;
connection_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
authentication_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
greylisting_config : Tezos_p2p.P2p_point_state.Info.greylisting_config;
proof_of_work_target : Tezos_base__TzPervasives.Crypto_box.target;
listening_port : option Tezos_base__TzPervasives.P2p_addr.port }.
Record t {msg peer_meta conn_meta : Type} := {
config : config;
pool : Tezos_p2p.P2p_pool.t msg peer_meta conn_meta;
log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit;
triggers : Tezos_p2p.P2p_trigger.t;
io_sched : Tezos_p2p.P2p_io_scheduler.t;
announced_version : Tezos_base__TzPervasives.Network_version.t;
conn_meta_config : Tezos_p2p.P2p_socket.metadata_config conn_meta;
message_config : message_config msg;
custom_p2p_versions : list Tezos_base__TzPervasives.P2p_version.t;
encoding :
Tezos_base__TzPervasives.Data_encoding.t (Tezos_p2p.P2p_message.t msg);
incoming :
Tezos_base__TzPervasives.P2p_point.Table.t Tezos_stdlib.Lwt_canceler.t;
new_connection_hook :
list
(Tezos_base__TzPervasives.P2p_peer.Id.t ->
(Tezos_p2p.P2p_conn.t msg peer_meta conn_meta) -> unit);
answerer : Stdlib.Lazy.t (Tezos_p2p.P2p_answerer.t msg) }.
Arguments t : clear implicits.
Definition create {A B C : Type}
(op_staroptstar : option (list Tezos_base__TzPervasives.P2p_version.t))
: config ->
(Tezos_p2p.P2p_pool.t A B C) ->
(message_config A) ->
(Tezos_p2p.P2p_socket.metadata_config C) ->
Tezos_p2p.P2p_io_scheduler.t ->
Tezos_p2p.P2p_trigger.t ->
(Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit) ->
(Stdlib.Lazy.t (Tezos_p2p.P2p_answerer.t A)) -> t A B C :=
let p2p_versions :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => P2p_version.supported
end in
fun config =>
fun pool =>
fun message_config =>
fun conn_meta_config =>
fun io_sched =>
fun triggers =>
fun log =>
fun answerer =>
{| config := config; pool := pool; log := log;
triggers := triggers; io_sched := io_sched;
announced_version :=
Network_version.announced (chain_name message_config)
(distributed_db_versions message_config) p2p_versions;
conn_meta_config := conn_meta_config;
message_config := message_config;
custom_p2p_versions := p2p_versions;
encoding := P2p_message.encoding (encoding message_config);
incoming := P2p_point.Table.create 53;
new_connection_hook := []; answerer := answerer |}.
Definition create_connection {A B C : Type}
(t : t A B C)
(p2p_conn : Tezos_p2p.P2p_socket.t (Tezos_p2p.P2p_message.t A) C)
(id_point : Tezos_base__P2p_connection.Id.t)
(point_info :
option
(Tezos_p2p.P2p_point_state.Info.point_info (Tezos_p2p.P2p_conn.t A B C)))
(peer_info :
Tezos_p2p.P2p_peer_state.Info.peer_info (Tezos_p2p.P2p_conn.t A B C) B C)
(negotiated_version : Tezos_base__TzPervasives.Network_version.t)
: Tezos_p2p.P2p_conn.t A B C :=
let peer_id := P2p_peer_state.Info.peer_id peer_info in
let canceler := Lwt_canceler.create tt in
let size :=
Option.map
(fun qs =>
(qs,
(fun function_parameter =>
let '(size, _) := function_parameter in
Z.add (Z.add (Z.mul (Z.div Sys.word_size 8) 11) size)
Lwt_pipe.push_overhead)))
(incoming_app_message_queue_size (config t)) in
let messages := Lwt_pipe.create size tt in
let conn :=
P2p_conn.create p2p_conn point_info peer_info messages canceler
(Lazy.force (answerer t)) negotiated_version in
let conn_meta := P2p_socket.remote_metadata p2p_conn in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Option.iter
(fun point_info =>
let point := P2p_point_state.Info.point point_info in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_point_state.set_running None point_info peer_id conn in
P2p_pool.Points.add_connected (pool t) point point_info) point_info in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(log t)
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Connection_established
id_point peer_id) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_peer_state.set_running None peer_info id_point conn conn_meta in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_pool.Peers.add_connected (pool t) peer_id peer_info in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_trigger.broadcast_new_connection (triggers t) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_canceler.on_cancel canceler
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Disconnect: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"Disconnect: %a (%a)" % string) P2p_peer.Id.pp peer_id
P2p_connection.Id.pp id_point)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Option.iter
(P2p_point_state.set_disconnected None None
(greylisting_config (config t))) point_info in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(log t)
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Disconnection
peer_id) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_peer_state.set_disconnected None None peer_info in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Option.iter
(fun point_info =>
P2p_pool.Points.remove_connected (pool t) point_info)
point_info in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_pool.Peers.remove_connected (pool t) peer_id in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
OCaml.Stdlib.le (max_connections (config t))
(P2p_pool.active_connections (pool t)) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_trigger.broadcast_too_many_connections (triggers t)
in
(log t)
Tezos_base__TzPervasives.P2p_connection.P2p_event.Too_many_connections
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_pipe.close messages in
P2p_conn.close conn)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter (fun f => f peer_id conn) (new_connection_hook t) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
OCaml.Stdlib.lt (P2p_pool.active_connections (pool t))
(min_connections (config t)) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_trigger.broadcast_too_few_connections (triggers t) in
(log t)
Tezos_base__TzPervasives.P2p_connection.P2p_event.Too_few_connections
else
tt in
conn.
Definition may_register_my_id_point {A B C : Type}
(pool : Tezos_p2p.P2p_pool.t A B C)
(function_parameter : list Tezos_base__TzPervasives.error) : unit :=
match function_parameter with
| cons (Tezos_base__TzPervasives.Myself (addr, Some port)) [] =>
P2p_pool.add_to_id_points pool (addr, port)
| _ => tt
end.
Definition raw_authenticate {A B C : Type}
(t : t A B C)
(point_info :
option (Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t A B C)))
(canceler : Tezos_stdlib.Lwt_canceler.t)
(fd : Tezos_p2p.P2p_io_scheduler.connection)
(point : Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult (Tezos_p2p.P2p_conn.t A B C)) :=
let incoming := equiv_decb point_info None in
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "authenticate: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"authenticate: %a%s" % string) P2p_point.Id.pp point
(if incoming then
" incoming" % string
else
"" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(protect
(Some
(fun err =>
op_gtgteq
match err with
| cons Tezos_base__TzPervasives.Canceled [] =>
lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"authenticate: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" -> canceled" % string
CamlinternalFormatBasics.End_of_format))))
"authenticate: %a%s -> canceled" % string) P2p_point.Id.pp
point
(if incoming then
" incoming" % string
else
"" % string)
| err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun function_parameter =>
match function_parameter with
|
Tezos_base__TzPervasives.Not_enough_proof_of_work _ |
Tezos_base__TzPervasives.Invalid_auth |
Tezos_base__TzPervasives.Decipher_error |
Tezos_base__TzPervasives.Invalid_message_size |
Tezos_base__TzPervasives.Encoding_error |
Tezos_base__TzPervasives.Decoding_error |
Tezos_base__TzPervasives.Invalid_chunks_size _ =>
P2p_pool.greylist_addr (pool t) (fst point)
| _ => tt
end) err in
lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"authenticate: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" -> failed" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string
1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"@[authenticate: %a%s -> failed@ %a@]" % string)
P2p_point.Id.pp point
(if incoming then
" incoming" % string
else
"" % string) pp_print_error err
end
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := may_register_my_id_point (pool t) err in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(log t)
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Authentication_failed
point) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if incoming then
P2p_point.Table.remove (incoming t) point
else
Option.iter
(P2p_point_state.set_disconnected None None
(greylisting_config (config t))) point_info in
Lwt.return_error err))) (Some canceler)
(fun function_parameter =>
let 'tt := function_parameter in
P2p_socket.authenticate canceler (proof_of_work_target (config t))
incoming fd point (listening_port (config t))
(identity (config t)) (announced_version t) (conn_meta_config t)))
(fun function_parameter =>
let '(info, auth_fd) := function_parameter in
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"authenticate: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" -> auth " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"authenticate: %a -> auth %a" % string) P2p_point.Id.pp point
P2p_peer.Id.pp (peer_id info))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_when (P2p_pool.Peers.banned (pool t) (peer_id info))
(Tezos_base__TzPervasives.Peer_banned (peer_id info)))
(fun function_parameter =>
let 'tt := function_parameter in
let remote_point_info :=
match id_point info with
| (addr, Some port) =>
P2p_pool.register_new_point None (pool t) (addr, port)
| _ => None
end in
let connection_point_info :=
match (point_info, remote_point_info) with
| (None, None) => None
| ((Some _) as point_info, _) | (_, (Some _) as point_info)
=> point_info
end in
let peer_info :=
P2p_pool.register_peer (pool t) (peer_id info) in
let acceptable_version :=
Network_version.select (chain_name (message_config t))
(distributed_db_versions (message_config t))
(custom_p2p_versions t) (announced_version info) in
let acceptable_point :=
Option.unopt_map
(fun connection_point_info =>
match P2p_point_state.get connection_point_info with
| Tezos_p2p.P2p_point_state.Requested _ => negb incoming
| Tezos_p2p.P2p_point_state.Disconnected =>
let unexpected :=
andb (private_mode (config t))
(negb
(P2p_point_state.Info.trusted
connection_point_info)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if unexpected then
warn
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"[private node] incoming connection from untrused peer rejected!"
% string
CamlinternalFormatBasics.End_of_format)
"[private node] incoming connection from untrused peer rejected!"
% string)
else
tt in
negb unexpected
|
Tezos_p2p.P2p_point_state.Accepted _ |
Tezos_p2p.P2p_point_state.Running _ => false
end) (negb (private_mode (config t)))
connection_point_info in
let acceptable_peer_id :=
match P2p_peer_state.get peer_info with
| Tezos_p2p.P2p_peer_state.Accepted _ => false
| Tezos_p2p.P2p_peer_state.Running _ => false
| Tezos_p2p.P2p_peer_state.Disconnected => true
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if incoming then
P2p_point.Table.remove (incoming t) point
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Option.iter
(fun point_info =>
P2p_point_state.set_private point_info
(private_node info)) connection_point_info in
match acceptable_version with
| Some version =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(log t)
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Accepting_request
point (id_point info) (peer_id info)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Option.iter
(fun point_info =>
P2p_point_state.set_accepted None point_info
(peer_id info) canceler) connection_point_info in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
P2p_peer_state.set_accepted None peer_info (id_point info)
canceler in
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"authenticate: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" -> accept " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"authenticate: %a -> accept %a" % string)
P2p_point.Id.pp point P2p_peer.Id.pp (peer_id info))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(protect
(Some
(fun err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if incoming then
(log t)
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Request_rejected
point
(Some ((id_point info), (peer_id info))))
else
tt in
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"authenticate: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" -> rejected " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"authenticate: %a -> rejected %a" % string)
P2p_point.Id.pp point P2p_peer.Id.pp
(peer_id info))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Option.iter
(P2p_point_state.set_disconnected None
None (greylisting_config (config t)))
connection_point_info in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
P2p_peer_state.set_disconnected None None
peer_info in
Lwt.return_error err))) (Some canceler)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(P2p_socket.accept
(incoming_message_queue_size (config t))
(outgoing_message_queue_size (config t))
(binary_chunks_size (config t)) canceler
auth_fd (encoding t))
(fun conn =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"authenticate: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" -> Connected " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"authenticate: %a -> Connected %a" %
string) P2p_point.Id.pp point
P2p_peer.Id.pp (peer_id info))
(fun function_parameter =>
let 'tt := function_parameter in
_return conn))))
(fun conn =>
let id_point :=
match
((id_point info),
(Option.map P2p_point_state.Info.point
point_info)) with
| ((addr, _), Some (_, port)) =>
(addr, (Some port))
| (id_point, None) => id_point
end in
_return
(create_connection t conn id_point
connection_point_info peer_info version)))
| _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(log t)
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Rejecting_request
point (id_point info) (peer_id info)) in
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"authenticate: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" -> kick " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" point: " % string
(CamlinternalFormatBasics.Bool
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" peer_id: " % string
(CamlinternalFormatBasics.Bool
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))))))
"authenticate: %a -> kick %a point: %B peer_id: %B" %
string) P2p_point.Id.pp point P2p_peer.Id.pp
(peer_id info) acceptable_point acceptable_peer_id)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.kick auth_fd)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if negb incoming then
Option.iter
(P2p_point_state.set_disconnected None None
(greylisting_config (config t))) point_info
else
tt in
match acceptable_version with
| None =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No common protocol" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
"(chains: local " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" - remote " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
"(db_versions: local [" %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"] - remote " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
"(p2p_versions: local ["
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"] - remote "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" %
char
CamlinternalFormatBasics.End_of_format)))))))))))))))))))
"No common protocol@.(chains: local %a - remote %a)@.(db_versions: local [%a] - remote %a)@.(p2p_versions: local [%a] - remote %a)"
% string) Distributed_db_version.pp_name
(chain_name (message_config t))
Distributed_db_version.pp_name
(chain_name (announced_version info))
(Format.pp_print_list None
Distributed_db_version.pp)
(distributed_db_versions (message_config t))
Distributed_db_version.pp
(distributed_db_version
(announced_version info))
(Format.pp_print_list None P2p_version.pp)
(custom_p2p_versions t) P2p_version.pp
(p2p_version (announced_version info)))
(fun function_parameter =>
let 'tt := function_parameter in
fail
(Tezos_base__TzPervasives.Rejected_no_common_protocol
{| announced := announced_version info |}))
| Some _ =>
fail
(Tezos_base__TzPervasives.Rejected
(peer_id info))
end))
end)))).
Definition authenticate {A B C : Type}
(t : t A B C)
(point_info :
option (Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t A B C)))
(canceler : Tezos_stdlib.Lwt_canceler.t) (fd : Tezos_p2p.P2p_fd.t)
(point : Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult (Tezos_p2p.P2p_conn.t A B C)) :=
let fd := P2p_io_scheduler.register (io_sched t) fd in
op_gtgteq (raw_authenticate t point_info canceler fd point)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok connection => _return connection
| (Stdlib.Error _) as err =>
op_gtgteqquestion (P2p_io_scheduler.close None fd)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return err)
end).
Definition accept {A B C : Type}
(t : t A B C) (fd : Tezos_p2p.P2p_fd.t) (point : Tezos_base.P2p_point.Id.t)
: unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(log t)
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Incoming_connection
point) in
let max_active_conns := Z.add (max_connections (config t)) (Random.int 2) in
if
orb
(OCaml.Stdlib.le (max_incoming_connections (config t))
(P2p_point.Table.length (incoming t)))
(orb
(OCaml.Stdlib.le max_active_conns (P2p_pool.active_connections (pool t)))
(P2p_pool.Points.banned (pool t) point)) then
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
P2p_fd.close fd)
else
let canceler := Lwt_canceler.create tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_point.Table.add (incoming t) point canceler in
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
with_timeout (Some canceler)
(Systime_os.sleep (authentication_timeout (config t)))
(fun canceler => authenticate t None canceler fd point)).
Definition fail_unless_disconnected_point {A : Type}
(point_info : Tezos_p2p.P2p_point_state.Info.t A)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match P2p_point_state.get point_info with
| Tezos_p2p.P2p_point_state.Disconnected => return_unit
| Tezos_p2p.P2p_point_state.Requested _ | Tezos_p2p.P2p_point_state.Accepted _
=> fail Tezos_base__TzPervasives.Pending_connection
| Tezos_p2p.P2p_point_state.Running _ =>
fail Tezos_base__TzPervasives.Connected
end.
Definition connect {A B C : Type}
(timeout : option Tezos_base__TzPervasives.Time.System.Span.t) (t : t A B C)
(point : Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult (Tezos_p2p.P2p_conn.t A B C)) :=
op_gtgteqquestion
(fail_when (P2p_pool.Points.banned (pool t) point)
(Tezos_base__TzPervasives.Point_banned point))
(fun function_parameter =>
let 'tt := function_parameter in
let timeout := Option.unopt (connection_timeout (config t)) timeout in
op_gtgteqquestion
(fail_unless
(OCaml.Stdlib.le (P2p_pool.active_connections (pool t))
(max_connections (config t)))
Tezos_base__TzPervasives.Too_many_connections)
(fun function_parameter =>
let 'tt := function_parameter in
let canceler := Lwt_canceler.create tt in
with_timeout (Some canceler) (Systime_os.sleep timeout)
(fun canceler =>
let point_info := P2p_pool.register_point None (pool t) point in
let '(addr, port) as point :=
P2p_point_state.Info.point point_info in
op_gtgteqquestion
(fail_unless
(orb (negb (private_mode (config t)))
(P2p_point_state.Info.trusted point_info))
Tezos_base__TzPervasives.Private_mode)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (fail_unless_disconnected_point point_info)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
P2p_point_state.set_requested None point_info canceler
in
let fd :=
P2p_fd.socket Lwt_unix.PF_INET6 Lwt_unix.SOCK_STREAM 0
in
let uaddr :=
Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr)
port in
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"connect: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"connect: %a" % string) P2p_point.Id.pp point)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(protect
(Some
(fun err =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"connect: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" -> disconnect" % string
CamlinternalFormatBasics.End_of_format)))
"connect: %a -> disconnect" % string)
P2p_point.Id.pp point)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
P2p_point_state.set_disconnected None
None (greylisting_config (config t))
point_info in
op_gtgteq (P2p_fd.close fd)
(fun function_parameter =>
let 'tt := function_parameter in
match err with
|
cons
(Tezos_base__TzPervasives.Exn
(Unix_error Unix.ECONNREFUSED _
_)) [] =>
fail
Tezos_base__TzPervasives.Connection_refused
| err => Lwt.return_error err
end)))) (Some canceler)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(log t)
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Outgoing_connection
point) in
op_gtgteq (P2p_fd.connect fd uaddr)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"connect: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" -> authenticate" % string
CamlinternalFormatBasics.End_of_format)))
"connect: %a -> authenticate" % string)
P2p_point.Id.pp point)
(fun function_parameter =>
let 'tt := function_parameter in
authenticate t (Some point_info) canceler fd
point)))))))).
Definition stat {A B C : Type} (t : t A B C)
: Tezos_base__TzPervasives.P2p_stat.t :=
P2p_io_scheduler.global_stat (io_sched t).
Definition on_new_connection {A B C : Type}
(t : t A B C)
(f :
Tezos_base__TzPervasives.P2p_peer.Id.t ->
(Tezos_p2p.P2p_conn.t A B C) -> unit) : unit :=
(* ❌ Set record field not handled. *)
set_record_field t "new_connection_hook" % string
(cons f (new_connection_hook t)).
Definition destroy {A B C : Type} (t : t A B C) : Lwt.t unit :=
P2p_point.Table.fold
(fun _point =>
fun canceler =>
fun acc =>
op_gtgteq (Lwt_canceler.cancel canceler)
(fun function_parameter =>
let 'tt := function_parameter in
acc)) (incoming t) Lwt.return_unit.
src/lib_p2p/p2p_discovery.ml 20 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make (struct
let name = "p2p.discovery"
end)
type pool = Pool : ('msg, 'meta, 'meta_conn) P2p_pool.t -> pool
module Message = struct
let encoding =
Data_encoding.(tup3 (Fixed.string 10) P2p_peer.Id.encoding int16)
let length = Data_encoding.Binary.fixed_length_exn encoding
let key = "DISCOMAGIC"
let make peer_id port =
Data_encoding.Binary.to_bytes_exn encoding (key, peer_id, port)
end
module Answer = struct
type t = {
my_peer_id : P2p_peer.Id.t;
pool : pool;
discovery_port : int;
canceler : Lwt_canceler.t;
trust_discovered_peers : bool;
mutable worker : unit Lwt.t;
}
let create_socket st =
Lwt.catch
(fun () ->
let socket = Lwt_unix.socket PF_INET SOCK_DGRAM 0 in
Lwt_canceler.on_cancel st.canceler (fun () ->
Lwt_utils_unix.safe_close socket) ;
Lwt_unix.setsockopt socket SO_BROADCAST true ;
Lwt_unix.setsockopt socket SO_REUSEADDR true ;
let addr =
Lwt_unix.ADDR_INET (Unix.inet_addr_any, st.discovery_port)
in
Lwt_unix.bind socket addr >>= fun () -> Lwt.return socket)
(fun exn ->
lwt_debug "Error creating a socket" >>= fun () -> Lwt.fail exn)
let loop st =
protect ~canceler:st.canceler (fun () ->
create_socket st >>= fun socket -> return socket)
>>=? fun socket ->
(* Infinite loop, should never exit. *)
let rec aux () =
let buf = Bytes.create Message.length in
protect ~canceler:st.canceler (fun () ->
Lwt_unix.recvfrom socket buf 0 Message.length []
>>= fun content ->
lwt_debug "Received discovery message..."
>>= fun () -> return content)
>>=? function
| (len, Lwt_unix.ADDR_INET (remote_addr, _))
when Compare.Int.equal len Message.length -> (
match Data_encoding.Binary.of_bytes Message.encoding buf with
| Some (key, remote_peer_id, remote_port)
when Compare.String.equal key Message.key
&& not (P2p_peer.Id.equal remote_peer_id st.my_peer_id) -> (
let s_addr = Unix.string_of_inet_addr remote_addr in
match P2p_addr.of_string_opt s_addr with
| None ->
lwt_debug "Failed to parse %S\n@." s_addr >>= fun () -> aux ()
| Some addr ->
let (Pool pool) = st.pool in
lwt_log_info
"Registering new point %a:%d"
P2p_addr.pp
addr
remote_port
>>= fun () ->
P2p_pool.register_new_point
~trusted:st.trust_discovered_peers
pool
(addr, remote_port)
|> ignore ;
aux () )
| _ ->
aux () )
| _ ->
aux ()
in
aux ()
let worker_loop st =
loop st
>>= function
| Error (Canceled :: _) ->
Lwt.return_unit
| Error err ->
lwt_log_error
"@[<v 2>Unexpected error in answer worker@ %a@]"
pp_print_error
err
>>= fun () -> Lwt_canceler.cancel st.canceler
| Ok () ->
lwt_log_error "@[<v 2>Unexpected exit in answer worker@]"
>>= fun () -> Lwt_canceler.cancel st.canceler
let create my_peer_id pool ~trust_discovered_peers ~discovery_port =
{
canceler = Lwt_canceler.create ();
my_peer_id;
discovery_port;
trust_discovered_peers;
pool = Pool pool;
worker = Lwt.return_unit;
}
let activate st =
st.worker <-
Lwt_utils.worker
"discovery_answer"
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> worker_loop st)
~cancel:(fun () -> Lwt_canceler.cancel st.canceler)
end
(* ************************************************************ *)
(* Sender *)
module Sender = struct
type t = {
canceler : Lwt_canceler.t;
my_peer_id : P2p_peer.Id.t;
listening_port : int;
discovery_port : int;
discovery_addr : Ipaddr.V4.t;
pool : pool;
restart_discovery : unit Lwt_condition.t;
mutable worker : unit Lwt.t;
}
module Config = struct
type t = {delay : float; loop : int}
let initial = {delay = 0.1; loop = 0}
let increase_delay config = {config with delay = 2.0 *. config.delay}
let max_loop = 10
end
let broadcast_message st =
let msg = Message.make st.my_peer_id st.listening_port in
Lwt.catch
(fun () ->
let socket = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in
Lwt_canceler.on_cancel st.canceler (fun () ->
Lwt_utils_unix.safe_close socket) ;
Lwt_unix.setsockopt socket Lwt_unix.SO_BROADCAST true ;
let broadcast_ipv4 = Ipaddr_unix.V4.to_inet_addr st.discovery_addr in
let addr = Lwt_unix.ADDR_INET (broadcast_ipv4, st.discovery_port) in
Lwt_unix.connect socket addr
>>= fun () ->
lwt_debug "Broadcasting discovery message..."
>>= fun () ->
Lwt_unix.sendto socket msg 0 Message.length [] addr
>>= fun _len -> Lwt_utils_unix.safe_close socket)
(fun _exn -> lwt_debug "Error broadcasting a discovery request")
let rec worker_loop sender_config st =
protect ~canceler:st.canceler (fun () ->
broadcast_message st >>= fun () -> return_unit)
>>=? (fun () ->
protect ~canceler:st.canceler (fun () ->
Lwt.pick
[ ( Lwt_condition.wait st.restart_discovery
>>= fun () -> return Config.initial );
( Lwt_unix.sleep sender_config.Config.delay
>>= fun () ->
return
{sender_config with Config.loop = succ sender_config.loop}
) ]))
>>= function
| Ok config when config.Config.loop = Config.max_loop ->
let new_sender_config = {config with Config.loop = pred config.loop} in
worker_loop new_sender_config st
| Ok config ->
let new_sender_config = Config.increase_delay config in
worker_loop new_sender_config st
| Error (Canceled :: _) ->
Lwt.return_unit
| Error err ->
lwt_log_error
"@[<v 2>Unexpected error in sender worker@ %a@]"
pp_print_error
err
>>= fun () -> Lwt_canceler.cancel st.canceler
let create my_peer_id pool ~listening_port ~discovery_port ~discovery_addr =
{
canceler = Lwt_canceler.create ();
my_peer_id;
listening_port;
discovery_port;
discovery_addr;
restart_discovery = Lwt_condition.create ();
pool = Pool pool;
worker = Lwt.return_unit;
}
let activate st =
st.worker <-
Lwt_utils.worker
"discovery_sender"
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> worker_loop Config.initial st)
~cancel:(fun () -> Lwt_canceler.cancel st.canceler)
end
(* ********************************************************************** *)
type t = {answer : Answer.t; sender : Sender.t}
let create ~listening_port ~discovery_port ~discovery_addr
~trust_discovered_peers pool my_peer_id =
let answer =
Answer.create my_peer_id pool ~discovery_port ~trust_discovered_peers
in
let sender =
Sender.create
my_peer_id
pool
~listening_port
~discovery_port
~discovery_addr
in
{answer; sender}
let activate {answer; sender} = Answer.activate answer ; Sender.activate sender
let wakeup t = Lwt_condition.signal t.sender.restart_discovery ()
let shutdown t =
Lwt.join
[ Lwt_canceler.cancel t.answer.canceler;
Lwt_canceler.cancel t.sender.canceler ]
src/lib_p2p/p2p_discovery.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Inductive pool : Type :=
| Pool : forall {meta meta_conn msg : Type},
(Tezos_p2p.P2p_pool.t msg meta meta_conn) -> pool.
Module Message.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
(string * Tezos_base__TzPervasives.P2p_peer.Id.t * Z) :=
tup3 (Fixed.string 10) P2p_peer.Id.encoding int16.
Definition length : Z := Data_encoding.Binary.fixed_length_exn encoding.
Definition key : string := "DISCOMAGIC" % string.
Definition make (peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t) (port : Z)
: Stdlib.Bytes.t :=
Data_encoding.Binary.to_bytes_exn encoding (key, peer_id, port).
End Message.
Module Answer.
Record t := {
my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
pool : pool;
discovery_port : Z;
canceler : Tezos_stdlib.Lwt_canceler.t;
trust_discovered_peers : bool;
worker : Lwt.t unit }.
Definition create_socket (st : t) : Lwt.t Lwt_unix.file_descr :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
let socket := Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_DGRAM 0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_canceler.on_cancel (canceler st)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.safe_close socket) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_unix.setsockopt socket Lwt_unix.SO_BROADCAST true in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_unix.setsockopt socket Lwt_unix.SO_REUSEADDR true in
let addr := Lwt_unix.ADDR_INET Unix.inet_addr_any (discovery_port st) in
op_gtgteq (Lwt_unix.bind socket addr)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return socket))
(fun exn =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error creating a socket" % string
CamlinternalFormatBasics.End_of_format)
"Error creating a socket" % string))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.fail exn)).
Definition loop {A : Type} (st : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
op_gtgteqquestion
(protect None (Some (canceler st))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (create_socket st) (fun socket => _return socket)))
(fun socket =>
let fix aux {B : Type} (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
let 'tt := function_parameter in
let buf := Stdlib.Bytes.create Message.length in
op_gtgteqquestion
(protect None (Some (canceler st))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_unix.recvfrom socket buf 0 Message.length [])
(fun content =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Received discovery message..." % string
CamlinternalFormatBasics.End_of_format)
"Received discovery message..." % string))
(fun function_parameter =>
let 'tt := function_parameter in
_return content))))
(fun function_parameter =>
match function_parameter with
| (len, Lwt_unix.ADDR_INET remote_addr _) =>
match Data_encoding.Binary.of_bytes Message.encoding buf with
| Some (key, remote_peer_id, remote_port) =>
let s_addr := Unix.string_of_inet_addr remote_addr in
match P2p_addr.of_string_opt s_addr with
| None =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to parse " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Failed to parse %S
@." % string) s_addr)
(fun function_parameter =>
let 'tt := function_parameter in
aux tt)
| Some addr =>
let 'Pool pool := pool st in
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Registering new point " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))))
"Registering new point %a:%d" % string) P2p_addr.pp
addr remote_port)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.reverse_apply
(P2p_pool.register_new_point
(Some (trust_discovered_peers st)) pool
(addr, remote_port)) OCaml.Stdlib.ignore in
aux tt)
end
| _ => aux tt
end
| _ => aux tt
end) in
aux tt).
Definition worker_loop (st : t) : Lwt.t unit :=
op_gtgteq (loop st)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) =>
Lwt.return_unit
| Stdlib.Error err =>
op_gtgteq
(lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Unexpected error in answer worker" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>Unexpected error in answer worker@ %a@]" % string)
pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler st))
| Stdlib.Ok tt =>
op_gtgteq
(lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Unexpected exit in answer worker" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))
"@[<v 2>Unexpected exit in answer worker@]" % string))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler st))
end).
Definition create {A B C : Type}
(my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
(pool : Tezos_p2p.P2p_pool.t A B C) (trust_discovered_peers : bool)
(discovery_port : Z) : t :=
{| my_peer_id := my_peer_id; pool := Pool pool;
discovery_port := discovery_port; canceler := Lwt_canceler.create tt;
trust_discovered_peers := trust_discovered_peers;
worker := Lwt.return_unit |}.
Definition activate (st : t) : unit :=
(* ❌ Set record field not handled. *)
set_record_field st "worker" % string
(Lwt_utils.worker "discovery_answer" % string
Internal_event.Lwt_worker_event.on_event
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop st)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler st))).
End Answer.
Module Sender.
Record t := {
canceler : Tezos_stdlib.Lwt_canceler.t;
my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
listening_port : Z;
discovery_port : Z;
discovery_addr : Ipaddr.V4.t;
pool : pool;
restart_discovery : Lwt_condition.t unit;
worker : Lwt.t unit }.
Module Config.
Record t := {
delay : Z;
loop : Z }.
Definition initial : t :=
{|
delay :=
(* ❌ Float constant 0.1 is approximated by the integer 0 *)
0; loop := 0 |}.
Definition increase_delay (config : t) : t :=
(* ❌ Record substitution not handled *)
record_substitution.
Definition max_loop : Z := 10.
End Config.
Definition broadcast_message (st : t) : Lwt.t unit :=
let msg := Message.make (my_peer_id st) (listening_port st) in
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
let socket := socket Lwt_unix.PF_INET Lwt_unix.SOCK_DGRAM 0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_canceler.on_cancel (canceler st)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.safe_close socket) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_unix.setsockopt socket Lwt_unix.SO_BROADCAST true in
let broadcast_ipv4 := Ipaddr_unix.V4.to_inet_addr (discovery_addr st) in
let addr := Lwt_unix.ADDR_INET broadcast_ipv4 (discovery_port st) in
op_gtgteq (Lwt_unix.connect socket addr)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Broadcasting discovery message..." % string
CamlinternalFormatBasics.End_of_format)
"Broadcasting discovery message..." % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_unix.sendto socket msg 0 Message.length [] addr)
(fun _len => Lwt_utils_unix.safe_close socket))))
(fun _exn =>
lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error broadcasting a discovery request" % string
CamlinternalFormatBasics.End_of_format)
"Error broadcasting a discovery request" % string)).
Fixpoint worker_loop (sender_config : Config.t) (st : t) : Lwt.t unit :=
op_gtgteq
(op_gtgteqquestion
(protect None (Some (canceler st))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (broadcast_message st)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(fun function_parameter =>
let 'tt := function_parameter in
protect None (Some (canceler st))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.pick
(cons
(op_gtgteq (Lwt_condition.wait None (restart_discovery st))
(fun function_parameter =>
let 'tt := function_parameter in
_return Config.initial))
(cons
(op_gtgteq (Lwt_unix.sleep (Config.delay sender_config))
(fun function_parameter =>
let 'tt := function_parameter in
_return
(* ❌ Record substitution not handled *)
record_substitution)) [])))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok config =>
let new_sender_config :=
(* ❌ Record substitution not handled *)
record_substitution in
worker_loop new_sender_config st
| Stdlib.Ok config =>
let new_sender_config := Config.increase_delay config in
worker_loop new_sender_config st
| Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) =>
Lwt.return_unit
| Stdlib.Error err =>
op_gtgteq
(lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Unexpected error in sender worker" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>Unexpected error in sender worker@ %a@]" % string)
pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler st))
end).
Definition create {A B C : Type}
(my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
(pool : Tezos_p2p.P2p_pool.t A B C) (listening_port : Z)
(discovery_port : Z) (discovery_addr : Ipaddr.V4.t) : t :=
{| canceler := Lwt_canceler.create tt; my_peer_id := my_peer_id;
listening_port := listening_port; discovery_port := discovery_port;
discovery_addr := discovery_addr; pool := Pool pool;
restart_discovery := Lwt_condition.create tt; worker := Lwt.return_unit |}.
Definition activate (st : t) : unit :=
(* ❌ Set record field not handled. *)
set_record_field st "worker" % string
(Lwt_utils.worker "discovery_sender" % string
Internal_event.Lwt_worker_event.on_event
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop Config.initial st)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler st))).
End Sender.
Record t := {
answer : Answer.t;
sender : Sender.t }.
Definition create {A B C : Type}
(listening_port : Z) (discovery_port : Z) (discovery_addr : Ipaddr.V4.t)
(trust_discovered_peers : bool) (pool : Tezos_p2p.P2p_pool.t A B C)
(my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t) : t :=
let answer :=
Answer.create my_peer_id pool trust_discovered_peers discovery_port in
let sender :=
Sender.create my_peer_id pool listening_port discovery_port discovery_addr
in
{| answer := answer; sender := sender |}.
Definition activate (function_parameter : t) : unit :=
let '{| answer := answer; sender := sender |} := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Answer.activate answer in
Sender.activate sender.
Definition wakeup (t : t) : unit :=
Lwt_condition.signal (restart_discovery (sender t)) tt.
Definition shutdown (t : t) : Lwt.t unit :=
Lwt.join
(cons (Lwt_canceler.cancel (canceler (answer t)))
(cons (Lwt_canceler.cancel (canceler (sender t))) [])).
src/lib_p2p/p2p_errors.ml 22 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(************************ p2p io scheduler ********************************)
type error += Connection_closed
let () =
(* Connection closed *)
register_error_kind
`Permanent
~id:"node.p2p_io_scheduler.connection_closed"
~title:"Connection closed"
~description:"IO error: connection with a peer is closed."
~pp:(fun ppf () ->
Format.fprintf ppf "IO error: connection with a peer is closed.")
Data_encoding.empty
(function Connection_closed -> Some () | _ -> None)
(fun () -> Connection_closed)
(***************************** p2p socket *********************************)
type error += Decipher_error
type error += Invalid_message_size
type error += Encoding_error
type error += Rejected_socket_connection
type error += Rejected_no_common_protocol of {announced : Network_version.t}
type error += Decoding_error
type error += Myself of P2p_connection.Id.t
type error += Not_enough_proof_of_work of P2p_peer.Id.t
type error += Invalid_auth
type error += Invalid_chunks_size of {value : int; min : int; max : int}
let () =
(* Decipher error *)
register_error_kind
`Permanent
~id:"node.p2p_socket.decipher_error"
~title:"Decipher error"
~description:"An error occurred while deciphering."
~pp:(fun ppf () ->
Format.fprintf ppf "An error occurred while deciphering.")
Data_encoding.empty
(function Decipher_error -> Some () | _ -> None)
(fun () -> Decipher_error) ;
(* Invalid message size *)
register_error_kind
`Permanent
~id:"node.p2p_socket.invalid_message_size"
~title:"Invalid message size"
~description:"The size of the message to be written is invalid."
~pp:(fun ppf () ->
Format.fprintf ppf "The size of the message to be written is invalid.")
Data_encoding.empty
(function Invalid_message_size -> Some () | _ -> None)
(fun () -> Invalid_message_size) ;
(* Encoding error *)
register_error_kind
`Permanent
~id:"node.p2p_socket.encoding_error"
~title:"Encoding error"
~description:"An error occurred while encoding."
~pp:(fun ppf () -> Format.fprintf ppf "An error occurred while encoding.")
Data_encoding.empty
(function Encoding_error -> Some () | _ -> None)
(fun () -> Encoding_error) ;
(* Rejected socket connection *)
register_error_kind
`Permanent
~id:"node.p2p_socket.rejected_socket_connection"
~title:"Rejected socket connection"
~description:"Rejected peer connection: rejected socket connection."
~pp:(fun ppf () ->
Format.fprintf
ppf
"Rejected peer connection: rejected socket connection.")
Data_encoding.empty
(function Rejected_socket_connection -> Some () | _ -> None)
(fun () -> Rejected_socket_connection) ;
(* Rejected socket connection, no common network protocol *)
register_error_kind
`Permanent
~id:"node.p2p_socket.rejected_no_common_protocol"
~title:"Rejected socket connection - no common network protocol"
~description:
"Rejected peer connection: rejected socket connection as we have no \
common network protocol with the peer."
~pp:(fun ppf _lst ->
Format.fprintf
ppf
"Rejected peer connection: no common network protocol.")
Data_encoding.(obj1 (req "announced_version" Network_version.encoding))
(function
| Rejected_no_common_protocol {announced} -> Some announced | _ -> None)
(fun announced -> Rejected_no_common_protocol {announced}) ;
(* Decoding error *)
register_error_kind
`Permanent
~id:"node.p2p_socket.decoding_error"
~title:"Decoding error"
~description:"An error occurred while decoding."
~pp:(fun ppf () -> Format.fprintf ppf "An error occurred while decoding.")
Data_encoding.empty
(function Decoding_error -> Some () | _ -> None)
(fun () -> Decoding_error) ;
(* Myself *)
register_error_kind
`Permanent
~id:"node.p2p_socket.myself"
~title:"Myself"
~description:"Remote peer is actually yourself."
~pp:(fun ppf id ->
Format.fprintf
ppf
"Remote peer %a cannot be authenticated: peer is actually yourself."
P2p_connection.Id.pp
id)
Data_encoding.(obj1 (req "connection id" P2p_connection.Id.encoding))
(function Myself id -> Some id | _ -> None)
(fun id -> Myself id) ;
(* Not enough proof of work *)
register_error_kind
`Permanent
~id:"node.p2p_socket.not_enough_proof_of_work"
~title:"Not enough proof of work"
~description:
"Remote peer cannot be authenticated: not enough proof of work."
~pp:(fun ppf id ->
Format.fprintf
ppf
"Remote peer %a cannot be authenticated: not enough proof of work."
P2p_peer.Id.pp
id)
Data_encoding.(obj1 (req "peer id" P2p_peer.Id.encoding))
(function Not_enough_proof_of_work id -> Some id | _ -> None)
(fun id -> Not_enough_proof_of_work id) ;
(* Invalid authentication *)
register_error_kind
`Permanent
~id:"node.p2p_socket.invalid_auth"
~title:"Invalid authentication"
~description:"Rejected peer connection: invalid authentication."
~pp:(fun ppf () ->
Format.fprintf ppf "Rejected peer connection: invalid authentication.")
Data_encoding.empty
(function Invalid_auth -> Some () | _ -> None)
(fun () -> Invalid_auth) ;
(* Invalid chunks size *)
register_error_kind
`Permanent
~id:"node.p2p_socket.invalid_chunks_size"
~title:"Invalid chunks size"
~description:"Size of chunks is not valid."
~pp:(fun ppf (value, min, max) ->
Format.fprintf
ppf
"Size of chunks is invalid: should be between %d and %d but is %d"
min
max
value)
Data_encoding.(
obj3 (req "value" int31) (req "min" int31) (req "max" int31))
(function
| Invalid_chunks_size {value; min; max} ->
Some (value, min, max)
| _ ->
None)
(fun (value, min, max) -> Invalid_chunks_size {value; min; max})
(***************************** p2p pool ***********************************)
type error += Pending_connection
type error += Connected
type error += Connection_refused
type error += Rejected of P2p_peer.Id.t
type error += Too_many_connections
type error += Private_mode
type error += Point_banned of P2p_point.Id.t
type error += Peer_banned of P2p_peer.Id.t
let () =
(* Pending connection *)
register_error_kind
`Permanent
~id:"node.p2p_pool.pending_connection"
~title:"Pending connection"
~description:
"Fail to connect with a peer: a connection is already pending."
~pp:(fun ppf () ->
Format.fprintf
ppf
"Fail to connect with a peer: a connection is already pending.")
Data_encoding.empty
(function Pending_connection -> Some () | _ -> None)
(fun () -> Pending_connection) ;
(* Connected *)
register_error_kind
`Permanent
~id:"node.p2p_pool.connected"
~title:"Connected"
~description:
"Fail to connect with a peer: a connection is already established."
~pp:(fun ppf () ->
Format.fprintf
ppf
"Fail to connect with a peer: a connection is already established.")
Data_encoding.empty
(function Connected -> Some () | _ -> None)
(fun () -> Connected) ;
(* Connected refused *)
register_error_kind
`Permanent
~id:"node.p2p_pool.connection_refused"
~title:"Connection refused"
~description:"Connection was refused."
~pp:(fun ppf () -> Format.fprintf ppf "Connection was refused.")
Data_encoding.empty
(function Connection_refused -> Some () | _ -> None)
(fun () -> Connection_refused) ;
(* Rejected *)
register_error_kind
`Permanent
~id:"node.p2p_pool.rejected"
~title:"Rejected peer"
~description:"Connection to peer was rejected."
~pp:(fun ppf id ->
Format.fprintf
ppf
"Connection to peer %a was rejected."
P2p_peer.Id.pp
id)
Data_encoding.(obj1 (req "peer id" P2p_peer.Id.encoding))
(function Rejected id -> Some id | _ -> None)
(fun id -> Rejected id) ;
(* Too many connections *)
register_error_kind
`Permanent
~id:"node.p2p_pool.too_many_connections"
~title:"Too many connections"
~description:"Too many connections."
~pp:(fun ppf () -> Format.fprintf ppf "Too many connections.")
Data_encoding.empty
(function Too_many_connections -> Some () | _ -> None)
(fun () -> Too_many_connections) ;
(* Private mode *)
register_error_kind
`Permanent
~id:"node.p2p_pool.private_mode"
~title:"Private mode"
~description:"Node is in private mode."
~pp:(fun ppf () -> Format.fprintf ppf "Node is in private mode.")
Data_encoding.empty
(function Private_mode -> Some () | _ -> None)
(fun () -> Private_mode) ;
(* Point Banned *)
register_error_kind
`Permanent
~id:"node.p2p_pool.point_banned"
~title:"Point Banned"
~description:"The address you tried to connect is banned."
~pp:(fun ppf (addr, _port) ->
Format.fprintf
ppf
"The address you tried to connect (%a) is banned."
P2p_addr.pp
addr)
Data_encoding.(obj1 (req "point" P2p_point.Id.encoding))
(function Point_banned point -> Some point | _ -> None)
(fun point -> Point_banned point) ;
(* Peer Banned *)
register_error_kind
`Permanent
~id:"node.p2p_pool.peer_banned"
~title:"Peer Banned"
~description:"The peer identity you tried to connect is banned."
~pp:(fun ppf peer_id ->
Format.fprintf
ppf
"The peer identity you tried to connect (%a) is banned."
P2p_peer.Id.pp
peer_id)
Data_encoding.(obj1 (req "peer" P2p_peer.Id.encoding))
(function Peer_banned peer_id -> Some peer_id | _ -> None)
(fun peer_id -> Peer_banned peer_id)
src/lib_p2p/p2p_errors.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension (* ❌ Structure item `typext` not handled. *) type_extension
src/lib_p2p/p2p_fd.ml 16 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* logging facility to monitor sockets *)
let is_not_windows = Sys.os_type <> "Win32"
let () =
(* Otherwise some writes trigger a SIGPIPE instead of raising an
Lwt_unit exception. In the node, this is already done by
Cohttp, so this is only useful when using the P2P layer as a
stand alone library. *)
if is_not_windows then Sys.(set_signal sigpipe Signal_ignore)
(* Logging facility for the P2P layer *)
module Log = Internal_event.Legacy_logging.Make (struct
let name = "p2p.fd"
end)
type t = {
fd : Lwt_unix.file_descr;
id : int;
mutable nread : int;
mutable nwrit : int;
}
(* we use a prefix ' cnx:' that allows easy grepping in the log to lookup
everything related to a particular connection. *)
let log t fmt = Format.kasprintf (fun s -> Log.debug "cnx:%d:%s" t.id s) fmt
let create =
let counter = ref 0 in
function
| fd ->
incr counter ;
let t = {fd; id = !counter; nread = 0; nwrit = 0} in
log t "create: fd %d" t.id ; t
let string_of_sockaddr addr =
match addr with
| Lwt_unix.ADDR_INET (ip, port) ->
Printf.sprintf "%s:%d" (Unix.string_of_inet_addr ip) port
| Lwt_unix.ADDR_UNIX file ->
Printf.sprintf "@%s" file
let id t = t.id
let socket proto kind arg = create (Lwt_unix.socket proto kind arg)
let close t =
log t "close: stats %d/%d" t.nread t.nwrit ;
Lwt_utils_unix.safe_close t.fd
let read t buf pos len =
log t "try-read: %d" len ;
Lwt_unix.read t.fd buf pos len
>>= fun nread ->
t.nread <- t.nread + nread ;
log t "read: %d (%d)" nread t.nread ;
Lwt.return nread
let write t buf =
let len = Bytes.length buf in
log t "try-write: %d" len ;
Lwt_utils_unix.write_mbytes t.fd buf
>>= fun () ->
t.nwrit <- t.nwrit + len ;
log t "written: %d (%d)" len t.nwrit ;
Lwt.return_unit
let connect t saddr =
log t "connect: %s" (string_of_sockaddr saddr) ;
Lwt_unix.connect t.fd saddr
let accept sock =
Lwt_unix.accept sock
>>= fun (fd, saddr) ->
let t = create fd in
log t "accept: %s" (string_of_sockaddr saddr) ;
Lwt.return (t, saddr)
module Table = Hashtbl.Make (struct
type nonrec t = t
let equal {id = x; _} {id = y; _} = x = y
let hash {id; _} = Hashtbl.hash id
end)
src/lib_p2p/p2p_fd.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition is_not_windows : bool := nequiv_decb Sys.os_type "Win32" % string.
(* ❌ Applications of functors are not handled. *)
functor_application
Record t := {
fd : Lwt_unix.file_descr;
id : Z;
nread : Z;
nwrit : Z }.
Definition log {A : Type}
(t : t) (fmt : Stdlib.format4 A Stdlib.Format.formatter unit unit) : A :=
Format.kasprintf
(fun s =>
Log.debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "cnx:" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"cnx:%d:%s" % string) (id t) s) fmt.
Definition create : Lwt_unix.file_descr -> t :=
let counter := Stdlib.ref 0 in
fun fd =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.incr counter in
let t :=
{| fd := fd; id := Stdlib.op_exclamation counter; nread := 0; nwrit := 0
|} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log t
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "create: fd " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "create: fd %d" % string)
(id t) in
t.
Definition string_of_sockaddr (addr : Lwt_unix.sockaddr) : string :=
match addr with
| Lwt_unix.ADDR_INET ip port =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))) "%s:%d" % string)
(Unix.string_of_inet_addr ip) port
| Lwt_unix.ADDR_UNIX file =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "@" % char
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "@%s" % string) file
end.
Definition id (t : t) : Z := id t.
Definition socket
(proto : Lwt_unix.socket_domain) (kind : Lwt_unix.socket_type) (arg : Z)
: t := create (Lwt_unix.socket proto kind arg).
Definition close (t : t) : Lwt.t unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log t
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "close: stats " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal "/" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))))
"close: stats %d/%d" % string) (nread t) (nwrit t) in
Lwt_utils_unix.safe_close (fd t).
Definition read (t : t) (buf : string) (pos : Z) (len : Z) : Lwt.t Z :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log t
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "try-read: " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "try-read: %d" % string)
len in
op_gtgteq (Lwt_unix.read (fd t) buf pos len)
(fun nread =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field t "nread" % string (Z.add (nread t) nread) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log t
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "read: " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"read: %d (%d)" % string) nread (nread t) in
Lwt._return nread).
Definition write (t : t) (buf : Stdlib.Bytes.t) : Lwt.t unit :=
let len := String.length buf in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log t
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "try-write: " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "try-write: %d" % string)
len in
op_gtgteq (Lwt_utils_unix.write_mbytes None None (fd t) buf)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field t "nwrit" % string (Z.add (nwrit t) len) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log t
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "written: " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"written: %d (%d)" % string) len (nwrit t) in
Lwt.return_unit).
Definition connect (t : t) (saddr : Lwt_unix.sockaddr) : Lwt.t unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log t
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "connect: " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "connect: %s" % string)
(string_of_sockaddr saddr) in
Lwt_unix.connect (fd t) saddr.
Definition accept (sock : Lwt_unix.file_descr)
: Lwt.t (t * Lwt_unix.sockaddr) :=
op_gtgteq (Lwt_unix.accept sock)
(fun function_parameter =>
let '(fd, saddr) := function_parameter in
let t := create fd in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log t
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "accept: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "accept: %s" % string)
(string_of_sockaddr saddr) in
Lwt._return (t, saddr)).
(* ❌ Applications of functors are not handled. *)
functor_application
src/lib_p2p/p2p_io_scheduler.ml 58 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* TODO decide whether we need to preallocate buffers or not. *)
include Internal_event.Legacy_logging.Make (struct
let name = "p2p.io-scheduler"
end)
let alpha = 0.2
module type IO = sig
val name : string
type in_param
val pop : in_param -> Bytes.t tzresult Lwt.t
type out_param
val push : out_param -> Bytes.t -> unit tzresult Lwt.t
val close : out_param -> error list -> unit Lwt.t
end
module Scheduler (IO : IO) = struct
[@@@ocaml.warning "-30"]
type t = {
canceler : Lwt_canceler.t;
mutable worker : unit Lwt.t;
counter : Moving_average.t;
max_speed : int option;
mutable quota : int;
quota_updated : unit Lwt_condition.t;
readys : unit Lwt_condition.t;
readys_high : (connection * Bytes.t tzresult) Queue.t;
readys_low : (connection * Bytes.t tzresult) Queue.t;
}
and connection = {
id : int;
mutable closed : bool;
canceler : Lwt_canceler.t;
in_param : IO.in_param;
out_param : IO.out_param;
mutable current_pop : Bytes.t tzresult Lwt.t;
mutable current_push : unit tzresult Lwt.t;
counter : Moving_average.t;
mutable quota : int;
mutable last_quota : int;
}
let cancel (conn : connection) err =
Lwt_utils.unless conn.closed (fun () ->
lwt_debug "Connection closed (%d, %s) " conn.id IO.name
>>= fun () ->
conn.closed <- true ;
Lwt.catch
(fun () -> IO.close conn.out_param err)
(fun _ -> Lwt.return_unit)
>>= fun () -> Lwt_canceler.cancel conn.canceler)
let waiter st conn =
assert (Lwt.state conn.current_pop <> Sleep) ;
conn.current_pop <- IO.pop conn.in_param ;
Lwt.async (fun () ->
conn.current_pop
>>= fun res ->
conn.current_push
>>= fun _ ->
let was_empty =
Queue.is_empty st.readys_high && Queue.is_empty st.readys_low
in
if conn.quota > 0 then Queue.push (conn, res) st.readys_high
else Queue.push (conn, res) st.readys_low ;
if was_empty then Lwt_condition.broadcast st.readys () ;
Lwt.return_unit)
let wait_data st =
let is_empty =
Queue.is_empty st.readys_high && Queue.is_empty st.readys_low
in
if is_empty then Lwt_condition.wait st.readys else Lwt.return_unit
let check_quota st =
if st.max_speed <> None && st.quota < 0 then
lwt_debug "scheduler.wait_quota(%s)" IO.name
>>= fun () -> Lwt_condition.wait st.quota_updated
else Lwt_unix.yield ()
let rec worker_loop st =
check_quota st
>>= fun () ->
lwt_debug "scheduler.wait(%s)" IO.name
>>= fun () ->
Lwt.pick [Lwt_canceler.cancellation st.canceler; wait_data st]
>>= fun () ->
if Lwt_canceler.canceled st.canceler then Lwt.return_unit
else
let (prio, (conn, msg)) =
if not (Queue.is_empty st.readys_high) then
(true, Queue.pop st.readys_high)
else (false, Queue.pop st.readys_low)
in
match msg with
| Error (Canceled :: _) ->
worker_loop st
| Error (P2p_errors.Connection_closed :: _ as err)
| Error (Exn Lwt_pipe.Closed :: _ as err)
| Error (Exn (Unix.Unix_error ((EBADF | ETIMEDOUT), _, _)) :: _ as err)
->
lwt_debug "Connection closed (pop: %d, %s)" conn.id IO.name
>>= fun () -> cancel conn err >>= fun () -> worker_loop st
| Error err ->
lwt_log_error
"@[Unexpected error in connection (pop: %d, %s):@ %a@]"
conn.id
IO.name
pp_print_error
err
>>= fun () -> cancel conn err >>= fun () -> worker_loop st
| Ok msg ->
conn.current_push <-
( IO.push conn.out_param msg
>>= function
| Ok () | Error (Canceled :: _) ->
return_unit
| Error (P2p_errors.Connection_closed :: _ as err)
| Error (Exn (Unix.Unix_error (EBADF, _, _)) :: _ as err)
| Error (Exn Lwt_pipe.Closed :: _ as err) ->
lwt_debug "Connection closed (push: %d, %s)" conn.id IO.name
>>= fun () -> cancel conn err >>= fun () -> return_unit
| Error err ->
lwt_log_error
"@[Unexpected error in connection (push: %d, %s):@ %a@]"
conn.id
IO.name
pp_print_error
err
>>= fun () ->
cancel conn err >>= fun () -> Lwt.return_error err ) ;
let len = Bytes.length msg in
lwt_debug "Handle: %d (%d, %s)" len conn.id IO.name
>>= fun () ->
Moving_average.add st.counter len ;
st.quota <- st.quota - len ;
Moving_average.add conn.counter len ;
if prio then conn.quota <- conn.quota - len ;
waiter st conn ;
worker_loop st
let create max_speed =
let st =
{
canceler = Lwt_canceler.create ();
worker = Lwt.return_unit;
counter = Moving_average.create ~init:0 ~alpha;
max_speed;
quota = Option.unopt ~default:0 max_speed;
quota_updated = Lwt_condition.create ();
readys = Lwt_condition.create ();
readys_high = Queue.create ();
readys_low = Queue.create ();
}
in
st.worker <-
Lwt_utils.worker
IO.name
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> worker_loop st)
~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ;
st
let create_connection st in_param out_param canceler id =
debug "scheduler(%s).create_connection (%d)" IO.name id ;
let conn =
{
id;
closed = false;
canceler;
in_param;
out_param;
current_pop = Lwt.fail Not_found (* dummy *);
current_push = return_unit;
counter = Moving_average.create ~init:0 ~alpha;
quota = 0;
last_quota = 0;
}
in
waiter st conn ; conn
let update_quota st =
debug "scheduler(%s).update_quota" IO.name ;
Option.iter st.max_speed ~f:(fun quota ->
st.quota <- min st.quota 0 + quota ;
Lwt_condition.broadcast st.quota_updated ()) ;
if not (Queue.is_empty st.readys_low) then (
let tmp = Queue.create () in
Queue.iter
(fun (((conn : connection), _) as msg) ->
if conn.quota > 0 then Queue.push msg st.readys_high
else Queue.push msg tmp)
st.readys_low ;
Queue.clear st.readys_low ;
Queue.transfer tmp st.readys_low )
let shutdown st =
lwt_debug "--> scheduler(%s).shutdown" IO.name
>>= fun () ->
Lwt_canceler.cancel st.canceler
>>= fun () ->
st.worker >>= fun () -> lwt_debug "<-- scheduler(%s).shutdown" IO.name
end
module ReadScheduler = Scheduler (struct
let name = "io_scheduler(read)"
type in_param = P2p_fd.t * int
let pop (fd, maxlen) =
Lwt.catch
(fun () ->
let buf = Bytes.create maxlen in
P2p_fd.read fd buf 0 maxlen
>>= fun len ->
if len = 0 then fail P2p_errors.Connection_closed
else return (Bytes.sub buf 0 len))
(function
| Unix.Unix_error (Unix.ECONNRESET, _, _) ->
fail P2p_errors.Connection_closed
| exn ->
Lwt.return (error_exn exn))
type out_param = Bytes.t tzresult Lwt_pipe.t
let push p msg =
Lwt.catch
(fun () -> Lwt_pipe.push p (Ok msg) >>= fun () -> return_unit)
(fun exn -> fail (Exn exn))
let close p err =
Lwt.catch
(fun () -> Lwt_pipe.push p (Error err))
(fun _ -> Lwt.return_unit)
end)
module WriteScheduler = Scheduler (struct
let name = "io_scheduler(write)"
type in_param = Bytes.t Lwt_pipe.t
let pop p =
Lwt.catch
(fun () -> Lwt_pipe.pop p >>= return)
(fun _ -> fail (Exn Lwt_pipe.Closed))
type out_param = P2p_fd.t
let push fd buf =
Lwt.catch
(fun () -> P2p_fd.write fd buf >>= return)
(function
| Unix.Unix_error (Unix.ECONNRESET, _, _)
| Unix.Unix_error (Unix.EPIPE, _, _)
| Lwt.Canceled
| End_of_file ->
fail P2p_errors.Connection_closed
| exn ->
Lwt.return (error_exn exn))
let close _p _err = Lwt.return_unit
end)
type connection = {
sched : t;
fd : P2p_fd.t;
canceler : Lwt_canceler.t;
read_conn : ReadScheduler.connection;
read_queue : Bytes.t tzresult Lwt_pipe.t;
write_conn : WriteScheduler.connection;
write_queue : Bytes.t Lwt_pipe.t;
mutable partial_read : Bytes.t option;
}
and t = {
mutable closed : bool;
connected : connection P2p_fd.Table.t;
read_scheduler : ReadScheduler.t;
write_scheduler : WriteScheduler.t;
max_upload_speed : int option;
(* bytes per second. *)
max_download_speed : int option;
read_buffer_size : int;
read_queue_size : int option;
write_queue_size : int option;
}
let reset_quota st =
debug "--> reset quota" ;
let {Moving_average.average = current_inflow; _} =
Moving_average.stat st.read_scheduler.counter
and {Moving_average.average = current_outflow; _} =
Moving_average.stat st.write_scheduler.counter
in
let nb_conn = P2p_fd.Table.length st.connected in
( if nb_conn > 0 then
let fair_read_quota = current_inflow / nb_conn
and fair_write_quota = current_outflow / nb_conn in
P2p_fd.Table.iter
(fun _id conn ->
conn.read_conn.last_quota <- fair_read_quota ;
conn.read_conn.quota <- min conn.read_conn.quota 0 + fair_read_quota ;
conn.write_conn.last_quota <- fair_write_quota ;
conn.write_conn.quota <- min conn.write_conn.quota 0 + fair_write_quota)
st.connected ) ;
ReadScheduler.update_quota st.read_scheduler ;
WriteScheduler.update_quota st.write_scheduler
let create ?max_upload_speed ?max_download_speed ?read_queue_size
?write_queue_size ~read_buffer_size () =
log_info "--> create" ;
let st =
{
closed = false;
connected = P2p_fd.Table.create 53;
read_scheduler = ReadScheduler.create max_download_speed;
write_scheduler = WriteScheduler.create max_upload_speed;
max_upload_speed;
max_download_speed;
read_buffer_size;
read_queue_size;
write_queue_size;
}
in
Moving_average.on_update (fun () -> reset_quota st) ;
st
exception Closed
let read_size = function
| Ok buf ->
(Sys.word_size / 8 * 8) + Bytes.length buf + Lwt_pipe.push_overhead
| Error _ ->
0
(* we push Error only when we close the socket,
we don't fear memory leaks in that case... *)
let write_size mbytes =
(Sys.word_size / 8 * 6) + Bytes.length mbytes + Lwt_pipe.push_overhead
let register st fd =
if st.closed then (
Lwt.async (fun () -> P2p_fd.close fd) ;
raise Closed )
else
let id = P2p_fd.id fd in
let canceler = Lwt_canceler.create () in
let read_size =
Option.map st.read_queue_size ~f:(fun v -> (v, read_size))
in
let write_size =
Option.map st.write_queue_size ~f:(fun v -> (v, write_size))
in
let read_queue = Lwt_pipe.create ?size:read_size () in
let write_queue = Lwt_pipe.create ?size:write_size () in
let read_conn =
ReadScheduler.create_connection
st.read_scheduler
(fd, st.read_buffer_size)
read_queue
canceler
id
and write_conn =
WriteScheduler.create_connection
st.write_scheduler
write_queue
fd
canceler
id
in
Lwt_canceler.on_cancel canceler (fun () ->
P2p_fd.Table.remove st.connected fd ;
Moving_average.destroy read_conn.counter ;
Moving_average.destroy write_conn.counter ;
Lwt_pipe.close write_queue ;
Lwt_pipe.close read_queue ;
P2p_fd.close fd) ;
let conn =
{
sched = st;
fd;
canceler;
read_queue;
read_conn;
write_queue;
write_conn;
partial_read = None;
}
in
P2p_fd.Table.add st.connected conn.fd conn ;
log_info "--> register (%d)" id ;
conn
let write ?canceler {write_queue; _} msg =
trace P2p_errors.Connection_closed
@@ protect ?canceler (fun () ->
Lwt_pipe.push write_queue msg >>= fun () -> return_unit)
let write_now {write_queue; _} msg = Lwt_pipe.push_now write_queue msg
let read_from conn ?pos ?len buf msg =
let maxlen = Bytes.length buf in
let pos = Option.unopt ~default:0 pos in
assert (0 <= pos && pos < maxlen) ;
let len = Option.unopt ~default:(maxlen - pos) len in
assert (len <= maxlen - pos) ;
match msg with
| Ok msg ->
let msg_len = Bytes.length msg in
let read_len = min len msg_len in
Bytes.blit msg 0 buf pos read_len ;
if read_len < msg_len then
conn.partial_read <- Some (Bytes.sub msg read_len (msg_len - read_len)) ;
Ok read_len
| Error _ ->
error P2p_errors.Connection_closed
let read_now conn ?pos ?len buf =
match conn.partial_read with
| Some msg ->
conn.partial_read <- None ;
Some (read_from conn ?pos ?len buf (Ok msg))
| None -> (
try
Option.map
~f:(read_from conn ?pos ?len buf)
(Lwt_pipe.pop_now conn.read_queue)
with Lwt_pipe.Closed -> Some (error P2p_errors.Connection_closed) )
let read ?canceler conn ?pos ?len buf =
match conn.partial_read with
| Some msg ->
conn.partial_read <- None ;
Lwt.return (read_from conn ?pos ?len buf (Ok msg))
| None ->
Lwt.catch
(fun () ->
protect ?canceler (fun () -> Lwt_pipe.pop conn.read_queue)
>|= fun msg -> read_from conn ?pos ?len buf msg)
(fun _ -> fail P2p_errors.Connection_closed)
let read_full ?canceler conn ?pos ?len buf =
let maxlen = Bytes.length buf in
let pos = Option.unopt ~default:0 pos in
let len = Option.unopt ~default:(maxlen - pos) len in
assert (0 <= pos && pos < maxlen) ;
assert (len <= maxlen - pos) ;
let rec loop pos len =
if len = 0 then return_unit
else
read ?canceler conn ~pos ~len buf
>>=? fun read_len -> loop (pos + read_len) (len - read_len)
in
loop pos len
let convert ~ws ~rs =
{
P2p_stat.total_sent = ws.Moving_average.total;
total_recv = rs.Moving_average.total;
current_outflow = ws.average;
current_inflow = rs.average;
}
let global_stat {read_scheduler; write_scheduler; _} =
let rs = Moving_average.stat read_scheduler.counter
and ws = Moving_average.stat write_scheduler.counter in
convert ~rs ~ws
let stat {read_conn; write_conn; _} =
let rs = Moving_average.stat read_conn.counter
and ws = Moving_average.stat write_conn.counter in
convert ~rs ~ws
let close ?timeout conn =
let id = P2p_fd.id conn.fd in
lwt_log_info "--> close (%d)" id
>>= fun () ->
P2p_fd.Table.remove conn.sched.connected conn.fd ;
Lwt_pipe.close conn.write_queue ;
( match timeout with
| None ->
return (Lwt_canceler.cancellation conn.canceler)
| Some timeout ->
with_timeout
~canceler:conn.canceler
(Lwt_unix.sleep timeout)
(fun canceler -> return (Lwt_canceler.cancellation canceler)) )
>>=? fun _ ->
conn.write_conn.current_push
>>= fun res -> lwt_log_info "<-- close (%d)" id >>= fun () -> Lwt.return res
let iter_connection {connected; _} f =
P2p_fd.Table.iter (fun _ conn -> f conn) connected
let shutdown ?timeout st =
lwt_log_info "--> shutdown"
>>= fun () ->
st.closed <- true ;
ReadScheduler.shutdown st.read_scheduler
>>= fun () ->
P2p_fd.Table.fold
(fun _peer_id conn acc -> close ?timeout conn >>= fun _ -> acc)
st.connected
Lwt.return_unit
>>= fun () ->
WriteScheduler.shutdown st.write_scheduler
>>= fun () -> lwt_log_info "<-- shutdown"
let id conn = P2p_fd.id conn.fd
src/lib_p2p/p2p_io_scheduler.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition alpha : Z :=
(* ❌ Float constant 0.2 is approximated by the integer 0 *)
0.
Module IO.
Record signature {in_param out_param : Type} := {
name : string;
in_param := in_param;
pop : in_param -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t);
out_param := out_param;
push : out_param ->
Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
close : out_param -> (list Tezos_base__TzPervasives.error) -> Lwt.t unit;
}.
Arguments signature : clear implicits.
End IO.
(* ❌ Functors are not handled. *)
functor
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
.
Definition reset_quota (st : t) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "--> reset quota" % string
CamlinternalFormatBasics.End_of_format) "--> reset quota" % string) in
in
let nb_conn := P2p_fd.Table.length (connected st) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.gt nb_conn 0 then
let fair_read_quota : Z :=
Z.div current_inflow nb_conn
with fair_write_quota : Z :=
Z.div current_outflow nb_conn in
P2p_fd.Table.iter
(fun _id =>
fun conn =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field (read_conn conn) "last_quota" % string
fair_read_quota in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field (read_conn conn) "quota" % string
(Z.add (OCaml.Stdlib.min (quota (read_conn conn)) 0)
fair_read_quota) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field (write_conn conn) "last_quota" % string
fair_write_quota in
(* ❌ Set record field not handled. *)
set_record_field (write_conn conn) "quota" % string
(Z.add (OCaml.Stdlib.min (quota (write_conn conn)) 0)
fair_write_quota)) (connected st)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := ReadScheduler.update_quota (read_scheduler st) in
WriteScheduler.update_quota (write_scheduler st).
Definition create
(max_upload_speed : option Z) (max_download_speed : option Z)
(read_queue_size : option Z) (write_queue_size : option Z)
(read_buffer_size : Z) (function_parameter : unit) : t :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "--> create" % string
CamlinternalFormatBasics.End_of_format) "--> create" % string) in
let st :=
{| closed := false; connected := P2p_fd.Table.create 53;
read_scheduler := ReadScheduler.create max_download_speed;
write_scheduler := WriteScheduler.create max_upload_speed;
max_upload_speed := max_upload_speed;
max_download_speed := max_download_speed;
read_buffer_size := read_buffer_size; read_queue_size := read_queue_size;
write_queue_size := write_queue_size |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Moving_average.on_update
(fun function_parameter =>
let 'tt := function_parameter in
reset_quota st) in
st.
(* ❌ The definition of exceptions is not handled. *)
exception
Definition read_size {A : Type} (function_parameter : sum string A) : Z :=
match function_parameter with
| Stdlib.Ok buf =>
Z.add (Z.add (Z.mul (Z.div Sys.word_size 8) 8) (String.length buf))
Lwt_pipe.push_overhead
| Stdlib.Error _ => 0
end.
Definition write_size (mbytes : string) : Z :=
Z.add (Z.add (Z.mul (Z.div Sys.word_size 8) 6) (String.length mbytes))
Lwt_pipe.push_overhead.
Definition register (st : t) (fd : Tezos_p2p.P2p_fd.t) : connection :=
if closed st then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
P2p_fd.close fd) in
Stdlib.raise Closed
else
let id := P2p_fd.id fd in
let canceler := Lwt_canceler.create tt in
let read_size := Option.map (fun v => (v, read_size)) (read_queue_size st)
in
let write_size :=
Option.map (fun v => (v, write_size)) (write_queue_size st) in
let read_queue := Lwt_pipe.create read_size tt in
let write_queue := Lwt_pipe.create write_size tt in
let read_conn : ReadScheduler.connection :=
ReadScheduler.create_connection (read_scheduler st)
(fd, (read_buffer_size st)) read_queue canceler id
with write_conn : WriteScheduler.connection :=
WriteScheduler.create_connection (write_scheduler st) write_queue fd
canceler id in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_canceler.on_cancel canceler
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_fd.Table.remove (connected st) fd in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Moving_average.destroy (counter read_conn) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Moving_average.destroy (counter write_conn) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_pipe.close write_queue in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_pipe.close read_queue in
P2p_fd.close fd) in
let conn :=
{| sched := st; fd := fd; canceler := canceler; read_conn := read_conn;
read_queue := read_queue; write_conn := write_conn;
write_queue := write_queue; partial_read := None |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_fd.Table.add (connected st) (fd conn) conn in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "--> register (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"--> register (%d)" % string) id in
conn.
Definition write
(canceler : option Tezos_stdlib.Lwt_canceler.t)
(function_parameter : connection)
: Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{| write_queue := write_queue |} := function_parameter in
fun msg =>
apply (trace Tezos_base__TzPervasives.Connection_closed)
(protect None canceler
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_pipe.push write_queue msg)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))).
Definition write_now (function_parameter : connection)
: Stdlib.Bytes.t -> bool :=
let '{| write_queue := write_queue |} := function_parameter in
fun msg => Lwt_pipe.push_now write_queue msg.
Definition read_from {A : Type}
(conn : connection) (pos : option Z) (len : option Z) (buf : string)
(msg : sum string A) : sum Z Tezos_base__TzPervasives.trace :=
let maxlen := String.length buf in
let pos := Option.unopt 0 pos in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (andb (OCaml.Stdlib.le 0 pos) (OCaml.Stdlib.lt pos maxlen)) in
let len := Option.unopt (Z.sub maxlen pos) len in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.le len (Z.sub maxlen pos)) in
match msg with
| Stdlib.Ok msg =>
let msg_len := String.length msg in
let read_len := OCaml.Stdlib.min len msg_len in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.Bytes.blit msg 0 buf pos read_len in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt read_len msg_len then
(* ❌ Set record field not handled. *)
set_record_field conn "partial_read" % string
(Some (String.sub msg read_len (Z.sub msg_len read_len)))
else
tt in
Stdlib.Ok read_len
| Stdlib.Error _ => error Tezos_base__TzPervasives.Connection_closed
end.
Definition read_now
(conn : connection) (pos : option Z) (len : option Z) (buf : string)
: option (sum Z Tezos_base__TzPervasives.trace) :=
match partial_read conn with
| Some msg =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field conn "partial_read" % string None in
Some (read_from conn pos len buf (Stdlib.Ok msg))
| None =>
(* ❌ Try-with are not handled *)
try
(Option.map (read_from conn pos len buf)
(Lwt_pipe.pop_now (read_queue conn)))
end.
Definition read
(canceler : option Tezos_stdlib.Lwt_canceler.t) (conn : connection)
(pos : option Z) (len : option Z) (buf : string)
: Lwt.t (sum Z Tezos_base__TzPervasives.trace) :=
match partial_read conn with
| Some msg =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field conn "partial_read" % string None in
Lwt._return (read_from conn pos len buf (Stdlib.Ok msg))
| None =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtpipeeq
(protect None canceler
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_pipe.pop (read_queue conn)))
(fun msg => read_from conn pos len buf msg))
(fun function_parameter =>
let '_ := function_parameter in
fail Tezos_base__TzPervasives.Connection_closed)
end.
Definition read_full
(canceler : option Tezos_stdlib.Lwt_canceler.t) (conn : connection)
(pos : option Z) (len : option Z) (buf : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let maxlen := String.length buf in
let pos := Option.unopt 0 pos in
let len := Option.unopt (Z.sub maxlen pos) len in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (andb (OCaml.Stdlib.le 0 pos) (OCaml.Stdlib.lt pos maxlen)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.le len (Z.sub maxlen pos)) in
let fix loop (pos : Z) (len : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if equiv_decb len 0 then
return_unit
else
op_gtgteqquestion (read canceler conn (Some pos) (Some len) buf)
(fun read_len => loop (Z.add pos read_len) (Z.sub len read_len)) in
loop pos len.
Definition convert
(ws : Tezos_stdlib_unix.Moving_average.stat)
(rs : Tezos_stdlib_unix.Moving_average.stat)
: Tezos_base__TzPervasives.P2p_stat.t :=
{| P2p_stat.total_sent := Moving_average.total ws;
P2p_stat.total_recv := Moving_average.total rs;
P2p_stat.current_inflow := average rs;
P2p_stat.current_outflow := average ws |}.
Definition global_stat (function_parameter : t)
: Tezos_base__TzPervasives.P2p_stat.t :=
let '{|
read_scheduler := read_scheduler; write_scheduler := write_scheduler |} :=
function_parameter in
let rs : Tezos_stdlib_unix.Moving_average.stat :=
Moving_average.stat (counter read_scheduler)
with ws : Tezos_stdlib_unix.Moving_average.stat :=
Moving_average.stat (counter write_scheduler) in
convert ws rs.
Definition stat (function_parameter : connection)
: Tezos_base__TzPervasives.P2p_stat.t :=
let '{| read_conn := read_conn; write_conn := write_conn |} :=
function_parameter in
let rs : Tezos_stdlib_unix.Moving_average.stat :=
Moving_average.stat (counter read_conn)
with ws : Tezos_stdlib_unix.Moving_average.stat :=
Moving_average.stat (counter write_conn) in
convert ws rs.
Definition close (timeout : option Z) (conn : connection)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let id := P2p_fd.id (fd conn) in
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "--> close (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"--> close (%d)" % string) id)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_fd.Table.remove (connected (sched conn)) (fd conn) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_pipe.close (write_queue conn) in
op_gtgteqquestion
match timeout with
| None => _return (Lwt_canceler.cancellation (canceler conn))
| Some timeout =>
with_timeout (Some (canceler conn)) (Lwt_unix.sleep timeout)
(fun canceler => _return (Lwt_canceler.cancellation canceler))
end
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (current_push (write_conn conn))
(fun res =>
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<-- close (" % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"<-- close (%d)" % string) id)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return res)))).
Definition iter_connection (function_parameter : t)
: (connection -> unit) -> unit :=
let '{| connected := connected |} := function_parameter in
fun f =>
P2p_fd.Table.iter
(fun function_parameter =>
let '_ := function_parameter in
fun conn => f conn) connected.
Definition shutdown (timeout : option Z) (st : t) : Lwt.t unit :=
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "--> shutdown" % string
CamlinternalFormatBasics.End_of_format) "--> shutdown" % string))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field st "closed" % string true in
op_gtgteq (ReadScheduler.shutdown (read_scheduler st))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(P2p_fd.Table.fold
(fun _peer_id =>
fun conn =>
fun acc =>
op_gtgteq (close timeout conn)
(fun function_parameter =>
let '_ := function_parameter in
acc)) (connected st) Lwt.return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (WriteScheduler.shutdown (write_scheduler st))
(fun function_parameter =>
let 'tt := function_parameter in
lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<-- shutdown" % string
CamlinternalFormatBasics.End_of_format)
"<-- shutdown" % string))))).
Definition id (conn : connection) : Z := P2p_fd.id (fd conn).
src/lib_p2p/p2p_maintenance.ml 59 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make (struct
let name = "p2p.maintenance"
end)
let time_between_looking_for_peers = 5.0 (* TODO put this in config *)
type bounds = {
min_threshold : int;
min_target : int;
max_target : int;
max_threshold : int;
}
type config = {
maintenance_idle_time : Time.System.Span.t;
greylist_timeout : Time.System.Span.t;
private_mode : bool;
min_connections : int;
max_connections : int;
expected_connections : int;
}
type ('msg, 'meta, 'meta_conn) t = {
canceler : Lwt_canceler.t;
config : config;
bounds : bounds;
pool : ('msg, 'meta, 'meta_conn) P2p_pool.t;
connect_handler : ('msg, 'meta, 'meta_conn) P2p_connect_handler.t;
discovery : P2p_discovery.t option;
just_maintained : unit Lwt_condition.t;
please_maintain : unit Lwt_condition.t;
mutable maintain_worker : unit Lwt.t;
triggers : P2p_trigger.t;
log : P2p_connection.P2p_event.t -> unit;
}
let broadcast_bootstrap_msg pool =
P2p_peer.Table.iter
(fun _peer_id peer_info ->
match P2p_peer_state.get peer_info with
| Running {data = conn; _} ->
if not (P2p_conn.private_node conn) then
ignore (P2p_conn.write_bootstrap conn)
| _ ->
())
(P2p_pool.connected_peer_ids pool)
let send_swap_request t =
match P2p_pool.Connection.propose_swap_request t.pool with
| None ->
()
| Some (proposed_point, proposed_peer_id, recipient) ->
let recipient_peer_id = (P2p_conn.info recipient).peer_id in
t.log (Swap_request_sent {source = recipient_peer_id}) ;
ignore
(P2p_conn.write_swap_request recipient proposed_point proposed_peer_id)
let classify pool private_mode start_time seen_points point pi =
let now = Systime_os.now () in
if
P2p_point.Set.mem point seen_points
|| P2p_pool.Points.banned pool point
|| (private_mode && not (P2p_point_state.Info.trusted pi))
then `Ignore
else
match P2p_point_state.get pi with
| Disconnected -> (
match P2p_point_state.Info.last_miss pi with
| Some last
when Time.System.(start_time < last)
|| P2p_point_state.Info.greylisted ~now pi ->
`Seen
| last ->
`Candidate last )
| _ ->
`Seen
(** [establish t contactable] tries to establish as many connection as possible
with points in [contactable]. It returns the number of established
connections *)
let establish t contactable =
let try_to_connect acc point =
protect ~canceler:t.canceler (fun () ->
P2p_connect_handler.connect t.connect_handler point)
>>= function Ok _ -> acc >|= succ | Error _ -> acc
in
List.fold_left try_to_connect (Lwt.return 0) contactable
(* [connectable t start_time expected seen_points] selects at most
[expected] connections candidates from the known points, not in [seen]
points. *)
let connectable t start_time expected seen_points =
let module Bounded_point_info = List.Bounded (struct
type t = Time.System.t option * P2p_point.Id.t
let compare (t1, _) (t2, _) =
match (t1, t2) with
| (None, None) ->
0
| (None, Some _) ->
1
| (Some _, None) ->
-1
| (Some t1, Some t2) ->
Time.System.compare t2 t1
end) in
let acc = Bounded_point_info.create expected in
let f point pi seen_points =
match
classify t.pool t.config.private_mode start_time seen_points point pi
with
| `Ignore ->
seen_points (* Ignored points can be retried again *)
| `Candidate last ->
Bounded_point_info.insert (last, point) acc ;
P2p_point.Set.add point seen_points
| `Seen ->
P2p_point.Set.add point seen_points
in
let seen_points = P2p_pool.Points.fold_known t.pool ~init:seen_points ~f in
(List.map snd (Bounded_point_info.get acc), seen_points)
(* [try_to_contact_loop t start_time ~seen_points] is the main loop
for contacting points. [start_time] is set when calling the function
and remains constant in the loop. [seen_points] simply accumulates the
points already seen, to avoid trying to contact them again.
It repeats two operations until the number of connections is reached:
- get [max_to_contact] points
- connect to many of them as possible
TODO why not the simpler implementation. Sort all candidates points,
and try to connect to [n] of them. *)
let rec try_to_contact_loop t start_time ~seen_points min_to_contact
max_to_contact =
if min_to_contact <= 0 then Lwt.return_true
else
let (candidates, seen_points) =
connectable t start_time max_to_contact seen_points
in
if candidates = [] then Lwt_unix.yield () >>= fun () -> Lwt.return_false
else
establish t candidates
>>= fun established ->
try_to_contact_loop
t
start_time
~seen_points
(min_to_contact - established)
(max_to_contact - established)
(** [try_to_contact t min_to_contact max_to_contact] tries to create
between [min_to_contact] and [max_to_contact] new connections.
It goes through all know points, and ignores points which are
- greylisted,
- banned,
- for which a connection failed after the time this function is called
- Non-trusted points if option --private-mode is set.
It tries to favor points for which the last failed missed connection is old.
Note that this function works as a sequence of lwt tasks that tries
to incrementally reach the number of connections. The set of
known points maybe be concurrently updated. *)
let try_to_contact t min_to_contact max_to_contact =
let start_time = Systime_os.now () in
let seen_points = P2p_point.Set.empty in
try_to_contact_loop t start_time min_to_contact max_to_contact ~seen_points
(** not enough contacts, ask the pals of our pals,
discover the local network and then wait *)
let ask_for_more_contacts t =
broadcast_bootstrap_msg t.pool ;
Option.iter ~f:P2p_discovery.wakeup t.discovery ;
protect ~canceler:t.canceler (fun () ->
Lwt.pick
[ P2p_trigger.wait_new_peer t.triggers;
P2p_trigger.wait_new_point t.triggers;
(* TODO exponential back-off, or wait for the existence
of a non grey-listed peer? *)
Lwt_unix.sleep time_between_looking_for_peers ]
>>= fun () -> return_unit)
(** Selects [n] random connections. Ignore connections to
nodes who are both private and trusted. *)
let random_connections pool n =
let open P2p_conn in
let f _ conn acc =
if private_node conn && trusted_node conn then acc else conn :: acc
in
let candidates =
P2p_pool.Connection.fold pool ~init:[] ~f |> TzList.shuffle
in
TzList.rev_sub candidates n
(** GC peers from the greylist that has been greylisted for more than
[t.config.greylist_timeout] *)
let trigger_greylist_gc t =
let now = Systime_os.now () in
let minus_greylist_timeout = Ptime.Span.neg t.config.greylist_timeout in
let time = Ptime.add_span now minus_greylist_timeout in
let older_than =
Option.unopt_exn (Failure "P2p_maintenance.maintain: time overflow") time
in
P2p_pool.gc_greylist t.pool ~older_than
(** Maintenance step.
1. trigger greylist gc
2. tries *forever* to achieve a number of connections
between `min_threshold` and `max_threshold`. *)
let rec do_maintain t =
trigger_greylist_gc t ;
let n_connected = P2p_pool.active_connections t.pool in
if n_connected < t.bounds.min_threshold then
too_few_connections t n_connected
else if t.bounds.max_threshold < n_connected then
too_many_connections t n_connected
else (
(* end of maintenance when enough users have been reached *)
Lwt_condition.broadcast t.just_maintained () ;
lwt_debug "Maintenance step ended" >>= fun () -> return_unit )
and too_few_connections t n_connected =
(* try and contact new peers *)
lwt_log_notice "Too few connections (%d)" n_connected
>>= fun () ->
let min_to_contact = t.bounds.min_target - n_connected in
let max_to_contact = t.bounds.max_target - n_connected in
try_to_contact t min_to_contact max_to_contact
>>= fun success ->
(if success then return_unit else ask_for_more_contacts t)
>>=? fun () -> do_maintain t
and too_many_connections t n_connected =
(* kill random connections *)
let n = n_connected - t.bounds.max_target in
lwt_log_notice "Too many connections, will kill %d" n
>>= fun () ->
let connections = random_connections t.pool n in
Lwt_list.iter_p P2p_conn.disconnect connections >>= fun () -> do_maintain t
let rec worker_loop t =
(let n_connected = P2p_pool.active_connections t.pool in
if
n_connected < t.bounds.min_threshold
|| t.bounds.max_threshold < n_connected
then do_maintain t
else
( if not t.config.private_mode then send_swap_request t ;
return_unit )
>>=? fun () ->
protect ~canceler:t.canceler (fun () ->
Lwt.pick
[ Systime_os.sleep t.config.maintenance_idle_time;
Lwt_condition.wait t.please_maintain;
(* when asked *)
P2p_trigger.wait_too_few_connections t.triggers;
(* limits *)
P2p_trigger.wait_too_many_connections t.triggers ]
>>= fun () -> return_unit))
>>= function
| Ok () ->
worker_loop t
| Error (Canceled :: _) ->
Lwt.return_unit
| Error _ ->
Lwt.return_unit
let bounds ~min ~expected ~max =
assert (min <= expected) ;
assert (expected <= max) ;
let step_min = (expected - min) / 3 and step_max = (max - expected) / 3 in
{
min_threshold = min + step_min;
min_target = min + (2 * step_min);
max_target = max - (2 * step_max);
max_threshold = max - step_max;
}
let create ?discovery config pool connect_handler triggers ~log =
let bounds =
bounds
~min:config.min_connections
~expected:config.expected_connections
~max:config.max_connections
in
{
canceler = Lwt_canceler.create ();
config;
bounds;
discovery;
pool;
connect_handler;
just_maintained = Lwt_condition.create ();
please_maintain = Lwt_condition.create ();
maintain_worker = Lwt.return_unit;
triggers;
log;
}
let activate t =
t.maintain_worker <-
Lwt_utils.worker
"maintenance"
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> worker_loop t)
~cancel:(fun () -> Lwt_canceler.cancel t.canceler) ;
Option.iter t.discovery ~f:P2p_discovery.activate
let maintain t =
let wait = Lwt_condition.wait t.just_maintained in
Lwt_condition.broadcast t.please_maintain () ;
wait
let shutdown {canceler; discovery; maintain_worker; just_maintained; _} =
Lwt_canceler.cancel canceler
>>= fun () ->
Lwt_utils.may ~f:P2p_discovery.shutdown discovery
>>= fun () ->
maintain_worker
>>= fun () ->
Lwt_condition.broadcast just_maintained () ;
Lwt.return_unit
src/lib_p2p/p2p_maintenance.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition time_between_looking_for_peers : Z :=
(* ❌ Float constant 5.0 is approximated by the integer 5 *)
5.
Record bounds := {
min_threshold : Z;
min_target : Z;
max_target : Z;
max_threshold : Z }.
Record config := {
maintenance_idle_time : Tezos_base__TzPervasives.Time.System.Span.t;
greylist_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
private_mode : bool;
min_connections : Z;
max_connections : Z;
expected_connections : Z }.
Record t {msg meta meta_conn : Type} := {
canceler : Tezos_stdlib.Lwt_canceler.t;
config : config;
bounds : bounds;
pool : Tezos_p2p.P2p_pool.t msg meta meta_conn;
connect_handler : Tezos_p2p.P2p_connect_handler.t msg meta meta_conn;
discovery : option Tezos_p2p.P2p_discovery.t;
just_maintained : Lwt_condition.t unit;
please_maintain : Lwt_condition.t unit;
maintain_worker : Lwt.t unit;
triggers : Tezos_p2p.P2p_trigger.t;
log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit }.
Arguments t : clear implicits.
Definition broadcast_bootstrap_msg {A B C : Type}
(pool : Tezos_p2p.P2p_pool.t A B C) : unit :=
P2p_peer.Table.iter
(fun _peer_id =>
fun peer_info =>
match P2p_peer_state.get peer_info with
| Tezos_p2p.P2p_peer_state.Running {| data := conn |} =>
if negb (P2p_conn.private_node conn) then
OCaml.Stdlib.ignore (P2p_conn.write_bootstrap conn)
else
tt
| _ => tt
end) (P2p_pool.connected_peer_ids pool).
Definition send_swap_request {A B C : Type} (t : t A B C) : unit :=
match P2p_pool.Connection.propose_swap_request (pool t) with
| None => tt
| Some (proposed_point, proposed_peer_id, recipient) =>
let recipient_peer_id := peer_id (P2p_conn.info recipient) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(log t)
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_request_sent
{| source := recipient_peer_id |}) in
OCaml.Stdlib.ignore
(P2p_conn.write_swap_request recipient proposed_point proposed_peer_id)
end.
Definition classify {A B C D : Type}
(pool : Tezos_p2p__P2p_pool.t A B C) (private_mode : bool)
(start_time : Tezos_base__TzPervasives.Time.System.t)
(seen_points : Tezos_base__TzPervasives.P2p_point.Set.t)
(point : Tezos_base__TzPervasives.P2p_point.Set.elt)
(pi : Tezos_p2p.P2p_point_state.Info.point_info D) : variant :=
let now := Systime_os.now tt in
if
orb (P2p_point.Set.mem point seen_points)
(orb (P2p_pool.Points.banned pool point)
(andb private_mode (negb (P2p_point_state.Info.trusted pi)))) then
(* ❌ Variants not supported *)
variant
else
match P2p_point_state.get pi with
| Tezos_p2p.P2p_point_state.Disconnected =>
match P2p_point_state.Info.last_miss pi with
| Some last =>
(* ❌ Variants not supported *)
variant
| last =>
(* ❌ Variants not supported *)
variant
end
| _ =>
(* ❌ Variants not supported *)
variant
end.
Definition establish {A B C : Type}
(t : t A B C) (contactable : list Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t Z :=
let try_to_connect
(acc : Lwt.t Z) (point : Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t Z :=
op_gtgteq
(protect None (Some (canceler t))
(fun function_parameter =>
let 'tt := function_parameter in
P2p_connect_handler.connect None (connect_handler t) point))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok _ => op_gtpipeeq acc Z.succ
| Stdlib.Error _ => acc
end) in
List.fold_left try_to_connect (Lwt._return 0) contactable.
Definition connectable {A B C : Type}
(t : t A B C) (start_time : Tezos_base__TzPervasives.Time.System.t)
(expected : Z) (seen_points : Tezos_base__TzPervasives.P2p_point.Set.t)
: (list Tezos_base__TzPervasives.P2p_point.Id.t) *
Tezos_base__TzPervasives.P2p_point.Set.t :=
let Bounded_point_info :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
let acc := Bounded_point_info.create expected in
let f {D : Type}
(point : Tezos_base__TzPervasives.P2p_point.Set.elt) (pi :
Tezos_p2p.P2p_point_state.Info.point_info D) (seen_points :
Tezos_base__TzPervasives.P2p_point.Set.t)
: Tezos_base__TzPervasives.P2p_point.Set.t :=
match
classify (pool t) (private_mode (config t)) start_time seen_points point
pi with
| Ignore => seen_points
| Candidate last =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bounded_point_info.insert (last, point) acc in
P2p_point.Set.add point seen_points
| Seen => P2p_point.Set.add point seen_points
end in
let seen_points := P2p_pool.Points.fold_known (pool t) seen_points f in
((List.map snd (Bounded_point_info.get acc)), seen_points).
Fixpoint try_to_contact_loop {A B C : Type}
(t : t A B C) (start_time : Tezos_base__TzPervasives.Time.System.t)
(seen_points : Tezos_base__TzPervasives.P2p_point.Set.t) (min_to_contact : Z)
(max_to_contact : Z) : Lwt.t bool :=
if OCaml.Stdlib.le min_to_contact 0 then
Lwt.return_true
else
let '(candidates, seen_points) :=
connectable t start_time max_to_contact seen_points in
if equiv_decb candidates [] then
op_gtgteq (Lwt_unix.yield tt)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_false)
else
op_gtgteq (establish t candidates)
(fun established =>
try_to_contact_loop t start_time seen_points
(Z.sub min_to_contact established)
(Z.sub max_to_contact established)).
Definition try_to_contact {A B C : Type}
(t : t A B C) (min_to_contact : Z) (max_to_contact : Z) : Lwt.t bool :=
let start_time := Systime_os.now tt in
let seen_points := P2p_point.Set.empty in
try_to_contact_loop t start_time seen_points min_to_contact max_to_contact.
Definition ask_for_more_contacts {A B C : Type} (t : t A B C)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := broadcast_bootstrap_msg (pool t) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Option.iter P2p_discovery.wakeup (discovery t) in
protect None (Some (canceler t))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt.pick
(cons (P2p_trigger.wait_new_peer (triggers t))
(cons (P2p_trigger.wait_new_point (triggers t))
(cons (Lwt_unix.sleep time_between_looking_for_peers) []))))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)).
Definition random_connections {A B C : Type}
(pool : Tezos_p2p__P2p_pool.t A B C) (n : Z)
: list (Tezos_p2p.P2p_conn.t A B C) :=
let f {D E F G : Type} (function_parameter : D)
: (Tezos_p2p.P2p_conn.t E F G) ->
(list (Tezos_p2p.P2p_conn.t E F G)) -> list (Tezos_p2p.P2p_conn.t E F G) :=
let '_ := function_parameter in
fun conn =>
fun acc =>
if andb (private_node conn) (trusted_node conn) then
acc
else
cons conn acc in
let candidates :=
OCaml.Stdlib.reverse_apply (P2p_pool.Connection.fold pool [] f)
TzList.shuffle in
TzList.rev_sub candidates n.
Definition trigger_greylist_gc {A B C : Type} (t : t A B C) : unit :=
let now := Systime_os.now tt in
let minus_greylist_timeout := Ptime.Span.neg (greylist_timeout (config t)) in
let time := Ptime.add_span now minus_greylist_timeout in
let older_than :=
Option.unopt_exn
(OCaml.Failure "P2p_maintenance.maintain: time overflow" % string) time in
P2p_pool.gc_greylist older_than (pool t).
Fixpoint do_maintain {A B C : Type} (t : t A B C)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := trigger_greylist_gc t in
let n_connected := P2p_pool.active_connections (pool t) in
if OCaml.Stdlib.lt n_connected (min_threshold (bounds t)) then
too_few_connections t n_connected
else
if OCaml.Stdlib.lt (max_threshold (bounds t)) n_connected then
too_many_connections t n_connected
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_condition.broadcast (just_maintained t) tt in
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Maintenance step ended" % string
CamlinternalFormatBasics.End_of_format)
"Maintenance step ended" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
with too_few_connections {A B C : Type} (t : t A B C) (n_connected : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq
(lwt_log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Too few connections (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"Too few connections (%d)" % string) n_connected)
(fun function_parameter =>
let 'tt := function_parameter in
let min_to_contact := Z.sub (min_target (bounds t)) n_connected in
let max_to_contact := Z.sub (max_target (bounds t)) n_connected in
op_gtgteq (try_to_contact t min_to_contact max_to_contact)
(fun success =>
op_gtgteqquestion
(if success then
return_unit
else
ask_for_more_contacts t)
(fun function_parameter =>
let 'tt := function_parameter in
do_maintain t)))
with too_many_connections {A B C : Type} (t : t A B C) (n_connected : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let n := Z.sub n_connected (max_target (bounds t)) in
op_gtgteq
(lwt_log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Too many connections, will kill " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"Too many connections, will kill %d" % string) n)
(fun function_parameter =>
let 'tt := function_parameter in
let connections := random_connections (pool t) n in
op_gtgteq
(Lwt_list.iter_p
(let arg := P2p_conn.disconnect in
fun eta => arg None eta) connections)
(fun function_parameter =>
let 'tt := function_parameter in
do_maintain t)).
Fixpoint worker_loop {A B C : Type} (t : t A B C) : Lwt.t unit :=
op_gtgteq
(let n_connected := P2p_pool.active_connections (pool t) in
if
orb (OCaml.Stdlib.lt n_connected (min_threshold (bounds t)))
(OCaml.Stdlib.lt (max_threshold (bounds t)) n_connected) then
do_maintain t
else
op_gtgteqquestion
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ :=
if negb (private_mode (config t)) then
send_swap_request t
else
tt in
return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
protect None (Some (canceler t))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt.pick
(cons (Systime_os.sleep (maintenance_idle_time (config t)))
(cons (Lwt_condition.wait None (please_maintain t))
(cons (P2p_trigger.wait_too_few_connections (triggers t))
(cons
(P2p_trigger.wait_too_many_connections (triggers t))
[])))))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => worker_loop t
| Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) =>
Lwt.return_unit
| Stdlib.Error _ => Lwt.return_unit
end).
Definition bounds (min : Z) (expected : Z) (max : Z) : bounds :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.le min expected) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.le expected max) in
let step_min : Z :=
Z.div (Z.sub expected min) 3
with step_max : Z :=
Z.div (Z.sub max expected) 3 in
{| min_threshold := Z.add min step_min;
min_target := Z.add min (Z.mul 2 step_min);
max_target := Z.sub max (Z.mul 2 step_max);
max_threshold := Z.sub max step_max |}.
Definition create {A B C : Type}
(discovery : option Tezos_p2p.P2p_discovery.t) (config : config)
(pool : Tezos_p2p.P2p_pool.t A B C)
(connect_handler : Tezos_p2p.P2p_connect_handler.t A B C)
(triggers : Tezos_p2p.P2p_trigger.t)
(log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit)
: t A B C :=
let bounds :=
bounds (min_connections config) (expected_connections config)
(max_connections config) in
{| canceler := Lwt_canceler.create tt; config := config; bounds := bounds;
pool := pool; connect_handler := connect_handler; discovery := discovery;
just_maintained := Lwt_condition.create tt;
please_maintain := Lwt_condition.create tt;
maintain_worker := Lwt.return_unit; triggers := triggers; log := log |}.
Definition activate {A B C : Type} (t : t A B C) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field t "maintain_worker" % string
(Lwt_utils.worker "maintenance" % string
Internal_event.Lwt_worker_event.on_event
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop t)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler t))) in
Option.iter P2p_discovery.activate (discovery t).
Definition maintain {A B C : Type} (t : t A B C) : Lwt.t unit :=
let wait := Lwt_condition.wait None (just_maintained t) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_condition.broadcast (please_maintain t) tt in
wait.
Definition shutdown {A B C : Type} (function_parameter : t A B C)
: Lwt.t unit :=
let '{|
canceler := canceler;
discovery := discovery;
just_maintained := just_maintained;
maintain_worker := maintain_worker
|} := function_parameter in
op_gtgteq (Lwt_canceler.cancel canceler)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_utils.may P2p_discovery.shutdown discovery)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq maintain_worker
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_condition.broadcast just_maintained tt in
Lwt.return_unit))).
src/lib_p2p/p2p_message.ml 9 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type 'msg encoding =
| Encoding : {
tag : int;
title : string;
encoding : 'a Data_encoding.t;
wrap : 'a -> 'msg;
unwrap : 'msg -> 'a option;
max_length : int option;
}
-> 'msg encoding
type 'msg t =
| Bootstrap
| Advertise of P2p_point.Id.t list
| Swap_request of P2p_point.Id.t * P2p_peer.Id.t
| Swap_ack of P2p_point.Id.t * P2p_peer.Id.t
| Message of 'msg
| Disconnect
let encoding msg_encoding =
let open Data_encoding in
dynamic_size
@@ union
~tag_size:`Uint16
( [ case
(Tag 0x01)
~title:"Disconnect"
(obj1 (req "kind" (constant "Disconnect")))
(function Disconnect -> Some () | _ -> None)
(fun () -> Disconnect);
case
(Tag 0x02)
~title:"Bootstrap"
(obj1 (req "kind" (constant "Bootstrap")))
(function Bootstrap -> Some () | _ -> None)
(fun () -> Bootstrap);
case
(Tag 0x03)
~title:"Advertise"
(obj2
(req "id" (Variable.list P2p_point.Id.encoding))
(req "kind" (constant "Advertise")))
(function Advertise points -> Some (points, ()) | _ -> None)
(fun (points, ()) -> Advertise points);
case
(Tag 0x04)
~title:"Swap_request"
(obj3
(req "point" P2p_point.Id.encoding)
(req "peer_id" P2p_peer.Id.encoding)
(req "kind" (constant "Swap_request")))
(function
| Swap_request (point, peer_id) ->
Some (point, peer_id, ())
| _ ->
None)
(fun (point, peer_id, ()) -> Swap_request (point, peer_id));
case
(Tag 0x05)
~title:"Swap_ack"
(obj3
(req "point" P2p_point.Id.encoding)
(req "peer_id" P2p_peer.Id.encoding)
(req "kind" (constant "Swap_ack")))
(function
| Swap_ack (point, peer_id) ->
Some (point, peer_id, ())
| _ ->
None)
(fun (point, peer_id, ()) -> Swap_ack (point, peer_id)) ]
@ ListLabels.map msg_encoding ~f:(function
| Encoding
{tag; title; encoding; wrap; unwrap; max_length = _ (* ?? *)}
->
Data_encoding.case
(Tag tag)
~title
encoding
(function Message msg -> unwrap msg | _ -> None)
(fun msg -> Message (wrap msg))) )
src/lib_p2p/p2p_message.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive encoding (msg : Type) : Type :=
| Encoding : forall {a : Type}, Z -> string ->
(Tezos_base__TzPervasives.Data_encoding.t a) -> (a -> msg) ->
(msg -> option a) -> (option Z) -> encoding msg.
Arguments Encoding {_}.
Inductive t (msg : Type) : Type :=
| Bootstrap : t msg
| Advertise : (list Tezos_base__TzPervasives.P2p_point.Id.t) -> t msg
| Swap_request : Tezos_base__TzPervasives.P2p_point.Id.t ->
Tezos_base__TzPervasives.P2p_peer.Id.t -> t msg
| Swap_ack : Tezos_base__TzPervasives.P2p_point.Id.t ->
Tezos_base__TzPervasives.P2p_peer.Id.t -> t msg
| Message : msg -> t msg
| Disconnect : t msg.
Arguments Bootstrap {_}.
Arguments Advertise {_}.
Arguments Swap_request {_}.
Arguments Swap_ack {_}.
Arguments Message {_}.
Arguments Disconnect {_}.
Definition encoding {A : Type} (msg_encoding : list (encoding A))
: Tezos_base__TzPervasives.Data_encoding.encoding (t A) :=
apply
(let arg := dynamic_size in
fun eta => arg None eta)
(union
(Some
(* ❌ Variants not supported *)
variant)
(OCaml.Stdlib.app
(cons
(case "Disconnect" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj1
(req None None "kind" % string (constant "Disconnect" % string)))
(fun function_parameter =>
match function_parameter with
| Disconnect => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Disconnect))
(cons
(case "Bootstrap" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 2)
(obj1
(req None None "kind" % string (constant "Bootstrap" % string)))
(fun function_parameter =>
match function_parameter with
| Bootstrap => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Bootstrap))
(cons
(case "Advertise" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 3)
(obj2
(req None None "id" % string
(Variable.list None P2p_point.Id.encoding))
(req None None "kind" % string (constant "Advertise" % string)))
(fun function_parameter =>
match function_parameter with
| Advertise points => Some (points, tt)
| _ => None
end)
(fun function_parameter =>
let '(points, tt) := function_parameter in
Advertise points))
(cons
(case "Swap_request" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 4)
(obj3 (req None None "point" % string P2p_point.Id.encoding)
(req None None "peer_id" % string P2p_peer.Id.encoding)
(req None None "kind" % string
(constant "Swap_request" % string)))
(fun function_parameter =>
match function_parameter with
| Swap_request point peer_id => Some (point, peer_id, tt)
| _ => None
end)
(fun function_parameter =>
let '(point, peer_id, tt) := function_parameter in
Swap_request point peer_id))
(cons
(case "Swap_ack" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 5)
(obj3 (req None None "point" % string P2p_point.Id.encoding)
(req None None "peer_id" % string P2p_peer.Id.encoding)
(req None None "kind" % string
(constant "Swap_ack" % string)))
(fun function_parameter =>
match function_parameter with
| Swap_ack point peer_id => Some (point, peer_id, tt)
| _ => None
end)
(fun function_parameter =>
let '(point, peer_id, tt) := function_parameter in
Swap_ack point peer_id)) [])))))
(ListLabels.map
(fun function_parameter =>
let
'Encoding {|
tag := tag;
title := title;
encoding := encoding;
wrap := wrap;
unwrap := unwrap;
max_length := _
|} := function_parameter in
Data_encoding.case title None
(Tezos_base__TzPervasives.Data_encoding.Tag tag) encoding
(fun function_parameter =>
match function_parameter with
| Message msg => unwrap msg
| _ => None
end) (fun msg => Message (wrap msg))) msg_encoding))).
src/lib_p2p/p2p_peer_state.ml 84 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open P2p_peer
type ('conn, 'conn_meta) t =
| Accepted of {current_point : P2p_connection.Id.t; cancel : Lwt_canceler.t}
| Running of {
data : 'conn;
conn_metadata : 'conn_meta;
current_point : P2p_connection.Id.t;
}
| Disconnected
type ('conn, 'conn_meta) state = ('conn, 'conn_meta) t
let pp ppf = function
| Accepted {current_point; _} ->
Format.fprintf ppf "accepted %a" P2p_connection.Id.pp current_point
| Running {current_point; _} ->
Format.fprintf ppf "running %a" P2p_connection.Id.pp current_point
| Disconnected ->
Format.fprintf ppf "disconnected"
module Info = struct
type ('conn, 'peer_meta, 'conn_meta) t = {
peer_id : Id.t;
created : Time.System.t;
mutable state : ('conn, 'conn_meta) state;
mutable peer_metadata : 'peer_meta;
mutable trusted : bool;
mutable last_failed_connection :
(P2p_connection.Id.t * Time.System.t) option;
mutable last_rejected_connection :
(P2p_connection.Id.t * Time.System.t) option;
mutable last_established_connection :
(P2p_connection.Id.t * Time.System.t) option;
mutable last_disconnection : (P2p_connection.Id.t * Time.System.t) option;
events : Pool_event.t Ring.t;
watchers : Pool_event.t Lwt_watcher.input;
}
type ('conn, 'peer_meta, 'conn_meta) peer_info =
('conn, 'peer_meta, 'conn_meta) t
let compare gi1 gi2 = Id.compare gi1.peer_id gi2.peer_id
let log_size = 100
let create ?(created = Systime_os.now ()) ?(trusted = false) ~peer_metadata
peer_id =
{
peer_id;
created;
state = Disconnected;
peer_metadata;
trusted;
last_failed_connection = None;
last_rejected_connection = None;
last_established_connection = None;
last_disconnection = None;
events = Ring.create log_size;
watchers = Lwt_watcher.create_input ();
}
let encoding peer_metadata_encoding =
let open Data_encoding in
conv
(fun { peer_id;
trusted;
peer_metadata;
events;
created;
last_failed_connection;
last_rejected_connection;
last_established_connection;
last_disconnection;
_ } ->
( peer_id,
created,
trusted,
peer_metadata,
Ring.elements events,
last_failed_connection,
last_rejected_connection,
last_established_connection,
last_disconnection ))
(fun ( peer_id,
created,
trusted,
peer_metadata,
event_list,
last_failed_connection,
last_rejected_connection,
last_established_connection,
last_disconnection ) ->
let info = create ~trusted ~peer_metadata peer_id in
let events = Ring.create log_size in
Ring.add_list info.events event_list ;
{
state = Disconnected;
trusted;
peer_id;
peer_metadata;
created;
last_failed_connection;
last_rejected_connection;
last_established_connection;
last_disconnection;
events;
watchers = Lwt_watcher.create_input ();
})
(obj9
(req "peer_id" Id.encoding)
(req "created" Time.System.encoding)
(dft "trusted" bool false)
(req "peer_metadata" peer_metadata_encoding)
(dft "events" (list Pool_event.encoding) [])
(opt
"last_failed_connection"
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt
"last_rejected_connection"
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt
"last_established_connection"
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt
"last_disconnection"
(tup2 P2p_connection.Id.encoding Time.System.encoding)))
let peer_id {peer_id; _} = peer_id
let created {created; _} = created
let peer_metadata {peer_metadata; _} = peer_metadata
let set_peer_metadata gi peer_metadata = gi.peer_metadata <- peer_metadata
let trusted {trusted; _} = trusted
let set_trusted gi = gi.trusted <- true
let unset_trusted gi = gi.trusted <- false
let last_established_connection s = s.last_established_connection
let last_disconnection s = s.last_disconnection
let last_failed_connection s = s.last_failed_connection
let last_rejected_connection s = s.last_rejected_connection
let last_seen s =
Time.System.recent
s.last_established_connection
(Time.System.recent s.last_rejected_connection s.last_disconnection)
let last_miss s =
Time.System.recent
s.last_failed_connection
(Time.System.recent s.last_rejected_connection s.last_disconnection)
let log {events; watchers; _} ?(timestamp = Systime_os.now ()) point kind =
let event = {Pool_event.kind; timestamp; point} in
Ring.add events event ;
Lwt_watcher.notify watchers event
let log_incoming_rejection ?timestamp peer_info point =
log peer_info ?timestamp point Rejecting_request
module File = struct
let load path peer_metadata_encoding =
let enc = Data_encoding.list (encoding peer_metadata_encoding) in
if path <> "/dev/null" && Sys.file_exists path then
Lwt_utils_unix.Json.read_file path
>>=? fun json -> return (Data_encoding.Json.destruct enc json)
else return_nil
let save path peer_metadata_encoding peers =
let open Data_encoding in
Lwt_utils_unix.Json.write_file path
@@ Json.construct (list (encoding peer_metadata_encoding)) peers
end
let watch {watchers; _} = Lwt_watcher.create_stream watchers
let fold {events; _} ~init ~f = Ring.fold events ~init ~f
end
let get {Info.state; _} = state
let is_disconnected {Info.state; _} =
match state with Disconnected -> true | Accepted _ | Running _ -> false
let set_accepted ?(timestamp = Systime_os.now ()) peer_info current_point
cancel =
assert (
match peer_info.Info.state with
| Accepted _ | Running _ ->
false
| Disconnected ->
true ) ;
peer_info.state <- Accepted {current_point; cancel} ;
Info.log peer_info ~timestamp current_point Accepting_request
let set_running ?(timestamp = Systime_os.now ()) peer_info point data
conn_metadata =
assert (
match peer_info.Info.state with
| Disconnected ->
true (* request to unknown peer_id. *)
| Running _ ->
false
| Accepted {current_point; _} ->
P2p_connection.Id.equal point current_point ) ;
peer_info.state <- Running {data; conn_metadata; current_point = point} ;
peer_info.last_established_connection <- Some (point, timestamp) ;
Info.log peer_info ~timestamp point Connection_established
let set_disconnected ?(timestamp = Systime_os.now ()) ?(requested = false)
peer_info =
let (current_point, (event : Pool_event.kind)) =
match peer_info.Info.state with
| Accepted {current_point; _} ->
peer_info.last_rejected_connection <- Some (current_point, timestamp) ;
(current_point, Request_rejected)
| Running {current_point; _} ->
peer_info.last_disconnection <- Some (current_point, timestamp) ;
( current_point,
if requested then Disconnection else External_disconnection )
| Disconnected ->
assert false
in
peer_info.state <- Disconnected ;
Info.log peer_info ~timestamp current_point event
src/lib_p2p/p2p_peer_state.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import P2p_peer.
Inductive t (conn conn_meta : Type) : Type :=
| Accepted : Tezos_base__TzPervasives.P2p_connection.Id.t ->
Tezos_stdlib.Lwt_canceler.t -> t conn conn_meta
| Running : conn -> conn_meta -> Tezos_base__TzPervasives.P2p_connection.Id.t ->
t conn conn_meta
| Disconnected : t conn conn_meta.
Arguments Accepted {_ _}.
Arguments Running {_ _}.
Arguments Disconnected {_ _}.
Definition state (conn conn_meta : Type) := t conn conn_meta.
Definition pp {A B : Type}
(ppf : Stdlib.Format.formatter) (function_parameter : t A B) : unit :=
match function_parameter with
| Accepted {| current_point := current_point |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "accepted " % string
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
"accepted %a" % string) P2p_connection.Id.pp current_point
| Running {| current_point := current_point |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "running " % string
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
"running %a" % string) P2p_connection.Id.pp current_point
| Disconnected =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "disconnected" % string
CamlinternalFormatBasics.End_of_format) "disconnected" % string)
end.
Module Info.
Record t {conn peer_meta conn_meta : Type} := {
peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
created : Tezos_base__TzPervasives.Time.System.t;
state : state conn conn_meta;
peer_metadata : peer_meta;
trusted : bool;
last_failed_connection :
option
(Tezos_base__TzPervasives.P2p_connection.Id.t *
Tezos_base__TzPervasives.Time.System.t);
last_rejected_connection :
option
(Tezos_base__TzPervasives.P2p_connection.Id.t *
Tezos_base__TzPervasives.Time.System.t);
last_established_connection :
option
(Tezos_base__TzPervasives.P2p_connection.Id.t *
Tezos_base__TzPervasives.Time.System.t);
last_disconnection :
option
(Tezos_base__TzPervasives.P2p_connection.Id.t *
Tezos_base__TzPervasives.Time.System.t);
events : Tezos_stdlib.Ring.t Tezos_base__TzPervasives.P2p_peer.Pool_event.t;
watchers :
Tezos_stdlib.Lwt_watcher.input
Tezos_base__TzPervasives.P2p_peer.Pool_event.t }.
Arguments t : clear implicits.
Definition peer_info (conn peer_meta conn_meta : Type) :=
t conn peer_meta conn_meta.
Definition compare {A B C D E F : Type} (gi1 : t A B C) (gi2 : t D E F) : Z :=
Id.compare (peer_id gi1) (peer_id gi2).
Definition log_size : Z := 100.
Definition create {A B C : Type}
(op_staroptstar : option Tezos_base__TzPervasives.Time.System.t)
: (option bool) -> A -> Tezos_base__TzPervasives.P2p_peer.Id.t -> t B A C :=
let created :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Systime_os.now tt
end in
fun op_staroptstar =>
let trusted :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun peer_metadata =>
fun peer_id =>
{| peer_id := peer_id; created := created; state := Disconnected;
peer_metadata := peer_metadata; trusted := trusted;
last_failed_connection := None; last_rejected_connection := None;
last_established_connection := None; last_disconnection := None;
events := Ring.create log_size;
watchers := Lwt_watcher.create_input tt |}.
Definition encoding {A B C : Type}
(peer_metadata_encoding : Tezos_base__TzPervasives.Data_encoding.encoding A)
: Tezos_base__TzPervasives.Data_encoding.encoding (t B A C) :=
conv
(fun function_parameter =>
let '{|
peer_id := peer_id;
created := created;
peer_metadata := peer_metadata;
trusted := trusted;
last_failed_connection := last_failed_connection;
last_rejected_connection := last_rejected_connection;
last_established_connection := last_established_connection;
last_disconnection := last_disconnection;
events := events
|} := function_parameter in
(peer_id, created, trusted, peer_metadata, (Ring.elements events),
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection))
(fun function_parameter =>
let
'(peer_id, created, trusted, peer_metadata, event_list,
last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection) :=
function_parameter in
let info := create None (Some trusted) peer_metadata peer_id in
let events := Ring.create log_size in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Ring.add_list (events info) event_list in
{| peer_id := peer_id; created := created; state := Disconnected;
peer_metadata := peer_metadata; trusted := trusted;
last_failed_connection := last_failed_connection;
last_rejected_connection := last_rejected_connection;
last_established_connection := last_established_connection;
last_disconnection := last_disconnection; events := events;
watchers := Lwt_watcher.create_input tt |}) None
(obj9 (req None None "peer_id" % string Id.encoding)
(req None None "created" % string Time.System.encoding)
(dft None None "trusted" % string bool false)
(req None None "peer_metadata" % string peer_metadata_encoding)
(dft None None "events" % string (list None Pool_event.encoding) [])
(opt None None "last_failed_connection" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt None None "last_rejected_connection" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt None None "last_established_connection" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding))
(opt None None "last_disconnection" % string
(tup2 P2p_connection.Id.encoding Time.System.encoding))).
Definition peer_id {A B C : Type} (function_parameter : t A B C)
: Tezos_base__TzPervasives.P2p_peer.Id.t :=
let '{| peer_id := peer_id |} := function_parameter in
peer_id.
Definition created {A B C : Type} (function_parameter : t A B C)
: Tezos_base__TzPervasives.Time.System.t :=
let '{| created := created |} := function_parameter in
created.
Definition peer_metadata {A B C : Type} (function_parameter : t A B C) : B :=
let '{| peer_metadata := peer_metadata |} := function_parameter in
peer_metadata.
Definition set_peer_metadata {A B C : Type} (gi : t A B C) (peer_metadata : B)
: unit :=
(* ❌ Set record field not handled. *)
set_record_field gi "peer_metadata" % string peer_metadata.
Definition trusted {A B C : Type} (function_parameter : t A B C) : bool :=
let '{| trusted := trusted |} := function_parameter in
trusted.
Definition set_trusted {A B C : Type} (gi : t A B C) : unit :=
(* ❌ Set record field not handled. *)
set_record_field gi "trusted" % string true.
Definition unset_trusted {A B C : Type} (gi : t A B C) : unit :=
(* ❌ Set record field not handled. *)
set_record_field gi "trusted" % string false.
Definition last_established_connection {A B C : Type} (s : t A B C)
: option
(Tezos_base__TzPervasives.P2p_connection.Id.t *
Tezos_base__TzPervasives.Time.System.t) := last_established_connection s.
Definition last_disconnection {A B C : Type} (s : t A B C)
: option
(Tezos_base__TzPervasives.P2p_connection.Id.t *
Tezos_base__TzPervasives.Time.System.t) := last_disconnection s.
Definition last_failed_connection {A B C : Type} (s : t A B C)
: option
(Tezos_base__TzPervasives.P2p_connection.Id.t *
Tezos_base__TzPervasives.Time.System.t) := last_failed_connection s.
Definition last_rejected_connection {A B C : Type} (s : t A B C)
: option
(Tezos_base__TzPervasives.P2p_connection.Id.t *
Tezos_base__TzPervasives.Time.System.t) := last_rejected_connection s.
Definition last_seen {A B C : Type} (s : t A B C)
: option
(Tezos_base__TzPervasives.P2p_connection.Id.t *
Tezos_base__TzPervasives.Time.System.t) :=
Time.System.recent (last_established_connection s)
(Time.System.recent (last_rejected_connection s) (last_disconnection s)).
Definition last_miss {A B C : Type} (s : t A B C)
: option
(Tezos_base__TzPervasives.P2p_connection.Id.t *
Tezos_base__TzPervasives.Time.System.t) :=
Time.System.recent (last_failed_connection s)
(Time.System.recent (last_rejected_connection s) (last_disconnection s)).
Definition log {A B C : Type} (function_parameter : t A B C)
: (option Tezos_base.Time.System.t) ->
Tezos_base.P2p_connection.Id.t ->
Tezos_base__TzPervasives.P2p_peer.Pool_event.kind -> unit :=
let '{| events := events; watchers := watchers |} := function_parameter in
fun op_staroptstar =>
let timestamp :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Systime_os.now tt
end in
fun point =>
fun kind =>
let event :=
{| Pool_event.kind := kind; Pool_event.timestamp := timestamp;
Pool_event.point := point |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Ring.add events event in
Lwt_watcher.notify watchers event.
Definition log_incoming_rejection {A B C : Type}
(timestamp : option Tezos_base.Time.System.t) (peer_info : t A B C)
(point : Tezos_base.P2p_connection.Id.t) : unit :=
log peer_info timestamp point
Tezos_base__TzPervasives.P2p_peer.Pool_event.Rejecting_request.
Module File.
Definition load {A B C : Type}
(path : string)
(peer_metadata_encoding :
Tezos_base__TzPervasives.Data_encoding.encoding A)
: Lwt.t (Tezos_base__TzPervasives.tzresult (list (t B A C))) :=
let enc := Data_encoding.list None (encoding peer_metadata_encoding) in
if andb (nequiv_decb path "/dev/null" % string) (Sys.file_exists path)
then
op_gtgteqquestion (Lwt_utils_unix.Json.read_file path)
(fun json => _return (Data_encoding.Json.destruct enc json))
else
return_nil.
Definition save {A B C : Type}
(path : string)
(peer_metadata_encoding :
Tezos_base__TzPervasives.Data_encoding.encoding A)
(peers : list (t B A C))
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
apply (Lwt_utils_unix.Json.write_file path)
(Json.construct (list None (encoding peer_metadata_encoding)) peers).
End File.
Definition watch {A B C : Type} (function_parameter : t A B C)
: (Lwt_stream.t Tezos_base__TzPervasives.P2p_peer.Pool_event.t) *
Tezos_stdlib.Lwt_watcher.stopper :=
let '{| watchers := watchers |} := function_parameter in
Lwt_watcher.create_stream watchers.
Definition fold {A B C D : Type} (function_parameter : t A B C)
: D -> (D -> Tezos_base__TzPervasives.P2p_peer.Pool_event.t -> D) -> D :=
let '{| events := events |} := function_parameter in
fun init => fun f => Ring.fold events init f.
End Info.
Definition get {A B C : Type} (function_parameter : Info.t A B C) : state A C :=
let '{| Info.state := state |} := function_parameter in
state.
Definition is_disconnected {A B C : Type} (function_parameter : Info.t A B C)
: bool :=
let '{| Info.state := state |} := function_parameter in
match state with
| Disconnected => true
| Accepted _ | Running _ => false
end.
Definition set_accepted {A B C : Type}
(op_staroptstar : option Tezos_base.Time.System.t)
: (Info.t A B C) ->
Tezos_base__TzPervasives.P2p_connection.Id.t ->
Tezos_stdlib.Lwt_canceler.t -> unit :=
let timestamp :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Systime_os.now tt
end in
fun peer_info =>
fun current_point =>
fun cancel =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
match Info.state peer_info with
| Accepted _ | Running _ => false
| Disconnected => true
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field peer_info "state" % string
(Accepted {| current_point := current_point; cancel := cancel |}) in
Info.log peer_info (Some timestamp) current_point
Tezos_base__TzPervasives.P2p_peer.Pool_event.Accepting_request.
Definition set_running {A B C : Type}
(op_staroptstar : option Tezos_base__TzPervasives.Time.System.t)
: (Info.t A B C) ->
Tezos_base__TzPervasives.P2p_connection.Id.t -> A -> C -> unit :=
let timestamp :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Systime_os.now tt
end in
fun peer_info =>
fun point =>
fun data =>
fun conn_metadata =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
match Info.state peer_info with
| Disconnected => true
| Running _ => false
| Accepted {| current_point := current_point |} =>
P2p_connection.Id.equal point current_point
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field peer_info "state" % string
(Running
{| data := data; conn_metadata := conn_metadata;
current_point := point |}) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field peer_info "last_established_connection" % string
(Some (point, timestamp)) in
Info.log peer_info (Some timestamp) point
Tezos_base__TzPervasives.P2p_peer.Pool_event.Connection_established.
Definition set_disconnected {A B C : Type}
(op_staroptstar : option Tezos_base.Time.System.t)
: (option bool) -> (Info.t A B C) -> unit :=
let timestamp :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Systime_os.now tt
end in
fun op_staroptstar =>
let requested :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun peer_info =>
let '(current_point, _ as event) :=
match Info.state peer_info with
| Accepted {| current_point := current_point |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field peer_info "last_rejected_connection" % string
(Some (current_point, timestamp)) in
(current_point,
Tezos_base__TzPervasives.P2p_peer.Pool_event.Request_rejected)
| Running {| current_point := current_point |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field peer_info "last_disconnection" % string
(Some (current_point, timestamp)) in
(current_point,
(if requested then
Tezos_base__TzPervasives.P2p_peer.Pool_event.Disconnection
else
Tezos_base__TzPervasives.P2p_peer.Pool_event.External_disconnection))
| Disconnected =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field peer_info "state" % string Disconnected in
Info.log peer_info (Some timestamp) current_point event.
src/lib_p2p/p2p_point_state.ml 89 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open P2p_point
type 'data t =
| Requested of {cancel : Lwt_canceler.t}
| Accepted of {current_peer_id : P2p_peer.Id.t; cancel : Lwt_canceler.t}
| Running of {data : 'data; current_peer_id : P2p_peer.Id.t}
| Disconnected
type 'data state = 'data t
let pp ppf = function
| Requested _ ->
Format.fprintf ppf "requested"
| Accepted {current_peer_id; _} ->
Format.fprintf ppf "accepted %a" P2p_peer.Id.pp current_peer_id
| Running {current_peer_id; _} ->
Format.fprintf ppf "running %a" P2p_peer.Id.pp current_peer_id
| Disconnected ->
Format.fprintf ppf "disconnected"
module Info = struct
type greylisting_config = {
factor : float;
initial_delay : Time.System.Span.t;
disconnection_delay : Time.System.Span.t;
increase_cap : Time.System.Span.t;
}
type 'data t = {
point : Id.t;
mutable trusted : bool;
mutable state : 'data state;
mutable last_failed_connection : Time.System.t option;
mutable last_rejected_connection : (P2p_peer.Id.t * Time.System.t) option;
mutable last_established_connection :
(P2p_peer.Id.t * Time.System.t) option;
mutable known_public : bool;
mutable last_disconnection : (P2p_peer.Id.t * Time.System.t) option;
mutable greylisting_delay : Time.System.Span.t;
mutable greylisting_end : Time.System.t;
events : Pool_event.t Ring.t;
watchers : Pool_event.t Lwt_watcher.input;
}
type 'data point_info = 'data t
let compare pi1 pi2 = Id.compare pi1.point pi2.point
let log_size = 100
let default_greylisting_config =
{
factor = 1.2;
initial_delay = Ptime.Span.of_int_s 1;
disconnection_delay = Ptime.Span.of_int_s 60;
increase_cap = Ptime.Span.of_int_s 172800 (* 2 days *);
}
let greylisting_config_encoding =
let open Data_encoding in
conv
(fun {factor; initial_delay; disconnection_delay; increase_cap} ->
(factor, initial_delay, disconnection_delay, increase_cap))
(fun (factor, initial_delay, disconnection_delay, increase_cap) ->
{factor; initial_delay; disconnection_delay; increase_cap})
(obj4
(dft
"factor"
~description:
"The factor by which the greylisting delay is increased when an \
already greylisted peer is greylisted again. This value should \
be set to 1 for a linear back-off and to >1 for an exponential \
back-off."
float
default_greylisting_config.factor)
(dft
"initial-delay"
~description:
"The span of time a peer is greylisted for when it is first \
greylisted."
Time.System.Span.encoding
default_greylisting_config.initial_delay)
(dft
"disconnection-delay"
~description:
"The span of time a peer is greylisted for when it is \
greylisted as the result of an abrupt disconnection."
Time.System.Span.encoding
default_greylisting_config.disconnection_delay)
(dft
"increase-cap"
~description:
"The maximum amount by which the greylisting is extended. This \
limits the rate of the exponential back-off, which eventually \
becomes linear when it reaches this limit. This limit is set \
to avoid reaching the End-of-Time when repeatedly greylisting \
a peer."
Time.System.Span.encoding
default_greylisting_config.increase_cap))
let create ?(trusted = false) addr port =
{
point = (addr, port);
trusted;
state = Disconnected;
last_failed_connection = None;
last_rejected_connection = None;
last_established_connection = None;
last_disconnection = None;
known_public = false;
events = Ring.create log_size;
greylisting_delay = Ptime.Span.of_int_s 1;
greylisting_end = Time.System.epoch;
watchers = Lwt_watcher.create_input ();
}
let point s = s.point
let trusted s = s.trusted
let set_trusted gi = gi.trusted <- true
let unset_trusted gi = gi.trusted <- false
let last_established_connection s = s.last_established_connection
let last_disconnection s = s.last_disconnection
let last_failed_connection s = s.last_failed_connection
let last_rejected_connection s = s.last_rejected_connection
let known_public s = s.known_public
let greylisted ?(now = Systime_os.now ()) s =
Time.System.compare now s.greylisting_end <= 0
let greylisted_until s = s.greylisting_end
let last_seen s =
Time.System.recent
s.last_rejected_connection
(Time.System.recent s.last_established_connection s.last_disconnection)
let last_miss s =
match
( s.last_failed_connection,
Option.map ~f:(fun (_, time) -> time)
@@ Time.System.recent s.last_rejected_connection s.last_disconnection
)
with
| (None, None) ->
None
| (None, (Some _ as a)) | ((Some _ as a), None) ->
a
| ((Some t1 as a1), (Some t2 as a2)) ->
if Time.System.compare t1 t2 < 0 then a2 else a1
let log {events; watchers; _} ?timestamp kind =
let time = Option.unopt ~default:(Systime_os.now ()) timestamp in
let event = Time.System.stamp ~time kind in
Ring.add events event ;
Lwt_watcher.notify watchers event
let log_incoming_rejection ?timestamp point_info peer_id =
log point_info ?timestamp (Rejecting_request peer_id)
let fold {events; _} ~init ~f = Ring.fold events ~init ~f
let watch {watchers; _} = Lwt_watcher.create_stream watchers
end
let get {Info.state; _} = state
let is_disconnected {Info.state; _} =
match state with
| Disconnected ->
true
| Requested _ | Accepted _ | Running _ ->
false
let set_requested ?timestamp point_info cancel =
assert (
match point_info.Info.state with
| Requested _ ->
true
| Accepted _ | Running _ ->
false
| Disconnected ->
true ) ;
point_info.state <- Requested {cancel} ;
Info.log point_info ?timestamp Outgoing_request
let set_accepted ?(timestamp = Systime_os.now ()) point_info current_peer_id
cancel =
(* log_notice "SET_ACCEPTED %a@." P2p_point.pp point_info.point ; *)
assert (
match point_info.Info.state with
| Accepted _ | Running _ ->
false
| Requested _ | Disconnected ->
true ) ;
point_info.state <- Accepted {current_peer_id; cancel} ;
Info.log point_info ~timestamp (Accepting_request current_peer_id)
let set_private point_info known_private =
point_info.Info.known_public <- not known_private
let set_running ?(timestamp = Systime_os.now ()) point_info peer_id data =
assert (
match point_info.Info.state with
| Disconnected ->
true (* request to unknown peer_id. *)
| Running _ ->
false
| Accepted {current_peer_id; _} ->
P2p_peer.Id.equal peer_id current_peer_id
| Requested _ ->
true ) ;
point_info.state <- Running {data; current_peer_id = peer_id} ;
point_info.last_established_connection <- Some (peer_id, timestamp) ;
Info.log point_info ~timestamp (Connection_established peer_id)
let maxed_time_add t s =
match Ptime.add_span t s with Some t -> t | None -> Ptime.max
let set_greylisted greylisting_config timestamp point_info =
point_info.Info.greylisting_end <-
maxed_time_add timestamp point_info.Info.greylisting_delay ;
point_info.greylisting_delay <-
(let new_delay =
Time.System.Span.multiply_exn
greylisting_config.Info.factor
point_info.greylisting_delay
in
if Ptime.Span.compare greylisting_config.Info.increase_cap new_delay > 0
then new_delay
else greylisting_config.Info.increase_cap)
let set_disconnected ?(timestamp = Systime_os.now ()) ?(requested = false)
greylisting_config point_info =
let event : Pool_event.kind =
match point_info.Info.state with
| Requested _ ->
set_greylisted greylisting_config timestamp point_info ;
point_info.last_failed_connection <- Some timestamp ;
Request_rejected None
| Accepted {current_peer_id; _} ->
set_greylisted greylisting_config timestamp point_info ;
point_info.last_rejected_connection <- Some (current_peer_id, timestamp) ;
Request_rejected (Some current_peer_id)
| Running {current_peer_id; _} ->
point_info.greylisting_delay <- greylisting_config.Info.initial_delay ;
point_info.greylisting_end <-
maxed_time_add timestamp greylisting_config.Info.disconnection_delay ;
point_info.last_disconnection <- Some (current_peer_id, timestamp) ;
if requested then Disconnection current_peer_id
else External_disconnection current_peer_id
| Disconnected ->
assert false
in
point_info.state <- Disconnected ;
Info.log point_info ~timestamp event
src/lib_p2p/p2p_point_state.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import P2p_point.
Inductive t (data : Type) : Type :=
| Requested : Tezos_stdlib.Lwt_canceler.t -> t data
| Accepted : Tezos_base__TzPervasives.P2p_peer.Id.t ->
Tezos_stdlib.Lwt_canceler.t -> t data
| Running : data -> Tezos_base__TzPervasives.P2p_peer.Id.t -> t data
| Disconnected : t data.
Arguments Requested {_}.
Arguments Accepted {_}.
Arguments Running {_}.
Arguments Disconnected {_}.
Definition state (data : Type) := t data.
Definition pp {A : Type}
(ppf : Stdlib.Format.formatter) (function_parameter : t A) : unit :=
match function_parameter with
| Requested _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "requested" % string
CamlinternalFormatBasics.End_of_format) "requested" % string)
| Accepted {| current_peer_id := current_peer_id |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "accepted " % string
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
"accepted %a" % string) P2p_peer.Id.pp current_peer_id
| Running {| current_peer_id := current_peer_id |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "running " % string
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
"running %a" % string) P2p_peer.Id.pp current_peer_id
| Disconnected =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "disconnected" % string
CamlinternalFormatBasics.End_of_format) "disconnected" % string)
end.
Module Info.
Record greylisting_config := {
factor : Z;
initial_delay : Tezos_base__TzPervasives.Time.System.Span.t;
disconnection_delay : Tezos_base__TzPervasives.Time.System.Span.t;
increase_cap : Tezos_base__TzPervasives.Time.System.Span.t }.
Record t {data : Type} := {
point : Tezos_base__TzPervasives.P2p_point.Id.t;
trusted : bool;
state : state data;
last_failed_connection : option Tezos_base__TzPervasives.Time.System.t;
last_rejected_connection :
option
(Tezos_base__TzPervasives.P2p_peer.Id.t *
Tezos_base__TzPervasives.Time.System.t);
last_established_connection :
option
(Tezos_base__TzPervasives.P2p_peer.Id.t *
Tezos_base__TzPervasives.Time.System.t);
known_public : bool;
last_disconnection :
option
(Tezos_base__TzPervasives.P2p_peer.Id.t *
Tezos_base__TzPervasives.Time.System.t);
greylisting_delay : Tezos_base__TzPervasives.Time.System.Span.t;
greylisting_end : Tezos_base__TzPervasives.Time.System.t;
events : Tezos_stdlib.Ring.t Tezos_base__TzPervasives.P2p_point.Pool_event.t;
watchers :
Tezos_stdlib.Lwt_watcher.input
Tezos_base__TzPervasives.P2p_point.Pool_event.t }.
Arguments t : clear implicits.
Definition point_info (data : Type) := t data.
Definition compare {A B : Type} (pi1 : t A) (pi2 : t B) : Z :=
Id.compare (point pi1) (point pi2).
Definition log_size : Z := 100.
Definition default_greylisting_config : greylisting_config :=
{|
factor :=
(* ❌ Float constant 1.2 is approximated by the integer 1 *)
1; initial_delay := Ptime.Span.of_int_s 1;
disconnection_delay := Ptime.Span.of_int_s 60;
increase_cap := Ptime.Span.of_int_s 172800 |}.
Definition greylisting_config_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding greylisting_config :=
conv
(fun function_parameter =>
let '{|
factor := factor;
initial_delay := initial_delay;
disconnection_delay := disconnection_delay;
increase_cap := increase_cap
|} := function_parameter in
(factor, initial_delay, disconnection_delay, increase_cap))
(fun function_parameter =>
let '(factor, initial_delay, disconnection_delay, increase_cap) :=
function_parameter in
{| factor := factor; initial_delay := initial_delay;
disconnection_delay := disconnection_delay;
increase_cap := increase_cap |}) None
(obj4
(dft None
(Some
"The factor by which the greylisting delay is increased when an already greylisted peer is greylisted again. This value should be set to 1 for a linear back-off and to >1 for an exponential back-off."
% string) "factor" % string float
(factor default_greylisting_config))
(dft None
(Some
"The span of time a peer is greylisted for when it is first greylisted."
% string) "initial-delay" % string Time.System.Span.encoding
(initial_delay default_greylisting_config))
(dft None
(Some
"The span of time a peer is greylisted for when it is greylisted as the result of an abrupt disconnection."
% string) "disconnection-delay" % string Time.System.Span.encoding
(disconnection_delay default_greylisting_config))
(dft None
(Some
"The maximum amount by which the greylisting is extended. This limits the rate of the exponential back-off, which eventually becomes linear when it reaches this limit. This limit is set to avoid reaching the End-of-Time when repeatedly greylisting a peer."
% string) "increase-cap" % string Time.System.Span.encoding
(increase_cap default_greylisting_config))).
Definition create {A : Type} (op_staroptstar : option bool)
: Tezos_base.P2p_addr.t -> Tezos_base.P2p_addr.port -> t A :=
let trusted :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun addr =>
fun port =>
{| point := (addr, port); trusted := trusted; state := Disconnected;
last_failed_connection := None; last_rejected_connection := None;
last_established_connection := None; known_public := false;
last_disconnection := None;
greylisting_delay := Ptime.Span.of_int_s 1;
greylisting_end := Time.System.epoch; events := Ring.create log_size;
watchers := Lwt_watcher.create_input tt |}.
Definition point {A : Type} (s : t A)
: Tezos_base__TzPervasives.P2p_point.Id.t := point s.
Definition trusted {A : Type} (s : t A) : bool := trusted s.
Definition set_trusted {A : Type} (gi : t A) : unit :=
(* ❌ Set record field not handled. *)
set_record_field gi "trusted" % string true.
Definition unset_trusted {A : Type} (gi : t A) : unit :=
(* ❌ Set record field not handled. *)
set_record_field gi "trusted" % string false.
Definition last_established_connection {A : Type} (s : t A)
: option
(Tezos_base__TzPervasives.P2p_peer.Id.t *
Tezos_base__TzPervasives.Time.System.t) := last_established_connection s.
Definition last_disconnection {A : Type} (s : t A)
: option
(Tezos_base__TzPervasives.P2p_peer.Id.t *
Tezos_base__TzPervasives.Time.System.t) := last_disconnection s.
Definition last_failed_connection {A : Type} (s : t A)
: option Tezos_base__TzPervasives.Time.System.t := last_failed_connection s.
Definition last_rejected_connection {A : Type} (s : t A)
: option
(Tezos_base__TzPervasives.P2p_peer.Id.t *
Tezos_base__TzPervasives.Time.System.t) := last_rejected_connection s.
Definition known_public {A : Type} (s : t A) : bool := known_public s.
Definition greylisted {A : Type}
(op_staroptstar : option Tezos_base__TzPervasives.Time.System.t)
: (t A) -> bool :=
let now :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Systime_os.now tt
end in
fun s => OCaml.Stdlib.le (Time.System.compare now (greylisting_end s)) 0.
Definition greylisted_until {A : Type} (s : t A)
: Tezos_base__TzPervasives.Time.System.t := greylisting_end s.
Definition last_seen {A : Type} (s : t A)
: option
(Tezos_base__TzPervasives.P2p_peer.Id.t *
Tezos_base__TzPervasives.Time.System.t) :=
Time.System.recent (last_rejected_connection s)
(Time.System.recent (last_established_connection s) (last_disconnection s)).
Definition last_miss {A : Type} (s : t A)
: option Tezos_base__TzPervasives.Time.System.t :=
match
((last_failed_connection s),
(apply
(Option.map
(fun function_parameter =>
let '(_, time) := function_parameter in
time))
(Time.System.recent (last_rejected_connection s)
(last_disconnection s)))) with
| (None, None) => None
| (None, (Some _) as a) | ((Some _) as a, None) => a
| ((Some t1) as a1, (Some t2) as a2) =>
if OCaml.Stdlib.lt (Time.System.compare t1 t2) 0 then
a2
else
a1
end.
Definition log {A : Type} (function_parameter : t A)
: (option Tezos_base__TzPervasives.Time.System.t) ->
Tezos_base__TzPervasives.P2p_point.Pool_event.kind -> unit :=
let '{| events := events; watchers := watchers |} := function_parameter in
fun timestamp =>
fun kind =>
let time := Option.unopt (Systime_os.now tt) timestamp in
let event := Time.System.stamp time kind in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Ring.add events event in
Lwt_watcher.notify watchers event.
Definition log_incoming_rejection {A : Type}
(timestamp : option Tezos_base__TzPervasives.Time.System.t)
(point_info : t A) (peer_id : Tezos_base.P2p_peer_id.t) : unit :=
log point_info timestamp
(Tezos_base__TzPervasives.P2p_point.Pool_event.Rejecting_request peer_id).
Definition fold {A B : Type} (function_parameter : t A)
: B -> (B -> Tezos_base__TzPervasives.P2p_point.Pool_event.t -> B) -> B :=
let '{| events := events |} := function_parameter in
fun init => fun f => Ring.fold events init f.
Definition watch {A : Type} (function_parameter : t A)
: (Lwt_stream.t Tezos_base__TzPervasives.P2p_point.Pool_event.t) *
Tezos_stdlib.Lwt_watcher.stopper :=
let '{| watchers := watchers |} := function_parameter in
Lwt_watcher.create_stream watchers.
End Info.
Definition get {A : Type} (function_parameter : Info.t A) : state A :=
let '{| Info.state := state |} := function_parameter in
state.
Definition is_disconnected {A : Type} (function_parameter : Info.t A) : bool :=
let '{| Info.state := state |} := function_parameter in
match state with
| Disconnected => true
| Requested _ | Accepted _ | Running _ => false
end.
Definition set_requested {A : Type}
(timestamp : option Tezos_base__TzPervasives.Time.System.t)
(point_info : Info.t A) (cancel : Tezos_stdlib.Lwt_canceler.t) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
match Info.state point_info with
| Requested _ => true
| Accepted _ | Running _ => false
| Disconnected => true
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field point_info "state" % string
(Requested {| cancel := cancel |}) in
Info.log point_info timestamp
Tezos_base__TzPervasives.P2p_point.Pool_event.Outgoing_request.
Definition set_accepted {A : Type}
(op_staroptstar : option Tezos_base__TzPervasives.Time.System.t)
: (Info.t A) ->
Tezos_base__TzPervasives.P2p_peer.Id.t ->
Tezos_stdlib.Lwt_canceler.t -> unit :=
let timestamp :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Systime_os.now tt
end in
fun point_info =>
fun current_peer_id =>
fun cancel =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
match Info.state point_info with
| Accepted _ | Running _ => false
| Requested _ | Disconnected => true
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field point_info "state" % string
(Accepted {| current_peer_id := current_peer_id; cancel := cancel |})
in
Info.log point_info (Some timestamp)
(Tezos_base__TzPervasives.P2p_point.Pool_event.Accepting_request
current_peer_id).
Definition set_private {A : Type} (point_info : Info.t A) (known_private : bool)
: unit :=
(* ❌ Set record field not handled. *)
set_record_field point_info "known_public" % string (negb known_private).
Definition set_running {A : Type}
(op_staroptstar : option Tezos_base__TzPervasives.Time.System.t)
: (Info.t A) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> A -> unit :=
let timestamp :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Systime_os.now tt
end in
fun point_info =>
fun peer_id =>
fun data =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
match Info.state point_info with
| Disconnected => true
| Running _ => false
| Accepted {| current_peer_id := current_peer_id |} =>
P2p_peer.Id.equal peer_id current_peer_id
| Requested _ => true
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field point_info "state" % string
(Running {| data := data; current_peer_id := peer_id |}) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field point_info "last_established_connection" % string
(Some (peer_id, timestamp)) in
Info.log point_info (Some timestamp)
(Tezos_base__TzPervasives.P2p_point.Pool_event.Connection_established
peer_id).
Definition maxed_time_add (t : Ptime.t) (s : Ptime.span) : Ptime.t :=
match Ptime.add_span t s with
| Some t => t
| None => Ptime.max
end.
Definition set_greylisted {A : Type}
(greylisting_config : Info.greylisting_config) (timestamp : Ptime.t)
(point_info : Info.t A) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field point_info "greylisting_end" % string
(maxed_time_add timestamp (Info.greylisting_delay point_info)) in
(* ❌ Set record field not handled. *)
set_record_field point_info "greylisting_delay" % string
(let new_delay :=
Time.System.Span.multiply_exn (Info.factor greylisting_config)
(greylisting_delay point_info) in
if
OCaml.Stdlib.gt
(Ptime.Span.compare (Info.increase_cap greylisting_config) new_delay) 0
then
new_delay
else
Info.increase_cap greylisting_config).
Definition set_disconnected {A : Type}
(op_staroptstar : option Tezos_base__TzPervasives.Time.System.t)
: (option bool) -> Info.greylisting_config -> (Info.t A) -> unit :=
let timestamp :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Systime_os.now tt
end in
fun op_staroptstar =>
let requested :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun greylisting_config =>
fun point_info =>
let event :=
match Info.state point_info with
| Requested _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := set_greylisted greylisting_config timestamp point_info in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field point_info "last_failed_connection" % string
(Some timestamp) in
Tezos_base__TzPervasives.P2p_point.Pool_event.Request_rejected None
| Accepted {| current_peer_id := current_peer_id |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := set_greylisted greylisting_config timestamp point_info in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field point_info "last_rejected_connection" % string
(Some (current_peer_id, timestamp)) in
Tezos_base__TzPervasives.P2p_point.Pool_event.Request_rejected
(Some current_peer_id)
| Running {| current_peer_id := current_peer_id |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field point_info "greylisting_delay" % string
(Info.initial_delay greylisting_config) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field point_info "greylisting_end" % string
(maxed_time_add timestamp
(Info.disconnection_delay greylisting_config)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field point_info "last_disconnection" % string
(Some (current_peer_id, timestamp)) in
if requested then
Tezos_base__TzPervasives.P2p_point.Pool_event.Disconnection
current_peer_id
else
Tezos_base__TzPervasives.P2p_point.Pool_event.External_disconnection
current_peer_id
| Disconnected =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field point_info "state" % string Disconnected in
Info.log point_info (Some timestamp) event.
src/lib_p2p/p2p_pool.ml 128 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* TODO Test cancellation of a (pending) connection *)
(* TODO do not recompute list_known_points at each requests... but
only once in a while, e.g. every minutes or when a point
or the associated peer_id is blacklisted. *)
(* TODO allow to track "requested peer_ids" when we reconnect to a point. *)
include Internal_event.Legacy_logging.Make (struct
let name = "p2p.pool"
end)
type config = {
identity : P2p_identity.t;
trusted_points : P2p_point.Id.t list;
peers_file : string;
private_mode : bool;
max_known_points : (int * int) option;
max_known_peer_ids : (int * int) option;
}
type 'peer peer_meta_config = {
peer_meta_encoding : 'peer Data_encoding.t;
peer_meta_initial : unit -> 'peer;
score : 'peer -> float;
}
type ('msg, 'peer, 'conn) t = {
config : config;
peer_meta_config : 'peer peer_meta_config;
(* Set of points corresponding to this peer *)
my_id_points : unit P2p_point.Table.t;
known_peer_ids :
(('msg, 'peer, 'conn) P2p_conn.t, 'peer, 'conn) P2p_peer_state.Info.t
P2p_peer.Table.t;
connected_peer_ids :
(('msg, 'peer, 'conn) P2p_conn.t, 'peer, 'conn) P2p_peer_state.Info.t
P2p_peer.Table.t;
known_points :
('msg, 'peer, 'conn) P2p_conn.t P2p_point_state.Info.t P2p_point.Table.t;
connected_points :
('msg, 'peer, 'conn) P2p_conn.t P2p_point_state.Info.t P2p_point.Table.t;
triggers : P2p_trigger.t;
log : P2p_connection.P2p_event.t -> unit;
acl : P2p_acl.t;
}
module Gc_point_set = List.Bounded (struct
type t = Time.System.t * P2p_point.Id.t
let compare (x, _) (y, _) = -Time.System.compare x y
end)
let gc_points {config = {max_known_points; _}; known_points; log; _} =
match max_known_points with
| None ->
()
| Some (_, target) ->
let current_size = P2p_point.Table.length known_points in
if current_size > target then (
let to_remove_target = current_size - target in
let now = Systime_os.now () in
(* TODO: maybe time of discovery? *)
let table = Gc_point_set.create to_remove_target in
P2p_point.Table.iter
(fun p point_info ->
if P2p_point_state.is_disconnected point_info then
let time =
match P2p_point_state.Info.last_miss point_info with
| None ->
now
| Some t ->
t
in
Gc_point_set.insert (time, p) table)
known_points ;
let to_remove = Gc_point_set.get table in
ListLabels.iter to_remove ~f:(fun (_, p) ->
P2p_point.Table.remove known_points p) ;
log Gc_points )
let register_point ?trusted pool ((addr, port) as point) =
match P2p_point.Table.find_opt pool.known_points point with
| None ->
let point_info = P2p_point_state.Info.create ?trusted addr port in
Option.iter pool.config.max_known_points ~f:(fun (max, _) ->
if P2p_point.Table.length pool.known_points >= max then
gc_points pool) ;
P2p_point.Table.add pool.known_points point point_info ;
P2p_trigger.broadcast_new_point pool.triggers ;
pool.log (New_point point) ;
point_info
| Some point_info ->
( match trusted with
| Some true ->
P2p_point_state.Info.set_trusted point_info
| Some false ->
P2p_point_state.Info.unset_trusted point_info
| None ->
() ) ;
point_info
let register_new_point ?trusted t point =
if not (P2p_point.Table.mem t.my_id_points point) then
Some (register_point ?trusted t point)
else None
(* Bounded table used to garbage collect peer_id infos when needed. The
strategy used is to remove the info of the peer_id with the lowest
score first. In case of equality, the info of the most recent added
peer_id is removed. The rationale behind this choice is that in the
case of a flood attack, the newly added infos will probably belong
to peer_ids with the same (low) score and removing the most recent ones
ensure that older (and probably legit) peer_id infos are kept. *)
module Gc_peer_set = List.Bounded (struct
type t = float * Time.System.t * P2p_peer.Id.t
let compare (s, t, _) (s', t', _) =
let score_cmp = Pervasives.compare s s' in
if score_cmp = 0 then Time.System.compare t t' else -score_cmp
end)
let gc_peer_ids
{ peer_meta_config = {score; _};
config = {max_known_peer_ids; _};
known_peer_ids;
log;
_ } =
match max_known_peer_ids with
| None ->
()
| Some (_, target) ->
let current_size = P2p_peer.Table.length known_peer_ids in
if current_size > target then (
let to_remove_target = current_size - target in
let table = Gc_peer_set.create to_remove_target in
P2p_peer.Table.iter
(fun peer_id peer_info ->
let created = P2p_peer_state.Info.created peer_info in
let score = score @@ P2p_peer_state.Info.peer_metadata peer_info in
if P2p_peer_state.is_disconnected peer_info then
Gc_peer_set.insert (score, created, peer_id) table)
known_peer_ids ;
let to_remove = Gc_peer_set.get table in
ListLabels.iter to_remove ~f:(fun (_, _, peer_id) ->
P2p_peer.Table.remove known_peer_ids peer_id) ;
log Gc_peer_ids )
let register_peer pool peer_id =
match P2p_peer.Table.find_opt pool.known_peer_ids peer_id with
| None ->
P2p_trigger.broadcast_new_peer pool.triggers ;
let peer =
P2p_peer_state.Info.create
peer_id
~peer_metadata:(pool.peer_meta_config.peer_meta_initial ())
in
Option.iter pool.config.max_known_peer_ids ~f:(fun (max, _) ->
if P2p_peer.Table.length pool.known_peer_ids >= max then
gc_peer_ids pool) ;
P2p_peer.Table.add pool.known_peer_ids peer_id peer ;
pool.log (New_peer peer_id) ;
peer
| Some peer ->
peer
(* this function duplicates bit of code from the modules below to avoid
creating mutually recursive modules *)
let connection_of_peer_id pool peer_id =
Option.apply
(P2p_peer.Table.find_opt pool.known_peer_ids peer_id)
~f:(fun p ->
match P2p_peer_state.get p with
| Running {data; _} ->
Some data
| _ ->
None)
(* Every running connection matching the point's ip address is returned. *)
let connections_of_addr pool addr =
P2p_point.Table.fold
(fun (addr', _) p acc ->
if Ipaddr.V6.compare addr addr' = 0 then
match P2p_point_state.get p with
| P2p_point_state.Running {data; _} ->
data :: acc
| _ ->
acc
else acc)
pool.connected_points
[]
let get_addr pool peer_id =
Option.map (connection_of_peer_id pool peer_id) ~f:(fun ci ->
(P2p_conn.info ci).id_point)
module Points = struct
type ('msg, 'peer, 'conn) info =
('msg, 'peer, 'conn) P2p_conn.t P2p_point_state.Info.t
let info {known_points; _} point =
P2p_point.Table.find_opt known_points point
let get_trusted pool point =
Option.unopt_map
~default:false
~f:P2p_point_state.Info.trusted
(P2p_point.Table.find_opt pool.known_points point)
let set_trusted pool point =
ignore @@ register_point ~trusted:true pool point
let unset_trusted pool point =
Option.iter
~f:P2p_point_state.Info.unset_trusted
(P2p_point.Table.find_opt pool.known_points point)
let fold_known pool ~init ~f = P2p_point.Table.fold f pool.known_points init
let fold_connected pool ~init ~f =
P2p_point.Table.fold f pool.connected_points init
let add_connected t point point_info =
P2p_point.Table.add t.connected_points point point_info
let remove_connected t point_info =
P2p_point.Table.remove
t.connected_points
(P2p_point_state.Info.point point_info)
let banned pool (addr, _port) = P2p_acl.banned_addr pool.acl addr
let ban pool (addr, _port) =
P2p_acl.IPBlacklist.add pool.acl addr ;
(* Kick [addr]:* if it is in `Running` state. *)
List.iter
(fun conn -> Lwt.async (fun () -> P2p_conn.disconnect conn))
(connections_of_addr pool addr)
let unban pool (addr, _port) = P2p_acl.unban_addr pool.acl addr
let trust pool point = unban pool point ; set_trusted pool point
let untrust pool point = unset_trusted pool point
end
module Peers = struct
type ('msg, 'peer, 'conn) info =
(('msg, 'peer, 'conn) P2p_conn.t, 'peer, 'conn) P2p_peer_state.Info.t
let info {known_peer_ids; _} peer_id =
try Some (P2p_peer.Table.find known_peer_ids peer_id)
with Not_found -> None
let get_peer_metadata pool peer_id =
try
P2p_peer_state.Info.peer_metadata
(P2p_peer.Table.find pool.known_peer_ids peer_id)
with Not_found -> pool.peer_meta_config.peer_meta_initial ()
let get_score pool peer_id =
pool.peer_meta_config.score (get_peer_metadata pool peer_id)
let set_peer_metadata pool peer_id data =
P2p_peer_state.Info.set_peer_metadata (register_peer pool peer_id) data
let get_trusted pool peer_id =
try
P2p_peer_state.Info.trusted
(P2p_peer.Table.find pool.known_peer_ids peer_id)
with Not_found -> false
let set_trusted pool peer_id =
try P2p_peer_state.Info.set_trusted (register_peer pool peer_id)
with Not_found -> ()
(* TODO can this exception occur *)
let unset_trusted pool peer_id =
try
P2p_peer_state.Info.unset_trusted
(P2p_peer.Table.find pool.known_peer_ids peer_id)
with Not_found -> ()
let fold_known pool ~init ~f = P2p_peer.Table.fold f pool.known_peer_ids init
let fold_connected pool ~init ~f =
P2p_peer.Table.fold f pool.connected_peer_ids init
let add_connected pool peer_id peer_info =
P2p_peer.Table.add pool.connected_peer_ids peer_id peer_info
let remove_connected t peer_id =
P2p_peer.Table.remove t.connected_peer_ids peer_id
let ban pool peer =
P2p_acl.PeerBlacklist.add pool.acl peer ;
(* Kick [peer] if it is in `Running` state. *)
let f conn = Lwt.async (fun () -> P2p_conn.disconnect conn) in
Option.iter (connection_of_peer_id pool peer) ~f
let unban pool peer = P2p_acl.unban_peer pool.acl peer
let trust pool peer = unban pool peer ; set_trusted pool peer
let untrust pool peer = unset_trusted pool peer
let banned pool peer = P2p_acl.banned_peer pool.acl peer
end
module Connection = struct
let fold pool ~init ~f =
Peers.fold_connected pool ~init ~f:(fun peer_id peer_info acc ->
match P2p_peer_state.get peer_info with
| Running {data; _} ->
f peer_id data acc
| _ ->
acc)
let list pool =
fold pool ~init:[] ~f:(fun peer_id c acc -> (peer_id, c) :: acc)
let random_elt l =
let n = List.length l in
let r = Random.int n in
List.nth l r
let random_addr ?different_than ~no_private pool =
let candidates =
fold pool ~init:[] ~f:(fun _peer conn acc ->
if no_private && P2p_conn.private_node conn then acc
else
match different_than with
| Some excluded_conn when P2p_conn.equal_sock conn excluded_conn ->
acc
| Some _ | None -> (
let ci = P2p_conn.info conn in
match ci.id_point with
| (_, None) ->
acc
| (addr, Some port) ->
((addr, port), ci.peer_id) :: acc ))
in
match candidates with [] -> None | _ -> Some (random_elt candidates)
(** [random_connection ?conn no_private t] returns a random connection from
the pool of connections. It ignores:
- connections to private peers if [no_private] is set to [true]
- connection [conn]
Unlike [random_addr], it may return a connection to a peer who didn't
provide a listening port *)
let random_connection ?different_than ~no_private pool =
let candidates =
fold pool ~init:[] ~f:(fun _peer conn acc ->
if no_private && P2p_conn.private_node conn then acc
else
match different_than with
| Some excluded_conn when P2p_conn.equal_sock conn excluded_conn ->
acc
| Some _ | None ->
conn :: acc)
in
match candidates with [] -> None | _ -> Some (random_elt candidates)
let propose_swap_request pool =
match random_connection ~no_private:true pool with
| Some recipient -> (
match random_addr ~different_than:recipient ~no_private:true pool with
| None ->
None
| Some (proposed_point, proposed_peer_id) ->
Some (proposed_point, proposed_peer_id, recipient) )
| None ->
None
let find_by_peer_id pool peer_id =
Option.apply (Peers.info pool peer_id) ~f:(fun p ->
match P2p_peer_state.get p with
| Running {data; _} ->
Some data
| _ ->
None)
let find_by_point pool point =
Option.apply (Points.info pool point) ~f:(fun p ->
match P2p_point_state.get p with
| Running {data; _} ->
Some data
| _ ->
None)
end
let connected_peer_ids pool = pool.connected_peer_ids
let greylist_addr pool addr =
P2p_acl.IPGreylist.add pool.acl addr (Systime_os.now ())
let greylist_peer pool peer =
Option.iter (get_addr pool peer) ~f:(fun (addr, _port) ->
greylist_addr pool addr ;
P2p_acl.PeerGreylist.add pool.acl peer)
let acl_clear pool = P2p_acl.clear pool.acl
let gc_greylist ~older_than pool =
P2p_acl.IPGreylist.remove_old ~older_than pool.acl
let config {config; _} = config
let score {peer_meta_config = {score; _}; _} meta = score meta
let active_connections pool = P2p_peer.Table.length pool.connected_peer_ids
let create config peer_meta_config triggers ~log =
let pool =
{
config;
peer_meta_config;
my_id_points = P2p_point.Table.create 7;
known_peer_ids = P2p_peer.Table.create 53;
connected_peer_ids = P2p_peer.Table.create 53;
known_points = P2p_point.Table.create 53;
connected_points = P2p_point.Table.create 53;
triggers;
acl = P2p_acl.create 1023;
log;
}
in
List.iter (Points.set_trusted pool) config.trusted_points ;
P2p_peer_state.Info.File.load
config.peers_file
peer_meta_config.peer_meta_encoding
>>= function
| Ok peer_ids ->
List.iter
(fun peer_info ->
let peer_id = P2p_peer_state.Info.peer_id peer_info in
P2p_peer.Table.add pool.known_peer_ids peer_id peer_info ;
match P2p_peer_state.Info.last_seen peer_info with
| None | Some ((_, None (* no reachable port stored*)), _) ->
()
| Some ((addr, Some port), _) ->
register_point pool (addr, port) |> ignore)
peer_ids ;
Lwt.return pool
| Error err ->
log_error "@[Failed to parse peers file:@ %a@]" pp_print_error err ;
Lwt.return pool
let destroy {config; peer_meta_config; known_peer_ids; known_points; _} =
lwt_log_info "Saving metadata in %s" config.peers_file
>>= fun () ->
P2p_peer_state.Info.File.save
config.peers_file
peer_meta_config.peer_meta_encoding
(P2p_peer.Table.fold (fun _ a b -> a :: b) known_peer_ids [])
>>= (function
| Error err ->
log_error "@[Failed to save peers file:@ %a@]" pp_print_error err ;
Lwt.return_unit
| Ok () ->
Lwt.return_unit)
>>= fun () ->
P2p_point.Table.fold
(fun _point point_info acc ->
match P2p_point_state.get point_info with
| Requested {cancel} | Accepted {cancel; _} ->
Lwt_canceler.cancel cancel >>= fun () -> acc
| Running {data = conn; _} ->
P2p_conn.disconnect conn >>= fun () -> acc
| Disconnected ->
acc)
known_points
@@ P2p_peer.Table.fold
(fun _peer_id peer_info acc ->
match P2p_peer_state.get peer_info with
| Accepted {cancel; _} ->
Lwt_canceler.cancel cancel >>= fun () -> acc
| Running {data = conn; _} ->
P2p_conn.disconnect conn >>= fun () -> acc
| Disconnected ->
acc)
known_peer_ids
Lwt.return_unit
let add_to_id_points t point =
P2p_point.Table.add t.my_id_points point () ;
P2p_point.Table.remove t.known_points point
(* [sample best other points] return a list of elements selected in [points].
The [best] first elements are taken, then [other] elements are chosen
randomly in the rest of the list.
Note that it might select fewer elements than [other] if it the same index
close to the end of the list is picked multiple times. *)
let sample best other points =
let l = List.length points in
if l <= best + other then points
else
let best_indexes = List.init best (fun i -> i) in
let other_indexes =
List.sort compare
@@ List.init other (fun _ -> best + Random.int (l - best))
in
let indexes = best_indexes @ other_indexes in
(* Note: we are doing a [fold_left_i] by hand, passing [i] manually *)
(fun (_, _, result) -> result)
@@ List.fold_left
(fun (i, indexes, acc) point ->
match indexes with
| [] ->
(0, [], acc) (* TODO: early return *)
| index :: indexes when i >= index ->
(* We compare `i >= index` (rather than `i = index`) to avoid a
corner case whereby two identical `index`es are present in the
list. In that case, using `>=` makes it so that if `i` overtakes
`index` we still pick elements. *)
(succ i, indexes, point :: acc)
| _ ->
(succ i, indexes, acc))
(0, indexes, [])
points
let compare_known_point_info p1 p2 =
(* The most-recently disconnected peers are greater. *)
(* Then come long-standing connected peers. *)
let disconnected1 = P2p_point_state.is_disconnected p1
and disconnected2 = P2p_point_state.is_disconnected p2 in
let compare_last_seen p1 p2 =
match
(P2p_point_state.Info.last_seen p1, P2p_point_state.Info.last_seen p2)
with
| (None, None) ->
(Random.int 2 * 2) - 1 (* HACK... *)
| (Some _, None) ->
1
| (None, Some _) ->
-1
| (Some (_, time1), Some (_, time2)) -> (
match compare time1 time2 with
| 0 ->
(Random.int 2 * 2) - 1 (* HACK... *)
| x ->
x )
in
match (disconnected1, disconnected2) with
| (false, false) ->
compare_last_seen p1 p2
| (false, true) ->
-1
| (true, false) ->
1
| (true, true) ->
compare_last_seen p2 p1
let list_known_points ~ignore_private pool =
P2p_point.Table.fold
(fun point_id point_info acc ->
if
(ignore_private && not (P2p_point_state.Info.known_public point_info))
|| Points.banned pool point_id
then acc
else point_info :: acc)
pool.known_points
[]
|> List.sort compare_known_point_info
|> sample 30 20
|> List.map P2p_point_state.Info.point
|> Lwt.return
src/lib_p2p/p2p_pool.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Record config := {
identity : Tezos_base__TzPervasives.P2p_identity.t;
trusted_points : list Tezos_base__TzPervasives.P2p_point.Id.t;
peers_file : string;
private_mode : bool;
max_known_points : option (Z * Z);
max_known_peer_ids : option (Z * Z) }.
Record peer_meta_config {peer : Type} := {
peer_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t peer;
peer_meta_initial : unit -> peer;
score : peer -> Z }.
Arguments peer_meta_config : clear implicits.
Record t {msg peer conn : Type} := {
config : config;
peer_meta_config : peer_meta_config peer;
my_id_points : Tezos_base__TzPervasives.P2p_point.Table.t unit;
known_peer_ids :
Tezos_base__TzPervasives.P2p_peer.Table.t
(Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t msg peer conn) peer
conn);
connected_peer_ids :
Tezos_base__TzPervasives.P2p_peer.Table.t
(Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t msg peer conn) peer
conn);
known_points :
Tezos_base__TzPervasives.P2p_point.Table.t
(Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t msg peer conn));
connected_points :
Tezos_base__TzPervasives.P2p_point.Table.t
(Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t msg peer conn));
triggers : Tezos_p2p.P2p_trigger.t;
log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit;
acl : Tezos_p2p.P2p_acl.t }.
Arguments t : clear implicits.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition gc_points {A B C : Type} (function_parameter : t A B C) : unit :=
let '{|
config := {| max_known_points := max_known_points |};
known_points := known_points;
log := log
|} := function_parameter in
match max_known_points with
| None => tt
| Some (_, target) =>
let current_size := P2p_point.Table.length known_points in
if OCaml.Stdlib.gt current_size target then
let to_remove_target := Z.sub current_size target in
let now := Systime_os.now tt in
let table := Gc_point_set.create to_remove_target in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
P2p_point.Table.iter
(fun p =>
fun point_info =>
if P2p_point_state.is_disconnected point_info then
let time :=
match P2p_point_state.Info.last_miss point_info with
| None => now
| Some t => t
end in
Gc_point_set.insert (time, p) table
else
tt) known_points in
let to_remove := Gc_point_set.get table in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
ListLabels.iter
(fun function_parameter =>
let '(_, p) := function_parameter in
P2p_point.Table.remove known_points p) to_remove in
log Tezos_base__TzPervasives.P2p_connection.P2p_event.Gc_points
else
tt
end.
Definition register_point {A B C : Type}
(trusted : option bool) (pool : t A B C)
(function_parameter : Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port)
: Tezos_p2p.P2p_point_state.Info.point_info (Tezos_p2p.P2p_conn.t A B C) :=
let '(addr, port) as point := function_parameter in
match P2p_point.Table.find_opt (known_points pool) point with
| None =>
let point_info := P2p_point_state.Info.create trusted addr port in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Option.iter
(fun function_parameter =>
let '(max, _) := function_parameter in
if OCaml.Stdlib.ge (P2p_point.Table.length (known_points pool)) max
then
gc_points pool
else
tt) (max_known_points (config pool)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_point.Table.add (known_points pool) point point_info in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_trigger.broadcast_new_point (triggers pool) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(log pool)
(Tezos_base__TzPervasives.P2p_connection.P2p_event.New_point point) in
point_info
| Some point_info =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match trusted with
| Some true => P2p_point_state.Info.set_trusted point_info
| Some false => P2p_point_state.Info.unset_trusted point_info
| None => tt
end in
point_info
end.
Definition register_new_point {A B C : Type}
(trusted : option bool) (t : t A B C)
(point : Tezos_base__TzPervasives.P2p_point.Table.key)
: option
(Tezos_p2p.P2p_point_state.Info.point_info (Tezos_p2p.P2p_conn.t A B C)) :=
if negb (P2p_point.Table.mem (my_id_points t) point) then
Some (register_point trusted t point)
else
None.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition gc_peer_ids {A B C : Type} (function_parameter : t A B C) : unit :=
let '{|
config := {| max_known_peer_ids := max_known_peer_ids |};
peer_meta_config := {| score := score |};
known_peer_ids := known_peer_ids;
log := log
|} := function_parameter in
match max_known_peer_ids with
| None => tt
| Some (_, target) =>
let current_size := P2p_peer.Table.length known_peer_ids in
if OCaml.Stdlib.gt current_size target then
let to_remove_target := Z.sub current_size target in
let table := Gc_peer_set.create to_remove_target in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
P2p_peer.Table.iter
(fun peer_id =>
fun peer_info =>
let created := P2p_peer_state.Info.created peer_info in
let score :=
apply score (P2p_peer_state.Info.peer_metadata peer_info) in
if P2p_peer_state.is_disconnected peer_info then
Gc_peer_set.insert (score, created, peer_id) table
else
tt) known_peer_ids in
let to_remove := Gc_peer_set.get table in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
ListLabels.iter
(fun function_parameter =>
let '(_, _, peer_id) := function_parameter in
P2p_peer.Table.remove known_peer_ids peer_id) to_remove in
log Tezos_base__TzPervasives.P2p_connection.P2p_event.Gc_peer_ids
else
tt
end.
Definition register_peer {A B C : Type}
(pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
: Tezos_p2p.P2p_peer_state.Info.peer_info (Tezos_p2p.P2p_conn.t A B C) B C :=
match P2p_peer.Table.find_opt (known_peer_ids pool) peer_id with
| None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_trigger.broadcast_new_peer (triggers pool) in
let peer :=
P2p_peer_state.Info.create None None
((peer_meta_initial (peer_meta_config pool)) tt) peer_id in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Option.iter
(fun function_parameter =>
let '(max, _) := function_parameter in
if OCaml.Stdlib.ge (P2p_peer.Table.length (known_peer_ids pool)) max
then
gc_peer_ids pool
else
tt) (max_known_peer_ids (config pool)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_peer.Table.add (known_peer_ids pool) peer_id peer in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(log pool)
(Tezos_base__TzPervasives.P2p_connection.P2p_event.New_peer peer_id) in
peer
| Some peer => peer
end.
Definition connection_of_peer_id {A B C : Type}
(pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
: option (Tezos_p2p.P2p_conn.t A B C) :=
Option.apply
(fun p =>
match P2p_peer_state.get p with
| Tezos_p2p.P2p_peer_state.Running {| data := data |} => Some data
| _ => None
end) (P2p_peer.Table.find_opt (known_peer_ids pool) peer_id).
Definition connections_of_addr {A B C : Type}
(pool : t A B C) (addr : Ipaddr.V6.t) : list (Tezos_p2p.P2p_conn.t A B C) :=
P2p_point.Table.fold
(fun function_parameter =>
let '(addr', _) := function_parameter in
fun p =>
fun acc =>
if equiv_decb (Ipaddr.V6.compare addr addr') 0 then
match P2p_point_state.get p with
| Tezos_p2p.P2p_point_state.Running {| data := data |} =>
cons data acc
| _ => acc
end
else
acc) (connected_points pool) [].
Definition get_addr {A B C : Type}
(pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
: option Tezos_base__P2p_connection.Id.t :=
Option.map (fun ci => id_point (P2p_conn.info ci))
(connection_of_peer_id pool peer_id).
Module Points.
Definition info (msg peer conn : Type) :=
Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t msg peer conn).
Definition info {A B C : Type} (function_parameter : t A B C)
: Tezos_base__TzPervasives.P2p_point.Table.key ->
option (Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t A B C)) :=
let '{| known_points := known_points |} := function_parameter in
fun point => P2p_point.Table.find_opt known_points point.
Definition get_trusted {A B C : Type}
(pool : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key)
: bool :=
Option.unopt_map P2p_point_state.Info.trusted false
(P2p_point.Table.find_opt (known_points pool) point).
Definition set_trusted {A B C : Type}
(pool : t A B C) (point : Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port)
: unit := apply OCaml.Stdlib.ignore (register_point (Some true) pool point).
Definition unset_trusted {A B C : Type}
(pool : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key)
: unit :=
Option.iter P2p_point_state.Info.unset_trusted
(P2p_point.Table.find_opt (known_points pool) point).
Definition fold_known {A B C D : Type}
(pool : t A B C) (init : D)
(f :
Tezos_base__TzPervasives.P2p_point.Table.key ->
(Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t A B C)) ->
D -> D) : D := P2p_point.Table.fold f (known_points pool) init.
Definition fold_connected {A B C D : Type}
(pool : t A B C) (init : D)
(f :
Tezos_base__TzPervasives.P2p_point.Table.key ->
(Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t A B C)) ->
D -> D) : D := P2p_point.Table.fold f (connected_points pool) init.
Definition add_connected {A B C : Type}
(t : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key)
(point_info : Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t A B C))
: unit := P2p_point.Table.add (connected_points t) point point_info.
Definition remove_connected {A B C D : Type}
(t : t A B C) (point_info : Tezos_p2p.P2p_point_state.Info.point_info D)
: unit :=
P2p_point.Table.remove (connected_points t)
(P2p_point_state.Info.point point_info).
Definition banned {A B C D : Type}
(pool : t A B C)
(function_parameter : Tezos_base__TzPervasives.P2p_addr.t * D) : bool :=
let '(addr, _port) := function_parameter in
P2p_acl.banned_addr (acl pool) addr.
Definition ban {A B C D : Type}
(pool : t A B C)
(function_parameter : Tezos_base__TzPervasives.P2p_addr.t * D) : unit :=
let '(addr, _port) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_acl.IPBlacklist.add (acl pool) addr in
List.iter
(fun conn =>
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
P2p_conn.disconnect None conn)) (connections_of_addr pool addr).
Definition unban {A B C D : Type}
(pool : t A B C)
(function_parameter : Tezos_base__TzPervasives.P2p_addr.t * D) : unit :=
let '(addr, _port) := function_parameter in
P2p_acl.unban_addr (acl pool) addr.
Definition trust {A B C : Type}
(pool : t A B C) (point : Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port)
: unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := unban pool point in
set_trusted pool point.
Definition untrust {A B C : Type}
(pool : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key)
: unit := unset_trusted pool point.
End Points.
Module Peers.
Definition info (msg peer conn : Type) :=
Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t msg peer conn) peer
conn.
Definition info {A B C : Type} (function_parameter : t A B C)
: Tezos_base__TzPervasives.P2p_peer.Table.key ->
option (Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t A B C) B C) :=
let '{| known_peer_ids := known_peer_ids |} := function_parameter in
fun peer_id =>
(* ❌ Try-with are not handled *)
try (Some (P2p_peer.Table.find known_peer_ids peer_id)).
Definition get_peer_metadata {A B C : Type}
(pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
: B :=
(* ❌ Try-with are not handled *)
try
(P2p_peer_state.Info.peer_metadata
(P2p_peer.Table.find (known_peer_ids pool) peer_id)).
Definition get_score {A B C : Type}
(pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
: Z := (score (peer_meta_config pool)) (get_peer_metadata pool peer_id).
Definition set_peer_metadata {A B C : Type}
(pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
(data : B) : unit :=
P2p_peer_state.Info.set_peer_metadata (register_peer pool peer_id) data.
Definition get_trusted {A B C : Type}
(pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
: bool :=
(* ❌ Try-with are not handled *)
try
(P2p_peer_state.Info.trusted
(P2p_peer.Table.find (known_peer_ids pool) peer_id)).
Definition set_trusted {A B C : Type}
(pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
: unit :=
(* ❌ Try-with are not handled *)
try (P2p_peer_state.Info.set_trusted (register_peer pool peer_id)).
Definition unset_trusted {A B C : Type}
(pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
: unit :=
(* ❌ Try-with are not handled *)
try
(P2p_peer_state.Info.unset_trusted
(P2p_peer.Table.find (known_peer_ids pool) peer_id)).
Definition fold_known {A B C D : Type}
(pool : t A B C) (init : D)
(f :
Tezos_base__TzPervasives.P2p_peer.Table.key ->
(Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t A B C) B C) ->
D -> D) : D := P2p_peer.Table.fold f (known_peer_ids pool) init.
Definition fold_connected {A B C D : Type}
(pool : t A B C) (init : D)
(f :
Tezos_base__TzPervasives.P2p_peer.Table.key ->
(Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t A B C) B C) ->
D -> D) : D := P2p_peer.Table.fold f (connected_peer_ids pool) init.
Definition add_connected {A B C : Type}
(pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
(peer_info :
Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t A B C) B C)
: unit := P2p_peer.Table.add (connected_peer_ids pool) peer_id peer_info.
Definition remove_connected {A B C : Type}
(t : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
: unit := P2p_peer.Table.remove (connected_peer_ids t) peer_id.
Definition ban {A B C : Type}
(pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_acl.PeerBlacklist.add (acl pool) peer in
let f {D E F : Type} (conn : Tezos_p2p.P2p_conn.t D E F) : unit :=
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
P2p_conn.disconnect None conn) in
Option.iter f (connection_of_peer_id pool peer).
Definition unban {A B C : Type}
(pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
P2p_acl.unban_peer (acl pool) peer.
Definition trust {A B C : Type}
(pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := unban pool peer in
set_trusted pool peer.
Definition untrust {A B C : Type}
(pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Table.key)
: unit := unset_trusted pool peer.
Definition banned {A B C : Type}
(pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : bool :=
P2p_acl.banned_peer (acl pool) peer.
End Peers.
Module Connection.
Definition fold {A B C D : Type}
(pool : t A B C) (init : D)
(f :
Tezos_base__TzPervasives.P2p_peer.Table.key ->
(Tezos_p2p.P2p_conn.t A B C) -> D -> D) : D :=
Peers.fold_connected pool init
(fun peer_id =>
fun peer_info =>
fun acc =>
match P2p_peer_state.get peer_info with
| Tezos_p2p.P2p_peer_state.Running {| data := data |} =>
f peer_id data acc
| _ => acc
end).
Definition list {A B C : Type} (pool : t A B C)
: list
(Tezos_base__TzPervasives.P2p_peer.Table.key *
(Tezos_p2p.P2p_conn.t A B C)) :=
fold pool [] (fun peer_id => fun c => fun acc => cons (peer_id, c) acc).
Definition random_elt {A : Type} (l : list A) : A :=
let n := List.length l in
let r := Random.int n in
List.nth l r.
Definition random_addr {A B C : Type}
(different_than : option (Tezos_p2p.P2p_conn.t A B C)) (no_private : bool)
(pool : t A B C)
: option
((Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port) *
Tezos_base.P2p_peer_id.t) :=
let candidates :=
fold pool []
(fun _peer =>
fun conn =>
fun acc =>
if andb no_private (P2p_conn.private_node conn) then
acc
else
match different_than with
| Some excluded_conn => acc
| Some _ | None =>
let ci := P2p_conn.info conn in
match id_point ci with
| (_, None) => acc
| (addr, Some port) => cons ((addr, port), (peer_id ci)) acc
end
end) in
match candidates with
| [] => None
| _ => Some (random_elt candidates)
end.
Definition random_connection {A B C : Type}
(different_than : option (Tezos_p2p.P2p_conn.t A B C)) (no_private : bool)
(pool : t A B C) : option (Tezos_p2p.P2p_conn.t A B C) :=
let candidates :=
fold pool []
(fun _peer =>
fun conn =>
fun acc =>
if andb no_private (P2p_conn.private_node conn) then
acc
else
match different_than with
| Some excluded_conn => acc
| Some _ | None => cons conn acc
end) in
match candidates with
| [] => None
| _ => Some (random_elt candidates)
end.
Definition propose_swap_request {A B C : Type} (pool : t A B C)
: option
((Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port) *
Tezos_base.P2p_peer_id.t * (Tezos_p2p.P2p_conn.t A B C)) :=
match random_connection None true pool with
| Some recipient =>
match random_addr (Some recipient) true pool with
| None => None
| Some (proposed_point, proposed_peer_id) =>
Some (proposed_point, proposed_peer_id, recipient)
end
| None => None
end.
Definition find_by_peer_id {A B C : Type}
(pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
: option (Tezos_p2p.P2p_conn.t A B C) :=
Option.apply
(fun p =>
match P2p_peer_state.get p with
| Tezos_p2p.P2p_peer_state.Running {| data := data |} => Some data
| _ => None
end) (Peers.info pool peer_id).
Definition find_by_point {A B C : Type}
(pool : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key)
: option (Tezos_p2p.P2p_conn.t A B C) :=
Option.apply
(fun p =>
match P2p_point_state.get p with
| Tezos_p2p.P2p_point_state.Running {| data := data |} => Some data
| _ => None
end) (Points.info pool point).
End Connection.
Definition connected_peer_ids {A B C : Type} (pool : t A B C)
: Tezos_base__TzPervasives.P2p_peer.Table.t
(Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t A B C) B C) :=
connected_peer_ids pool.
Definition greylist_addr {A B C : Type}
(pool : t A B C) (addr : Tezos_base__TzPervasives.P2p_addr.t) : unit :=
P2p_acl.IPGreylist.add (acl pool) addr (Systime_os.now tt).
Definition greylist_peer {A B C : Type}
(pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
Option.iter
(fun function_parameter =>
let '(addr, _port) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := greylist_addr pool addr in
P2p_acl.PeerGreylist.add (acl pool) peer) (get_addr pool peer).
Definition acl_clear {A B C : Type} (pool : t A B C) : unit :=
P2p_acl.clear (acl pool).
Definition gc_greylist {A B C : Type}
(older_than : Tezos_base__TzPervasives.Time.System.t) (pool : t A B C)
: unit := P2p_acl.IPGreylist.remove_old (acl pool) older_than.
Definition config {A B C : Type} (function_parameter : t A B C) : config :=
let '{| config := config |} := function_parameter in
config.
Definition score {A B C : Type} (function_parameter : t A B C) : B -> Z :=
let '{| peer_meta_config := {| score := score |} |} := function_parameter in
fun meta => score meta.
Definition active_connections {A B C : Type} (pool : t A B C) : Z :=
P2p_peer.Table.length (connected_peer_ids pool).
Definition create {A B C : Type}
(config : config) (peer_meta_config : peer_meta_config A)
(triggers : Tezos_p2p.P2p_trigger.t)
(log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit)
: Lwt.t (t B A C) :=
let pool :=
{| config := config; peer_meta_config := peer_meta_config;
my_id_points := P2p_point.Table.create 7;
known_peer_ids := P2p_peer.Table.create 53;
connected_peer_ids := P2p_peer.Table.create 53;
known_points := P2p_point.Table.create 53;
connected_points := P2p_point.Table.create 53; triggers := triggers;
log := log; acl := P2p_acl.create 1023 |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter (Points.set_trusted pool) (trusted_points config) in
op_gtgteq
(P2p_peer_state.Info.File.load (peers_file config)
(peer_meta_encoding peer_meta_config))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok peer_ids =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun peer_info =>
let peer_id := P2p_peer_state.Info.peer_id peer_info in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
P2p_peer.Table.add (known_peer_ids pool) peer_id peer_info in
match P2p_peer_state.Info.last_seen peer_info with
| None | Some ((_, None), _) => tt
| Some ((addr, Some port), _) =>
OCaml.Stdlib.reverse_apply
(register_point None pool (addr, port)) OCaml.Stdlib.ignore
end) peer_ids in
Lwt._return pool
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Failed to parse peers file:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Failed to parse peers file:@ %a@]" % string) pp_print_error err
in
Lwt._return pool
end).
Definition destroy {A B C : Type} (function_parameter : t A B C) : Lwt.t unit :=
let '{|
config := config;
peer_meta_config := peer_meta_config;
known_peer_ids := known_peer_ids;
known_points := known_points
|} := function_parameter in
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Saving metadata in " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Saving metadata in %s" % string) (peers_file config))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtgteq
(P2p_peer_state.Info.File.save (peers_file config)
(peer_meta_encoding peer_meta_config)
(P2p_peer.Table.fold
(fun function_parameter =>
let '_ := function_parameter in
fun a => fun b => cons a b) known_peer_ids []))
(fun function_parameter =>
match function_parameter with
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Failed to save peers file:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Failed to save peers file:@ %a@]" % string)
pp_print_error err in
Lwt.return_unit
| Stdlib.Ok tt => Lwt.return_unit
end))
(fun function_parameter =>
let 'tt := function_parameter in
apply
(P2p_point.Table.fold
(fun _point =>
fun point_info =>
fun acc =>
match P2p_point_state.get point_info with
|
Tezos_p2p.P2p_point_state.Requested {| cancel := cancel |}
|
Tezos_p2p.P2p_point_state.Accepted {|
cancel := cancel |} =>
op_gtgteq (Lwt_canceler.cancel cancel)
(fun function_parameter =>
let 'tt := function_parameter in
acc)
| Tezos_p2p.P2p_point_state.Running {| data := conn |} =>
op_gtgteq (P2p_conn.disconnect None conn)
(fun function_parameter =>
let 'tt := function_parameter in
acc)
| Tezos_p2p.P2p_point_state.Disconnected => acc
end) known_points)
(P2p_peer.Table.fold
(fun _peer_id =>
fun peer_info =>
fun acc =>
match P2p_peer_state.get peer_info with
| Tezos_p2p.P2p_peer_state.Accepted {| cancel := cancel |}
=>
op_gtgteq (Lwt_canceler.cancel cancel)
(fun function_parameter =>
let 'tt := function_parameter in
acc)
| Tezos_p2p.P2p_peer_state.Running {| data := conn |} =>
op_gtgteq (P2p_conn.disconnect None conn)
(fun function_parameter =>
let 'tt := function_parameter in
acc)
| Tezos_p2p.P2p_peer_state.Disconnected => acc
end) known_peer_ids Lwt.return_unit))).
Definition add_to_id_points {A B C : Type}
(t : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_point.Table.add (my_id_points t) point tt in
P2p_point.Table.remove (known_points t) point.
Definition sample {A : Type} (best : Z) (other : Z) (points : list A)
: list A :=
let l := List.length points in
if OCaml.Stdlib.le l (Z.add best other) then
points
else
let best_indexes := List.init best (fun i => i) in
let other_indexes :=
apply (List.sort OCaml.Stdlib.compare)
(List.init other
(fun function_parameter =>
let '_ := function_parameter in
Z.add best (Random.int (Z.sub l best)))) in
let indexes := OCaml.Stdlib.app best_indexes other_indexes in
apply
(fun function_parameter =>
let '(_, _, result) := function_parameter in
result)
(List.fold_left
(fun function_parameter =>
let '(i, indexes, acc) := function_parameter in
fun point =>
match indexes with
| [] => (0, [], acc)
| cons index indexes => ((Z.succ i), indexes, (cons point acc))
| _ => ((Z.succ i), indexes, acc)
end) (0, indexes, []) points).
Definition compare_known_point_info {A B : Type}
(p1 : Tezos_p2p.P2p_point_state.Info.t A)
(p2 : Tezos_p2p.P2p_point_state.Info.t B) : Z :=
let disconnected1 : bool :=
P2p_point_state.is_disconnected p1
with disconnected2 : bool :=
P2p_point_state.is_disconnected p2 in
let compare_last_seen {C D : Type}
(p1 : Tezos_p2p.P2p_point_state.Info.point_info C) (p2 :
Tezos_p2p.P2p_point_state.Info.point_info D) : Z :=
match
((P2p_point_state.Info.last_seen p1), (P2p_point_state.Info.last_seen p2))
with
| (None, None) => Z.sub (Z.mul (Random.int 2) 2) 1
| (Some _, None) => 1
| (None, Some _) => (-1)
| (Some (_, time1), Some (_, time2)) =>
match OCaml.Stdlib.compare time1 time2 with
| 0 => Z.sub (Z.mul (Random.int 2) 2) 1
| x => x
end
end in
match (disconnected1, disconnected2) with
| (false, false) => compare_last_seen p1 p2
| (false, true) => (-1)
| (true, false) => 1
| (true, true) => compare_last_seen p2 p1
end.
Definition list_known_points {A B C : Type}
(ignore_private : bool) (pool : t A B C)
: Lwt.t (list Tezos_base__TzPervasives.P2p_point.Id.t) :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(P2p_point.Table.fold
(fun point_id =>
fun point_info =>
fun acc =>
if
orb
(andb ignore_private
(negb (P2p_point_state.Info.known_public point_info)))
(Points.banned pool point_id) then
acc
else
cons point_info acc) (known_points pool) [])
(List.sort compare_known_point_info)) (sample 30 20))
(List.map P2p_point_state.Info.point)) Lwt._return.
src/lib_p2p/p2p_protocol.ml 36 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make (struct
let name = "p2p.protocol"
end)
type ('msg, 'peer, 'conn) config = {
swap_linger : Time.System.Span.t;
pool : ('msg, 'peer, 'conn) P2p_pool.t;
log : P2p_connection.P2p_event.t -> unit;
connect : P2p_point.Id.t -> ('msg, 'peer, 'conn) P2p_conn.t tzresult Lwt.t;
mutable latest_accepted_swap : Time.System.t;
mutable latest_successful_swap : Time.System.t;
}
let private_node_warn fmt =
Format.kasprintf (fun s -> lwt_warn "[private node] %s" s) fmt
open P2p_answerer
let message conn _request size msg = Lwt_pipe.push conn.messages (size, msg)
module Private_answerer = struct
let advertise conn _request _points =
private_node_warn
"Received new peers addresses from %a"
P2p_peer.Id.pp
conn.peer_id
let bootstrap conn _request =
private_node_warn
"Receive requests for peers addresses from %a"
P2p_peer.Id.pp
conn.peer_id
>>= fun () -> Lwt.return_nil
let swap_request conn _request _new_point _peer =
private_node_warn
"Received swap requests from %a"
P2p_peer.Id.pp
conn.peer_id
let swap_ack conn _request _point _peer_id =
private_node_warn "Received swap ack from %a" P2p_peer.Id.pp conn.peer_id
let create conn =
P2p_answerer.
{
message = message conn;
advertise = advertise conn;
bootstrap = bootstrap conn;
swap_request = swap_request conn;
swap_ack = swap_ack conn;
}
end
module Default_answerer = struct
open P2p_connection.P2p_event
let advertise config _conn _request points =
let f point = P2p_pool.register_new_point config.pool point |> ignore in
List.iter f points ; Lwt.return_unit
let bootstrap config conn _request_info =
if conn.is_private then
private_node_warn
"Private peer (%a) asked other peers addresses"
P2p_peer.Id.pp
conn.peer_id
>>= fun () -> Lwt.return_nil
else P2p_pool.list_known_points ~ignore_private:true config.pool
let swap t pool source_peer_id ~connect current_peer_id new_point =
t.latest_accepted_swap <- Systime_os.now () ;
connect new_point
>>= function
| Ok _new_conn -> (
t.latest_successful_swap <- Systime_os.now () ;
t.log (Swap_success {source = source_peer_id}) ;
lwt_log_info "Swap to %a succeeded" P2p_point.Id.pp new_point
>>= fun () ->
match P2p_pool.Connection.find_by_peer_id pool current_peer_id with
| None ->
Lwt.return_unit
| Some conn ->
P2p_conn.disconnect conn )
| Error err -> (
t.latest_accepted_swap <- t.latest_successful_swap ;
t.log (Swap_failure {source = source_peer_id}) ;
match err with
| [Timeout] ->
lwt_debug
"Swap to %a was interrupted: %a"
P2p_point.Id.pp
new_point
pp_print_error
err
| _ ->
lwt_log_error
"Swap to %a failed: %a"
P2p_point.Id.pp
new_point
pp_print_error
err )
let swap_ack config conn request new_point _peer =
let source_peer_id = conn.peer_id in
let pool = config.pool in
let connect = config.connect in
let log = config.log in
log (Swap_ack_received {source = source_peer_id}) ;
lwt_log_info "Swap ack received from %a" P2p_peer.Id.pp source_peer_id
>>= fun () ->
match request.last_sent_swap_request with
| None ->
Lwt.return_unit (* ignore *)
| Some (_time, proposed_peer_id) -> (
match P2p_pool.Connection.find_by_peer_id pool proposed_peer_id with
| None ->
swap config pool source_peer_id ~connect proposed_peer_id new_point
>>= fun () -> Lwt.return_unit
| Some _ ->
Lwt.return_unit )
let swap_request config conn _request new_point _peer =
let source_peer_id = conn.peer_id in
let pool = config.pool in
let swap_linger = config.swap_linger in
let connect = config.connect in
let log = config.log in
log (Swap_request_received {source = source_peer_id}) ;
lwt_log_info "Swap request received from %a" P2p_peer.Id.pp source_peer_id
>>= fun () ->
(* Ignore if already connected to peer or already swapped less
than <swap_linger> seconds ago. *)
let span_since_last_swap =
Ptime.diff
(Systime_os.now ())
(Time.System.max
config.latest_successful_swap
config.latest_accepted_swap)
in
let new_point_info = P2p_pool.register_point pool new_point in
if
Ptime.Span.compare span_since_last_swap swap_linger < 0
|| not (P2p_point_state.is_disconnected new_point_info)
then (
log (Swap_request_ignored {source = source_peer_id}) ;
lwt_log_info
"Ignoring swap request from %a"
P2p_peer.Id.pp
source_peer_id )
else
match P2p_pool.Connection.random_addr pool ~no_private:true with
| None ->
lwt_log_info "No swap candidate for %a" P2p_peer.Id.pp source_peer_id
| Some (proposed_point, proposed_peer_id) -> (
match conn.write_swap_ack proposed_point proposed_peer_id with
| Ok true ->
log (Swap_ack_sent {source = source_peer_id}) ;
swap config pool source_peer_id ~connect proposed_peer_id new_point
>>= fun () -> Lwt.return_unit
| Ok false ->
log (Swap_request_received {source = source_peer_id}) ;
Lwt.return_unit
| Error _ ->
log (Swap_request_received {source = source_peer_id}) ;
Lwt.return_unit )
let create config conn =
P2p_answerer.
{
message = message conn;
advertise = advertise config conn;
bootstrap = bootstrap config conn;
swap_request = swap_request config conn;
swap_ack = swap_ack config conn;
}
end
let create_default = Default_answerer.create
let create_private () = Private_answerer.create
src/lib_p2p/p2p_protocol.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Record config {msg peer conn : Type} := {
swap_linger : Tezos_base__TzPervasives.Time.System.Span.t;
pool : Tezos_p2p.P2p_pool.t msg peer conn;
log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit;
connect :
Tezos_base__TzPervasives.P2p_point.Id.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult (Tezos_p2p.P2p_conn.t msg peer conn));
latest_accepted_swap : Tezos_base__TzPervasives.Time.System.t;
latest_successful_swap : Tezos_base__TzPervasives.Time.System.t }.
Arguments config : clear implicits.
Definition private_node_warn {A : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
Format.kasprintf
(fun s =>
lwt_warn
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "[private node] " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"[private node] %s" % string) s) fmt.
Import P2p_answerer.
Definition message {A B : Type}
(conn : Tezos_p2p.P2p_answerer.conn_info A) (_request : B) (size : Z)
(msg : A) : Lwt.t unit := Lwt_pipe.push (messages conn) (size, msg).
Module Private_answerer.
Definition advertise {A B C : Type}
(conn : Tezos_p2p.P2p_answerer.conn_info A) (_request : B) (_points : C)
: Lwt.t unit :=
private_node_warn
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Received new peers addresses from " % string
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
"Received new peers addresses from %a" % string) P2p_peer.Id.pp
(peer_id conn).
Definition bootstrap {A B C : Type}
(conn : Tezos_p2p.P2p_answerer.conn_info A) (_request : B)
: Lwt.t (list C) :=
op_gtgteq
(private_node_warn
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Receive requests for peers addresses from " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Receive requests for peers addresses from %a" % string)
P2p_peer.Id.pp (peer_id conn))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_nil).
Definition swap_request {A B C D : Type}
(conn : Tezos_p2p.P2p_answerer.conn_info A) (_request : B) (_new_point : C)
(_peer : D) : Lwt.t unit :=
private_node_warn
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Received swap requests from " % string
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
"Received swap requests from %a" % string) P2p_peer.Id.pp (peer_id conn).
Definition swap_ack {A B C D : Type}
(conn : Tezos_p2p.P2p_answerer.conn_info A) (_request : B) (_point : C)
(_peer_id : D) : Lwt.t unit :=
private_node_warn
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Received swap ack from " % string
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
"Received swap ack from %a" % string) P2p_peer.Id.pp (peer_id conn).
Definition create {A : Type} (conn : Tezos_p2p.P2p_answerer.conn_info A)
: Tezos_p2p.P2p_answerer.callback A :=
{| bootstrap := bootstrap conn; advertise := advertise conn;
message := message conn; swap_request := swap_request conn;
swap_ack := swap_ack conn |}.
End Private_answerer.
Module Default_answerer.
Import P2p_connection.P2p_event.
Definition advertise {A B C D E : Type}
(config : config A B C) (_conn : D) (_request : E)
(points : list Tezos_base__TzPervasives.P2p_point.Id.t) : Lwt.t unit :=
let f (point : Tezos_base__TzPervasives.P2p_point.Id.t) : unit :=
OCaml.Stdlib.reverse_apply
(P2p_pool.register_new_point None (pool config) point)
OCaml.Stdlib.ignore in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter f points in
Lwt.return_unit.
Definition bootstrap {A B C D E : Type}
(config : config A B C) (conn : Tezos_p2p.P2p_answerer.conn_info D)
(_request_info : E)
: Lwt.t (list Tezos_base__TzPervasives.P2p_point.Id.t) :=
if is_private conn then
op_gtgteq
(private_node_warn
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Private peer (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
") asked other peers addresses" % string
CamlinternalFormatBasics.End_of_format)))
"Private peer (%a) asked other peers addresses" % string)
P2p_peer.Id.pp (peer_id conn))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_nil)
else
P2p_pool.list_known_points true (pool config).
Definition swap {A B C D E F G : Type}
(t : config A B C) (pool : Tezos_p2p__P2p_pool.t D E F)
(source_peer_id : Tezos_base.P2p_peer_id.t)
(connect :
Tezos_base__TzPervasives.P2p_point.Id.t ->
Lwt.t (sum G Tezos_base__TzPervasives.trace))
(current_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
(new_point : Tezos_base__TzPervasives.P2p_point.Id.t) : Lwt.t unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field t "latest_accepted_swap" % string (Systime_os.now tt) in
op_gtgteq (connect new_point)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok _new_conn =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field t "latest_successful_swap" % string
(Systime_os.now tt) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(log t)
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_success
{| source := source_peer_id |}) in
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Swap to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" succeeded" % string
CamlinternalFormatBasics.End_of_format)))
"Swap to %a succeeded" % string) P2p_point.Id.pp new_point)
(fun function_parameter =>
let 'tt := function_parameter in
match P2p_pool.Connection.find_by_peer_id pool current_peer_id
with
| None => Lwt.return_unit
| Some conn => P2p_conn.disconnect None conn
end)
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field t "latest_accepted_swap" % string
(latest_successful_swap t) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(log t)
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_failure
{| source := source_peer_id |}) in
match err with
| cons Tezos_base__TzPervasives.Timeout [] =>
lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Swap to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" was interrupted: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Swap to %a was interrupted: %a" % string) P2p_point.Id.pp
new_point pp_print_error err
| _ =>
lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Swap to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" failed: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Swap to %a failed: %a" % string) P2p_point.Id.pp new_point
pp_print_error err
end
end).
Definition swap_ack {A B C D E : Type}
(config : config A B C) (conn : Tezos_p2p.P2p_answerer.conn_info D)
(request : Tezos_p2p.P2p_answerer.request_info)
(new_point : Tezos_base__TzPervasives.P2p_point.Id.t) (_peer : E)
: Lwt.t unit :=
let source_peer_id := peer_id conn in
let pool := pool config in
let connect := connect config in
let log := log config in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_ack_received
{| source := source_peer_id |}) in
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Swap ack received from " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Swap ack received from %a" % string) P2p_peer.Id.pp source_peer_id)
(fun function_parameter =>
let 'tt := function_parameter in
match last_sent_swap_request request with
| None => Lwt.return_unit
| Some (_time, proposed_peer_id) =>
match P2p_pool.Connection.find_by_peer_id pool proposed_peer_id with
| None =>
op_gtgteq
(swap config pool source_peer_id connect proposed_peer_id
new_point)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_unit)
| Some _ => Lwt.return_unit
end
end).
Definition swap_request {A B C D E F : Type}
(config : config A B C) (conn : Tezos_p2p.P2p_answerer.conn_info D)
(_request : E) (new_point : Tezos_base__TzPervasives.P2p_point.Id.t)
(_peer : F) : Lwt.t unit :=
let source_peer_id := peer_id conn in
let pool := pool config in
let swap_linger := swap_linger config in
let connect := connect config in
let log := log config in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_request_received
{| source := source_peer_id |}) in
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Swap request received from " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Swap request received from %a" % string) P2p_peer.Id.pp
source_peer_id)
(fun function_parameter =>
let 'tt := function_parameter in
let span_since_last_swap :=
Ptime.diff (Systime_os.now tt)
(Time.System.max (latest_successful_swap config)
(latest_accepted_swap config)) in
let new_point_info := P2p_pool.register_point None pool new_point in
if
orb
(OCaml.Stdlib.lt
(Ptime.Span.compare span_since_last_swap swap_linger) 0)
(negb (P2p_point_state.is_disconnected new_point_info)) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_request_ignored
{| source := source_peer_id |}) in
lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Ignoring swap request from " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Ignoring swap request from %a" % string) P2p_peer.Id.pp
source_peer_id
else
match P2p_pool.Connection.random_addr None true pool with
| None =>
lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No swap candidate for " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"No swap candidate for %a" % string) P2p_peer.Id.pp
source_peer_id
| Some (proposed_point, proposed_peer_id) =>
match (write_swap_ack conn) proposed_point proposed_peer_id with
| Stdlib.Ok true =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_ack_sent
{| source := source_peer_id |}) in
op_gtgteq
(swap config pool source_peer_id connect proposed_peer_id
new_point)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_unit)
| Stdlib.Ok false =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_request_received
{| source := source_peer_id |}) in
Lwt.return_unit
| Stdlib.Error _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log
(Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_request_received
{| source := source_peer_id |}) in
Lwt.return_unit
end
end).
Definition create {A B C D : Type}
(config : config A B C) (conn : Tezos_p2p.P2p_answerer.conn_info D)
: Tezos_p2p.P2p_answerer.callback D :=
{| bootstrap := bootstrap config conn; advertise := advertise config conn;
message := message conn; swap_request := swap_request config conn;
swap_ack := swap_ack config conn |}.
End Default_answerer.
Definition create_default {A B C D : Type}
: (config A B C) ->
(Tezos_p2p.P2p_answerer.conn_info D) -> Tezos_p2p.P2p_answerer.callback D :=
Default_answerer.create.
Definition create_private {A : Type} (function_parameter : unit)
: (Tezos_p2p.P2p_answerer.conn_info A) -> Tezos_p2p.P2p_answerer.callback A :=
let 'tt := function_parameter in
Private_answerer.create.
src/lib_p2p/p2p_socket.ml 58 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* TODO test `close ~wait:true`. *)
include Internal_event.Legacy_logging.Make (struct
let name = "p2p.connection"
end)
module Crypto = struct
(* maximal size of the buffer *)
let bufsize = (1 lsl 16) - 1
let header_length = 2
let max_content_length = bufsize - Crypto_box.zerobytes
(* The size of extra data added by encryption. *)
let boxextrabytes = Crypto_box.zerobytes - Crypto_box.boxzerobytes
(* The number of bytes added by encryption + header *)
let extrabytes = header_length + boxextrabytes
type data = {
channel_key : Crypto_box.channel_key;
mutable local_nonce : Crypto_box.nonce;
mutable remote_nonce : Crypto_box.nonce;
}
(* We do the following assumptions on the NaCl library. Note that
we also make the assumption, here, that the NaCl library allows
in-place boxing and unboxing, since we use the same buffer for
input and output. *)
let () = assert (Crypto_box.boxzerobytes >= header_length)
let write_chunk ?canceler fd cryptobox_data msg =
let msglen = Bytes.length msg in
fail_unless (msglen <= max_content_length) P2p_errors.Invalid_message_size
>>=? fun () ->
let buf_length = msglen + Crypto_box.zerobytes in
let buf = Bytes.make buf_length '\x00' in
Bytes.blit msg 0 buf Crypto_box.zerobytes msglen ;
let local_nonce = cryptobox_data.local_nonce in
cryptobox_data.local_nonce <- Crypto_box.increment_nonce local_nonce ;
Crypto_box.fast_box_noalloc cryptobox_data.channel_key local_nonce buf ;
let encrypted_length = buf_length - Crypto_box.boxzerobytes in
let header_pos = Crypto_box.boxzerobytes - header_length in
TzEndian.set_int16 buf header_pos encrypted_length ;
let payload = Bytes.sub buf header_pos (buf_length - header_pos) in
P2p_io_scheduler.write ?canceler fd payload
let read_chunk ?canceler fd cryptobox_data =
let header_buf = Bytes.create header_length in
P2p_io_scheduler.read_full ?canceler ~len:header_length fd header_buf
>>=? fun () ->
let encrypted_length = TzEndian.get_uint16 header_buf 0 in
let buf_length = encrypted_length + Crypto_box.boxzerobytes in
let buf = Bytes.make buf_length '\x00' in
P2p_io_scheduler.read_full
?canceler
~pos:Crypto_box.boxzerobytes
~len:encrypted_length
fd
buf
>>=? fun () ->
let remote_nonce = cryptobox_data.remote_nonce in
cryptobox_data.remote_nonce <- Crypto_box.increment_nonce remote_nonce ;
match
Crypto_box.fast_box_open_noalloc
cryptobox_data.channel_key
remote_nonce
buf
with
| false ->
fail P2p_errors.Decipher_error
| true ->
return
(Bytes.sub
buf
Crypto_box.zerobytes
(buf_length - Crypto_box.zerobytes))
end
(* Note: there is an inconsistency here, since we display an error in
bytes, whereas the option is set in kbytes. Also, since the default
size is 64kB-1, it is actually impossible to set the default
size using the option (the max is 63 kB). *)
let check_binary_chunks_size size =
let value = size - Crypto.extrabytes in
fail_unless
(value > 0 && value <= Crypto.max_content_length)
(P2p_errors.Invalid_chunks_size
{value = size; min = Crypto.extrabytes + 1; max = Crypto.bufsize})
module Connection_message = struct
type t = {
port : int option;
public_key : Crypto_box.public_key;
proof_of_work_stamp : Crypto_box.nonce;
message_nonce : Crypto_box.nonce;
version : Network_version.t;
}
let encoding =
let open Data_encoding in
conv
(fun {port; public_key; proof_of_work_stamp; message_nonce; version} ->
let port = match port with None -> 0 | Some port -> port in
(port, public_key, proof_of_work_stamp, message_nonce, version))
(fun (port, public_key, proof_of_work_stamp, message_nonce, version) ->
let port = if port = 0 then None else Some port in
{port; public_key; proof_of_work_stamp; message_nonce; version})
(obj5
(req "port" uint16)
(req "pubkey" Crypto_box.public_key_encoding)
(req "proof_of_work_stamp" Crypto_box.nonce_encoding)
(req "message_nonce" Crypto_box.nonce_encoding)
(req "version" Network_version.encoding))
let write ~canceler fd message =
let encoded_message_len = Data_encoding.Binary.length encoding message in
fail_unless
(encoded_message_len < 1 lsl (Crypto.header_length * 8))
P2p_errors.Encoding_error
>>=? fun () ->
let len = Crypto.header_length + encoded_message_len in
let buf = Bytes.create len in
match
Data_encoding.Binary.write encoding message buf Crypto.header_length len
with
| None ->
fail P2p_errors.Encoding_error
| Some last ->
fail_unless (last = len) P2p_errors.Encoding_error
>>=? fun () ->
TzEndian.set_int16 buf 0 encoded_message_len ;
P2p_io_scheduler.write ~canceler fd buf
>>=? fun () ->
(* We return the raw message as it is used later to compute
the nonces *)
return buf
let read ~canceler fd =
let header_buf = Bytes.create Crypto.header_length in
P2p_io_scheduler.read_full
~canceler
~len:Crypto.header_length
fd
header_buf
>>=? fun () ->
let len = TzEndian.get_uint16 header_buf 0 in
let pos = Crypto.header_length in
let buf = Bytes.create (pos + len) in
TzEndian.set_int16 buf 0 len ;
P2p_io_scheduler.read_full ~canceler ~len ~pos fd buf
>>=? fun () ->
match Data_encoding.Binary.read encoding buf pos len with
| None ->
fail P2p_errors.Decoding_error
| Some (next_pos, message) ->
if next_pos <> pos + len then fail P2p_errors.Decoding_error
else return (message, buf)
end
type 'meta metadata_config = {
conn_meta_encoding : 'meta Data_encoding.t;
conn_meta_value : P2p_peer.Id.t -> 'meta;
private_node : 'meta -> bool;
}
module Metadata = struct
let write ~canceler metadata_config cryptobox_data fd message =
let encoded_message_len =
Data_encoding.Binary.length metadata_config.conn_meta_encoding message
in
let buf = Bytes.create encoded_message_len in
match
Data_encoding.Binary.write
metadata_config.conn_meta_encoding
message
buf
0
encoded_message_len
with
| None ->
fail P2p_errors.Encoding_error
| Some last ->
fail_unless (last = encoded_message_len) P2p_errors.Encoding_error
>>=? fun () -> Crypto.write_chunk ~canceler cryptobox_data fd buf
let read ~canceler metadata_config fd cryptobox_data =
Crypto.read_chunk ~canceler fd cryptobox_data
>>=? fun buf ->
let length = Bytes.length buf in
let encoding = metadata_config.conn_meta_encoding in
match Data_encoding.Binary.read encoding buf 0 length with
| None ->
fail P2p_errors.Decoding_error
| Some (read_len, message) ->
if read_len <> length then fail P2p_errors.Decoding_error
else return message
end
module Ack = struct
type t = Ack | Nack
let encoding =
let open Data_encoding in
let ack_encoding = obj1 (req "ack" empty) in
let nack_encoding = obj1 (req "nack" empty) in
let ack_case tag =
case
tag
ack_encoding
~title:"Ack"
(function Ack -> Some () | _ -> None)
(fun () -> Ack)
in
let nack_case tag =
case
tag
nack_encoding
~title:"Nack"
(function Nack -> Some () | _ -> None)
(fun _ -> Nack)
in
union [ack_case (Tag 0); nack_case (Tag 255)]
let write ?canceler fd cryptobox_data message =
let encoded_message_len = Data_encoding.Binary.length encoding message in
let buf = Bytes.create encoded_message_len in
match
Data_encoding.Binary.write encoding message buf 0 encoded_message_len
with
| None ->
fail P2p_errors.Encoding_error
| Some last ->
fail_unless (last = encoded_message_len) P2p_errors.Encoding_error
>>=? fun () -> Crypto.write_chunk ?canceler fd cryptobox_data buf
let read ?canceler fd cryptobox_data =
Crypto.read_chunk ?canceler fd cryptobox_data
>>=? fun buf ->
let length = Bytes.length buf in
match Data_encoding.Binary.read encoding buf 0 length with
| None ->
fail P2p_errors.Decoding_error
| Some (read_len, message) ->
if read_len <> length then fail P2p_errors.Decoding_error
else return message
end
type 'meta authenticated_connection = {
fd : P2p_io_scheduler.connection;
info : 'meta P2p_connection.Info.t;
cryptobox_data : Crypto.data;
}
let kick {fd; cryptobox_data; _} =
Ack.write fd cryptobox_data Nack
>>= fun _ -> P2p_io_scheduler.close fd >>= fun _ -> Lwt.return_unit
(* First step: write and read credentials, makes no difference
whether we're trying to connect to a peer or checking an incoming
connection, both parties must first introduce themselves. *)
let authenticate ~canceler ~proof_of_work_target ~incoming fd
((remote_addr, remote_socket_port) as point) ?listening_port identity
announced_version metadata_config =
let local_nonce_seed = Crypto_box.random_nonce () in
lwt_debug "Sending authenfication to %a" P2p_point.Id.pp point
>>= fun () ->
Connection_message.write
~canceler
fd
{
public_key = identity.P2p_identity.public_key;
proof_of_work_stamp = identity.proof_of_work_stamp;
message_nonce = local_nonce_seed;
port = listening_port;
version = announced_version;
}
>>=? fun sent_msg ->
Connection_message.read ~canceler fd
>>=? fun (msg, recv_msg) ->
let remote_listening_port =
if incoming then msg.port else Some remote_socket_port
in
let id_point = (remote_addr, remote_listening_port) in
let remote_peer_id = Crypto_box.hash msg.public_key in
fail_unless
(remote_peer_id <> identity.P2p_identity.peer_id)
(P2p_errors.Myself id_point)
>>=? fun () ->
fail_unless
(Crypto_box.check_proof_of_work
msg.public_key
msg.proof_of_work_stamp
proof_of_work_target)
(P2p_errors.Not_enough_proof_of_work remote_peer_id)
>>=? fun () ->
let channel_key =
Crypto_box.precompute identity.P2p_identity.secret_key msg.public_key
in
let (local_nonce, remote_nonce) =
Crypto_box.generate_nonces ~incoming ~sent_msg ~recv_msg
in
let cryptobox_data = {Crypto.channel_key; local_nonce; remote_nonce} in
let local_metadata = metadata_config.conn_meta_value remote_peer_id in
Metadata.write ~canceler metadata_config fd cryptobox_data local_metadata
>>=? fun () ->
Metadata.read ~canceler metadata_config fd cryptobox_data
>>=? fun remote_metadata ->
let info =
{
P2p_connection.Info.peer_id = remote_peer_id;
announced_version = msg.version;
incoming;
id_point;
remote_socket_port;
private_node = metadata_config.private_node remote_metadata;
local_metadata;
remote_metadata;
}
in
return (info, {fd; info; cryptobox_data})
module Reader = struct
type ('msg, 'meta) t = {
canceler : Lwt_canceler.t;
conn : 'meta authenticated_connection;
encoding : 'msg Data_encoding.t;
messages : (int * 'msg) tzresult Lwt_pipe.t;
mutable worker : unit Lwt.t;
}
let read_message st init =
let rec loop status =
Lwt_unix.yield ()
>>= fun () ->
let open Data_encoding.Binary in
match status with
| Success {result; size; stream} ->
return_some (result, size, stream)
| Error _err ->
lwt_debug "[read_message] incremental decoding error"
>>= fun () -> return_none
| Await decode_next_buf ->
Crypto.read_chunk
~canceler:st.canceler
st.conn.fd
st.conn.cryptobox_data
>>=? fun buf ->
lwt_debug
"reading %d bytes from %a"
(Bytes.length buf)
P2p_peer.Id.pp
st.conn.info.peer_id
>>= fun () -> loop (decode_next_buf buf)
in
loop (Data_encoding.Binary.read_stream ?init st.encoding)
let rec worker_loop st stream =
read_message st stream
>>=? (fun msg ->
match msg with
| None ->
protect ~canceler:st.canceler (fun () ->
Lwt_pipe.push st.messages (error P2p_errors.Decoding_error)
>>= fun () -> return_none)
| Some (msg, size, stream) ->
protect ~canceler:st.canceler (fun () ->
Lwt_pipe.push st.messages (Ok (size, msg))
>>= fun () -> return_some stream))
>>= function
| Ok (Some stream) ->
worker_loop st (Some stream)
| Ok None ->
Lwt_canceler.cancel st.canceler
| Error (Canceled :: _) | Error (Exn Lwt_pipe.Closed :: _) ->
lwt_debug "connection closed to %a" P2p_peer.Id.pp st.conn.info.peer_id
| Error _ as err ->
Lwt_pipe.safe_push_now st.messages err ;
Lwt_canceler.cancel st.canceler
let run ?size conn encoding canceler =
let compute_size = function
| Ok (size, _) ->
(Sys.word_size / 8 * 11) + size + Lwt_pipe.push_overhead
| Error _ ->
0
(* we push Error only when we close the socket,
we don't fear memory leaks in that case... *)
in
let size = Option.map size ~f:(fun max -> (max, compute_size)) in
let st =
{
canceler;
conn;
encoding;
messages = Lwt_pipe.create ?size ();
worker = Lwt.return_unit;
}
in
Lwt_canceler.on_cancel st.canceler (fun () ->
Lwt_pipe.close st.messages ; Lwt.return_unit) ;
st.worker <-
Lwt_utils.worker
"reader"
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> worker_loop st None)
~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ;
st
let shutdown st = Lwt_canceler.cancel st.canceler >>= fun () -> st.worker
end
module Writer = struct
type ('msg, 'meta) t = {
canceler : Lwt_canceler.t;
conn : 'meta authenticated_connection;
encoding : 'msg Data_encoding.t;
messages : (Bytes.t list * unit tzresult Lwt.u option) Lwt_pipe.t;
mutable worker : unit Lwt.t;
binary_chunks_size : int; (* in bytes *)
}
let send_message st buf =
let rec loop = function
| [] ->
return_unit
| buf :: l ->
Crypto.write_chunk
~canceler:st.canceler
st.conn.fd
st.conn.cryptobox_data
buf
>>=? fun () ->
lwt_debug
"writing %d bytes to %a"
(Bytes.length buf)
P2p_peer.Id.pp
st.conn.info.peer_id
>>= fun () -> loop l
in
loop buf
let encode_message st msg =
try
ok
(Utils.cut
st.binary_chunks_size
(Data_encoding.Binary.to_bytes_exn st.encoding msg))
with Data_encoding.Binary.Write_error _ ->
error P2p_errors.Encoding_error
let rec worker_loop st =
Lwt_unix.yield ()
>>= fun () ->
protect ~canceler:st.canceler (fun () ->
Lwt_pipe.pop st.messages >>= return)
>>= function
| Error (Canceled :: _) | Error (Exn Lwt_pipe.Closed :: _) ->
lwt_debug "connection closed to %a" P2p_peer.Id.pp st.conn.info.peer_id
| Error err ->
lwt_log_error
"@[<v 2>error writing to %a@ %a@]"
P2p_peer.Id.pp
st.conn.info.peer_id
pp_print_error
err
>>= fun () -> Lwt_canceler.cancel st.canceler
| Ok (buf, wakener) -> (
send_message st buf
>>= fun res ->
match res with
| Ok () ->
Option.iter wakener ~f:(fun u -> Lwt.wakeup_later u res) ;
worker_loop st
| Error err -> (
Option.iter wakener ~f:(fun u ->
Lwt.wakeup_later u (error P2p_errors.Connection_closed)) ;
match err with
| (Canceled | Exn Lwt_pipe.Closed) :: _ ->
lwt_debug
"connection closed to %a"
P2p_peer.Id.pp
st.conn.info.peer_id
| P2p_errors.Connection_closed :: _ ->
lwt_debug
"connection closed to %a"
P2p_peer.Id.pp
st.conn.info.peer_id
>>= fun () -> Lwt_canceler.cancel st.canceler
| err ->
lwt_log_error
"@[<v 2>error writing to %a@ %a@]"
P2p_peer.Id.pp
st.conn.info.peer_id
pp_print_error
err
>>= fun () -> Lwt_canceler.cancel st.canceler ) )
let run ?size ?binary_chunks_size conn encoding canceler =
let binary_chunks_size =
match binary_chunks_size with
| None ->
Crypto.max_content_length
| Some size ->
let size = size - Crypto.extrabytes in
assert (size > 0) ;
assert (size <= Crypto.max_content_length) ;
size
in
let compute_size =
let buf_list_size =
List.fold_left
(fun sz buf -> sz + Bytes.length buf + (2 * Sys.word_size))
0
in
function
| (buf_l, None) ->
Sys.word_size + buf_list_size buf_l + Lwt_pipe.push_overhead
| (buf_l, Some _) ->
(2 * Sys.word_size) + buf_list_size buf_l + Lwt_pipe.push_overhead
in
let size = Option.map size ~f:(fun max -> (max, compute_size)) in
let st =
{
canceler;
conn;
encoding;
messages = Lwt_pipe.create ?size ();
worker = Lwt.return_unit;
binary_chunks_size;
}
in
Lwt_canceler.on_cancel st.canceler (fun () ->
Lwt_pipe.close st.messages ;
while not (Lwt_pipe.is_empty st.messages) do
let (_, w) = Lwt_pipe.pop_now_exn st.messages in
Option.iter w ~f:(fun u ->
Lwt.wakeup_later u (error (Exn Lwt_pipe.Closed)))
done ;
Lwt.return_unit) ;
st.worker <-
Lwt_utils.worker
"writer"
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> worker_loop st)
~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ;
st
let shutdown st = Lwt_canceler.cancel st.canceler >>= fun () -> st.worker
end
type ('msg, 'meta) t = {
conn : 'meta authenticated_connection;
reader : ('msg, 'meta) Reader.t;
writer : ('msg, 'meta) Writer.t;
}
let equal {conn = {fd = fd2; _}; _} {conn = {fd = fd1; _}; _} =
P2p_io_scheduler.id fd1 = P2p_io_scheduler.id fd2
let pp ppf {conn; _} = P2p_connection.Info.pp (fun _ _ -> ()) ppf conn.info
let info {conn; _} = conn.info
let local_metadata {conn; _} = conn.info.local_metadata
let remote_metadata {conn; _} = conn.info.remote_metadata
let private_node {conn; _} = conn.info.private_node
let accept ?incoming_message_queue_size ?outgoing_message_queue_size
?binary_chunks_size ~canceler conn encoding =
protect
(fun () ->
Ack.write ~canceler conn.fd conn.cryptobox_data Ack
>>=? fun () -> Ack.read ~canceler conn.fd conn.cryptobox_data)
~on_error:(fun err ->
P2p_io_scheduler.close conn.fd
>>= fun _ ->
match err with
| [P2p_errors.Connection_closed] ->
fail P2p_errors.Rejected_socket_connection
| [P2p_errors.Decipher_error] ->
fail P2p_errors.Invalid_auth
| err ->
Lwt.return_error err)
>>=? function
| Ack ->
let canceler = Lwt_canceler.create () in
let reader =
Reader.run ?size:incoming_message_queue_size conn encoding canceler
and writer =
Writer.run
?size:outgoing_message_queue_size
?binary_chunks_size
conn
encoding
canceler
in
let conn = {conn; reader; writer} in
Lwt_canceler.on_cancel canceler (fun () ->
P2p_io_scheduler.close conn.conn.fd >>= fun _ -> Lwt.return_unit) ;
return conn
| Nack ->
fail P2p_errors.Rejected_socket_connection
let catch_closed_pipe f =
Lwt.catch f (function
| Lwt_pipe.Closed ->
fail P2p_errors.Connection_closed
| exn ->
fail (Exn exn))
>>= function
| Error (Exn Lwt_pipe.Closed :: _) ->
fail P2p_errors.Connection_closed
| (Error _ | Ok _) as v ->
Lwt.return v
let pp_json encoding ppf msg =
Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding msg)
let write {writer; conn; _} msg =
catch_closed_pipe (fun () ->
debug
"Sending message to %a: %a"
P2p_peer.Id.pp_short
conn.info.peer_id
(pp_json writer.encoding)
msg ;
Lwt.return (Writer.encode_message writer msg)
>>=? fun buf ->
Lwt_pipe.push writer.messages (buf, None) >>= fun () -> return_unit)
let write_sync {writer; conn; _} msg =
catch_closed_pipe (fun () ->
let (waiter, wakener) = Lwt.wait () in
debug
"Sending message to %a: %a"
P2p_peer.Id.pp_short
conn.info.peer_id
(pp_json writer.encoding)
msg ;
Lwt.return (Writer.encode_message writer msg)
>>=? fun buf ->
Lwt_pipe.push writer.messages (buf, Some wakener) >>= fun () -> waiter)
let write_now {writer; conn; _} msg =
debug
"Try sending message to %a: %a"
P2p_peer.Id.pp_short
conn.info.peer_id
(pp_json writer.encoding)
msg ;
Writer.encode_message writer msg
>>? fun buf ->
try Ok (Lwt_pipe.push_now writer.messages (buf, None))
with Lwt_pipe.Closed -> error P2p_errors.Connection_closed
let rec split_bytes size bytes =
if Bytes.length bytes <= size then [bytes]
else
Bytes.sub bytes 0 size
:: split_bytes size (Bytes.sub bytes size (Bytes.length bytes - size))
let raw_write_sync {writer; _} bytes =
let bytes = split_bytes writer.binary_chunks_size bytes in
catch_closed_pipe (fun () ->
let (waiter, wakener) = Lwt.wait () in
Lwt_pipe.push writer.messages (bytes, Some wakener) >>= fun () -> waiter)
let is_readable {reader; _} = not (Lwt_pipe.is_empty reader.messages)
let wait_readable {reader; _} =
catch_closed_pipe (fun () ->
Lwt_pipe.values_available reader.messages >>= fun () -> return_unit)
let read {reader; _} =
catch_closed_pipe (fun () -> Lwt_pipe.pop reader.messages)
let read_now {reader; _} =
try Lwt_pipe.pop_now reader.messages
with Lwt_pipe.Closed -> Some (error P2p_errors.Connection_closed)
let stat {conn = {fd; _}; _} = P2p_io_scheduler.stat fd
let close ?(wait = false) st =
( if not wait then Lwt.return_unit
else (
Lwt_pipe.close st.reader.messages ;
Lwt_pipe.close st.writer.messages ;
st.writer.worker ) )
>>= fun () ->
Reader.shutdown st.reader
>>= fun () ->
Writer.shutdown st.writer
>>= fun () -> P2p_io_scheduler.close st.conn.fd >>= fun _ -> Lwt.return_unit
src/lib_p2p/p2p_socket.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Module Crypto.
Definition bufsize : Z := Z.sub (Z.shiftl 1 16) 1.
Definition header_length : Z := 2.
Definition max_content_length : Z := Z.sub bufsize Crypto_box.zerobytes.
Definition boxextrabytes : Z :=
Z.sub Crypto_box.zerobytes Crypto_box.boxzerobytes.
Definition extrabytes : Z := Z.add header_length boxextrabytes.
Record data := {
channel_key : Tezos_base__TzPervasives.Crypto_box.channel_key;
local_nonce : Tezos_base__TzPervasives.Crypto_box.nonce;
remote_nonce : Tezos_base__TzPervasives.Crypto_box.nonce }.
Definition write_chunk
(canceler : option Tezos_stdlib.Lwt_canceler.t)
(fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : data)
(msg : string) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let msglen := String.length msg in
op_gtgteqquestion
(fail_unless (OCaml.Stdlib.le msglen max_content_length)
Tezos_base__TzPervasives.Invalid_message_size)
(fun function_parameter =>
let 'tt := function_parameter in
let buf_length := Z.add msglen Crypto_box.zerobytes in
let buf := Stdlib.Bytes.make buf_length "000" % char in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.Bytes.blit msg 0 buf Crypto_box.zerobytes msglen in
let local_nonce := local_nonce cryptobox_data in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field cryptobox_data "local_nonce" % string
(Crypto_box.increment_nonce None local_nonce) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Crypto_box.fast_box_noalloc (channel_key cryptobox_data) local_nonce
buf in
let encrypted_length := Z.sub buf_length Crypto_box.boxzerobytes in
let header_pos := Z.sub Crypto_box.boxzerobytes header_length in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := TzEndian.set_int16 buf header_pos encrypted_length in
let payload := String.sub buf header_pos (Z.sub buf_length header_pos)
in
P2p_io_scheduler.write canceler fd payload).
Definition read_chunk
(canceler : option Tezos_stdlib.Lwt_canceler.t)
(fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : data)
: Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
let header_buf := Stdlib.Bytes.create header_length in
op_gtgteqquestion
(P2p_io_scheduler.read_full canceler fd None (Some header_length)
header_buf)
(fun function_parameter =>
let 'tt := function_parameter in
let encrypted_length := TzEndian.get_uint16 header_buf 0 in
let buf_length := Z.add encrypted_length Crypto_box.boxzerobytes in
let buf := Stdlib.Bytes.make buf_length "000" % char in
op_gtgteqquestion
(P2p_io_scheduler.read_full canceler fd (Some Crypto_box.boxzerobytes)
(Some encrypted_length) buf)
(fun function_parameter =>
let 'tt := function_parameter in
let remote_nonce := remote_nonce cryptobox_data in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field cryptobox_data "remote_nonce" % string
(Crypto_box.increment_nonce None remote_nonce) in
match
Crypto_box.fast_box_open_noalloc (channel_key cryptobox_data)
remote_nonce buf with
| false => fail Tezos_base__TzPervasives.Decipher_error
| true =>
_return
(String.sub buf Crypto_box.zerobytes
(Z.sub buf_length Crypto_box.zerobytes))
end)).
End Crypto.
Definition check_binary_chunks_size (size : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let value := Z.sub size Crypto.extrabytes in
fail_unless
(andb (OCaml.Stdlib.gt value 0)
(OCaml.Stdlib.le value Crypto.max_content_length))
(Tezos_base__TzPervasives.Invalid_chunks_size
{| value := size; min := Z.add Crypto.extrabytes 1; max := Crypto.bufsize
|}).
Module Connection_message.
Record t := {
port : option Z;
public_key : Tezos_base__TzPervasives.Crypto_box.public_key;
proof_of_work_stamp : Tezos_base__TzPervasives.Crypto_box.nonce;
message_nonce : Tezos_base__TzPervasives.Crypto_box.nonce;
version : Tezos_base__TzPervasives.Network_version.t }.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
conv
(fun function_parameter =>
let '{|
port := port;
public_key := public_key;
proof_of_work_stamp := proof_of_work_stamp;
message_nonce := message_nonce;
version := version
|} := function_parameter in
let port :=
match port with
| None => 0
| Some port => port
end in
(port, public_key, proof_of_work_stamp, message_nonce, version))
(fun function_parameter =>
let '(port, public_key, proof_of_work_stamp, message_nonce, version) :=
function_parameter in
let port :=
if equiv_decb port 0 then
None
else
Some port in
{| port := port; public_key := public_key;
proof_of_work_stamp := proof_of_work_stamp;
message_nonce := message_nonce; version := version |}) None
(obj5 (req None None "port" % string uint16)
(req None None "pubkey" % string Crypto_box.public_key_encoding)
(req None None "proof_of_work_stamp" % string Crypto_box.nonce_encoding)
(req None None "message_nonce" % string Crypto_box.nonce_encoding)
(req None None "version" % string Network_version.encoding)).
Definition write
(canceler : Tezos_stdlib.Lwt_canceler.t)
(fd : Tezos_p2p.P2p_io_scheduler.connection) (message : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
let encoded_message_len := Data_encoding.Binary.length encoding message in
op_gtgteqquestion
(fail_unless
(OCaml.Stdlib.lt encoded_message_len
(Z.shiftl 1 (Z.mul Crypto.header_length 8)))
Tezos_base__TzPervasives.Encoding_error)
(fun function_parameter =>
let 'tt := function_parameter in
let len := Z.add Crypto.header_length encoded_message_len in
let buf := Stdlib.Bytes.create len in
match
Data_encoding.Binary.write encoding message buf Crypto.header_length
len with
| None => fail Tezos_base__TzPervasives.Encoding_error
| Some last =>
op_gtgteqquestion
(fail_unless (equiv_decb last len)
Tezos_base__TzPervasives.Encoding_error)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := TzEndian.set_int16 buf 0 encoded_message_len in
op_gtgteqquestion (P2p_io_scheduler.write (Some canceler) fd buf)
(fun function_parameter =>
let 'tt := function_parameter in
_return buf))
end).
Definition read
(canceler : Tezos_stdlib.Lwt_canceler.t)
(fd : Tezos_p2p.P2p_io_scheduler.connection)
: Lwt.t (Tezos_base__TzPervasives.tzresult (t * string)) :=
let header_buf := Stdlib.Bytes.create Crypto.header_length in
op_gtgteqquestion
(P2p_io_scheduler.read_full (Some canceler) fd None
(Some Crypto.header_length) header_buf)
(fun function_parameter =>
let 'tt := function_parameter in
let len := TzEndian.get_uint16 header_buf 0 in
let pos := Crypto.header_length in
let buf := Stdlib.Bytes.create (Z.add pos len) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := TzEndian.set_int16 buf 0 len in
op_gtgteqquestion
(P2p_io_scheduler.read_full (Some canceler) fd (Some pos) (Some len)
buf)
(fun function_parameter =>
let 'tt := function_parameter in
match Data_encoding.Binary.read encoding buf pos len with
| None => fail Tezos_base__TzPervasives.Decoding_error
| Some (next_pos, message) =>
if nequiv_decb next_pos (Z.add pos len) then
fail Tezos_base__TzPervasives.Decoding_error
else
_return (message, buf)
end)).
End Connection_message.
Record metadata_config {meta : Type} := {
conn_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t meta;
conn_meta_value : Tezos_base__TzPervasives.P2p_peer.Id.t -> meta;
private_node : meta -> bool }.
Arguments metadata_config : clear implicits.
Module Metadata.
Definition write {A : Type}
(canceler : Tezos_stdlib.Lwt_canceler.t)
(metadata_config : metadata_config A)
(cryptobox_data : Tezos_p2p.P2p_io_scheduler.connection) (fd : Crypto.data)
(message : A) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let encoded_message_len :=
Data_encoding.Binary.length (conn_meta_encoding metadata_config) message
in
let buf := Stdlib.Bytes.create encoded_message_len in
match
Data_encoding.Binary.write (conn_meta_encoding metadata_config) message
buf 0 encoded_message_len with
| None => fail Tezos_base__TzPervasives.Encoding_error
| Some last =>
op_gtgteqquestion
(fail_unless (equiv_decb last encoded_message_len)
Tezos_base__TzPervasives.Encoding_error)
(fun function_parameter =>
let 'tt := function_parameter in
Crypto.write_chunk (Some canceler) cryptobox_data fd buf)
end.
Definition read {A : Type}
(canceler : Tezos_stdlib.Lwt_canceler.t)
(metadata_config : metadata_config A)
(fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : Crypto.data)
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
op_gtgteqquestion (Crypto.read_chunk (Some canceler) fd cryptobox_data)
(fun buf =>
let length := String.length buf in
let encoding := conn_meta_encoding metadata_config in
match Data_encoding.Binary.read encoding buf 0 length with
| None => fail Tezos_base__TzPervasives.Decoding_error
| Some (read_len, message) =>
if nequiv_decb read_len length then
fail Tezos_base__TzPervasives.Decoding_error
else
_return message
end).
End Metadata.
Module Ack.
Inductive t : Type :=
| Ack : t
| Nack : t.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
let ack_encoding := obj1 (req None None "ack" % string empty) in
let nack_encoding := obj1 (req None None "nack" % string empty) in
let ack_case (tag : Tezos_base__TzPervasives.Data_encoding.case_tag)
: Tezos_base__TzPervasives.Data_encoding.case t :=
case "Ack" % string None tag ack_encoding
(fun function_parameter =>
match function_parameter with
| Ack => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Ack) in
let nack_case (tag : Tezos_base__TzPervasives.Data_encoding.case_tag)
: Tezos_base__TzPervasives.Data_encoding.case t :=
case "Nack" % string None tag nack_encoding
(fun function_parameter =>
match function_parameter with
| Nack => Some tt
| _ => None
end)
(fun function_parameter =>
let '_ := function_parameter in
Nack) in
union None
(cons (ack_case (Tezos_base__TzPervasives.Data_encoding.Tag 0))
(cons (nack_case (Tezos_base__TzPervasives.Data_encoding.Tag 255)) [])).
Definition write
(canceler : option Tezos_stdlib.Lwt_canceler.t)
(fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : Crypto.data)
(message : t) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let encoded_message_len := Data_encoding.Binary.length encoding message in
let buf := Stdlib.Bytes.create encoded_message_len in
match Data_encoding.Binary.write encoding message buf 0 encoded_message_len
with
| None => fail Tezos_base__TzPervasives.Encoding_error
| Some last =>
op_gtgteqquestion
(fail_unless (equiv_decb last encoded_message_len)
Tezos_base__TzPervasives.Encoding_error)
(fun function_parameter =>
let 'tt := function_parameter in
Crypto.write_chunk canceler fd cryptobox_data buf)
end.
Definition read
(canceler : option Tezos_stdlib.Lwt_canceler.t)
(fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : Crypto.data)
: Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
op_gtgteqquestion (Crypto.read_chunk canceler fd cryptobox_data)
(fun buf =>
let length := String.length buf in
match Data_encoding.Binary.read encoding buf 0 length with
| None => fail Tezos_base__TzPervasives.Decoding_error
| Some (read_len, message) =>
if nequiv_decb read_len length then
fail Tezos_base__TzPervasives.Decoding_error
else
_return message
end).
End Ack.
Record authenticated_connection {meta : Type} := {
fd : Tezos_p2p.P2p_io_scheduler.connection;
info : Tezos_base__TzPervasives.P2p_connection.Info.t meta;
cryptobox_data : Crypto.data }.
Arguments authenticated_connection : clear implicits.
Definition kick {A : Type} (function_parameter : authenticated_connection A)
: Lwt.t unit :=
let '{| fd := fd; cryptobox_data := cryptobox_data |} := function_parameter in
op_gtgteq (Ack.write None fd cryptobox_data Ack.Nack)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (P2p_io_scheduler.close None fd)
(fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit)).
Definition authenticate {A : Type}
(canceler : Tezos_stdlib.Lwt_canceler.t)
(proof_of_work_target : Tezos_base__TzPervasives.Crypto_box.target)
(incoming : bool) (fd : Tezos_p2p.P2p_io_scheduler.connection)
(function_parameter : Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port)
: (option Z) ->
Tezos_base__TzPervasives.P2p_identity.t ->
Tezos_base__TzPervasives.Network_version.t ->
(metadata_config A) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
((Tezos_base__TzPervasives.P2p_connection.Info.t A) *
(authenticated_connection A))) :=
let '(remote_addr, remote_socket_port) as point := function_parameter in
fun listening_port =>
fun identity =>
fun announced_version =>
fun metadata_config =>
let local_nonce_seed := Crypto_box.random_nonce tt in
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Sending authenfication to " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Sending authenfication to %a" % string) P2p_point.Id.pp point)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Connection_message.write canceler fd
{| port := listening_port;
public_key := P2p_identity.public_key identity;
proof_of_work_stamp := proof_of_work_stamp identity;
message_nonce := local_nonce_seed;
version := announced_version |})
(fun sent_msg =>
op_gtgteqquestion (Connection_message.read canceler fd)
(fun function_parameter =>
let '(msg, recv_msg) := function_parameter in
let remote_listening_port :=
if incoming then
port msg
else
Some remote_socket_port in
let id_point := (remote_addr, remote_listening_port) in
let remote_peer_id := Crypto_box.hash (public_key msg) in
op_gtgteqquestion
(fail_unless
(nequiv_decb remote_peer_id
(P2p_identity.peer_id identity))
(Tezos_base__TzPervasives.Myself id_point))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_unless
(Crypto_box.check_proof_of_work (public_key msg)
(proof_of_work_stamp msg) proof_of_work_target)
(Tezos_base__TzPervasives.Not_enough_proof_of_work
remote_peer_id))
(fun function_parameter =>
let 'tt := function_parameter in
let channel_key :=
Crypto_box.precompute
(P2p_identity.secret_key identity)
(public_key msg) in
let '(local_nonce, remote_nonce) :=
Crypto_box.generate_nonces incoming sent_msg
recv_msg in
let cryptobox_data :=
{| Crypto.channel_key := channel_key;
Crypto.local_nonce := local_nonce;
Crypto.remote_nonce := remote_nonce |} in
let local_metadata :=
(conn_meta_value metadata_config) remote_peer_id
in
op_gtgteqquestion
(Metadata.write canceler metadata_config fd
cryptobox_data local_metadata)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Metadata.read canceler metadata_config fd
cryptobox_data)
(fun remote_metadata =>
let info :=
{|
P2p_connection.Info.incoming :=
incoming;
P2p_connection.Info.peer_id :=
remote_peer_id;
P2p_connection.Info.id_point :=
id_point;
P2p_connection.Info.remote_socket_port :=
remote_socket_port;
P2p_connection.Info.announced_version :=
version msg;
P2p_connection.Info.private_node :=
(private_node metadata_config)
remote_metadata;
P2p_connection.Info.local_metadata :=
local_metadata;
P2p_connection.Info.remote_metadata :=
remote_metadata |} in
_return
(info,
{| fd := fd; info := info;
cryptobox_data := cryptobox_data |})))))))).
Module Reader.
Record t {msg meta : Type} := {
canceler : Tezos_stdlib.Lwt_canceler.t;
conn : authenticated_connection meta;
encoding : Tezos_base__TzPervasives.Data_encoding.t msg;
messages :
Tezos_stdlib.Lwt_pipe.t (Tezos_base__TzPervasives.tzresult (Z * msg));
worker : Lwt.t unit }.
Arguments t : clear implicits.
Definition read_message {A B : Type}
(st : t A B) (init : option Tezos_data_encoding.Binary_stream.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option (A * Z * Tezos_data_encoding.Binary_stream.t))) :=
let fix loop {C : Type}
(status : Tezos_base__TzPervasives.Data_encoding.Binary.status C)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option (C * Z * Tezos_data_encoding.Binary_stream.t))) :=
op_gtgteq (Lwt_unix.yield tt)
(fun function_parameter =>
let 'tt := function_parameter in
match status with
|
Tezos_base__TzPervasives.Data_encoding.Binary.Success {|
result := result; size := size; stream := stream |} =>
return_some (result, size, stream)
| Tezos_base__TzPervasives.Data_encoding.Binary.Error _err =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"[read_message] incremental decoding error" % string
CamlinternalFormatBasics.End_of_format)
"[read_message] incremental decoding error" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_none)
| Tezos_base__TzPervasives.Data_encoding.Binary.Await decode_next_buf
=>
op_gtgteqquestion
(Crypto.read_chunk (Some (canceler st)) (fd (conn st))
(cryptobox_data (conn st)))
(fun buf =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"reading " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" bytes from " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"reading %d bytes from %a" % string) (String.length buf)
P2p_peer.Id.pp (peer_id (info (conn st))))
(fun function_parameter =>
let 'tt := function_parameter in
loop (decode_next_buf buf)))
end) in
loop (Data_encoding.Binary.read_stream init (encoding st)).
Fixpoint worker_loop {A B : Type}
(st : t A B) (stream : option Tezos_data_encoding.Binary_stream.t)
: Lwt.t unit :=
op_gtgteq
(op_gtgteqquestion (read_message st stream)
(fun msg =>
match msg with
| None =>
protect None (Some (canceler st))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_pipe.push (messages st)
(error Tezos_base__TzPervasives.Decoding_error))
(fun function_parameter =>
let 'tt := function_parameter in
return_none))
| Some (msg, size, stream) =>
protect None (Some (canceler st))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_pipe.push (messages st) (Stdlib.Ok (size, msg)))
(fun function_parameter =>
let 'tt := function_parameter in
return_some stream))
end))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok (Some stream) => worker_loop st (Some stream)
| Stdlib.Ok None => Lwt_canceler.cancel (canceler st)
|
Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) |
Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Closed) _) =>
lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"connection closed to " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"connection closed to %a" % string) P2p_peer.Id.pp
(peer_id (info (conn st)))
| (Stdlib.Error _) as err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_pipe.safe_push_now (messages st) err in
Lwt_canceler.cancel (canceler st)
end).
Definition run {A B : Type}
(size : option Z) (conn : authenticated_connection A)
(encoding : Tezos_base__TzPervasives.Data_encoding.t B)
(canceler : Tezos_stdlib.Lwt_canceler.t) : t B A :=
let compute_size {C D : Type} (function_parameter : sum (Z * C) D) : Z :=
match function_parameter with
| Stdlib.Ok (size, _) =>
Z.add (Z.add (Z.mul (Z.div Sys.word_size 8) 11) size)
Lwt_pipe.push_overhead
| Stdlib.Error _ => 0
end in
let size := Option.map (fun max => (max, compute_size)) size in
let st :=
{| canceler := canceler; conn := conn; encoding := encoding;
messages := Lwt_pipe.create size tt; worker := Lwt.return_unit |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_canceler.on_cancel (canceler st)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_pipe.close (messages st) in
Lwt.return_unit) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field st "worker" % string
(Lwt_utils.worker "reader" % string
Internal_event.Lwt_worker_event.on_event
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop st None)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler st))) in
st.
Definition shutdown {A B : Type} (st : t A B) : Lwt.t unit :=
op_gtgteq (Lwt_canceler.cancel (canceler st))
(fun function_parameter =>
let 'tt := function_parameter in
worker st).
End Reader.
Module Writer.
Record t {msg meta : Type} := {
canceler : Tezos_stdlib.Lwt_canceler.t;
conn : authenticated_connection meta;
encoding : Tezos_base__TzPervasives.Data_encoding.t msg;
messages :
Tezos_stdlib.Lwt_pipe.t
((list Stdlib.Bytes.t) *
(option (Lwt.u (Tezos_base__TzPervasives.tzresult unit))));
worker : Lwt.t unit;
binary_chunks_size : Z }.
Arguments t : clear implicits.
Definition send_message {A B : Type} (st : t A B) (buf : list string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let fix loop (function_parameter : list string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match function_parameter with
| [] => return_unit
| cons buf l =>
op_gtgteqquestion
(Crypto.write_chunk (Some (canceler st)) (fd (conn st))
(cryptobox_data (conn st)) buf)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "writing " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" bytes to " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"writing %d bytes to %a" % string) (String.length buf)
P2p_peer.Id.pp (peer_id (info (conn st))))
(fun function_parameter =>
let 'tt := function_parameter in
loop l))
end in
loop buf.
Definition encode_message {A B : Type} (st : t A B) (msg : A)
: Tezos_base__TzPervasives.tzresult (list Stdlib.Bytes.t) :=
(* ❌ Try-with are not handled *)
try
(ok
(Utils.cut None (binary_chunks_size st)
(Data_encoding.Binary.to_bytes_exn (encoding st) msg))).
Fixpoint worker_loop {A B : Type} (st : t A B) : Lwt.t unit :=
op_gtgteq (Lwt_unix.yield tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(protect None (Some (canceler st))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_pipe.pop (messages st)) _return))
(fun function_parameter =>
match function_parameter with
|
Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) |
Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Closed) _) =>
lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"connection closed to " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"connection closed to %a" % string) P2p_peer.Id.pp
(peer_id (info (conn st)))
| Stdlib.Error err =>
op_gtgteq
(lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"error writing to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@[<v 2>error writing to %a@ %a@]" % string) P2p_peer.Id.pp
(peer_id (info (conn st))) pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler st))
| Stdlib.Ok (buf, wakener) =>
op_gtgteq (send_message st buf)
(fun res =>
match res with
| Stdlib.Ok tt =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Option.iter (fun u => Lwt.wakeup_later u res) wakener in
worker_loop st
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Option.iter
(fun u =>
Lwt.wakeup_later u
(error Tezos_base__TzPervasives.Connection_closed))
wakener in
match err with
|
cons
(Tezos_base__TzPervasives.Canceled |
Tezos_base__TzPervasives.Exn Closed) _ =>
lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"connection closed to " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"connection closed to %a" % string) P2p_peer.Id.pp
(peer_id (info (conn st)))
| cons Tezos_base__TzPervasives.Connection_closed _ =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"connection closed to " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"connection closed to %a" % string) P2p_peer.Id.pp
(peer_id (info (conn st))))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler st))
| err =>
op_gtgteq
(lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"error writing to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@[<v 2>error writing to %a@ %a@]" % string)
P2p_peer.Id.pp (peer_id (info (conn st)))
pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler st))
end
end)
end)).
Definition run {A B : Type}
(size : option Z) (binary_chunks_size : option Z)
(conn : authenticated_connection A)
(encoding : Tezos_base__TzPervasives.Data_encoding.t B)
(canceler : Tezos_stdlib.Lwt_canceler.t) : t B A :=
let binary_chunks_size :=
match binary_chunks_size with
| None => Crypto.max_content_length
| Some size =>
let size := Z.sub size Crypto.extrabytes in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.gt size 0) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.le size Crypto.max_content_length) in
size
end in
let compute_size :=
let buf_list_size :=
List.fold_left
(fun sz =>
fun buf =>
Z.add (Z.add sz (String.length buf)) (Z.mul 2 Sys.word_size)) 0 in
fun function_parameter =>
match function_parameter with
| (buf_l, None) =>
Z.add (Z.add Sys.word_size (buf_list_size buf_l))
Lwt_pipe.push_overhead
| (buf_l, Some _) =>
Z.add (Z.add (Z.mul 2 Sys.word_size) (buf_list_size buf_l))
Lwt_pipe.push_overhead
end in
let size := Option.map (fun max => (max, compute_size)) size in
let st :=
{| canceler := canceler; conn := conn; encoding := encoding;
messages := Lwt_pipe.create size tt; worker := Lwt.return_unit;
binary_chunks_size := binary_chunks_size |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_canceler.on_cancel (canceler st)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_pipe.close (messages st) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ While loops not handled. *)
while in
Lwt.return_unit) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field st "worker" % string
(Lwt_utils.worker "writer" % string
Internal_event.Lwt_worker_event.on_event
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop st)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler st))) in
st.
Definition shutdown {A B : Type} (st : t A B) : Lwt.t unit :=
op_gtgteq (Lwt_canceler.cancel (canceler st))
(fun function_parameter =>
let 'tt := function_parameter in
worker st).
End Writer.
Record t {msg meta : Type} := {
conn : authenticated_connection meta;
reader : Reader.t msg meta;
writer : Writer.t msg meta }.
Arguments t : clear implicits.
Definition equal {A B C D : Type} (function_parameter : t A B)
: (t C D) -> bool :=
let '{| conn := {| fd := fd2 |} |} := function_parameter in
fun function_parameter =>
let '{| conn := {| fd := fd1 |} |} := function_parameter in
equiv_decb (P2p_io_scheduler.id fd1) (P2p_io_scheduler.id fd2).
Definition pp {A B : Type}
(ppf : Stdlib.Format.formatter) (function_parameter : t A B) : unit :=
let '{| conn := conn |} := function_parameter in
P2p_connection.Info.pp
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
tt) ppf (info conn).
Definition info {A B : Type} (function_parameter : t A B)
: Tezos_base__TzPervasives.P2p_connection.Info.t B :=
let '{| conn := conn |} := function_parameter in
info conn.
Definition local_metadata {A B : Type} (function_parameter : t A B) : B :=
let '{| conn := conn |} := function_parameter in
local_metadata (info conn).
Definition remote_metadata {A B : Type} (function_parameter : t A B) : B :=
let '{| conn := conn |} := function_parameter in
remote_metadata (info conn).
Definition private_node {A B : Type} (function_parameter : t A B) : bool :=
let '{| conn := conn |} := function_parameter in
private_node (info conn).
Definition accept {A B : Type}
(incoming_message_queue_size : option Z)
(outgoing_message_queue_size : option Z) (binary_chunks_size : option Z)
(canceler : Tezos_stdlib.Lwt_canceler.t) (conn : authenticated_connection A)
(encoding : Tezos_base__TzPervasives.Data_encoding.t B)
: Lwt.t (Tezos_base__TzPervasives.tzresult (t B A)) :=
op_gtgteqquestion
(protect
(Some
(fun err =>
op_gtgteq (P2p_io_scheduler.close None (fd conn))
(fun function_parameter =>
let '_ := function_parameter in
match err with
| cons Tezos_base__TzPervasives.Connection_closed [] =>
fail Tezos_base__TzPervasives.Rejected_socket_connection
| cons Tezos_base__TzPervasives.Decipher_error [] =>
fail Tezos_base__TzPervasives.Invalid_auth
| err => Lwt.return_error err
end))) None
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Ack.write (Some canceler) (fd conn) (cryptobox_data conn) Ack.Ack)
(fun function_parameter =>
let 'tt := function_parameter in
Ack.read (Some canceler) (fd conn) (cryptobox_data conn))))
(fun function_parameter =>
match function_parameter with
| Ack.Ack =>
let canceler := Lwt_canceler.create tt in
let reader : Reader.t B A :=
Reader.run incoming_message_queue_size conn encoding canceler
with writer : Writer.t B A :=
Writer.run outgoing_message_queue_size binary_chunks_size conn
encoding canceler in
let conn := {| conn := conn; reader := reader; writer := writer |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_canceler.on_cancel canceler
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_io_scheduler.close None (fd (conn conn)))
(fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit)) in
_return conn
| Ack.Nack => fail Tezos_base__TzPervasives.Rejected_socket_connection
end).
Definition catch_closed_pipe {A : Type}
(f : unit -> Lwt.t (Tezos_base__TzPervasives.tzresult A))
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
op_gtgteq
(Lwt.catch f
(fun function_parameter =>
match function_parameter with
| Closed => fail Tezos_base__TzPervasives.Connection_closed
| exn => fail (Tezos_base__TzPervasives.Exn exn)
end))
(fun function_parameter =>
match function_parameter with
| Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Closed) _) =>
fail Tezos_base__TzPervasives.Connection_closed
| (Stdlib.Error _ | Stdlib.Ok _) as v => Lwt._return v
end).
Definition pp_json {A : Type}
(encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
(ppf : Stdlib.Format.formatter) (msg : A) : unit :=
Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding msg).
Definition write {A B : Type} (function_parameter : t A B)
: A -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{| conn := conn; writer := writer |} := function_parameter in
fun msg =>
catch_closed_pipe
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Sending message to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Sending message to %a: %a" % string) P2p_peer.Id.pp_short
(peer_id (info conn)) (pp_json (encoding writer)) msg in
op_gtgteqquestion (Lwt._return (Writer.encode_message writer msg))
(fun buf =>
op_gtgteq (Lwt_pipe.push (messages writer) (buf, None))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))).
Definition write_sync {A B : Type} (function_parameter : t A B)
: A -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{| conn := conn; writer := writer |} := function_parameter in
fun msg =>
catch_closed_pipe
(fun function_parameter =>
let 'tt := function_parameter in
let '(waiter, wakener) := Lwt.wait tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Sending message to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Sending message to %a: %a" % string) P2p_peer.Id.pp_short
(peer_id (info conn)) (pp_json (encoding writer)) msg in
op_gtgteqquestion (Lwt._return (Writer.encode_message writer msg))
(fun buf =>
op_gtgteq (Lwt_pipe.push (messages writer) (buf, (Some wakener)))
(fun function_parameter =>
let 'tt := function_parameter in
waiter))).
Definition write_now {A B : Type} (function_parameter : t A B)
: A -> Tezos_base__TzPervasives.tzresult bool :=
let '{| conn := conn; writer := writer |} := function_parameter in
fun msg =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Try sending message to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Try sending message to %a: %a" % string) P2p_peer.Id.pp_short
(peer_id (info conn)) (pp_json (encoding writer)) msg in
op_gtgtquestion (Writer.encode_message writer msg)
(fun buf =>
(* ❌ Try-with are not handled *)
try (Stdlib.Ok (Lwt_pipe.push_now (messages writer) (buf, None)))).
Fixpoint split_bytes (size : Z) (bytes : string) : list string :=
if OCaml.Stdlib.le (String.length string) size then
cons string []
else
cons (String.sub string 0 size)
(split_bytes size
(String.sub string size (Z.sub (String.length string) size))).
Definition raw_write_sync {A B : Type} (function_parameter : t A B)
: string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{| writer := writer |} := function_parameter in
fun bytes =>
let bytes := split_bytes (binary_chunks_size writer) string in
catch_closed_pipe
(fun function_parameter =>
let 'tt := function_parameter in
let '(waiter, wakener) := Lwt.wait tt in
op_gtgteq (Lwt_pipe.push (messages writer) (string, (Some wakener)))
(fun function_parameter =>
let 'tt := function_parameter in
waiter)).
Definition is_readable {A B : Type} (function_parameter : t A B) : bool :=
let '{| reader := reader |} := function_parameter in
negb (Lwt_pipe.is_empty (messages reader)).
Definition wait_readable {A B : Type} (function_parameter : t A B)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{| reader := reader |} := function_parameter in
catch_closed_pipe
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_pipe.values_available (messages reader))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)).
Definition read {A B : Type} (function_parameter : t A B)
: Lwt.t (Tezos_base__TzPervasives.tzresult (Z * A)) :=
let '{| reader := reader |} := function_parameter in
catch_closed_pipe
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_pipe.pop (messages reader)).
Definition read_now {A B : Type} (function_parameter : t A B)
: option (Tezos_base__TzPervasives.tzresult (Z * A)) :=
let '{| reader := reader |} := function_parameter in
(* ❌ Try-with are not handled *)
try (Lwt_pipe.pop_now (messages reader)).
Definition stat {A B : Type} (function_parameter : t A B)
: Tezos_base__TzPervasives.P2p_stat.t :=
let '{| conn := {| fd := fd |} |} := function_parameter in
P2p_io_scheduler.stat fd.
Definition close {A B : Type} (op_staroptstar : option bool)
: (t A B) -> Lwt.t unit :=
let wait :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun st =>
op_gtgteq
(if negb wait then
Lwt.return_unit
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_pipe.close (messages (reader st)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_pipe.close (messages (writer st)) in
worker (writer st))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Reader.shutdown (reader st))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Writer.shutdown (writer st))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_io_scheduler.close None (fd (conn st)))
(fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit)))).
src/lib_p2p/p2p_trigger.ml success
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {
too_few_connections : unit Lwt_condition.t;
too_many_connections : unit Lwt_condition.t;
new_peer : unit Lwt_condition.t;
new_point : unit Lwt_condition.t;
new_connection : unit Lwt_condition.t;
}
let create () =
{
too_few_connections = Lwt_condition.create ();
too_many_connections = Lwt_condition.create ();
new_peer = Lwt_condition.create ();
new_point = Lwt_condition.create ();
new_connection = Lwt_condition.create ();
}
let wait_too_few_connections t = Lwt_condition.wait t.too_few_connections
let wait_too_many_connections t = Lwt_condition.wait t.too_many_connections
let wait_new_peer t = Lwt_condition.wait t.new_peer
let wait_new_point t = Lwt_condition.wait t.new_point
let wait_new_connection t = Lwt_condition.wait t.new_connection
let broadcast_new_point t = Lwt_condition.broadcast t.new_point ()
let broadcast_new_connection t = Lwt_condition.broadcast t.new_connection ()
let broadcast_new_peer t = Lwt_condition.broadcast t.new_peer ()
let broadcast_too_few_connections t =
Lwt_condition.broadcast t.too_few_connections ()
let broadcast_too_many_connections t =
Lwt_condition.broadcast t.too_many_connections ()
src/lib_p2p/p2p_trigger.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record t := {
too_few_connections : Lwt_condition.t unit;
too_many_connections : Lwt_condition.t unit;
new_peer : Lwt_condition.t unit;
new_point : Lwt_condition.t unit;
new_connection : Lwt_condition.t unit }.
Definition create (function_parameter : unit) : t :=
let 'tt := function_parameter in
{| too_few_connections := Lwt_condition.create tt;
too_many_connections := Lwt_condition.create tt;
new_peer := Lwt_condition.create tt; new_point := Lwt_condition.create tt;
new_connection := Lwt_condition.create tt |}.
Definition wait_too_few_connections (t : t) : Lwt.t unit :=
Lwt_condition.wait None (too_few_connections t).
Definition wait_too_many_connections (t : t) : Lwt.t unit :=
Lwt_condition.wait None (too_many_connections t).
Definition wait_new_peer (t : t) : Lwt.t unit :=
Lwt_condition.wait None (new_peer t).
Definition wait_new_point (t : t) : Lwt.t unit :=
Lwt_condition.wait None (new_point t).
Definition wait_new_connection (t : t) : Lwt.t unit :=
Lwt_condition.wait None (new_connection t).
Definition broadcast_new_point (t : t) : unit :=
Lwt_condition.broadcast (new_point t) tt.
Definition broadcast_new_connection (t : t) : unit :=
Lwt_condition.broadcast (new_connection t) tt.
Definition broadcast_new_peer (t : t) : unit :=
Lwt_condition.broadcast (new_peer t) tt.
Definition broadcast_too_few_connections (t : t) : unit :=
Lwt_condition.broadcast (too_few_connections t) tt.
Definition broadcast_too_many_connections (t : t) : unit :=
Lwt_condition.broadcast (too_many_connections t) tt.
src/lib_p2p/p2p_welcome.ml 8 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make (struct
let name = "p2p.welcome"
end)
type connect_handler =
| Connect_handler :
('msg, 'meta, 'meta_conn) P2p_connect_handler.t
-> connect_handler
type t = {
socket : Lwt_unix.file_descr;
canceler : Lwt_canceler.t;
connect_handler : connect_handler;
mutable worker : unit Lwt.t;
}
let rec worker_loop st =
let (Connect_handler pool) = st.connect_handler in
Lwt_unix.yield ()
>>= fun () ->
protect ~canceler:st.canceler (fun () -> P2p_fd.accept st.socket >>= return)
>>= function
| Ok (fd, addr) ->
let point =
match addr with
| Lwt_unix.ADDR_UNIX _ ->
assert false
| Lwt_unix.ADDR_INET (addr, port) ->
(Ipaddr_unix.V6.of_inet_addr_exn addr, port)
in
P2p_connect_handler.accept pool fd point ;
worker_loop st
(* Unix errors related to the failure to create one connection,
No reason to abort just now, but we want to stress out that we
have a problem preventing us from accepting new connections. *)
| Error
( Exn
(Unix.Unix_error
( ( EMFILE (* Too many open files by the process *)
| ENFILE (* Too many open files in the system *)
| ENETDOWN (* Network is down *) ),
_,
_ ))
:: _ as err ) ->
lwt_log_error
"@[<v 2>Incoming connection failed with %a in the\n\
\ Welcome worker. Resuming in 5s.@]"
pp_print_error
err
>>= fun () ->
(* These are temporary system errors, giving some time for the system to
recover *)
Lwt_unix.sleep 5. >>= fun () -> worker_loop st
| Error
( Exn
(Unix.Unix_error
( ( EAGAIN (* Resource temporarily unavailable; try again *)
| EWOULDBLOCK (* Operation would block *)
| ENOPROTOOPT (* Protocol not available *)
| EOPNOTSUPP (* Operation not supported on socket *)
| ENETUNREACH (* Network is unreachable *)
| ECONNABORTED (* Software caused connection abort *)
| ECONNRESET (* Connection reset by peer *)
| ETIMEDOUT (* Connection timed out *)
| EHOSTDOWN (* Host is down *)
| EHOSTUNREACH (* No route to host *)
(* Ugly hack to catch EPROTO and ENONET, Protocol error, which are not
defined in the Unix module (which is 20 years late on the POSIX
standard). A better solution is to use the package ocaml-unix-errno or
redo the work *)
| EUNKNOWNERR (71 | 64)
(* On Linux EPROTO is 71, ENONET is 64
On BSD systems, accept cannot raise EPROTO.
71 is EREMOTE for openBSD, NetBSD, Darwin, which is irrelevant here
64 is EHOSTDOWN for openBSD, NetBSD, Darwin, which is already caught
*)
),
_,
_ ))
:: _ as err ) ->
(* These are socket-specific errors, ignoring. *)
lwt_log_error
"@[<v 2>Incoming connection failed with %a in the Welcome worker@]"
pp_print_error
err
>>= fun () -> worker_loop st
| Error (Canceled :: _) ->
Lwt.return_unit
| Error err ->
lwt_log_error
"@[<v 2>Unexpected error in the Welcome worker@ %a@]"
pp_print_error
err
let create_listening_socket ~backlog ?(addr = Ipaddr.V6.unspecified) port =
let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ;
Lwt_unix.bind
main_socket
Unix.(ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port))
>>= fun () ->
Lwt_unix.listen main_socket backlog ;
Lwt.return main_socket
let create ?addr ~backlog connect_handler port =
Lwt.catch
(fun () ->
create_listening_socket ~backlog ?addr port
>>= fun socket ->
let canceler = Lwt_canceler.create () in
Lwt_canceler.on_cancel canceler (fun () ->
Lwt_utils_unix.safe_close socket) ;
let st =
{
socket;
canceler;
connect_handler = Connect_handler connect_handler;
worker = Lwt.return_unit;
}
in
Lwt.return st)
(fun exn ->
lwt_log_error
"@[<v 2>Cannot accept incoming connections@ %a@]"
pp_exn
exn
>>= fun () -> Lwt.fail exn)
let activate st =
st.worker <-
Lwt_utils.worker
"welcome"
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> worker_loop st)
~cancel:(fun () -> Lwt_canceler.cancel st.canceler)
let shutdown st = Lwt_canceler.cancel st.canceler >>= fun () -> st.worker
src/lib_p2p/p2p_welcome.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Inductive connect_handler : Type :=
| Connect_handler : forall {meta meta_conn msg : Type},
(Tezos_p2p.P2p_connect_handler.t msg meta meta_conn) -> connect_handler.
Record t := {
socket : Lwt_unix.file_descr;
canceler : Tezos_stdlib.Lwt_canceler.t;
connect_handler : connect_handler;
worker : Lwt.t unit }.
Fixpoint worker_loop (st : t) : Lwt.t unit :=
let 'Connect_handler pool := connect_handler st in
op_gtgteq (Lwt_unix.yield tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(protect None (Some (canceler st))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_fd.accept (socket st)) _return))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok (fd, addr) =>
let point :=
match addr with
| Lwt_unix.ADDR_UNIX _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| Lwt_unix.ADDR_INET addr port =>
((Ipaddr_unix.V6.of_inet_addr_exn addr), port)
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_connect_handler.accept pool fd point in
worker_loop st
|
Stdlib.Error
((cons
(Tezos_base__TzPervasives.Exn
(Unix_error (Unix.EMFILE | Unix.ENFILE | Unix.ENETDOWN) _ _))
_) as err) =>
op_gtgteq
(lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Incoming connection failed with " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" in the
Welcome worker. Resuming in 5s." %
string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>Incoming connection failed with %a in the
Welcome worker. Resuming in 5s.@]"
% string) pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_unix.sleep
(* ❌ Float constant 5. is approximated by the integer 5 *)
5)
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop st))
|
Stdlib.Error
((cons
(Tezos_base__TzPervasives.Exn
(Unix_error
(Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.ENOPROTOOPT |
Unix.EOPNOTSUPP | Unix.ENETUNREACH | Unix.ECONNABORTED |
Unix.ECONNRESET | Unix.ETIMEDOUT | Unix.EHOSTDOWN |
Unix.EHOSTUNREACH | Unix.EUNKNOWNERR (71 | 64)) _ _)) _)
as err) =>
op_gtgteq
(lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Incoming connection failed with " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" in the Welcome worker" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>Incoming connection failed with %a in the Welcome worker@]"
% string) pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop st)
| Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) =>
Lwt.return_unit
| Stdlib.Error err =>
lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Unexpected error in the Welcome worker" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>Unexpected error in the Welcome worker@ %a@]" % string)
pp_print_error err
end)).
Definition create_listening_socket
(backlog : Z) (op_staroptstar : option Ipaddr.V6.t)
: Z -> Lwt.t Lwt_unix.file_descr :=
let addr :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Ipaddr.V6.unspecified
end in
fun port =>
let main_socket := socket Lwt_unix.PF_INET6 Lwt_unix.SOCK_STREAM 0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := setsockopt main_socket Lwt_unix.SO_REUSEADDR true in
op_gtgteq
(Lwt_unix.bind main_socket
(Unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr) port))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_unix.listen main_socket backlog in
Lwt._return main_socket).
Definition create {A B C : Type}
(addr : option Ipaddr.V6.t) (backlog : Z)
(connect_handler : Tezos_p2p.P2p_connect_handler.t A B C) (port : Z)
: Lwt.t t :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (create_listening_socket backlog addr port)
(fun socket =>
let canceler := Lwt_canceler.create tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_canceler.on_cancel canceler
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.safe_close socket) in
let st :=
{| socket := socket; canceler := canceler;
connect_handler := Connect_handler connect_handler;
worker := Lwt.return_unit |} in
Lwt._return st))
(fun exn =>
op_gtgteq
(lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Cannot accept incoming connections" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>Cannot accept incoming connections@ %a@]" % string) pp_exn
exn)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.fail exn)).
Definition activate (st : t) : unit :=
(* ❌ Set record field not handled. *)
set_record_field st "worker" % string
(Lwt_utils.worker "welcome" % string
Internal_event.Lwt_worker_event.on_event
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop st)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler st))).
Definition shutdown (st : t) : Lwt.t unit :=
op_gtgteq (Lwt_canceler.cancel (canceler st))
(fun function_parameter =>
let 'tt := function_parameter in
worker st).
src/lib_p2p/test/process.ml 15 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
let () = Lwt_unix.set_default_async_method Async_none
let section = Lwt_log.Section.make "process"
let log_f ~level format =
if level < Lwt_log.Section.level section then
Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter format
else Format.kasprintf (fun msg -> Lwt_log.log ~section ~level msg) format
let lwt_debug fmt = log_f ~level:Lwt_log.Debug fmt
let lwt_log_notice fmt = log_f ~level:Lwt_log.Notice fmt
let lwt_log_info fmt = log_f ~level:Lwt_log.Info fmt
let lwt_log_error fmt = log_f ~level:Lwt_log.Error fmt
exception Exited of int
exception Signaled of int
exception Stopped of int
let handle_error f =
Lwt.catch f (fun exn -> Lwt.return_error [Exn exn])
>>= function
| Ok () ->
Lwt.return_unit
| Error err ->
lwt_debug "%a" pp_print_error err >>= fun () -> exit 1
module Channel = struct
type ('a, 'b) t = Lwt_io.input_channel * Lwt_io.output_channel
let push (_, outch) v =
Lwt.catch
(fun () -> Lwt_io.write_value outch v >>= Lwt.return_ok)
(fun exn -> Lwt.return_error [Exn exn])
let pop (inch, _) =
Lwt.catch
(fun () -> Lwt_io.read_value inch >>= Lwt.return_ok)
(fun exn -> Lwt.return_error [Exn exn])
end
let wait pid =
Lwt.catch
(fun () ->
Lwt_unix.waitpid [] pid
>>= function
| (_, Lwt_unix.WEXITED 0) ->
Lwt.return_ok ()
| (_, Lwt_unix.WEXITED n) ->
Lwt.return_error [Exn (Exited n)]
| (_, Lwt_unix.WSIGNALED n) ->
Lwt.return_error [Exn (Signaled n)]
| (_, Lwt_unix.WSTOPPED n) ->
Lwt.return_error [Exn (Stopped n)])
(function
| Lwt.Canceled ->
Unix.kill pid Sys.sigkill ; Lwt.return_ok ()
| exn ->
Lwt.return_error [Exn exn])
type ('a, 'b) t = {
termination : unit tzresult Lwt.t;
channel : ('b, 'a) Channel.t;
}
let template = "$(date) - $(section): $(message)"
let detach ?(prefix = "") f =
Lwt_io.flush_all ()
>>= fun () ->
let (main_in, child_out) = Lwt_io.pipe () in
let (child_in, main_out) = Lwt_io.pipe () in
match Lwt_unix.fork () with
| 0 ->
Lwt_log.default :=
Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr () ;
Random.self_init () ;
let template = Format.asprintf "%s$(message)" prefix in
Lwt_main.run
( Lwt_io.close main_in
>>= fun () ->
Lwt_io.close main_out
>>= fun () ->
Lwt_log.default :=
Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr () ;
lwt_log_notice "PID: %d" (Unix.getpid ())
>>= fun () -> handle_error (fun () -> f (child_in, child_out)) ) ;
exit 0
| pid ->
let termination = wait pid in
Lwt_io.close child_in
>>= fun () ->
Lwt_io.close child_out
>>= fun () -> Lwt.return {termination; channel = (main_in, main_out)}
let signal_name =
let names =
[ (Sys.sigabrt, "ABRT");
(Sys.sigalrm, "ALRM");
(Sys.sigfpe, "FPE");
(Sys.sighup, "HUP");
(Sys.sigill, "ILL");
(Sys.sigint, "INT");
(Sys.sigkill, "KILL");
(Sys.sigpipe, "PIPE");
(Sys.sigquit, "QUIT");
(Sys.sigsegv, "SEGV");
(Sys.sigterm, "TERM");
(Sys.sigusr1, "USR1");
(Sys.sigusr2, "USR2");
(Sys.sigchld, "CHLD");
(Sys.sigcont, "CONT");
(Sys.sigstop, "STOP");
(Sys.sigtstp, "TSTP");
(Sys.sigttin, "TTIN");
(Sys.sigttou, "TTOU");
(Sys.sigvtalrm, "VTALRM");
(Sys.sigprof, "PROF");
(Sys.sigbus, "BUS");
(Sys.sigpoll, "POLL");
(Sys.sigsys, "SYS");
(Sys.sigtrap, "TRAP");
(Sys.sigurg, "URG");
(Sys.sigxcpu, "XCPU");
(Sys.sigxfsz, "XFSZ") ]
in
fun n -> List.assoc n names
let wait_all processes =
let rec loop processes =
match processes with
| [] ->
Lwt.return_none
| processes -> (
Lwt.nchoose_split processes
>>= function
| (finished, remaining) ->
let rec handle = function
| [] ->
loop remaining
| Ok () :: finished ->
handle finished
| Error err :: _ ->
Lwt.return_some (err, remaining)
in
handle finished )
in
loop (List.map (fun p -> p.termination) processes)
>>= function
| None ->
lwt_log_info "All done!" >>= fun () -> Lwt.return_ok ()
| Some ([Exn (Exited n)], remaining) ->
lwt_log_error "Early error!"
>>= fun () ->
List.iter Lwt.cancel remaining ;
join remaining
>>= fun _ -> failwith "A process finished with error %d !" n
| Some ([Exn (Signaled n)], remaining) ->
lwt_log_error "Early error!"
>>= fun () ->
List.iter Lwt.cancel remaining ;
join remaining
>>= fun _ -> failwith "A process was killed by a SIG%s !" (signal_name n)
| Some ([Exn (Stopped n)], remaining) ->
lwt_log_error "Early error!"
>>= fun () ->
List.iter Lwt.cancel remaining ;
join remaining
>>= fun _ ->
failwith "A process was stopped by a SIG%s !" (signal_name n)
| Some (err, remaining) ->
lwt_log_error "@[<v 2>Unexpected error!@,%a@]" pp_print_error err
>>= fun () ->
List.iter Lwt.cancel remaining ;
join remaining
>>= fun _ -> failwith "A process finished with an unexpected error !"
src/lib_p2p/test/process.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Definition section : Lwt_log_core.section :=
Lwt_log.Section.make "process" % string.
Definition log_f {A : Type}
(level : Lwt_log.level)
(format : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
if OCaml.Stdlib.lt level (Lwt_log.Section.level section) then
Format.ikfprintf
(fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit) Format.std_formatter format
else
Format.kasprintf
(fun msg => Lwt_log.log None (Some section) None None level msg) format.
Definition lwt_debug {A : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
log_f Lwt_log.Debug fmt.
Definition lwt_log_notice {A : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
log_f Lwt_log.Notice fmt.
Definition lwt_log_info {A : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
log_f Lwt_log.Info fmt.
Definition lwt_log_error {A : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
log_f Lwt_log.Error fmt.
(* ❌ The definition of exceptions is not handled. *)
exception
(* ❌ The definition of exceptions is not handled. *)
exception
(* ❌ The definition of exceptions is not handled. *)
exception
Definition handle_error
(f :
unit ->
Lwt.t
(Result.result unit (list Tezos_base__TzPervasives.Error_monad.error)))
: Lwt.t unit :=
op_gtgteq
(Lwt.catch f
(fun exn =>
Lwt.return_error
(cons (Tezos_base__TzPervasives.Error_monad.Exn exn) [])))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error err =>
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.exit 1)
end).
Module Channel.
Definition t (a b : Type) := Lwt_io.input_channel * Lwt_io.output_channel.
Definition push {A B : Type} (function_parameter : A * Lwt_io.output_channel)
: B ->
Lwt.t
(Result.result unit (list Tezos_base__TzPervasives.Error_monad.error)) :=
let '(_, outch) := function_parameter in
fun v =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_io.write_value outch None v) Lwt.return_ok)
(fun exn =>
Lwt.return_error
(cons (Tezos_base__TzPervasives.Error_monad.Exn exn) [])).
Definition pop {A B : Type} (function_parameter : Lwt_io.input_channel * A)
: Lwt.t (Result.result B (list Tezos_base__TzPervasives.Error_monad.error)) :=
let '(inch, _) := function_parameter in
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_io.read_value inch) Lwt.return_ok)
(fun exn =>
Lwt.return_error
(cons (Tezos_base__TzPervasives.Error_monad.Exn exn) [])).
End Channel.
Definition wait (pid : Z)
: Lwt.t (Result.result unit (list Tezos_base__TzPervasives.Error_monad.error)) :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_unix.waitpid [] pid)
(fun function_parameter =>
match function_parameter with
| (_, Lwt_unix.WEXITED 0) => Lwt.return_ok tt
| (_, Lwt_unix.WEXITED n) =>
Lwt.return_error
(cons (Tezos_base__TzPervasives.Error_monad.Exn (Exited n)) [])
| (_, Lwt_unix.WSIGNALED n) =>
Lwt.return_error
(cons (Tezos_base__TzPervasives.Error_monad.Exn (Signaled n)) [])
| (_, Lwt_unix.WSTOPPED n) =>
Lwt.return_error
(cons (Tezos_base__TzPervasives.Error_monad.Exn (Stopped n)) [])
end))
(fun function_parameter =>
match function_parameter with
| Canceled =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Unix.kill pid Sys.sigkill in
Lwt.return_ok tt
| exn =>
Lwt.return_error
(cons (Tezos_base__TzPervasives.Error_monad.Exn exn) [])
end).
Record t {a b : Type} := {
termination : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit);
channel : Channel.t b a }.
Arguments t : clear implicits.
Definition template : string := "$(date) - $(section): $(message)" % string.
Definition detach {A B : Type} (op_staroptstar : option string)
: ((Lwt_io.input_channel * Lwt_io.output_channel) ->
Lwt.t (Result.result unit (list Tezos_base__TzPervasives.Error_monad.error)))
-> Lwt.t (t A B) :=
let prefix :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun f =>
op_gtgteq (Lwt_io.flush_all tt)
(fun function_parameter =>
let 'tt := function_parameter in
let '(main_in, child_out) := Lwt_io.pipe None None tt in
let '(child_in, main_out) := Lwt_io.pipe None None tt in
match Lwt_unix.fork tt with
| 0 =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq Lwt_log.default
(Lwt_log.channel (Some template)
(* ❌ Variants not supported *)
variant Lwt_io.stderr tt) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Random.self_init tt in
let template :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal "$(message)" % string
CamlinternalFormatBasics.End_of_format))
"%s$(message)" % string) prefix in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_main.run
(op_gtgteq (Lwt_io.close main_in)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_io.close main_out)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq Lwt_log.default
(Lwt_log.channel (Some template)
(* ❌ Variants not supported *)
variant Lwt_io.stderr tt) in
op_gtgteq
(lwt_log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"PID: " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"PID: %d" % string) (Unix.getpid tt))
(fun function_parameter =>
let 'tt := function_parameter in
handle_error
(fun function_parameter =>
let 'tt := function_parameter in
f (child_in, child_out)))))) in
Stdlib.exit 0
| pid =>
let termination := wait pid in
op_gtgteq (Lwt_io.close child_in)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_io.close child_out)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return
{| termination := termination;
channel := (main_in, main_out) |}))
end).
Definition signal_name : Z -> string :=
let names :=
cons (Sys.sigabrt, "ABRT" % string)
(cons (Sys.sigalrm, "ALRM" % string)
(cons (Sys.sigfpe, "FPE" % string)
(cons (Sys.sighup, "HUP" % string)
(cons (Sys.sigill, "ILL" % string)
(cons (Sys.sigint, "INT" % string)
(cons (Sys.sigkill, "KILL" % string)
(cons (Sys.sigpipe, "PIPE" % string)
(cons (Sys.sigquit, "QUIT" % string)
(cons (Sys.sigsegv, "SEGV" % string)
(cons (Sys.sigterm, "TERM" % string)
(cons (Sys.sigusr1, "USR1" % string)
(cons (Sys.sigusr2, "USR2" % string)
(cons (Sys.sigchld, "CHLD" % string)
(cons (Sys.sigcont, "CONT" % string)
(cons (Sys.sigstop, "STOP" % string)
(cons (Sys.sigtstp, "TSTP" % string)
(cons (Sys.sigttin, "TTIN" % string)
(cons (Sys.sigttou, "TTOU" % string)
(cons
(Sys.sigvtalrm, "VTALRM" % string)
(cons (Sys.sigprof, "PROF" % string)
(cons (Sys.sigbus, "BUS" % string)
(cons
(Sys.sigpoll, "POLL" % string)
(cons
(Sys.sigsys, "SYS" % string)
(cons
(Sys.sigtrap,
"TRAP" % string)
(cons
(Sys.sigurg,
"URG" % string)
(cons
(Sys.sigxcpu,
"XCPU" % string)
(cons
(Sys.sigxfsz,
"XFSZ" % string)
[])))))))))))))))))))))))))))
in
fun n => List.assoc n names.
Definition wait_all {A B : Type} (processes : list (t A B))
: Lwt.t (Result.result unit Tezos_base__TzPervasives.Error_monad.trace) :=
let fix loop {C : Type} (processes : list (Lwt.t (sum unit C)))
: Lwt.t (option (C * (list (Lwt.t (sum unit C))))) :=
match processes with
| [] => Lwt.return_none
| processes =>
op_gtgteq (Lwt.nchoose_split processes)
(fun function_parameter =>
let '(finished, remaining) := function_parameter in
let fix handle (function_parameter : list (sum unit C))
: Lwt.t (option (C * (list (Lwt.t (sum unit C))))) :=
match function_parameter with
| [] => loop remaining
| cons (Stdlib.Ok tt) finished => handle finished
| cons (Stdlib.Error err) _ => Lwt.return_some (err, remaining)
end in
handle finished)
end in
op_gtgteq (loop (List.map (fun p => termination p) processes))
(fun function_parameter =>
match function_parameter with
| None =>
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "All done!" % string
CamlinternalFormatBasics.End_of_format) "All done!" % string))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_ok tt)
|
Some
(cons (Tezos_base__TzPervasives.Error_monad.Exn (Exited n)) [],
remaining) =>
op_gtgteq
(lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Early error!" % string
CamlinternalFormatBasics.End_of_format) "Early error!" % string))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter Lwt.cancel remaining in
op_gtgteq (join remaining)
(fun function_parameter =>
let '_ := function_parameter in
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"A process finished with error " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " !" % string
CamlinternalFormatBasics.End_of_format)))
"A process finished with error %d !" % string) n))
|
Some
(cons (Tezos_base__TzPervasives.Error_monad.Exn (Signaled n)) [],
remaining) =>
op_gtgteq
(lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Early error!" % string
CamlinternalFormatBasics.End_of_format) "Early error!" % string))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter Lwt.cancel remaining in
op_gtgteq (join remaining)
(fun function_parameter =>
let '_ := function_parameter in
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"A process was killed by a SIG" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " !" % string
CamlinternalFormatBasics.End_of_format)))
"A process was killed by a SIG%s !" % string)
(signal_name n)))
|
Some
(cons (Tezos_base__TzPervasives.Error_monad.Exn (Stopped n)) [],
remaining) =>
op_gtgteq
(lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Early error!" % string
CamlinternalFormatBasics.End_of_format) "Early error!" % string))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter Lwt.cancel remaining in
op_gtgteq (join remaining)
(fun function_parameter =>
let '_ := function_parameter in
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"A process was stopped by a SIG" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " !" % string
CamlinternalFormatBasics.End_of_format)))
"A process was stopped by a SIG%s !" % string)
(signal_name n)))
| Some (err, remaining) =>
op_gtgteq
(lwt_log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Unexpected error!" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>Unexpected error!@,%a@]" % string) pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter Lwt.cancel remaining in
op_gtgteq (join remaining)
(fun function_parameter =>
let '_ := function_parameter in
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"A process finished with an unexpected error !" % string
CamlinternalFormatBasics.End_of_format)
"A process finished with an unexpected error !" % string)))
end).
src/lib_p2p/test/test_p2p_banned_peers.ml 15 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make (struct
let name = "test-p2p-banned_peers"
end)
let assert_equal_bool ~msg a b = if a <> b then Alcotest.fail msg
let a (peer, addr) =
(P2p_peer.Id.hash_string [peer], Ipaddr.V6.of_string_exn addr)
let foo = a ("foo", "ffff::3")
let bar = a ("bar", "ffff:00::ff")
let baz = a ("baz", "a::2")
let peers = [foo; bar; baz]
let test_empty _ =
let empty = P2p_acl.create 10 in
List.iter
(fun (_peer, addr) ->
assert_equal_bool ~msg:__LOC__ false (P2p_acl.banned_addr empty addr))
peers ;
Lwt.return_unit
let test_ban _ =
let set = P2p_acl.create 10 in
List.iter
(fun (_, addr) -> P2p_acl.IPGreylist.add set addr Ptime.epoch)
peers ;
List.iter
(fun (_, addr) ->
assert_equal_bool ~msg:__LOC__ true (P2p_acl.banned_addr set addr))
peers ;
Lwt.return_unit
let test_gc _ =
let set = P2p_acl.create 10 in
List.iter
(fun (_, addr) -> P2p_acl.IPGreylist.add set addr Ptime.epoch)
peers ;
List.iter
(fun (_peer, addr) ->
assert_equal_bool ~msg:__LOC__ true (P2p_acl.banned_addr set addr))
peers ;
(* remove all peers *)
P2p_acl.IPGreylist.remove_old set ~older_than:Ptime.max ;
List.iter
(fun (_peer, addr) ->
assert_equal_bool ~msg:__LOC__ false (P2p_acl.banned_addr set addr))
peers ;
Lwt.return_unit
let () =
let init_logs = lazy (Internal_event_unix.init ()) in
let wrap (n, f) =
Alcotest_lwt.test_case n `Quick (fun _ () ->
Lazy.force init_logs >>= fun () -> f ())
in
Alcotest.run
~argv:[|""|]
"tezos-p2p"
[ ( "p2p.peerset",
List.map
wrap
[("empty", test_empty); ("ban", test_ban); ("gc", test_gc)] ) ]
src/lib_p2p/test/test_p2p_banned_peers.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition assert_equal_bool {A B : Type} (msg : A) (a : B) (b : B) : unit :=
if nequiv_decb a b then
op_startypeminuserrorstar msg
else
tt.
Definition a (function_parameter : string * string)
: Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t :=
let '(peer, addr) := function_parameter in
((P2p_peer.Id.hash_string None (cons peer [])), (Ipaddr.V6.of_string_exn addr)).
Definition foo : Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t :=
a ("foo" % string, "ffff::3" % string).
Definition bar : Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t :=
a ("bar" % string, "ffff:00::ff" % string).
Definition baz : Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t :=
a ("baz" % string, "a::2" % string).
Definition peers
: list (Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t) :=
cons foo (cons bar (cons baz [])).
Definition test_empty {A : Type} (function_parameter : A) : Lwt.t unit :=
let '_ := function_parameter in
let empty := P2p_acl.create 10 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun function_parameter =>
let '(_peer, addr) := function_parameter in
assert_equal_bool Stdlib.__LOC__ false (P2p_acl.banned_addr empty addr))
peers in
Lwt.return_unit.
Definition test_ban {A : Type} (function_parameter : A) : Lwt.t unit :=
let '_ := function_parameter in
let set := P2p_acl.create 10 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun function_parameter =>
let '(_, addr) := function_parameter in
P2p_acl.IPGreylist.add set addr Ptime.epoch) peers in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun function_parameter =>
let '(_, addr) := function_parameter in
assert_equal_bool Stdlib.__LOC__ true (P2p_acl.banned_addr set addr))
peers in
Lwt.return_unit.
Definition test_gc {A : Type} (function_parameter : A) : Lwt.t unit :=
let '_ := function_parameter in
let set := P2p_acl.create 10 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun function_parameter =>
let '(_, addr) := function_parameter in
P2p_acl.IPGreylist.add set addr Ptime.epoch) peers in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun function_parameter =>
let '(_peer, addr) := function_parameter in
assert_equal_bool Stdlib.__LOC__ true (P2p_acl.banned_addr set addr))
peers in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_acl.IPGreylist.remove_old set Ptime.max in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun function_parameter =>
let '(_peer, addr) := function_parameter in
assert_equal_bool Stdlib.__LOC__ false (P2p_acl.banned_addr set addr))
peers in
Lwt.return_unit.
src/lib_p2p/test/test_p2p_io_scheduler.ml 18 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make (struct
let name = "test-p2p-io-scheduler"
end)
exception Error of error list
let rec listen ?port addr =
let tentative_port =
match port with None -> 1024 + Random.int 8192 | Some port -> port
in
let uaddr = Ipaddr_unix.V6.to_inet_addr addr in
let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ;
Lwt.catch
(fun () ->
Lwt_unix.bind main_socket (ADDR_INET (uaddr, tentative_port))
>>= fun () ->
Lwt_unix.listen main_socket 50 ;
Lwt.return (main_socket, tentative_port))
(function
| Unix.Unix_error ((Unix.EADDRINUSE | Unix.EADDRNOTAVAIL), _, _)
when port = None ->
listen addr
| exn ->
Lwt.fail exn)
let accept main_socket =
P2p_fd.accept main_socket >>= fun (fd, _sockaddr) -> return fd
let rec accept_n main_socket n =
if n <= 0 then return_nil
else
accept_n main_socket (n - 1)
>>=? fun acc -> accept main_socket >>=? fun conn -> return (conn :: acc)
let connect addr port =
let fd = P2p_fd.socket PF_INET6 SOCK_STREAM 0 in
let uaddr = Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port) in
P2p_fd.connect fd uaddr >>= fun () -> return fd
let simple_msgs =
[| Bytes.create (1 lsl 6);
Bytes.create (1 lsl 7);
Bytes.create (1 lsl 8);
Bytes.create (1 lsl 9);
Bytes.create (1 lsl 10);
Bytes.create (1 lsl 11);
Bytes.create (1 lsl 12);
Bytes.create (1 lsl 13);
Bytes.create (1 lsl 14);
Bytes.create (1 lsl 15);
Bytes.create (1 lsl 16) |]
let nb_simple_msgs = Array.length simple_msgs
let receive conn =
let buf = Bytes.create (1 lsl 16) in
let rec loop () =
P2p_io_scheduler.read conn buf
>>= function
| Ok _ ->
loop ()
| Error (P2p_errors.Connection_closed :: _) ->
Lwt.return_unit
| Error err ->
Lwt.fail (Error err)
in
loop ()
let server ?(display_client_stat = true) ?max_download_speed ?read_queue_size
~read_buffer_size main_socket n =
let sched =
P2p_io_scheduler.create
?max_download_speed
?read_queue_size
~read_buffer_size
()
in
Moving_average.on_update (fun () ->
log_notice "Stat: %a" P2p_stat.pp (P2p_io_scheduler.global_stat sched) ;
if display_client_stat then
P2p_io_scheduler.iter_connection sched (fun conn ->
log_notice
" client(%d) %a"
(P2p_io_scheduler.id conn)
P2p_stat.pp
(P2p_io_scheduler.stat conn))) ;
(* Accept and read message until the connection is closed. *)
accept_n main_socket n
>>=? fun conns ->
let conns = List.map (P2p_io_scheduler.register sched) conns in
Lwt.join (List.map receive conns)
>>= fun () ->
iter_p P2p_io_scheduler.close conns
>>=? fun () ->
log_notice "OK %a" P2p_stat.pp (P2p_io_scheduler.global_stat sched) ;
return_unit
let max_size ?max_upload_speed () =
match max_upload_speed with
| None ->
nb_simple_msgs
| Some max_upload_speed ->
let rec loop n =
if n <= 1 then 1
else if Bytes.length simple_msgs.(n - 1) <= max_upload_speed then n
else loop (n - 1)
in
loop nb_simple_msgs
let rec send conn nb_simple_msgs =
Lwt_main.yield ()
>>= fun () ->
let msg = simple_msgs.(Random.int nb_simple_msgs) in
P2p_io_scheduler.write conn msg >>=? fun () -> send conn nb_simple_msgs
let client ?max_upload_speed ?write_queue_size addr port time _n =
let sched =
P2p_io_scheduler.create
?max_upload_speed
?write_queue_size
~read_buffer_size:(1 lsl 12)
()
in
connect addr port
>>=? fun conn ->
let conn = P2p_io_scheduler.register sched conn in
let nb_simple_msgs = max_size ?max_upload_speed () in
Lwt.pick [send conn nb_simple_msgs; Lwt_unix.sleep time >>= return]
>>=? fun () ->
P2p_io_scheduler.close conn
>>=? fun () ->
let stat = P2p_io_scheduler.stat conn in
lwt_log_notice "Client OK %a" P2p_stat.pp stat >>= fun () -> return_unit
let run ?display_client_stat ?max_download_speed ?max_upload_speed
~read_buffer_size ?read_queue_size ?write_queue_size addr port time n =
Internal_event_unix.init ()
>>= fun () ->
listen ?port addr
>>= fun (main_socket, port) ->
Process.detach ~prefix:"server: " (fun _ ->
server
?display_client_stat
?max_download_speed
~read_buffer_size
?read_queue_size
main_socket
n)
>>= fun server_node ->
let client n =
let prefix = Printf.sprintf "client(%d): " n in
Process.detach ~prefix (fun _ ->
Lwt_utils_unix.safe_close main_socket
>>= fun () ->
client ?max_upload_speed ?write_queue_size addr port time n)
in
Lwt_list.map_p client (1 -- n)
>>= fun client_nodes -> Process.wait_all (server_node :: client_nodes)
let () = Random.self_init ()
let addr = ref Ipaddr.V6.localhost
let port = ref None
let max_download_speed = ref None
let max_upload_speed = ref None
let read_buffer_size = ref (1 lsl 14)
let read_queue_size = ref (Some (1 lsl 14))
let write_queue_size = ref (Some (1 lsl 14))
let delay = ref 60.
let clients = ref 8
let display_client_stat = ref None
let spec =
Arg.
[ ("--port", Int (fun p -> port := Some p), " Listening port");
( "--addr",
String (fun p -> addr := Ipaddr.V6.of_string_exn p),
" Listening addr" );
( "--max-download-speed",
Int (fun i -> max_download_speed := Some i),
" Max download speed in B/s (default: unbounded)" );
( "--max-upload-speed",
Int (fun i -> max_upload_speed := Some i),
" Max upload speed in B/s (default: unbounded)" );
( "--read-buffer-size",
Set_int read_buffer_size,
" Size of the read buffers" );
( "--read-queue-size",
Int (fun i -> read_queue_size := if i <= 0 then None else Some i),
" Size of the read queue (0=unbounded)" );
( "--write-queue-size",
Int (fun i -> write_queue_size := if i <= 0 then None else Some i),
" Size of the write queue (0=unbounded)" );
("--delay", Set_float delay, " Client execution time.");
("--clients", Set_int clients, " Number of concurrent clients.");
( "--hide-clients-stat",
Unit (fun () -> display_client_stat := Some false),
" Hide the client bandwidth statistic." );
( "--display_clients_stat",
Unit (fun () -> display_client_stat := Some true),
" Display the client bandwidth statistic." ) ]
let () =
let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in
let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
Arg.parse spec anon_fun usage_msg
let init_logs = lazy (Internal_event_unix.init ())
let wrap n f =
Alcotest_lwt.test_case n `Quick (fun _ () ->
Lazy.force init_logs
>>= fun () ->
f ()
>>= function
| Ok () ->
Lwt.return_unit
| Error error ->
Format.kasprintf Pervasives.failwith "%a" pp_print_error error)
let () =
Alcotest.run
~argv:[|""|]
"tezos-p2p"
[ ( "p2p.io-scheduler",
[ wrap "trivial-quota" (fun () ->
run
?display_client_stat:!display_client_stat
?max_download_speed:!max_download_speed
?max_upload_speed:!max_upload_speed
~read_buffer_size:!read_buffer_size
?read_queue_size:!read_queue_size
?write_queue_size:!write_queue_size
!addr
!port
!delay
!clients) ] ) ]
src/lib_p2p/test/test_p2p_io_scheduler.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ The definition of exceptions is not handled. *)
exception
Fixpoint listen (port : option Z) (addr : Ipaddr.V6.t)
: Lwt.t (Lwt_unix.file_descr * Z) :=
let tentative_port :=
match port with
| None => Z.add 1024 (Random.int 8192)
| Some port => port
end in
let uaddr := Ipaddr_unix.V6.to_inet_addr addr in
let main_socket := socket Lwt_unix.PF_INET6 Lwt_unix.SOCK_STREAM 0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := setsockopt main_socket Lwt_unix.SO_REUSEADDR true in
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_unix.bind main_socket (Lwt_unix.ADDR_INET uaddr tentative_port))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_unix.listen main_socket 50 in
Lwt._return (main_socket, tentative_port)))
(fun function_parameter =>
match function_parameter with
| Unix_error (Unix.EADDRINUSE | Unix.EADDRNOTAVAIL) _ _ =>
listen None addr
| exn => Lwt.fail exn
end).
Definition accept (main_socket : Lwt_unix.file_descr)
: Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_p2p.P2p_fd.t) :=
op_gtgteq (P2p_fd.accept main_socket)
(fun function_parameter =>
let '(fd, _sockaddr) := function_parameter in
_return fd).
Fixpoint accept_n (main_socket : Lwt_unix.file_descr) (n : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult (list Tezos_p2p.P2p_fd.t)) :=
if OCaml.Stdlib.le n 0 then
return_nil
else
op_gtgteqquestion (accept_n main_socket (Z.sub n 1))
(fun acc =>
op_gtgteqquestion (accept main_socket)
(fun conn => _return (cons conn acc))).
Definition connect (addr : Ipaddr.V6.t) (port : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_p2p.P2p_fd.t) :=
let fd := P2p_fd.socket Lwt_unix.PF_INET6 Lwt_unix.SOCK_STREAM 0 in
let uaddr := Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr) port in
op_gtgteq (P2p_fd.connect fd uaddr)
(fun function_parameter =>
let 'tt := function_parameter in
_return fd).
Definition simple_msgs : array string :=
(* ❌ Arrays not handled. *)
[
Stdlib.Bytes.create (Z.shiftl 1 6);
Stdlib.Bytes.create (Z.shiftl 1 7);
Stdlib.Bytes.create (Z.shiftl 1 8);
Stdlib.Bytes.create (Z.shiftl 1 9);
Stdlib.Bytes.create (Z.shiftl 1 10);
Stdlib.Bytes.create (Z.shiftl 1 11);
Stdlib.Bytes.create (Z.shiftl 1 12);
Stdlib.Bytes.create (Z.shiftl 1 13);
Stdlib.Bytes.create (Z.shiftl 1 14);
Stdlib.Bytes.create (Z.shiftl 1 15);
Stdlib.Bytes.create (Z.shiftl 1 16)
].
Definition nb_simple_msgs : Z := Array.length simple_msgs.
Definition receive (conn : Tezos_p2p.P2p_io_scheduler.connection)
: Lwt.t unit :=
let buf := Stdlib.Bytes.create (Z.shiftl 1 16) in
let fix loop (function_parameter : unit) : Lwt.t unit :=
let 'tt := function_parameter in
op_gtgteq (P2p_io_scheduler.read None conn None None buf)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok _ => loop tt
| Stdlib.Error (cons Tezos_base__TzPervasives.Connection_closed _) =>
Lwt.return_unit
| Stdlib.Error err => Lwt.fail (inr err)
end) in
loop tt.
Definition server (op_staroptstar : option bool)
: (option Z) ->
(option Z) ->
Z ->
Lwt_unix.file_descr ->
Z -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let display_client_stat :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun max_download_speed =>
fun read_queue_size =>
fun read_buffer_size =>
fun main_socket =>
fun n =>
let sched :=
P2p_io_scheduler.create None max_download_speed read_queue_size
None read_buffer_size tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Moving_average.on_update
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Stat: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Stat: %a" % string) P2p_stat.pp
(P2p_io_scheduler.global_stat sched) in
if display_client_stat then
P2p_io_scheduler.iter_connection sched
(fun conn =>
log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" client(" % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
") " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
" client(%d) %a" % string)
(P2p_io_scheduler.id conn) P2p_stat.pp
(P2p_io_scheduler.stat conn))
else
tt) in
op_gtgteqquestion (accept_n main_socket n)
(fun conns =>
let conns := List.map (P2p_io_scheduler.register sched) conns in
op_gtgteq (Lwt.join (List.map receive conns))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(iter_p
(let arg := P2p_io_scheduler.close in
fun eta => arg None eta) conns)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"OK " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"OK %a" % string) P2p_stat.pp
(P2p_io_scheduler.global_stat sched) in
return_unit))).
Definition max_size (max_upload_speed : option Z) (function_parameter : unit)
: Z :=
let 'tt := function_parameter in
match max_upload_speed with
| None => nb_simple_msgs
| Some max_upload_speed =>
let fix loop (n : Z) : Z :=
if OCaml.Stdlib.le n 1 then
1
else
if
OCaml.Stdlib.le (String.length (Array.get simple_msgs (Z.sub n 1)))
max_upload_speed then
n
else
loop (Z.sub n 1) in
loop nb_simple_msgs
end.
Fixpoint send {A : Type}
(conn : Tezos_p2p.P2p_io_scheduler.connection) (nb_simple_msgs : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
op_gtgteq (Lwt_main.yield tt)
(fun function_parameter =>
let 'tt := function_parameter in
let msg := Array.get simple_msgs (Random.int nb_simple_msgs) in
op_gtgteqquestion (P2p_io_scheduler.write None conn msg)
(fun function_parameter =>
let 'tt := function_parameter in
send conn nb_simple_msgs)).
Definition client {A : Type}
(max_upload_speed : option Z) (write_queue_size : option Z)
(addr : Ipaddr.V6.t) (port : Z) (time : Z) (_n : A)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let sched :=
P2p_io_scheduler.create max_upload_speed None None write_queue_size
(Z.shiftl 1 12) tt in
op_gtgteqquestion (connect addr port)
(fun conn =>
let conn := P2p_io_scheduler.register sched conn in
let nb_simple_msgs := max_size max_upload_speed tt in
op_gtgteqquestion
(Lwt.pick
(cons (send conn nb_simple_msgs)
(cons (op_gtgteq (Lwt_unix.sleep time) _return) [])))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (P2p_io_scheduler.close None conn)
(fun function_parameter =>
let 'tt := function_parameter in
let stat := P2p_io_scheduler.stat conn in
op_gtgteq
(lwt_log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Client OK " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Client OK %a" % string) P2p_stat.pp stat)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))).
Definition run {A : Type}
(display_client_stat : option bool) (max_download_speed : option Z)
(max_upload_speed : option Z) (read_buffer_size : Z)
(read_queue_size : option Z) (write_queue_size : option Z)
(addr : Ipaddr.V6.t) (port : option Z) (time : Z) (n : Z) : Lwt.t A :=
op_gtgteq (Internal_event_unix.init None None tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (listen port addr)
(fun function_parameter =>
let '(main_socket, port) := function_parameter in
op_gtgteq
(op_startypeminuserrorstar "server: " % string
(fun function_parameter =>
let '_ := function_parameter in
server display_client_stat max_download_speed read_queue_size
read_buffer_size main_socket n))
(fun server_node =>
let client {B : Type} (n : Z) : B :=
let prefix :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"client(" % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
"): " % string
CamlinternalFormatBasics.End_of_format)))
"client(%d): " % string) n in
op_startypeminuserrorstar prefix
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Lwt_utils_unix.safe_close main_socket)
(fun function_parameter =>
let 'tt := function_parameter in
client max_upload_speed write_queue_size addr port time
n)) in
op_gtgteq (Lwt_list.map_p client (op_minusminus 1 n))
(fun client_nodes =>
op_startypeminuserrorstar (cons server_node client_nodes))))).
Definition addr : Stdlib.ref Ipaddr.V6.t := Stdlib.ref Ipaddr.V6.localhost.
Definition port : Stdlib.ref (option Z) := Stdlib.ref None.
Definition max_download_speed : Stdlib.ref (option Z) := Stdlib.ref None.
Definition max_upload_speed : Stdlib.ref (option Z) := Stdlib.ref None.
Definition read_buffer_size : Stdlib.ref Z := Stdlib.ref (Z.shiftl 1 14).
Definition read_queue_size : Stdlib.ref (option Z) :=
Stdlib.ref (Some (Z.shiftl 1 14)).
Definition write_queue_size : Stdlib.ref (option Z) :=
Stdlib.ref (Some (Z.shiftl 1 14)).
Definition delay : Stdlib.ref Z :=
Stdlib.ref
(* ❌ Float constant 60. is approximated by the integer 60 *)
60.
Definition clients : Stdlib.ref Z := Stdlib.ref 8.
Definition display_client_stat : Stdlib.ref (option bool) := Stdlib.ref None.
Definition spec : list (string * Stdlib.Arg.spec * string) :=
cons
("--port" % string,
(Stdlib.Arg.Int (fun p => Stdlib.op_coloneq port (Some p))),
" Listening port" % string)
(cons
("--addr" % string,
(Stdlib.Arg.String
(fun p => Stdlib.op_coloneq addr (Ipaddr.V6.of_string_exn p))),
" Listening addr" % string)
(cons
("--max-download-speed" % string,
(Stdlib.Arg.Int
(fun i => Stdlib.op_coloneq max_download_speed (Some i))),
" Max download speed in B/s (default: unbounded)" % string)
(cons
("--max-upload-speed" % string,
(Stdlib.Arg.Int
(fun i => Stdlib.op_coloneq max_upload_speed (Some i))),
" Max upload speed in B/s (default: unbounded)" % string)
(cons
("--read-buffer-size" % string,
(Stdlib.Arg.Set_int read_buffer_size),
" Size of the read buffers" % string)
(cons
("--read-queue-size" % string,
(Stdlib.Arg.Int
(fun i =>
Stdlib.op_coloneq read_queue_size
(if OCaml.Stdlib.le i 0 then
None
else
Some i))),
" Size of the read queue (0=unbounded)" % string)
(cons
("--write-queue-size" % string,
(Stdlib.Arg.Int
(fun i =>
Stdlib.op_coloneq write_queue_size
(if OCaml.Stdlib.le i 0 then
None
else
Some i))),
" Size of the write queue (0=unbounded)" % string)
(cons
("--delay" % string, (Stdlib.Arg.Set_float delay),
" Client execution time." % string)
(cons
("--clients" % string, (Stdlib.Arg.Set_int clients),
" Number of concurrent clients." % string)
(cons
("--hide-clients-stat" % string,
(Stdlib.Arg.Unit
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_coloneq display_client_stat (Some false))),
" Hide the client bandwidth statistic." % string)
(cons
("--display_clients_stat" % string,
(Stdlib.Arg.Unit
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_coloneq display_client_stat (Some true))),
" Display the client bandwidth statistic." % string)
[])))))))))).
Definition init_logs : lazy_t (Lwt.t unit) :=
(* ❌ Lazy expressions are not handled *)
lazy (Internal_event_unix.init None None tt).
Definition wrap {A B : Type}
(n : A) (f : unit -> Lwt.t (sum unit Tezos_base__TzPervasives.trace)) : B :=
op_startypeminuserrorstar n
(* ❌ Variants not supported *)
variant
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lazy.force init_logs)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (f tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error error =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
pp_print_error error
end))).
src/lib_p2p/test/test_p2p_ipv6set.ml 59 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make (struct
let name = "test-p2p-banned_ip"
end)
let assert_equal ?(eq = ( = )) ?prn ~msg a b =
let msg =
match prn with
| None ->
msg
| Some prn ->
Format.asprintf "@[<v 2>%s@,n(%a)@,<>@,(%a)@]" msg prn a prn b
in
if not (eq a b) then Alcotest.fail msg
let assert_equal_bool = assert_equal
let a = Ipaddr.V6.of_string_exn
let p = Ipaddr.V6.Prefix.of_string_exn
let timenow = Systime_os.now ()
let of_list l =
List.fold_left
(fun acc k -> P2p_acl.IpSet.add_prefix k timenow acc)
P2p_acl.IpSet.empty
l
let test_empty _ =
let addrs = List.map a ["::"; "ffff::"; "a::2"] in
List.iter
(fun addr ->
assert_equal_bool
~msg:__LOC__
false
(P2p_acl.IpSet.mem addr P2p_acl.IpSet.empty))
addrs
let test_inclusion _ =
let set =
P2p_acl.IpSet.add_prefix (p "ffff::/16") timenow P2p_acl.IpSet.empty
in
let included = List.map a ["ffff::3"; "ffff:ffff::"; "ffff:00::ff"] in
let not_included = List.map a ["fffe::3"; "ffee:ffff::"; "::"] in
List.iter
(fun addr ->
assert_equal_bool ~msg:__LOC__ true (P2p_acl.IpSet.mem addr set))
included ;
List.iter
(fun addr ->
assert_equal_bool ~msg:__LOC__ false (P2p_acl.IpSet.mem addr set))
not_included ;
let set =
P2p_acl.IpSet.add_prefix (p "f000::/4") timenow P2p_acl.IpSet.empty
in
assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "e000::") set) ;
(* Add one IP *)
let set =
P2p_acl.IpSet.add_prefix (p "::/128") timenow P2p_acl.IpSet.empty
in
assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "1::") set) ;
let set =
P2p_acl.IpSet.add_prefix (p "ffff:eeee::/32") timenow P2p_acl.IpSet.empty
in
assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "eeee:ffff::1") set) ;
assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "ffff:eeee::1") set) ;
let set = P2p_acl.IpSet.add_prefix (p "::/17") timenow P2p_acl.IpSet.empty in
assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "0000:0000::") set) ;
assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "0000:7000::") set) ;
assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "0000:8000::1") set) ;
let setlist = [p "e000::/4"; p "a000::/4"; p "ffff::/16"] in
let set = of_list setlist in
assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "ffff::1") set) ;
assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "a111:8000::1") set) ;
let set =
of_list [p "e000::/4"; p "a000::/4"; p "1234:5678::1/128"; p "ffff::/16"]
in
assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "1234:5678::1") set) ;
assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "a111:8000::1") set) ;
assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "b111:8000::1") set) ;
assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "1234:5678::100") set)
let test_contiguous _ =
let set = of_list [p "::/1"; p "8000::/1"] in
List.iter
(fun addr -> assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem addr set))
[a "00::"; a "01::"; a "ff::"]
module PSet = Set.Make (Ipaddr.V6.Prefix)
let test_fold _ =
let addr_list = [p "::/1"; p "8000::/1"; p "ffff:ffff::/32"] in
let pset = PSet.of_list addr_list in
let ipv6set =
P2p_acl.IpSet.fold
(fun prefix _value s -> PSet.add prefix s)
(of_list addr_list)
PSet.empty
in
assert_equal ~eq:PSet.equal ~msg:__LOC__ ipv6set pset
let print_pset ppf pset =
PSet.iter (fun p -> Format.fprintf ppf "%a " Ipaddr.V6.Prefix.pp p) pset
let print_list ppf l =
List.iter (fun p -> Format.fprintf ppf "%a " Ipaddr.V6.Prefix.pp p) l
let test_to_list _ =
let to_list s = P2p_acl.IpSet.fold (fun k _v acc -> k :: acc) s [] in
let list_eq = List.for_all2 (fun x y -> Ipaddr.V6.Prefix.compare x y = 0) in
let assert_equal_set ~msg a b =
let a = List.sort compare a in
let b = List.sort compare (to_list b) in
assert_equal ~prn:print_list ~eq:list_eq ~msg a b
in
let set = P2p_acl.IpSet.add_prefix (p "::/0") timenow P2p_acl.IpSet.empty in
assert_equal
~eq:list_eq
~prn:print_list
~msg:__LOC__
[p "::/0"]
(to_list set) ;
let set = of_list [p "::/1"; p "8000::/1"] in
assert_equal
~eq:list_eq
~prn:print_list
~msg:__LOC__
[p "8000::/1"; p "::/1"]
(to_list set) ;
let setlist = [p "1234:5678::/32"] in
let set = of_list setlist in
assert_equal_set ~msg:__LOC__ setlist set ;
let setlist =
[p "e000::/4"; p "a000::/4"; p "ffff::/16"; p "1234:5678::/32"]
in
let set = of_list setlist in
assert_equal_set ~msg:__LOC__ setlist set
let () =
Alcotest.run
~argv:[|""|]
"tezos-p2p"
[ ( "p2p.ipv6set",
[ ("empty", `Quick, test_empty);
("inclusion", `Quick, test_inclusion);
("contiguous", `Quick, test_contiguous);
("test_fold", `Quick, test_fold);
("to_list", `Quick, test_to_list) ] ) ]
src/lib_p2p/test/test_p2p_ipv6set.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition assert_equal {A : Type} (op_staroptstar : option (A -> A -> bool))
: (option (Stdlib.Format.formatter -> A -> unit)) -> string -> A -> A -> unit :=
let eq :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => equiv_decb
end in
fun prn =>
fun msg =>
fun a =>
fun b =>
let msg :=
match prn with
| None => msg
| Some prn =>
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "n(" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0
0)
(CamlinternalFormatBasics.String_literal
"<>" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Char_literal
"(" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))
"@[<v 2>%s@,n(%a)@,<>@,(%a)@]" % string) msg prn a prn b
end in
if negb (eq a b) then
op_startypeminuserrorstar msg
else
tt.
Definition assert_equal_bool {A : Type}
: (option (A -> A -> bool)) ->
(option (Stdlib.Format.formatter -> A -> unit)) -> string -> A -> A -> unit :=
assert_equal.
Definition a : string -> Ipaddr.V6.t := Ipaddr.V6.of_string_exn.
Definition p : string -> Ipaddr.V6.Prefix.t := Ipaddr.V6.Prefix.of_string_exn.
Definition timenow : Ptime.t := Systime_os.now tt.
Definition of_list (l : list Ipaddr.V6.Prefix.t) : Tezos_p2p.P2p_acl.IpSet.t :=
List.fold_left (fun acc => fun k => P2p_acl.IpSet.add_prefix k timenow acc)
P2p_acl.IpSet.empty l.
Definition test_empty {A : Type} (function_parameter : A) : unit :=
let '_ := function_parameter in
let addrs :=
List.map a
(cons "::" % string (cons "ffff::" % string (cons "a::2" % string []))) in
List.iter
(fun addr =>
assert_equal_bool None None Stdlib.__LOC__ false
(P2p_acl.IpSet.mem addr P2p_acl.IpSet.empty)) addrs.
Definition test_inclusion {A : Type} (function_parameter : A) : unit :=
let '_ := function_parameter in
let set :=
P2p_acl.IpSet.add_prefix (p "ffff::/16" % string) timenow
P2p_acl.IpSet.empty in
let included :=
List.map a
(cons "ffff::3" % string
(cons "ffff:ffff::" % string (cons "ffff:00::ff" % string []))) in
let not_included :=
List.map a
(cons "fffe::3" % string
(cons "ffee:ffff::" % string (cons "::" % string []))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun addr =>
assert_equal_bool None None Stdlib.__LOC__ true
(P2p_acl.IpSet.mem addr set)) included in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun addr =>
assert_equal_bool None None Stdlib.__LOC__ false
(P2p_acl.IpSet.mem addr set)) not_included in
let set :=
P2p_acl.IpSet.add_prefix (p "f000::/4" % string) timenow P2p_acl.IpSet.empty
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal None None Stdlib.__LOC__ false
(P2p_acl.IpSet.mem (a "e000::" % string) set) in
let set :=
P2p_acl.IpSet.add_prefix (p "::/128" % string) timenow P2p_acl.IpSet.empty
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal None None Stdlib.__LOC__ false
(P2p_acl.IpSet.mem (a "1::" % string) set) in
let set :=
P2p_acl.IpSet.add_prefix (p "ffff:eeee::/32" % string) timenow
P2p_acl.IpSet.empty in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal None None Stdlib.__LOC__ false
(P2p_acl.IpSet.mem (a "eeee:ffff::1" % string) set) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal None None Stdlib.__LOC__ true
(P2p_acl.IpSet.mem (a "ffff:eeee::1" % string) set) in
let set :=
P2p_acl.IpSet.add_prefix (p "::/17" % string) timenow P2p_acl.IpSet.empty in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal None None Stdlib.__LOC__ true
(P2p_acl.IpSet.mem (a "0000:0000::" % string) set) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal None None Stdlib.__LOC__ true
(P2p_acl.IpSet.mem (a "0000:7000::" % string) set) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal None None Stdlib.__LOC__ false
(P2p_acl.IpSet.mem (a "0000:8000::1" % string) set) in
let setlist :=
cons (p "e000::/4" % string)
(cons (p "a000::/4" % string) (cons (p "ffff::/16" % string) [])) in
let set := of_list setlist in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal None None Stdlib.__LOC__ true
(P2p_acl.IpSet.mem (a "ffff::1" % string) set) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal None None Stdlib.__LOC__ true
(P2p_acl.IpSet.mem (a "a111:8000::1" % string) set) in
let set :=
of_list
(cons (p "e000::/4" % string)
(cons (p "a000::/4" % string)
(cons (p "1234:5678::1/128" % string)
(cons (p "ffff::/16" % string) [])))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal None None Stdlib.__LOC__ true
(P2p_acl.IpSet.mem (a "1234:5678::1" % string) set) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal None None Stdlib.__LOC__ true
(P2p_acl.IpSet.mem (a "a111:8000::1" % string) set) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal None None Stdlib.__LOC__ false
(P2p_acl.IpSet.mem (a "b111:8000::1" % string) set) in
assert_equal None None Stdlib.__LOC__ false
(P2p_acl.IpSet.mem (a "1234:5678::100" % string) set).
Definition test_contiguous {A : Type} (function_parameter : A) : unit :=
let '_ := function_parameter in
let set :=
of_list (cons (p "::/1" % string) (cons (p "8000::/1" % string) [])) in
List.iter
(fun addr =>
assert_equal None None Stdlib.__LOC__ true (P2p_acl.IpSet.mem addr set))
(cons (a "00::" % string)
(cons (a "01::" % string) (cons (a "ff::" % string) []))).
(* ❌ Applications of functors are not handled. *)
functor_application
Definition test_fold {A : Type} (function_parameter : A) : unit :=
let '_ := function_parameter in
let addr_list :=
cons (p "::/1" % string)
(cons (p "8000::/1" % string) (cons (p "ffff:ffff::/32" % string) [])) in
let pset := PSet.of_list addr_list in
let ipv6set :=
P2p_acl.IpSet.fold (fun prefix => fun _value => fun s => PSet.add prefix s)
(of_list addr_list) PSet.empty in
assert_equal (Some PSet.equal) None Stdlib.__LOC__ ipv6set pset.
Definition print_pset (ppf : Stdlib.Format.formatter) (pset : PSet.t) : unit :=
PSet.iter
(fun p =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal " " % char
CamlinternalFormatBasics.End_of_format)) "%a " % string)
Ipaddr.V6.Prefix.pp p) pset.
Definition print_list
(ppf : Stdlib.Format.formatter) (l : list Ipaddr.V6.Prefix.t) : unit :=
List.iter
(fun p =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal " " % char
CamlinternalFormatBasics.End_of_format)) "%a " % string)
Ipaddr.V6.Prefix.pp p) l.
Definition test_to_list {A : Type} (function_parameter : A) : unit :=
let '_ := function_parameter in
let to_list (s : Tezos_p2p.P2p_acl.IpSet.t) : list Ipaddr.V6.Prefix.t :=
P2p_acl.IpSet.fold (fun k => fun _v => fun acc => cons k acc) s [] in
let list_eq :=
List.for_all2
(fun x => fun y => equiv_decb (Ipaddr.V6.Prefix.compare x y) 0) in
let assert_equal_set
(msg : string) (a : list Ipaddr.V6.Prefix.t) (b : Tezos_p2p.P2p_acl.IpSet.t)
: unit :=
let a := List.sort OCaml.Stdlib.compare a in
let b := List.sort OCaml.Stdlib.compare (to_list b) in
assert_equal (Some list_eq) (Some print_list) msg a b in
let set :=
P2p_acl.IpSet.add_prefix (p "::/0" % string) timenow P2p_acl.IpSet.empty in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal (Some list_eq) (Some print_list) Stdlib.__LOC__
(cons (p "::/0" % string) []) (to_list set) in
let set :=
of_list (cons (p "::/1" % string) (cons (p "8000::/1" % string) [])) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal (Some list_eq) (Some print_list) Stdlib.__LOC__
(cons (p "8000::/1" % string) (cons (p "::/1" % string) [])) (to_list set)
in
let setlist := cons (p "1234:5678::/32" % string) [] in
let set := of_list setlist in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := assert_equal_set Stdlib.__LOC__ setlist set in
let setlist :=
cons (p "e000::/4" % string)
(cons (p "a000::/4" % string)
(cons (p "ffff::/16" % string) (cons (p "1234:5678::/32" % string) [])))
in
let set := of_list setlist in
assert_equal_set Stdlib.__LOC__ setlist set.
src/lib_p2p/test/test_p2p_peerset.ml 32 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make (struct
let name = "test-p2p-banned_peers"
end)
let assert_equal_bool ~msg a b = if a <> b then Alcotest.fail msg
let a s = P2p_peer.Id.hash_string [s]
let test_empty _ =
let peers = List.map a ["foo"; "bar"; "baz"] in
let empty = P2p_acl.PeerRing.create 10 in
List.iter
(fun peer ->
assert_equal_bool ~msg:__LOC__ false (P2p_acl.PeerRing.mem empty peer))
peers
let test_add _ =
let peers = List.map a ["foo"; "bar"; "baz"] in
let set = P2p_acl.PeerRing.create 10 in
List.iter (fun peer -> P2p_acl.PeerRing.add set peer) peers ;
List.iter
(fun peer ->
assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set peer))
peers
let test_remove _ =
let peers = List.map a ["foo"; "bar"; "baz"] in
let set = P2p_acl.PeerRing.create 10 in
List.iter (fun peer -> P2p_acl.PeerRing.add set peer) peers ;
assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "bar")) ;
P2p_acl.PeerRing.remove set (a "bar") ;
assert_equal_bool ~msg:__LOC__ false (P2p_acl.PeerRing.mem set (a "bar"))
let test_overflow _ =
let peers = List.map a ["foo"; "bar"; "baz"] in
let set = P2p_acl.PeerRing.create 3 in
List.iter (fun peer -> P2p_acl.PeerRing.add set peer) peers ;
assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "baz")) ;
P2p_acl.PeerRing.add set (a "zor") ;
assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "zor")) ;
assert_equal_bool ~msg:__LOC__ false (P2p_acl.PeerRing.mem set (a "foo")) ;
assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "bar")) ;
assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "baz"))
let () =
Alcotest.run
~argv:[|""|]
"tezos-p2p"
[ ( "p2p.peerset",
[ ("empty", `Quick, test_empty);
("add", `Quick, test_add);
("overflow", `Quick, test_overflow);
("remove", `Quick, test_remove) ] ) ]
src/lib_p2p/test/test_p2p_peerset.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition assert_equal_bool {A B : Type} (msg : A) (a : B) (b : B) : unit :=
if nequiv_decb a b then
op_startypeminuserrorstar msg
else
tt.
Definition a (s : string) : Tezos_base__TzPervasives.P2p_peer.Id.t :=
P2p_peer.Id.hash_string None (cons s []).
Definition test_empty {A : Type} (function_parameter : A) : unit :=
let '_ := function_parameter in
let peers :=
List.map a
(cons "foo" % string (cons "bar" % string (cons "baz" % string []))) in
let empty := P2p_acl.PeerRing.create 10 in
List.iter
(fun peer =>
assert_equal_bool Stdlib.__LOC__ false (P2p_acl.PeerRing.mem empty peer))
peers.
Definition test_add {A : Type} (function_parameter : A) : unit :=
let '_ := function_parameter in
let peers :=
List.map a
(cons "foo" % string (cons "bar" % string (cons "baz" % string []))) in
let set := P2p_acl.PeerRing.create 10 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter (fun peer => P2p_acl.PeerRing.add set peer) peers in
List.iter
(fun peer =>
assert_equal_bool Stdlib.__LOC__ true (P2p_acl.PeerRing.mem set peer))
peers.
Definition test_remove {A : Type} (function_parameter : A) : unit :=
let '_ := function_parameter in
let peers :=
List.map a
(cons "foo" % string (cons "bar" % string (cons "baz" % string []))) in
let set := P2p_acl.PeerRing.create 10 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter (fun peer => P2p_acl.PeerRing.add set peer) peers in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal_bool Stdlib.__LOC__ true
(P2p_acl.PeerRing.mem set (a "bar" % string)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_acl.PeerRing.remove set (a "bar" % string) in
assert_equal_bool Stdlib.__LOC__ false
(P2p_acl.PeerRing.mem set (a "bar" % string)).
Definition test_overflow {A : Type} (function_parameter : A) : unit :=
let '_ := function_parameter in
let peers :=
List.map a
(cons "foo" % string (cons "bar" % string (cons "baz" % string []))) in
let set := P2p_acl.PeerRing.create 3 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter (fun peer => P2p_acl.PeerRing.add set peer) peers in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal_bool Stdlib.__LOC__ true
(P2p_acl.PeerRing.mem set (a "baz" % string)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_acl.PeerRing.add set (a "zor" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal_bool Stdlib.__LOC__ true
(P2p_acl.PeerRing.mem set (a "zor" % string)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal_bool Stdlib.__LOC__ false
(P2p_acl.PeerRing.mem set (a "foo" % string)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
assert_equal_bool Stdlib.__LOC__ true
(P2p_acl.PeerRing.mem set (a "bar" % string)) in
assert_equal_bool Stdlib.__LOC__ true
(P2p_acl.PeerRing.mem set (a "baz" % string)).
src/lib_p2p/test/test_p2p_pool.ml 58 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make (struct
let name = "test.p2p.connection-pool"
end)
type message = Ping
let msg_config : message P2p_connect_handler.message_config =
{
encoding =
[ P2p_message.Encoding
{
tag = 0x10;
title = "Ping";
encoding = Data_encoding.empty;
wrap = (function () -> Ping);
unwrap = (function Ping -> Some ());
max_length = None;
} ];
chain_name = Distributed_db_version.sandboxed_chain_name;
distributed_db_versions = [Distributed_db_version.zero];
}
type metadata = unit
let peer_meta_config : metadata P2p_pool.peer_meta_config =
{
peer_meta_encoding = Data_encoding.empty;
peer_meta_initial = (fun _ -> ());
score = (fun () -> 0.);
}
let conn_meta_config : metadata P2p_socket.metadata_config =
{
conn_meta_encoding = Data_encoding.empty;
conn_meta_value = (fun _ -> ());
private_node = (fun _ -> false);
}
let sync ch =
Process.Channel.push ch ()
>>=? fun () -> Process.Channel.pop ch >>=? fun () -> return_unit
let rec sync_nodes nodes =
iter_p (fun {Process.channel; _} -> Process.Channel.pop channel) nodes
>>=? fun () ->
iter_p (fun {Process.channel; _} -> Process.Channel.push channel ()) nodes
>>=? fun () -> sync_nodes nodes
let sync_nodes nodes =
sync_nodes nodes
>>= function
| Ok () | Error (Exn End_of_file :: _) ->
return_unit
| Error _ as err ->
Lwt.return err
let detach_node f points n =
let ((addr, port), points) = List.select n points in
let proof_of_work_target = Crypto_box.make_target 0. in
let identity = P2p_identity.generate proof_of_work_target in
let private_mode = true in
let nb_points = List.length points in
let connect_handler_cfg =
P2p_connect_handler.
{
identity;
proof_of_work_target;
listening_port = Some port;
private_mode;
greylisting_config = P2p_point_state.Info.default_greylisting_config;
min_connections = nb_points;
max_connections = nb_points;
max_incoming_connections = nb_points;
connection_timeout = Time.System.Span.of_seconds_exn 10.;
authentication_timeout = Time.System.Span.of_seconds_exn 2.;
incoming_app_message_queue_size = None;
incoming_message_queue_size = None;
outgoing_message_queue_size = None;
binary_chunks_size = None;
}
in
let pool_config =
P2p_pool.
{
identity;
trusted_points = points;
peers_file = "/dev/null";
private_mode;
max_known_points = None;
max_known_peer_ids = None;
}
in
(* swap_linger = Time.System.Span.of_seconds_exn 0. ; *)
Process.detach
~prefix:(Format.asprintf "%a: " P2p_peer.Id.pp_short identity.peer_id)
(fun channel ->
let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
let triggers = P2p_trigger.create () in
let log _ = () in
P2p_pool.create pool_config peer_meta_config ~log triggers
>>= fun pool ->
let answerer = lazy (P2p_protocol.create_private ()) in
let connect_handler =
P2p_connect_handler.create
connect_handler_cfg
pool
msg_config
conn_meta_config
sched
triggers
~log
~answerer
in
P2p_welcome.create ~backlog:10 connect_handler ~addr port
>>= fun welcome ->
P2p_welcome.activate welcome ;
lwt_log_info "Node ready (port: %d)" port
>>= fun () ->
sync channel
>>=? fun () ->
f channel connect_handler pool points
>>=? fun () ->
lwt_log_info "Shutting down..."
>>= fun () ->
P2p_welcome.shutdown welcome
>>= fun () ->
P2p_pool.destroy pool
>>= fun () ->
P2p_connect_handler.destroy connect_handler
>>= fun () ->
P2p_io_scheduler.shutdown sched
>>= fun () -> lwt_log_info "Bye." >>= fun () -> return_unit)
let detach_nodes run_node points =
let clients = List.length points in
Lwt_list.map_p (detach_node run_node points) (0 -- (clients - 1))
>>= fun nodes ->
Lwt.ignore_result (sync_nodes nodes) ;
Process.wait_all nodes
type error += Connect | Write | Read
module Simple = struct
let rec connect ~timeout connect_handler pool point =
lwt_log_info "Connect to %a" P2p_point.Id.pp point
>>= fun () ->
P2p_connect_handler.connect connect_handler point ~timeout
>>= function
| Error (P2p_errors.Connected :: _) -> (
match P2p_pool.Connection.find_by_point pool point with
| Some conn ->
return conn
| None ->
failwith "Woops..." )
| Error
(( ( P2p_errors.Connection_refused
| P2p_errors.Pending_connection
| P2p_errors.Rejected_socket_connection
| Canceled
| Timeout
| P2p_errors.Rejected _ ) as head_err )
:: _) ->
lwt_log_info
"Connection to %a failed (%a)"
P2p_point.Id.pp
point
(fun ppf err ->
match err with
| P2p_errors.Connection_refused ->
Format.fprintf ppf "connection refused"
| P2p_errors.Pending_connection ->
Format.fprintf ppf "pending connection"
| P2p_errors.Rejected_socket_connection ->
Format.fprintf ppf "rejected"
| Canceled ->
Format.fprintf ppf "canceled"
| Timeout ->
Format.fprintf ppf "timeout"
| P2p_errors.Rejected peer ->
Format.fprintf ppf "rejected (%a)" P2p_peer.Id.pp peer
| _ ->
assert false)
head_err
>>= fun () ->
Lwt_unix.sleep (0.5 +. Random.float 2.)
>>= fun () -> connect ~timeout connect_handler pool point
| (Ok _ | Error _) as res ->
Lwt.return res
let connect_all ~timeout connect_handler pool points =
map_p (connect ~timeout connect_handler pool) points
let write_all conns msg =
iter_p (fun conn -> trace Write @@ P2p_conn.write_sync conn msg) conns
let read_all conns =
iter_p
(fun conn ->
trace Read @@ P2p_conn.read conn >>=? fun Ping -> return_unit)
conns
let close_all conns = Lwt_list.iter_p P2p_conn.disconnect conns
let node channel connect_handler pool points =
connect_all
~timeout:(Time.System.Span.of_seconds_exn 2.)
connect_handler
pool
points
>>=? fun conns ->
lwt_log_info "Bootstrap OK"
>>= fun () ->
sync channel
>>=? fun () ->
write_all conns Ping
>>=? fun () ->
lwt_log_info "Sent all messages."
>>= fun () ->
sync channel
>>=? fun () ->
read_all conns
>>=? fun () ->
lwt_log_info "Read all messages."
>>= fun () ->
sync channel
>>=? fun () ->
close_all conns
>>= fun () ->
lwt_log_info "All connections successfully closed."
>>= fun () -> return_unit
let run points = detach_nodes node points
end
module Random_connections = struct
let rec connect_random connect_handler pool total rem point n =
Lwt_unix.sleep (0.2 +. Random.float 1.0)
>>= fun () ->
trace Connect
@@ Simple.connect
~timeout:(Time.System.Span.of_seconds_exn 2.)
connect_handler
pool
point
>>=? fun conn ->
trace Write @@ P2p_conn.write conn Ping
>>= fun _ ->
trace Read @@ P2p_conn.read conn
>>=? fun Ping ->
Lwt_unix.sleep (0.2 +. Random.float 1.0)
>>= fun () ->
P2p_conn.disconnect conn
>>= fun () ->
( decr rem ;
if !rem mod total = 0 then lwt_log_info "Remaining: %d." (!rem / total)
else Lwt.return_unit )
>>= fun () ->
if n > 1 then connect_random connect_handler pool total rem point (pred n)
else return_unit
let connect_random_all connect_handler pool points n =
let total = List.length points in
let rem = ref (n * total) in
iter_p
(fun point -> connect_random connect_handler pool total rem point n)
points
let node repeat _channel connect_handler pool points =
lwt_log_info "Begin random connections."
>>= fun () ->
connect_random_all connect_handler pool points repeat
>>=? fun () ->
lwt_log_info "Random connections OK." >>= fun () -> return_unit
let run points repeat = detach_nodes (node repeat) points
end
module Garbled = struct
let is_connection_closed = function
| Error ((Write | Read) :: P2p_errors.Connection_closed :: _) ->
true
| Ok _ ->
false
| Error err ->
log_info "Unexpected error: %a" pp_print_error err ;
false
let write_bad_all conns =
let bad_msg = Bytes.of_string (String.make 16 '\000') in
iter_p
(fun conn -> trace Write @@ P2p_conn.raw_write_sync conn bad_msg)
conns
let node ch connect_handler pool points =
Simple.connect_all
~timeout:(Time.System.Span.of_seconds_exn 2.)
connect_handler
pool
points
>>=? fun conns ->
sync ch
>>=? fun () ->
write_bad_all conns
>>=? (fun () -> Simple.read_all conns)
>>= fun err -> _assert (is_connection_closed err) __LOC__ ""
let run points = detach_nodes node points
end
let () = Random.self_init ()
let addr = ref Ipaddr.V6.localhost
let port = ref (1024 + Random.int 8192)
let clients = ref 10
let repeat_connections = ref 5
let log_config = ref None
let spec =
Arg.
[ ("--port", Int (fun p -> port := p), " Listening port of the first peer.");
( "--addr",
String (fun p -> addr := Ipaddr.V6.of_string_exn p),
" Listening addr" );
("--clients", Set_int clients, " Number of concurrent clients.");
( "--repeat",
Set_int repeat_connections,
" Number of connections/disconnections." );
( "-v",
Unit
(fun () ->
log_config :=
Some
(Lwt_log_sink_unix.create_cfg
~rules:
"test.p2p.connection-pool -> info; p2p.connection-pool \
-> info"
())),
" Log up to info msgs" );
( "-vv",
Unit
(fun () ->
log_config :=
Some
(Lwt_log_sink_unix.create_cfg
~rules:
"test.p2p.connection-pool -> debug; p2p.connection-pool \
-> debug"
())),
" Log up to debug msgs" ) ]
let init_logs = lazy (Internal_event_unix.init ?lwt_log_sink:!log_config ())
let wrap n f =
Alcotest_lwt.test_case n `Quick (fun _ () ->
Lazy.force init_logs
>>= fun () ->
f ()
>>= function
| Ok () ->
Lwt.return_unit
| Error error ->
Format.kasprintf Pervasives.failwith "%a" pp_print_error error)
let main () =
let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in
let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
Arg.parse spec anon_fun usage_msg ;
let ports = !port -- (!port + !clients - 1) in
let points = List.map (fun port -> (!addr, port)) ports in
Alcotest.run
~argv:[|""|]
"tezos-p2p"
[ ( "p2p-connection-pool",
[ wrap "simple" (fun _ -> Simple.run points);
wrap "random" (fun _ ->
Random_connections.run points !repeat_connections);
wrap "garbled" (fun _ -> Garbled.run points) ] ) ]
let () =
Sys.catch_break true ;
try main () with _ -> ()
src/lib_p2p/test/test_p2p_pool.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Inductive message : Type :=
| Ping : message.
Definition msg_config : Tezos_p2p.P2p_connect_handler.message_config message :=
{|
encoding :=
cons
(Tezos_p2p.P2p_message.Encoding
{| tag := 16; title := "Ping" % string;
encoding := Data_encoding.empty;
wrap :=
fun function_parameter =>
let 'tt := function_parameter in
Ping;
unwrap :=
fun function_parameter =>
let 'Ping := function_parameter in
Some tt; max_length := None |}) [];
chain_name := Distributed_db_version.sandboxed_chain_name;
distributed_db_versions := cons Distributed_db_version.zero [] |}.
Definition metadata := unit.
Definition peer_meta_config : Tezos_p2p.P2p_pool.peer_meta_config metadata :=
{| peer_meta_encoding := Data_encoding.empty;
peer_meta_initial :=
fun function_parameter =>
let '_ := function_parameter in
tt;
score :=
fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Float constant 0. is approximated by the integer 0 *)
0 |}.
Definition conn_meta_config : Tezos_p2p.P2p_socket.metadata_config metadata :=
{| conn_meta_encoding := Data_encoding.empty;
conn_meta_value :=
fun function_parameter =>
let '_ := function_parameter in
tt;
private_node :=
fun function_parameter =>
let '_ := function_parameter in
false |}.
Definition sync {A : Type} (ch : A)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (op_startypeminuserrorstar ch tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar ch)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)).
Fixpoint sync_nodes {A B : Type} (nodes : list A)
: Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
op_gtgteqquestion
(iter_p
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar op_startypeminuserrorstar) nodes)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(iter_p
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar op_startypeminuserrorstar tt) nodes)
(fun function_parameter =>
let 'tt := function_parameter in
sync_nodes nodes)).
Definition sync_nodes {A : Type} (nodes : list A)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (sync_nodes nodes)
(fun function_parameter =>
match function_parameter with
|
Stdlib.Ok tt |
Stdlib.Error (cons (Tezos_base__TzPervasives.Exn OCaml.End_of_file) _)
=> return_unit
| (Stdlib.Error _) as err => Lwt._return err
end).
Definition detach_node {A B : Type}
(f :
A ->
(Tezos_p2p.P2p_connect_handler.t message metadata metadata) ->
(Tezos_p2p.P2p_pool.t message metadata metadata) ->
(list Tezos_base__TzPervasives.P2p_point.Id.t) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit))
(points : list Tezos_base__TzPervasives.P2p_point.Id.t) (n : Z) : B :=
let '((addr, port), points) := List.select n points in
let proof_of_work_target :=
Crypto_box.make_target
(* ❌ Float constant 0. is approximated by the integer 0 *)
0 in
let identity := P2p_identity.generate proof_of_work_target in
let private_mode := true in
let nb_points := List.length points in
let connect_handler_cfg :=
{| incoming_app_message_queue_size := None; private_mode := private_mode;
min_connections := nb_points; max_connections := nb_points;
max_incoming_connections := nb_points;
incoming_message_queue_size := None; outgoing_message_queue_size := None;
binary_chunks_size := None; identity := identity;
connection_timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 10. is approximated by the integer 10 *)
10;
authentication_timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 2. is approximated by the integer 2 *)
2;
greylisting_config := P2p_point_state.Info.default_greylisting_config;
proof_of_work_target := proof_of_work_target; listening_port := Some port
|} in
let pool_config :=
{| identity := identity; trusted_points := points;
peers_file := "/dev/null" % string; private_mode := private_mode;
max_known_points := None; max_known_peer_ids := None |} in
op_startypeminuserrorstar
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ": " % string
CamlinternalFormatBasics.End_of_format)) "%a: " % string)
P2p_peer.Id.pp_short (peer_id identity))
(fun channel =>
let sched :=
P2p_io_scheduler.create None None None None (Z.shiftl 1 12) tt in
let triggers := P2p_trigger.create tt in
let log {C : Type} (function_parameter : C) : unit :=
let '_ := function_parameter in
tt in
op_gtgteq (P2p_pool.create pool_config peer_meta_config triggers log)
(fun pool =>
let answerer :=
(* ❌ Lazy expressions are not handled *)
lazy (P2p_protocol.create_private tt) in
let connect_handler :=
P2p_connect_handler.create None connect_handler_cfg pool msg_config
conn_meta_config sched triggers log answerer in
op_gtgteq (P2p_welcome.create (Some addr) 10 connect_handler port)
(fun welcome =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_welcome.activate welcome in
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Node ready (port: " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"Node ready (port: %d)" % string) port)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (sync channel)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (f channel connect_handler pool points)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down..." % string
CamlinternalFormatBasics.End_of_format)
"Shutting down..." % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_welcome.shutdown welcome)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_pool.destroy pool)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(P2p_connect_handler.destroy
connect_handler)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(P2p_io_scheduler.shutdown None
sched)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Bye." % string
CamlinternalFormatBasics.End_of_format)
"Bye." % string))
(fun function_parameter =>
let 'tt := function_parameter
in
return_unit)))))))))))).
Definition detach_nodes {A B : Type}
(run_node :
A ->
(Tezos_p2p.P2p_connect_handler.t message metadata metadata) ->
(Tezos_p2p.P2p_pool.t message metadata metadata) ->
(list Tezos_base__TzPervasives.P2p_point.Id.t) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit))
(points : list Tezos_base__TzPervasives.P2p_point.Id.t) : Lwt.t B :=
let clients := List.length points in
op_gtgteq
(Lwt_list.map_p (detach_node run_node points)
(op_minusminus 0 (Z.sub clients 1)))
(fun nodes =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt.ignore_result (sync_nodes nodes) in
op_startypeminuserrorstar nodes).
(* ❌ Structure item `typext` not handled. *)
type_extension
Module Simple.
Fixpoint connect {A B C : Type}
(timeout : Tezos_base__TzPervasives.Time.System.Span.t)
(connect_handler : Tezos_p2p.P2p_connect_handler.t A B C)
(pool : Tezos_p2p__P2p_pool.t A B C)
(point : Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult (Tezos_p2p.P2p_conn.t A B C)) :=
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Connect to " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "Connect to %a" % string)
P2p_point.Id.pp point)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(P2p_connect_handler.connect (Some timeout) connect_handler point)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error (cons Tezos_base__TzPervasives.Connected _) =>
match P2p_pool.Connection.find_by_point pool point with
| Some conn => _return conn
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Woops..." % string
CamlinternalFormatBasics.End_of_format)
"Woops..." % string)
end
|
Stdlib.Error
(cons
((Tezos_base__TzPervasives.Connection_refused |
Tezos_base__TzPervasives.Pending_connection |
Tezos_base__TzPervasives.Rejected_socket_connection |
Tezos_base__TzPervasives.Canceled |
Tezos_base__TzPervasives.Timeout |
Tezos_base__TzPervasives.Rejected _) as head_err) _) =>
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Connection to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" failed (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"Connection to %a failed (%a)" % string) P2p_point.Id.pp
point
(fun ppf =>
fun err =>
match err with
| Tezos_base__TzPervasives.Connection_refused =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"connection refused" % string
CamlinternalFormatBasics.End_of_format)
"connection refused" % string)
| Tezos_base__TzPervasives.Pending_connection =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"pending connection" % string
CamlinternalFormatBasics.End_of_format)
"pending connection" % string)
| Tezos_base__TzPervasives.Rejected_socket_connection =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"rejected" % string
CamlinternalFormatBasics.End_of_format)
"rejected" % string)
| Tezos_base__TzPervasives.Canceled =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"canceled" % string
CamlinternalFormatBasics.End_of_format)
"canceled" % string)
| Tezos_base__TzPervasives.Timeout =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"timeout" % string
CamlinternalFormatBasics.End_of_format)
"timeout" % string)
| Tezos_base__TzPervasives.Rejected peer =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"rejected (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))
"rejected (%a)" % string) P2p_peer.Id.pp peer
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end) head_err)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_unix.sleep
(Stdlib.op_pluspoint
(* ❌ Float constant 0.5 is approximated by the integer 0 *)
0
(Random.float
(* ❌ Float constant 2. is approximated by the integer 2 *)
2)))
(fun function_parameter =>
let 'tt := function_parameter in
connect timeout connect_handler pool point))
| (Stdlib.Ok _ | Stdlib.Error _) as res => Lwt._return res
end)).
Definition connect_all {A B C : Type}
(timeout : Tezos_base__TzPervasives.Time.System.Span.t)
(connect_handler : Tezos_p2p.P2p_connect_handler.t A B C)
(pool : Tezos_p2p__P2p_pool.t A B C)
(points : list Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult (list (Tezos_p2p.P2p_conn.t A B C))) :=
map_p (connect timeout connect_handler pool) points.
Definition write_all {A B C : Type}
(conns : list (Tezos_p2p.P2p_conn.t A B C)) (msg : A)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
iter_p
(fun conn =>
apply (trace Tezos_base__TzPervasives.Write)
(P2p_conn.write_sync conn msg)) conns.
Definition read_all {A B : Type}
(conns : list (Tezos_p2p.P2p_conn.t message A B))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
iter_p
(fun conn =>
op_gtgteqquestion
(apply (trace Tezos_base__TzPervasives.Read) (P2p_conn.read conn))
(fun function_parameter =>
let 'Ping := function_parameter in
return_unit)) conns.
Definition close_all {A B C : Type}
(conns : list (Tezos_p2p.P2p_conn.t A B C)) : Lwt.t unit :=
Lwt_list.iter_p
(let arg := P2p_conn.disconnect in
fun eta => arg None eta) conns.
Definition node {A B C : Type}
(channel : A)
(connect_handler : Tezos_p2p.P2p_connect_handler.t message B C)
(pool : Tezos_p2p__P2p_pool.t message B C)
(points : list Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
(connect_all
(Time.System.Span.of_seconds_exn
(* ❌ Float constant 2. is approximated by the integer 2 *)
2) connect_handler pool points)
(fun conns =>
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Bootstrap OK" % string
CamlinternalFormatBasics.End_of_format) "Bootstrap OK" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (sync channel)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (write_all conns Ping)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Sent all messages." % string
CamlinternalFormatBasics.End_of_format)
"Sent all messages." % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (sync channel)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (read_all conns)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Read all messages." % string
CamlinternalFormatBasics.End_of_format)
"Read all messages." % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (sync channel)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (close_all conns)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"All connections successfully closed."
% string
CamlinternalFormatBasics.End_of_format)
"All connections successfully closed."
% string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))))))))).
Definition run {A : Type}
(points : list Tezos_base__TzPervasives.P2p_point.Id.t) : Lwt.t A :=
detach_nodes node points.
End Simple.
Module Random_connections.
Fixpoint connect_random {A B : Type}
(connect_handler : Tezos_p2p.P2p_connect_handler.t message A B)
(pool : Tezos_p2p__P2p_pool.t message A B) (total : Z) (rem : Stdlib.ref Z)
(point : Tezos_base__TzPervasives.P2p_point.Id.t) (n : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq
(Lwt_unix.sleep
(Stdlib.op_pluspoint
(* ❌ Float constant 0.2 is approximated by the integer 0 *)
0
(Random.float
(* ❌ Float constant 1.0 is approximated by the integer 1 *)
1)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(apply (trace Tezos_base__TzPervasives.Connect)
(Simple.connect
(Time.System.Span.of_seconds_exn
(* ❌ Float constant 2. is approximated by the integer 2 *)
2) connect_handler pool point))
(fun conn =>
op_gtgteq
(apply (trace Tezos_base__TzPervasives.Write)
(P2p_conn.write conn Ping))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(apply (trace Tezos_base__TzPervasives.Read)
(P2p_conn.read conn))
(fun function_parameter =>
let 'Ping := function_parameter in
op_gtgteq
(Lwt_unix.sleep
(Stdlib.op_pluspoint
(* ❌ Float constant 0.2 is approximated by the integer 0 *)
0
(Random.float
(* ❌ Float constant 1.0 is approximated by the integer 1 *)
1)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_conn.disconnect None conn)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ := Stdlib.decr rem in
if
equiv_decb
(Z.modulo (Stdlib.op_exclamation rem) total) 0
then
lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Remaining: " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format)))
"Remaining: %d." % string)
(Z.div (Stdlib.op_exclamation rem) total)
else
Lwt.return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
if OCaml.Stdlib.gt n 1 then
connect_random connect_handler pool total rem
point (Z.pred n)
else
return_unit))))))).
Definition connect_random_all {A B : Type}
(connect_handler : Tezos_p2p.P2p_connect_handler.t message A B)
(pool : Tezos_p2p__P2p_pool.t message A B)
(points : list Tezos_base__TzPervasives.P2p_point.Id.t) (n : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let total := List.length points in
let rem := Stdlib.ref (Z.mul n total) in
iter_p (fun point => connect_random connect_handler pool total rem point n)
points.
Definition node {A B C : Type}
(repeat : Z) (_channel : A)
(connect_handler : Tezos_p2p.P2p_connect_handler.t message B C)
(pool : Tezos_p2p__P2p_pool.t message B C)
(points : list Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Begin random connections." % string
CamlinternalFormatBasics.End_of_format)
"Begin random connections." % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(connect_random_all connect_handler pool points repeat)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Random connections OK." % string
CamlinternalFormatBasics.End_of_format)
"Random connections OK." % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))).
Definition run {A : Type}
(points : list Tezos_base__TzPervasives.P2p_point.Id.t) (repeat : Z)
: Lwt.t A := detach_nodes (node repeat) points.
End Random_connections.
Module Garbled.
Definition is_connection_closed {A : Type}
(function_parameter : sum A Tezos_base__TzPervasives.trace) : bool :=
match function_parameter with
|
Stdlib.Error
(cons (Tezos_base__TzPervasives.Write | Tezos_base__TzPervasives.Read)
(cons Tezos_base__TzPervasives.Connection_closed _)) => true
| Stdlib.Ok _ => false
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unexpected error: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Unexpected error: %a" % string) pp_print_error err in
false
end.
Definition write_bad_all {A B C : Type}
(conns : list (Tezos_p2p.P2p_conn.t A B C))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let bad_msg := Stdlib.Bytes.of_string (String.make 16 "000" % char) in
iter_p
(fun conn =>
apply (trace Tezos_base__TzPervasives.Write)
(P2p_conn.raw_write_sync conn bad_msg)) conns.
Definition node {A B C : Type}
(ch : A) (connect_handler : Tezos_p2p.P2p_connect_handler.t message B C)
(pool : Tezos_p2p__P2p_pool.t message B C)
(points : list Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
(Simple.connect_all
(Time.System.Span.of_seconds_exn
(* ❌ Float constant 2. is approximated by the integer 2 *)
2) connect_handler pool points)
(fun conns =>
op_gtgteqquestion (sync ch)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtgteqquestion (write_bad_all conns)
(fun function_parameter =>
let 'tt := function_parameter in
Simple.read_all conns))
(fun err =>
_assert (is_connection_closed err) Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string)))).
Definition run {A : Type}
(points : list Tezos_base__TzPervasives.P2p_point.Id.t) : Lwt.t A :=
detach_nodes node points.
End Garbled.
Definition addr : Stdlib.ref Ipaddr.V6.t := Stdlib.ref Ipaddr.V6.localhost.
Definition port : Stdlib.ref Z := Stdlib.ref (Z.add 1024 (Random.int 8192)).
Definition clients : Stdlib.ref Z := Stdlib.ref 10.
Definition repeat_connections : Stdlib.ref Z := Stdlib.ref 5.
Definition log_config
: Stdlib.ref (option Tezos_stdlib_unix.Lwt_log_sink_unix.cfg) :=
Stdlib.ref None.
Definition spec : list (string * Stdlib.Arg.spec * string) :=
cons
("--port" % string, (Stdlib.Arg.Int (fun p => Stdlib.op_coloneq port p)),
" Listening port of the first peer." % string)
(cons
("--addr" % string,
(Stdlib.Arg.String
(fun p => Stdlib.op_coloneq addr (Ipaddr.V6.of_string_exn p))),
" Listening addr" % string)
(cons
("--clients" % string, (Stdlib.Arg.Set_int clients),
" Number of concurrent clients." % string)
(cons
("--repeat" % string, (Stdlib.Arg.Set_int repeat_connections),
" Number of connections/disconnections." % string)
(cons
("-v" % string,
(Stdlib.Arg.Unit
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_coloneq log_config
(Some
(Lwt_log_sink_unix.create_cfg None None
(Some
"test.p2p.connection-pool -> info; p2p.connection-pool -> info"
% string) None tt)))),
" Log up to info msgs" % string)
(cons
("-vv" % string,
(Stdlib.Arg.Unit
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_coloneq log_config
(Some
(Lwt_log_sink_unix.create_cfg None None
(Some
"test.p2p.connection-pool -> debug; p2p.connection-pool -> debug"
% string) None tt)))),
" Log up to debug msgs" % string) []))))).
Definition init_logs : lazy_t (Lwt.t unit) :=
(* ❌ Lazy expressions are not handled *)
lazy (Internal_event_unix.init (Stdlib.op_exclamation log_config) None tt).
Definition wrap {A B : Type}
(n : A) (f : unit -> Lwt.t (sum unit Tezos_base__TzPervasives.trace)) : B :=
op_startypeminuserrorstar n
(* ❌ Variants not supported *)
variant
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lazy.force init_logs)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (f tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error error =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
pp_print_error error
end))).
Definition main {A : Type} (function_parameter : unit) : A :=
let 'tt := function_parameter in
let anon_fun {B C : Type} (_num_peers : B) : C :=
Stdlib.raise (Bad "No anonymous argument." % string) in
let usage_msg := "Usage: %s <num_peers>.
Arguments are:" % string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Arg.parse spec anon_fun usage_msg in
let ports :=
op_minusminus (Stdlib.op_exclamation port)
(Z.sub
(Z.add (Stdlib.op_exclamation port) (Stdlib.op_exclamation clients)) 1)
in
let points :=
List.map (fun port => ((Stdlib.op_exclamation addr), port)) ports in
op_startypeminuserrorstar
(* ❌ Arrays not handled. *)
[ "" % string ] "tezos-p2p" % string
(cons
("p2p-connection-pool" % string,
(cons
(wrap "simple" % string
(fun function_parameter =>
let '_ := function_parameter in
Simple.run points))
(cons
(wrap "random" % string
(fun function_parameter =>
let '_ := function_parameter in
Random_connections.run points
(Stdlib.op_exclamation repeat_connections)))
(cons
(wrap "garbled" % string
(fun function_parameter =>
let '_ := function_parameter in
Garbled.run points)) [])))) []).
src/lib_p2p/test/test_p2p_socket.ml 44 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make (struct
let name = "test.p2p.connection"
end)
let addr = ref Ipaddr.V6.localhost
let canceler = Lwt_canceler.create () (* unused *)
let proof_of_work_target = Crypto_box.make_target 16.
let id1 = P2p_identity.generate proof_of_work_target
let id2 = P2p_identity.generate proof_of_work_target
let id0 =
(* Luckilly, this will be an insuficient proof of work! *)
P2p_identity.generate (Crypto_box.make_target 0.)
let version =
{
Network_version.chain_name = Distributed_db_version.sandboxed_chain_name;
distributed_db_version = Distributed_db_version.zero;
p2p_version = P2p_version.zero;
}
type metadata = unit
let conn_meta_config : metadata P2p_socket.metadata_config =
{
conn_meta_encoding = Data_encoding.empty;
conn_meta_value = (fun _ -> ());
private_node = (fun _ -> false);
}
let rec listen ?port addr =
let tentative_port =
match port with None -> 1024 + Random.int 8192 | Some port -> port
in
let uaddr = Ipaddr_unix.V6.to_inet_addr addr in
let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ;
Lwt.catch
(fun () ->
Lwt_unix.bind main_socket (ADDR_INET (uaddr, tentative_port))
>>= fun () ->
Lwt_unix.listen main_socket 1 ;
Lwt.return (main_socket, tentative_port))
(function
| Unix.Unix_error ((Unix.EADDRINUSE | Unix.EADDRNOTAVAIL), _, _)
when port = None ->
listen addr
| exn ->
Lwt.fail exn)
let sync ch =
Process.Channel.push ch ()
>>=? fun () -> Process.Channel.pop ch >>=? fun () -> return_unit
let rec sync_nodes nodes =
iter_p (fun {Process.channel; _} -> Process.Channel.pop channel) nodes
>>=? fun () ->
iter_p (fun {Process.channel; _} -> Process.Channel.push channel ()) nodes
>>=? fun () -> sync_nodes nodes
let sync_nodes nodes =
sync_nodes nodes
>>= function
| Ok () | Error (Exn End_of_file :: _) ->
return_unit
| Error _ as err ->
Lwt.return err
let run_nodes client server =
listen !addr
>>= fun (main_socket, port) ->
Process.detach ~prefix:"server: " (fun channel ->
let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
server channel sched main_socket
>>=? fun () -> P2p_io_scheduler.shutdown sched >>= fun () -> return_unit)
>>= fun server_node ->
Process.detach ~prefix:"client: " (fun channel ->
Lwt_utils_unix.safe_close main_socket
>>= fun () ->
let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
client channel sched !addr port
>>=? fun () -> P2p_io_scheduler.shutdown sched >>= fun () -> return_unit)
>>= fun client_node ->
let nodes = [server_node; client_node] in
Lwt.ignore_result (sync_nodes nodes) ;
Process.wait_all nodes
let raw_accept sched main_socket =
P2p_fd.accept main_socket
>>= fun (fd, sockaddr) ->
let fd = P2p_io_scheduler.register sched fd in
let point =
match sockaddr with
| Lwt_unix.ADDR_UNIX _ ->
assert false
| Lwt_unix.ADDR_INET (addr, port) ->
(Ipaddr_unix.V6.of_inet_addr_exn addr, port)
in
Lwt.return (fd, point)
let accept sched main_socket =
raw_accept sched main_socket
>>= fun (fd, point) ->
P2p_socket.authenticate
~canceler
~proof_of_work_target
~incoming:true
fd
point
id1
version
conn_meta_config
let raw_connect sched addr port =
let fd = P2p_fd.socket PF_INET6 SOCK_STREAM 0 in
let uaddr = Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port) in
P2p_fd.connect fd uaddr
>>= fun () ->
let fd = P2p_io_scheduler.register sched fd in
Lwt.return fd
let connect sched addr port id =
raw_connect sched addr port
>>= fun fd ->
P2p_socket.authenticate
~canceler
~proof_of_work_target
~incoming:false
fd
(addr, port)
id
version
conn_meta_config
>>=? fun (info, auth_fd) ->
_assert (not info.incoming) __LOC__ ""
>>=? fun () ->
_assert (P2p_peer.Id.compare info.peer_id id1.peer_id = 0) __LOC__ ""
>>=? fun () -> return auth_fd
let is_connection_closed = function
| Error (P2p_errors.Connection_closed :: _) ->
true
| Ok _ ->
false
| Error err ->
log_notice "Error: %a" pp_print_error err ;
false
let is_decoding_error = function
| Error (P2p_errors.Decoding_error :: _) ->
true
| Ok _ ->
false
| Error err ->
log_notice "Error: %a" pp_print_error err ;
false
module Crypto_test = struct
(* maximal size of the buffer *)
let bufsize = (1 lsl 16) - 1
let header_length = 2
let max_content_length = bufsize - Crypto_box.zerobytes
(* The size of extra data added by encryption. *)
let boxextrabytes = Crypto_box.zerobytes - Crypto_box.boxzerobytes
(* The number of bytes added by encryption + header *)
let extrabytes = header_length + boxextrabytes
type data = {
channel_key : Crypto_box.channel_key;
mutable local_nonce : Crypto_box.nonce;
mutable remote_nonce : Crypto_box.nonce;
}
let () = assert (Crypto_box.boxzerobytes >= header_length)
let write_chunk fd cryptobox_data msg =
let msglen = Bytes.length msg in
fail_unless (msglen <= max_content_length) P2p_errors.Invalid_message_size
>>=? fun () ->
let buf_length = msglen + Crypto_box.zerobytes in
let buf = Bytes.make buf_length '\x00' in
Bytes.blit msg 0 buf Crypto_box.zerobytes msglen ;
let local_nonce = cryptobox_data.local_nonce in
cryptobox_data.local_nonce <- Crypto_box.increment_nonce local_nonce ;
Crypto_box.fast_box_noalloc cryptobox_data.channel_key local_nonce buf ;
let encrypted_length = buf_length - Crypto_box.boxzerobytes in
let header_pos = Crypto_box.boxzerobytes - header_length in
TzEndian.set_int16 buf header_pos encrypted_length ;
let payload = Bytes.sub buf header_pos (buf_length - header_pos) in
return (Unix.write fd payload 0 (buf_length - header_pos))
>>=? fun i ->
_assert (buf_length - header_pos = i) __LOC__ "" >>=? fun () -> return_unit
let read_chunk fd cryptobox_data =
let header_buf = Bytes.create header_length in
return (Unix.read fd header_buf 0 header_length)
>>=? fun i ->
_assert (header_length = i) __LOC__ ""
>>=? fun () ->
let encrypted_length = TzEndian.get_uint16 header_buf 0 in
let buf_length = encrypted_length + Crypto_box.boxzerobytes in
let buf = Bytes.make buf_length '\x00' in
return (Unix.read fd buf Crypto_box.boxzerobytes encrypted_length)
>>=? fun i ->
_assert (encrypted_length = i) __LOC__ ""
>>=? fun () ->
let remote_nonce = cryptobox_data.remote_nonce in
cryptobox_data.remote_nonce <- Crypto_box.increment_nonce remote_nonce ;
match
Crypto_box.fast_box_open_noalloc
cryptobox_data.channel_key
remote_nonce
buf
with
| false ->
fail P2p_errors.Decipher_error
| true ->
return
(Bytes.sub
buf
Crypto_box.zerobytes
(buf_length - Crypto_box.zerobytes))
let (sk, pk, pkh) = Crypto_box.random_keypair ()
let zero_nonce = Crypto_box.zero_nonce
let channel_key = Crypto_box.precompute sk pk
let (in_fd, out_fd) = Unix.pipe ()
let data = {channel_key; local_nonce = zero_nonce; remote_nonce = zero_nonce}
let wrap () =
Alcotest_lwt.test_case "ACK" `Quick (fun _ () ->
let msg = Bytes.of_string "test" in
write_chunk out_fd data msg
>>= fun _ ->
read_chunk in_fd data
>>= function
| Ok res when Bytes.equal msg res ->
Lwt.return_unit
| Ok res ->
Format.kasprintf
Pervasives.failwith
"Error : %s <> %s"
(Bytes.to_string res)
(Bytes.to_string msg)
| Error error ->
Format.kasprintf Pervasives.failwith "%a" pp_print_error error)
end
module Low_level = struct
let simple_msg = Rand.generate (1 lsl 4)
let client _ch sched addr port =
let msg = Bytes.create (Bytes.length simple_msg) in
raw_connect sched addr port
>>= fun fd ->
P2p_io_scheduler.read_full fd msg
>>=? fun () ->
_assert (Bytes.compare simple_msg msg = 0) __LOC__ ""
>>=? fun () -> P2p_io_scheduler.close fd >>=? fun () -> return_unit
let server _ch sched socket =
raw_accept sched socket
>>= fun (fd, _point) ->
P2p_io_scheduler.write fd simple_msg
>>=? fun () -> P2p_io_scheduler.close fd >>=? fun _ -> return_unit
let run _dir = run_nodes client server
end
module Kick = struct
let encoding = Data_encoding.bytes
let is_rejected = function
| Error (P2p_errors.Rejected_socket_connection :: _) ->
true
| Ok _ ->
false
| Error err ->
log_notice "Error: %a" pp_print_error err ;
false
let server _ch sched socket =
accept sched socket
>>=? fun (info, auth_fd) ->
_assert info.incoming __LOC__ ""
>>=? fun () ->
_assert (P2p_peer.Id.compare info.peer_id id2.peer_id = 0) __LOC__ ""
>>=? fun () -> P2p_socket.kick auth_fd >>= fun () -> return_unit
let client _ch sched addr port =
connect sched addr port id2
>>=? fun auth_fd ->
P2p_socket.accept ~canceler auth_fd encoding
>>= fun conn ->
_assert (is_rejected conn) __LOC__ "" >>=? fun () -> return_unit
let run _dir = run_nodes client server
end
module Kicked = struct
let encoding = Data_encoding.bytes
let server _ch sched socket =
accept sched socket
>>=? fun (_info, auth_fd) ->
P2p_socket.accept ~canceler auth_fd encoding
>>= fun conn ->
_assert (Kick.is_rejected conn) __LOC__ "" >>=? fun () -> return_unit
let client _ch sched addr port =
connect sched addr port id2
>>=? fun auth_fd -> P2p_socket.kick auth_fd >>= fun () -> return_unit
let run _dir = run_nodes client server
end
module Simple_message = struct
let encoding = Data_encoding.bytes
let simple_msg = Rand.generate (1 lsl 4)
let simple_msg2 = Rand.generate (1 lsl 4)
let server ch sched socket =
accept sched socket
>>=? fun (_info, auth_fd) ->
P2p_socket.accept ~canceler auth_fd encoding
>>=? fun conn ->
P2p_socket.write_sync conn simple_msg
>>=? fun () ->
P2p_socket.read conn
>>=? fun (_msg_size, msg) ->
_assert (Bytes.compare simple_msg2 msg = 0) __LOC__ ""
>>=? fun () ->
sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit
let client ch sched addr port =
connect sched addr port id2
>>=? fun auth_fd ->
P2p_socket.accept ~canceler auth_fd encoding
>>=? fun conn ->
P2p_socket.write_sync conn simple_msg2
>>=? fun () ->
P2p_socket.read conn
>>=? fun (_msg_size, msg) ->
_assert (Bytes.compare simple_msg msg = 0) __LOC__ ""
>>=? fun () ->
sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit
let run _dir = run_nodes client server
end
module Chunked_message = struct
let encoding = Data_encoding.bytes
let simple_msg = Rand.generate (1 lsl 8)
let simple_msg2 = Rand.generate (1 lsl 8)
let server ch sched socket =
accept sched socket
>>=? fun (_info, auth_fd) ->
P2p_socket.accept ~canceler ~binary_chunks_size:21 auth_fd encoding
>>=? fun conn ->
P2p_socket.write_sync conn simple_msg
>>=? fun () ->
P2p_socket.read conn
>>=? fun (_msg_size, msg) ->
_assert (Bytes.compare simple_msg2 msg = 0) __LOC__ ""
>>=? fun () ->
sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit
let client ch sched addr port =
connect sched addr port id2
>>=? fun auth_fd ->
P2p_socket.accept ~canceler ~binary_chunks_size:21 auth_fd encoding
>>=? fun conn ->
P2p_socket.write_sync conn simple_msg2
>>=? fun () ->
P2p_socket.read conn
>>=? fun (_msg_size, msg) ->
_assert (Bytes.compare simple_msg msg = 0) __LOC__ ""
>>=? fun () ->
sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit
let run _dir = run_nodes client server
end
module Oversized_message = struct
let encoding = Data_encoding.bytes
let simple_msg = Rand.generate (1 lsl 17)
let simple_msg2 = Rand.generate (1 lsl 17)
let server ch sched socket =
accept sched socket
>>=? fun (_info, auth_fd) ->
P2p_socket.accept ~canceler auth_fd encoding
>>=? fun conn ->
P2p_socket.write_sync conn simple_msg
>>=? fun () ->
P2p_socket.read conn
>>=? fun (_msg_size, msg) ->
_assert (Bytes.compare simple_msg2 msg = 0) __LOC__ ""
>>=? fun () ->
sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit
let client ch sched addr port =
connect sched addr port id2
>>=? fun auth_fd ->
P2p_socket.accept ~canceler auth_fd encoding
>>=? fun conn ->
P2p_socket.write_sync conn simple_msg2
>>=? fun () ->
P2p_socket.read conn
>>=? fun (_msg_size, msg) ->
_assert (Bytes.compare simple_msg msg = 0) __LOC__ ""
>>=? fun () ->
sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit
let run _dir = run_nodes client server
end
module Close_on_read = struct
let encoding = Data_encoding.bytes
let simple_msg = Rand.generate (1 lsl 4)
let server ch sched socket =
accept sched socket
>>=? fun (_info, auth_fd) ->
P2p_socket.accept ~canceler auth_fd encoding
>>=? fun conn ->
sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit
let client ch sched addr port =
connect sched addr port id2
>>=? fun auth_fd ->
P2p_socket.accept ~canceler auth_fd encoding
>>=? fun conn ->
sync ch
>>=? fun () ->
P2p_socket.read conn
>>= fun err ->
_assert (is_connection_closed err) __LOC__ ""
>>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit
let run _dir = run_nodes client server
end
module Close_on_write = struct
let encoding = Data_encoding.bytes
let simple_msg = Rand.generate (1 lsl 4)
let server ch sched socket =
accept sched socket
>>=? fun (_info, auth_fd) ->
P2p_socket.accept ~canceler auth_fd encoding
>>=? fun conn ->
P2p_socket.close conn >>= fun _stat -> sync ch >>=? fun () -> return_unit
let client ch sched addr port =
connect sched addr port id2
>>=? fun auth_fd ->
P2p_socket.accept ~canceler auth_fd encoding
>>=? fun conn ->
sync ch
>>=? fun () ->
Lwt_unix.sleep 0.1
>>= fun () ->
P2p_socket.write_sync conn simple_msg
>>= fun err ->
_assert (is_connection_closed err) __LOC__ ""
>>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit
let run _dir = run_nodes client server
end
module Garbled_data = struct
let encoding =
let open Data_encoding in
dynamic_size @@ option @@ string
(* generate a fixed garbled_msg to avoid 'Data_encoding.Binary.Await
_', which blocks 'make test' *)
let garbled_msg =
let buf = Bytes.create (1 lsl 4) in
TzEndian.set_int32 buf 0 (Int32.of_int 4) ;
TzEndian.set_int32 buf 4 (Int32.of_int (-1)) ;
TzEndian.set_int32 buf 8 (Int32.of_int (-1)) ;
TzEndian.set_int32 buf 12 (Int32.of_int (-1)) ;
buf
let server _ch sched socket =
accept sched socket
>>=? fun (_info, auth_fd) ->
P2p_socket.accept ~canceler auth_fd encoding
>>=? fun conn ->
P2p_socket.raw_write_sync conn garbled_msg
>>=? fun () ->
P2p_socket.read conn
>>= fun err ->
_assert (is_connection_closed err) __LOC__ ""
>>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit
let client _ch sched addr port =
connect sched addr port id2
>>=? fun auth_fd ->
P2p_socket.accept ~canceler auth_fd encoding
>>=? fun conn ->
P2p_socket.read conn
>>= fun err ->
_assert (is_decoding_error err) __LOC__ ""
>>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit
let run _dir = run_nodes client server
end
let log_config = ref None
let spec =
Arg.
[ ( "--addr",
String (fun p -> addr := Ipaddr.V6.of_string_exn p),
" Listening addr" );
( "-v",
Unit
(fun () ->
log_config :=
Some
(Lwt_log_sink_unix.create_cfg
~rules:"test.p2p.connection -> info; p2p.connection -> info"
())),
" Log up to info msgs" );
( "-vv",
Unit
(fun () ->
log_config :=
Some
(Lwt_log_sink_unix.create_cfg
~rules:
"test.p2p.connection -> debug; p2p.connection -> debug"
())),
" Log up to debug msgs" ) ]
let init_logs = lazy (Internal_event_unix.init ?lwt_log_sink:!log_config ())
let wrap n f =
Alcotest_lwt.test_case n `Quick (fun _ () ->
Lazy.force init_logs
>>= fun () ->
f ()
>>= function
| Ok () ->
Lwt.return_unit
| Error error ->
Format.kasprintf Pervasives.failwith "%a" pp_print_error error)
let main () =
let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in
let usage_msg = "Usage: %s.\nArguments are:" in
Arg.parse spec anon_fun usage_msg ;
Alcotest.run
~argv:[|""|]
"tezos-p2p"
[ ( "p2p-connection.",
[ wrap "low-level" Low_level.run;
wrap "kick" Kick.run;
wrap "kicked" Kicked.run;
wrap "simple-message" Simple_message.run;
wrap "chunked-message" Chunked_message.run;
wrap "oversized-message" Oversized_message.run;
wrap "close-on-read" Close_on_read.run;
wrap "close-on-write" Close_on_write.run;
wrap "garbled-data" Garbled_data.run;
Crypto_test.wrap () ] ) ]
let () =
Sys.catch_break true ;
try main () with _ -> ()
src/lib_p2p/test/test_p2p_socket.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition addr : Stdlib.ref Ipaddr.V6.t := Stdlib.ref Ipaddr.V6.localhost.
Definition canceler : Tezos_stdlib.Lwt_canceler.t := Lwt_canceler.create tt.
Definition proof_of_work_target : Tezos_base__TzPervasives.Crypto_box.target :=
Crypto_box.make_target
(* ❌ Float constant 16. is approximated by the integer 16 *)
16.
Definition id1 : Tezos_base__TzPervasives.P2p_identity.t :=
P2p_identity.generate proof_of_work_target.
Definition id2 : Tezos_base__TzPervasives.P2p_identity.t :=
P2p_identity.generate proof_of_work_target.
Definition id0 : Tezos_base__TzPervasives.P2p_identity.t :=
P2p_identity.generate
(Crypto_box.make_target
(* ❌ Float constant 0. is approximated by the integer 0 *)
0).
Definition version : Tezos_base__TzPervasives.Network_version.t :=
{| Network_version.chain_name := Distributed_db_version.sandboxed_chain_name;
Network_version.distributed_db_version := Distributed_db_version.zero;
Network_version.p2p_version := P2p_version.zero |}.
Definition metadata := unit.
Definition conn_meta_config : Tezos_p2p.P2p_socket.metadata_config metadata :=
{| conn_meta_encoding := Data_encoding.empty;
conn_meta_value :=
fun function_parameter =>
let '_ := function_parameter in
tt;
private_node :=
fun function_parameter =>
let '_ := function_parameter in
false |}.
Fixpoint listen (port : option Z) (addr : Ipaddr.V6.t)
: Lwt.t (Lwt_unix.file_descr * Z) :=
let tentative_port :=
match port with
| None => Z.add 1024 (Random.int 8192)
| Some port => port
end in
let uaddr := Ipaddr_unix.V6.to_inet_addr addr in
let main_socket := socket Lwt_unix.PF_INET6 Lwt_unix.SOCK_STREAM 0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := setsockopt main_socket Lwt_unix.SO_REUSEADDR true in
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_unix.bind main_socket (Lwt_unix.ADDR_INET uaddr tentative_port))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_unix.listen main_socket 1 in
Lwt._return (main_socket, tentative_port)))
(fun function_parameter =>
match function_parameter with
| Unix_error (Unix.EADDRINUSE | Unix.EADDRNOTAVAIL) _ _ =>
listen None addr
| exn => Lwt.fail exn
end).
Definition sync {A : Type} (ch : A)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (op_startypeminuserrorstar ch tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar ch)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)).
Fixpoint sync_nodes {A B : Type} (nodes : list A)
: Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
op_gtgteqquestion
(iter_p
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar op_startypeminuserrorstar) nodes)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(iter_p
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar op_startypeminuserrorstar tt) nodes)
(fun function_parameter =>
let 'tt := function_parameter in
sync_nodes nodes)).
Definition sync_nodes {A : Type} (nodes : list A)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (sync_nodes nodes)
(fun function_parameter =>
match function_parameter with
|
Stdlib.Ok tt |
Stdlib.Error (cons (Tezos_base__TzPervasives.Exn OCaml.End_of_file) _)
=> return_unit
| (Stdlib.Error _) as err => Lwt._return err
end).
Definition run_nodes {A B C : Type}
(client :
A ->
Tezos_p2p.P2p_io_scheduler.t ->
Ipaddr.V6.t -> Z -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
(server :
B ->
Tezos_p2p.P2p_io_scheduler.t ->
Lwt_unix.file_descr -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
: Lwt.t C :=
op_gtgteq (listen None (Stdlib.op_exclamation addr))
(fun function_parameter =>
let '(main_socket, port) := function_parameter in
op_gtgteq
(op_startypeminuserrorstar "server: " % string
(fun channel =>
let sched :=
P2p_io_scheduler.create None None None None (Z.shiftl 1 12) tt in
op_gtgteqquestion (server channel sched main_socket)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_io_scheduler.shutdown None sched)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(fun server_node =>
op_gtgteq
(op_startypeminuserrorstar "client: " % string
(fun channel =>
op_gtgteq (Lwt_utils_unix.safe_close main_socket)
(fun function_parameter =>
let 'tt := function_parameter in
let sched :=
P2p_io_scheduler.create None None None None
(Z.shiftl 1 12) tt in
op_gtgteqquestion
(client channel sched (Stdlib.op_exclamation addr) port)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_io_scheduler.shutdown None sched)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))))
(fun client_node =>
let nodes := cons server_node (cons client_node []) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt.ignore_result (sync_nodes nodes) in
op_startypeminuserrorstar nodes))).
Definition raw_accept
(sched : Tezos_p2p.P2p_io_scheduler.t) (main_socket : Lwt_unix.file_descr)
: Lwt.t (Tezos_p2p.P2p_io_scheduler.connection * (Ipaddr.V6.t * Z)) :=
op_gtgteq (P2p_fd.accept main_socket)
(fun function_parameter =>
let '(fd, sockaddr) := function_parameter in
let fd := P2p_io_scheduler.register sched fd in
let point :=
match sockaddr with
| Lwt_unix.ADDR_UNIX _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| Lwt_unix.ADDR_INET addr port =>
((Ipaddr_unix.V6.of_inet_addr_exn addr), port)
end in
Lwt._return (fd, point)).
Definition accept
(sched : Tezos_p2p.P2p_io_scheduler.t) (main_socket : Lwt_unix.file_descr)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
((Tezos_base__TzPervasives.P2p_connection.Info.t metadata) *
(Tezos_p2p.P2p_socket.authenticated_connection metadata))) :=
op_gtgteq (raw_accept sched main_socket)
(fun function_parameter =>
let '(fd, point) := function_parameter in
P2p_socket.authenticate canceler proof_of_work_target true fd point None
id1 version conn_meta_config).
Definition raw_connect
(sched : Tezos_p2p.P2p_io_scheduler.t) (addr : Ipaddr.V6.t) (port : Z)
: Lwt.t Tezos_p2p.P2p_io_scheduler.connection :=
let fd := P2p_fd.socket Lwt_unix.PF_INET6 Lwt_unix.SOCK_STREAM 0 in
let uaddr := Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr) port in
op_gtgteq (P2p_fd.connect fd uaddr)
(fun function_parameter =>
let 'tt := function_parameter in
let fd := P2p_io_scheduler.register sched fd in
Lwt._return fd).
Definition connect
(sched : Tezos_p2p.P2p_io_scheduler.t) (addr : Tezos_base.P2p_addr.t)
(port : Tezos_base.P2p_addr.port)
(id : Tezos_base__TzPervasives.P2p_identity.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_p2p.P2p_socket.authenticated_connection metadata)) :=
op_gtgteq (raw_connect sched addr port)
(fun fd =>
op_gtgteqquestion
(P2p_socket.authenticate canceler proof_of_work_target false fd
(addr, port) None id version conn_meta_config)
(fun function_parameter =>
let '(info, auth_fd) := function_parameter in
op_gtgteqquestion
(_assert (negb (incoming info)) Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(_assert
(equiv_decb (P2p_peer.Id.compare (peer_id info) (peer_id id1))
0) Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
_return auth_fd)))).
Definition is_connection_closed {A : Type}
(function_parameter : sum A Tezos_base__TzPervasives.trace) : bool :=
match function_parameter with
| Stdlib.Error (cons Tezos_base__TzPervasives.Connection_closed _) => true
| Stdlib.Ok _ => false
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Error: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "Error: %a" % string)
pp_print_error err in
false
end.
Definition is_decoding_error {A : Type}
(function_parameter : sum A Tezos_base__TzPervasives.trace) : bool :=
match function_parameter with
| Stdlib.Error (cons Tezos_base__TzPervasives.Decoding_error _) => true
| Stdlib.Ok _ => false
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Error: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "Error: %a" % string)
pp_print_error err in
false
end.
Module Crypto_test.
Definition bufsize : Z := Z.sub (Z.shiftl 1 16) 1.
Definition header_length : Z := 2.
Definition max_content_length : Z := Z.sub bufsize Crypto_box.zerobytes.
Definition boxextrabytes : Z :=
Z.sub Crypto_box.zerobytes Crypto_box.boxzerobytes.
Definition extrabytes : Z := Z.add header_length boxextrabytes.
Record data := {
channel_key : Tezos_base__TzPervasives.Crypto_box.channel_key;
local_nonce : Tezos_base__TzPervasives.Crypto_box.nonce;
remote_nonce : Tezos_base__TzPervasives.Crypto_box.nonce }.
Definition write_chunk
(fd : Unix.file_descr) (cryptobox_data : data) (msg : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let msglen := String.length msg in
op_gtgteqquestion
(fail_unless (OCaml.Stdlib.le msglen max_content_length)
Tezos_base__TzPervasives.Invalid_message_size)
(fun function_parameter =>
let 'tt := function_parameter in
let buf_length := Z.add msglen Crypto_box.zerobytes in
let buf := Stdlib.Bytes.make buf_length "000" % char in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.Bytes.blit msg 0 buf Crypto_box.zerobytes msglen in
let local_nonce := local_nonce cryptobox_data in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field cryptobox_data "local_nonce" % string
(Crypto_box.increment_nonce None local_nonce) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Crypto_box.fast_box_noalloc (channel_key cryptobox_data) local_nonce
buf in
let encrypted_length := Z.sub buf_length Crypto_box.boxzerobytes in
let header_pos := Z.sub Crypto_box.boxzerobytes header_length in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := TzEndian.set_int16 buf header_pos encrypted_length in
let payload := String.sub buf header_pos (Z.sub buf_length header_pos)
in
op_gtgteqquestion
(_return (Unix.write fd payload 0 (Z.sub buf_length header_pos)))
(fun i =>
op_gtgteqquestion
(_assert (equiv_decb (Z.sub buf_length header_pos) i)
Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))).
Definition read_chunk (fd : Unix.file_descr) (cryptobox_data : data)
: Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
let header_buf := Stdlib.Bytes.create header_length in
op_gtgteqquestion (_return (Unix.read fd header_buf 0 header_length))
(fun i =>
op_gtgteqquestion
(_assert (equiv_decb header_length i) Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
let encrypted_length := TzEndian.get_uint16 header_buf 0 in
let buf_length := Z.add encrypted_length Crypto_box.boxzerobytes in
let buf := Stdlib.Bytes.make buf_length "000" % char in
op_gtgteqquestion
(_return
(Unix.read fd buf Crypto_box.boxzerobytes encrypted_length))
(fun i =>
op_gtgteqquestion
(_assert (equiv_decb encrypted_length i) Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
let remote_nonce := remote_nonce cryptobox_data in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field cryptobox_data "remote_nonce" % string
(Crypto_box.increment_nonce None remote_nonce) in
match
Crypto_box.fast_box_open_noalloc
(channel_key cryptobox_data) remote_nonce buf with
| false => fail Tezos_base__TzPervasives.Decipher_error
| true =>
_return
(String.sub buf Crypto_box.zerobytes
(Z.sub buf_length Crypto_box.zerobytes))
end)))).
Definition zero_nonce : Tezos_base__TzPervasives.Crypto_box.nonce :=
Crypto_box.zero_nonce.
Definition channel_key : Tezos_base__TzPervasives.Crypto_box.channel_key :=
Crypto_box.precompute sk pk.
Definition data : data :=
{| channel_key := channel_key; local_nonce := zero_nonce;
remote_nonce := zero_nonce |}.
Definition wrap {A : Type} (function_parameter : unit) : A :=
let 'tt := function_parameter in
op_startypeminuserrorstar "ACK" % string
(* ❌ Variants not supported *)
variant
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
let msg := Stdlib.Bytes.of_string "test" % string in
op_gtgteq (write_chunk out_fd data msg)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (read_chunk in_fd data)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok res => Lwt.return_unit
| Stdlib.Ok res =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error : " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" <> " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"Error : %s <> %s" % string)
(Stdlib.Bytes.to_string res) (Stdlib.Bytes.to_string msg)
| Stdlib.Error error =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
pp_print_error error
end))).
End Crypto_test.
Module Low_level.
Definition simple_msg : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 4).
Definition client {A : Type}
(_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t) (addr : Ipaddr.V6.t)
(port : Z) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let msg := Stdlib.Bytes.create (String.length simple_msg) in
op_gtgteq (raw_connect sched addr port)
(fun fd =>
op_gtgteqquestion (P2p_io_scheduler.read_full None fd None None msg)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(_assert (equiv_decb (Stdlib.Bytes.compare simple_msg msg) 0)
Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (P2p_io_scheduler.close None fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))).
Definition server {A : Type}
(_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(socket : Lwt_unix.file_descr)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (raw_accept sched socket)
(fun function_parameter =>
let '(fd, _point) := function_parameter in
op_gtgteqquestion (P2p_io_scheduler.write None fd simple_msg)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (P2p_io_scheduler.close None fd)
(fun function_parameter =>
let '_ := function_parameter in
return_unit))).
Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Low_level.
Module Kick.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
Data_encoding.bytes.
Definition is_rejected {A : Type}
(function_parameter : sum A Tezos_base__TzPervasives.trace) : bool :=
match function_parameter with
| Stdlib.Error (cons Tezos_base__TzPervasives.Rejected_socket_connection _)
=> true
| Stdlib.Ok _ => false
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Error: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "Error: %a" % string)
pp_print_error err in
false
end.
Definition server {A : Type}
(_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(socket : Lwt_unix.file_descr)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (accept sched socket)
(fun function_parameter =>
let '(info, auth_fd) := function_parameter in
op_gtgteqquestion
(_assert (incoming info) Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(_assert
(equiv_decb (P2p_peer.Id.compare (peer_id info) (peer_id id2)) 0)
Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.kick auth_fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))).
Definition client {A : Type}
(_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (connect sched addr port id2)
(fun auth_fd =>
op_gtgteq (P2p_socket.accept None None None canceler auth_fd encoding)
(fun conn =>
op_gtgteqquestion
(_assert (is_rejected conn) Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))).
Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Kick.
Module Kicked.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
Data_encoding.bytes.
Definition server {A : Type}
(_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(socket : Lwt_unix.file_descr)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (accept sched socket)
(fun function_parameter =>
let '(_info, auth_fd) := function_parameter in
op_gtgteq (P2p_socket.accept None None None canceler auth_fd encoding)
(fun conn =>
op_gtgteqquestion
(_assert (Kick.is_rejected conn) Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))).
Definition client {A : Type}
(_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (connect sched addr port id2)
(fun auth_fd =>
op_gtgteq (P2p_socket.kick auth_fd)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)).
Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Kicked.
Module Simple_message.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
Data_encoding.bytes.
Definition simple_msg : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 4).
Definition simple_msg2 : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 4).
Definition server {A : Type}
(ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(socket : Lwt_unix.file_descr)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (accept sched socket)
(fun function_parameter =>
let '(_info, auth_fd) := function_parameter in
op_gtgteqquestion
(P2p_socket.accept None None None canceler auth_fd encoding)
(fun conn =>
op_gtgteqquestion (P2p_socket.write_sync conn simple_msg)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (P2p_socket.read conn)
(fun function_parameter =>
let '(_msg_size, msg) := function_parameter in
op_gtgteqquestion
(_assert
(equiv_decb (Stdlib.Bytes.compare simple_msg2 msg) 0)
Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (sync ch)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.close None conn)
(fun _stat => return_unit))))))).
Definition client {A : Type}
(ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (connect sched addr port id2)
(fun auth_fd =>
op_gtgteqquestion
(P2p_socket.accept None None None canceler auth_fd encoding)
(fun conn =>
op_gtgteqquestion (P2p_socket.write_sync conn simple_msg2)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (P2p_socket.read conn)
(fun function_parameter =>
let '(_msg_size, msg) := function_parameter in
op_gtgteqquestion
(_assert
(equiv_decb (Stdlib.Bytes.compare simple_msg msg) 0)
Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (sync ch)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.close None conn)
(fun _stat => return_unit))))))).
Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Simple_message.
Module Chunked_message.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
Data_encoding.bytes.
Definition simple_msg : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 8).
Definition simple_msg2 : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 8).
Definition server {A : Type}
(ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(socket : Lwt_unix.file_descr)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (accept sched socket)
(fun function_parameter =>
let '(_info, auth_fd) := function_parameter in
op_gtgteqquestion
(P2p_socket.accept None None (Some 21) canceler auth_fd encoding)
(fun conn =>
op_gtgteqquestion (P2p_socket.write_sync conn simple_msg)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (P2p_socket.read conn)
(fun function_parameter =>
let '(_msg_size, msg) := function_parameter in
op_gtgteqquestion
(_assert
(equiv_decb (Stdlib.Bytes.compare simple_msg2 msg) 0)
Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (sync ch)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.close None conn)
(fun _stat => return_unit))))))).
Definition client {A : Type}
(ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (connect sched addr port id2)
(fun auth_fd =>
op_gtgteqquestion
(P2p_socket.accept None None (Some 21) canceler auth_fd encoding)
(fun conn =>
op_gtgteqquestion (P2p_socket.write_sync conn simple_msg2)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (P2p_socket.read conn)
(fun function_parameter =>
let '(_msg_size, msg) := function_parameter in
op_gtgteqquestion
(_assert
(equiv_decb (Stdlib.Bytes.compare simple_msg msg) 0)
Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (sync ch)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.close None conn)
(fun _stat => return_unit))))))).
Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Chunked_message.
Module Oversized_message.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
Data_encoding.bytes.
Definition simple_msg : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 17).
Definition simple_msg2 : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 17).
Definition server {A : Type}
(ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(socket : Lwt_unix.file_descr)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (accept sched socket)
(fun function_parameter =>
let '(_info, auth_fd) := function_parameter in
op_gtgteqquestion
(P2p_socket.accept None None None canceler auth_fd encoding)
(fun conn =>
op_gtgteqquestion (P2p_socket.write_sync conn simple_msg)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (P2p_socket.read conn)
(fun function_parameter =>
let '(_msg_size, msg) := function_parameter in
op_gtgteqquestion
(_assert
(equiv_decb (Stdlib.Bytes.compare simple_msg2 msg) 0)
Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (sync ch)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.close None conn)
(fun _stat => return_unit))))))).
Definition client {A : Type}
(ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (connect sched addr port id2)
(fun auth_fd =>
op_gtgteqquestion
(P2p_socket.accept None None None canceler auth_fd encoding)
(fun conn =>
op_gtgteqquestion (P2p_socket.write_sync conn simple_msg2)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (P2p_socket.read conn)
(fun function_parameter =>
let '(_msg_size, msg) := function_parameter in
op_gtgteqquestion
(_assert
(equiv_decb (Stdlib.Bytes.compare simple_msg msg) 0)
Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (sync ch)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.close None conn)
(fun _stat => return_unit))))))).
Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Oversized_message.
Module Close_on_read.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
Data_encoding.bytes.
Definition simple_msg : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 4).
Definition server {A : Type}
(ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(socket : Lwt_unix.file_descr)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (accept sched socket)
(fun function_parameter =>
let '(_info, auth_fd) := function_parameter in
op_gtgteqquestion
(P2p_socket.accept None None None canceler auth_fd encoding)
(fun conn =>
op_gtgteqquestion (sync ch)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.close None conn)
(fun _stat => return_unit)))).
Definition client {A : Type}
(ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (connect sched addr port id2)
(fun auth_fd =>
op_gtgteqquestion
(P2p_socket.accept None None None canceler auth_fd encoding)
(fun conn =>
op_gtgteqquestion (sync ch)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.read conn)
(fun err =>
op_gtgteqquestion
(_assert (is_connection_closed err) Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.close None conn)
(fun _stat => return_unit)))))).
Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Close_on_read.
Module Close_on_write.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
Data_encoding.bytes.
Definition simple_msg : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 4).
Definition server {A : Type}
(ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(socket : Lwt_unix.file_descr)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (accept sched socket)
(fun function_parameter =>
let '(_info, auth_fd) := function_parameter in
op_gtgteqquestion
(P2p_socket.accept None None None canceler auth_fd encoding)
(fun conn =>
op_gtgteq (P2p_socket.close None conn)
(fun _stat =>
op_gtgteqquestion (sync ch)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))).
Definition client {A : Type}
(ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (connect sched addr port id2)
(fun auth_fd =>
op_gtgteqquestion
(P2p_socket.accept None None None canceler auth_fd encoding)
(fun conn =>
op_gtgteqquestion (sync ch)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_unix.sleep
(* ❌ Float constant 0.1 is approximated by the integer 0 *)
0)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.write_sync conn simple_msg)
(fun err =>
op_gtgteqquestion
(_assert (is_connection_closed err) Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.close None conn)
(fun _stat => return_unit))))))).
Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Close_on_write.
Module Garbled_data.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding (option string) :=
apply
(let arg := dynamic_size in
fun eta => arg None eta) (apply option string).
Definition garbled_msg : string :=
let buf := Stdlib.Bytes.create (Z.shiftl 1 4) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := TzEndian.set_int32 buf 0 (Int32.of_int 4) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := TzEndian.set_int32 buf 4 (Int32.of_int (-1)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := TzEndian.set_int32 buf 8 (Int32.of_int (-1)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := TzEndian.set_int32 buf 12 (Int32.of_int (-1)) in
buf.
Definition server {A : Type}
(_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(socket : Lwt_unix.file_descr)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (accept sched socket)
(fun function_parameter =>
let '(_info, auth_fd) := function_parameter in
op_gtgteqquestion
(P2p_socket.accept None None None canceler auth_fd encoding)
(fun conn =>
op_gtgteqquestion (P2p_socket.raw_write_sync conn garbled_msg)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.read conn)
(fun err =>
op_gtgteqquestion
(_assert (is_connection_closed err) Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.close None conn)
(fun _stat => return_unit)))))).
Definition client {A : Type}
(_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
(addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (connect sched addr port id2)
(fun auth_fd =>
op_gtgteqquestion
(P2p_socket.accept None None None canceler auth_fd encoding)
(fun conn =>
op_gtgteq (P2p_socket.read conn)
(fun err =>
op_gtgteqquestion
(_assert (is_decoding_error err) Stdlib.__LOC__
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p_socket.close None conn)
(fun _stat => return_unit))))).
Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Garbled_data.
Definition log_config
: Stdlib.ref (option Tezos_stdlib_unix.Lwt_log_sink_unix.cfg) :=
Stdlib.ref None.
Definition spec : list (string * Stdlib.Arg.spec * string) :=
cons
("--addr" % string,
(Stdlib.Arg.String
(fun p => Stdlib.op_coloneq addr (Ipaddr.V6.of_string_exn p))),
" Listening addr" % string)
(cons
("-v" % string,
(Stdlib.Arg.Unit
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_coloneq log_config
(Some
(Lwt_log_sink_unix.create_cfg None None
(Some
"test.p2p.connection -> info; p2p.connection -> info" %
string) None tt)))), " Log up to info msgs" % string)
(cons
("-vv" % string,
(Stdlib.Arg.Unit
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_coloneq log_config
(Some
(Lwt_log_sink_unix.create_cfg None None
(Some
"test.p2p.connection -> debug; p2p.connection -> debug" %
string) None tt)))), " Log up to debug msgs" % string)
[])).
Definition init_logs : lazy_t (Lwt.t unit) :=
(* ❌ Lazy expressions are not handled *)
lazy (Internal_event_unix.init (Stdlib.op_exclamation log_config) None tt).
Definition wrap {A B : Type}
(n : A) (f : unit -> Lwt.t (sum unit Tezos_base__TzPervasives.trace)) : B :=
op_startypeminuserrorstar n
(* ❌ Variants not supported *)
variant
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lazy.force init_logs)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (f tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error error =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
pp_print_error error
end))).
Definition main {A : Type} (function_parameter : unit) : A :=
let 'tt := function_parameter in
let anon_fun {B C : Type} (_num_peers : B) : C :=
Stdlib.raise (Bad "No anonymous argument." % string) in
let usage_msg := "Usage: %s.
Arguments are:" % string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Arg.parse spec anon_fun usage_msg in
op_startypeminuserrorstar
(* ❌ Arrays not handled. *)
[ "" % string ] "tezos-p2p" % string
(cons
("p2p-connection." % string,
(cons (wrap "low-level" % string Low_level.run)
(cons (wrap "kick" % string Kick.run)
(cons (wrap "kicked" % string Kicked.run)
(cons (wrap "simple-message" % string Simple_message.run)
(cons (wrap "chunked-message" % string Chunked_message.run)
(cons
(wrap "oversized-message" % string Oversized_message.run)
(cons (wrap "close-on-read" % string Close_on_read.run)
(cons (wrap "close-on-write" % string Close_on_write.run)
(cons (wrap "garbled-data" % string Garbled_data.run)
(cons (Crypto_test.wrap tt) []))))))))))) []).
src/lib_protocol_compiler/byte.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** The OCaml compiler not being implemented with Lwt, the compilation
take place in a separated process (by using [Lwt_process.exec]).
The [main] function is the entry point for the forked process.
While [Updater.compile] is the 'forking' function to be called by
the [tezos-node] process.
*)
(** Semi-generic compilation functions *)
let pack_objects output objects =
let output = output ^ ".cmo" in
Compmisc.init_path true ;
Bytepackager.package_files
Format.err_formatter
Env.initial_safe_string
objects
output ;
Warnings.check_fatal () ;
output
let link_shared output objects =
Compenv.(readenv Format.err_formatter Before_link) ;
Compmisc.init_path true ;
Bytelink.link Format.err_formatter objects output ;
Warnings.check_fatal ()
let compile_ml ?for_pack ml =
let target = Filename.chop_extension ml in
Clflags.for_package := for_pack ;
Compenv.(readenv Format.err_formatter (Before_compile ml)) ;
Compile.implementation Format.err_formatter ml target ;
Clflags.for_package := None ;
target ^ ".cmo"
let () = Clflags.native_code := false
let driver = Compiler.{compile_ml; link_shared; pack_objects}
src/lib_protocol_compiler/byte.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition pack_objects (output : string) (objects : list string) : string :=
let output := String.append output ".cmo" % string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Compmisc.init_path None true in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Bytepackager.package_files Format.err_formatter Env.initial_safe_string
objects output in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Warnings.check_fatal tt in
output.
Definition link_shared (output : string) (objects : list string) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := readenv Format.err_formatter Compenv.Before_link in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Compmisc.init_path None true in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Bytelink.link Format.err_formatter objects output in
Warnings.check_fatal tt.
Definition compile_ml (for_pack : option string) (ml : Compenv.filename)
: string :=
let target := Filename.chop_extension ml in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq Clflags.for_package for_pack in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := readenv Format.err_formatter (Compenv.Before_compile ml) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Compile.implementation Format.err_formatter ml target in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq Clflags.for_package None in
String.append target ".cmo" % string.
Definition driver : Tezos_protocol_compiler.Compiler.driver :=
{| compile_ml := compile_ml; pack_objects := pack_objects;
link_shared := link_shared |}.
src/lib_protocol_compiler/compiler.ml 38 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let warnings = "+a-4-6-7-9-29-40..42-44-45-48"
let warn_error = "-a+8"
let () = Clflags.unsafe_string := false
(** Override the default 'Env.Persistent_signature.load'
with a lookup in locally defined hashtable.
*)
let preloaded_cmis : (string, Env.Persistent_signature.t) Hashtbl.t =
Hashtbl.create ~random:true 42
(* Set hook *)
let () =
Env.Persistent_signature.load :=
fun ~unit_name ->
try
Some (Hashtbl.find preloaded_cmis (String.capitalize_ascii unit_name))
with Not_found -> None
let load_cmi_from_file file =
Hashtbl.add
preloaded_cmis
(String.capitalize_ascii Filename.(basename (chop_extension file)))
{filename = file; cmi = Cmi_format.read_cmi file}
let load_embeded_cmi (unit_name, content) =
let content = Bytes.of_string content in
(* Read cmi magic *)
let magic_len = String.length Config.cmi_magic_number in
let magic = Bytes.sub content 0 magic_len in
assert (magic = Bytes.of_string Config.cmi_magic_number) ;
(* Read cmi_name and cmi_sign *)
let pos = magic_len in
let (cmi_name, cmi_sign) = Marshal.from_bytes content pos in
let pos = pos + Marshal.total_size content pos in
(* Read cmi_crcs *)
let cmi_crcs = Marshal.from_bytes content pos in
let pos = pos + Marshal.total_size content pos in
(* Read cmi_flags *)
let cmi_flags = Marshal.from_bytes content pos in
(* TODO check crcrs... *)
Hashtbl.add
preloaded_cmis
(String.capitalize_ascii unit_name)
{
filename = unit_name ^ ".cmi";
cmi = {cmi_name; cmi_sign; cmi_crcs; cmi_flags};
}
let load_embeded_cmis cmis = List.iter load_embeded_cmi cmis
(** Compilation environment.
[tezos_protocol_env] defines the list of [cmi] available while compiling
the protocol version. The [cmi] are packed into the [tezos-node]
binary by using [ocp-ocamlres], see the Makefile.
[register_env] defines a complementary list of [cmi] available
while compiling the generated [register.ml] file (that register
the protocol first-class module into the [Updater.versions]
hashtable).
*)
let tezos_protocol_env =
let open Embedded_cmis in
[ ("CamlinternalFormatBasics", camlinternalFormatBasics_cmi);
("Tezos_protocol_environment_sigs", tezos_protocol_environment_sigs_cmi);
( "Tezos_protocol_environment_sigs__V1",
tezos_protocol_environment_sigs__V1_cmi ) ]
let register_env =
let open Embedded_cmis in
[ ( "tezos_protocol_registerer__Registerer",
tezos_protocol_registerer__Registerer_cmi ) ]
(** Helpers *)
let ( // ) = Filename.concat
let create_file ?(perm = 0o644) name content =
let open Unix in
let fd = openfile name [O_TRUNC; O_CREAT; O_WRONLY] perm in
ignore (write_substring fd content 0 (String.length content)) ;
close fd
let safe_unlink file =
try Unix.unlink file with Unix.Unix_error (Unix.ENOENT, _, _) -> ()
let unlink_cmi dir (file, _) = safe_unlink ((dir // file) ^ ".cmi")
let unlink_object obj =
safe_unlink obj ;
safe_unlink (Filename.chop_suffix obj ".cmx" ^ ".cmi") ;
safe_unlink (Filename.chop_suffix obj ".cmx" ^ ".o")
let debug_flag = ref false
let debug fmt =
if !debug_flag then Format.eprintf fmt
else Format.ifprintf Format.err_formatter fmt
let mktemp_dir () =
Filename.get_temp_dir_name ()
// Printf.sprintf "tezos-protocol-build-%06X" (Random.int 0xFFFFFF)
(** Main *)
type driver = {
compile_ml : ?for_pack:string -> string -> string;
pack_objects : string -> string list -> string;
link_shared : string -> string list -> unit;
}
let main {compile_ml; pack_objects; link_shared} =
Random.self_init () ;
let anonymous = ref []
and static = ref false
and register = ref false
and build_dir = ref None
and output_file = ref None
and output_dep = ref false
and hash_only = ref false
and check_protocol_hash = ref true in
let args_spec =
[ ("-o", Arg.String (fun s -> output_file := Some s), "");
( "-hash-only",
Arg.Set hash_only,
" Only display the hash of the protocol and don't compile" );
( "-no-hash-check",
Arg.Clear check_protocol_hash,
" Don't check that TEZOS_PROTOCOL declares the expected protocol hash \
(if existent)" );
("-static", Arg.Set static, " Only build the static library (no .cmxs)");
("-register", Arg.Set register, " Generate the `Registerer` module");
("-bin-annot", Arg.Set Clflags.binary_annotations, " (see ocamlopt)");
("-g", Arg.Set Clflags.debug, " (see ocamlopt)");
("-output-dep", Arg.Set output_dep, " ...");
( "-build-dir",
Arg.String (fun s -> build_dir := Some s),
"use custom build directory and preserve build artifacts" ) ]
in
let usage_msg =
Printf.sprintf "Usage: %s [options] <srcdir>\nOptions are:" Sys.argv.(0)
in
Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) usage_msg ;
let source_dir =
match List.rev !anonymous with
| [protocol_dir] ->
protocol_dir
| _ ->
Arg.usage args_spec usage_msg ;
Pervasives.exit 1
in
let (announced_hash, protocol) =
match
Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir)
with
| Ok (hash, proto) ->
(hash, proto)
| Error err ->
Format.eprintf "Failed to read TEZOS_PROTOCOL: %a" pp_print_error err ;
exit 2
in
let real_hash = Protocol.hash protocol in
if !hash_only then (
Format.printf "%a@." Protocol_hash.pp real_hash ;
exit 0 ) ;
let hash =
match announced_hash with
| None ->
real_hash
| Some hash
when !check_protocol_hash && not (Protocol_hash.equal real_hash hash) ->
Format.eprintf
"Inconsistent hash for protocol in TEZOS_PROTOCOL.@\n\
Found: %a@\n\
Expected: %a@."
Protocol_hash.pp
hash
Protocol_hash.pp
real_hash ;
exit 2
| Some hash ->
hash
in
let build_dir =
match !build_dir with
| None ->
let dir = mktemp_dir () in
at_exit (fun () -> Lwt_main.run (Lwt_utils_unix.remove_dir dir)) ;
dir
| Some dir ->
dir
in
let output =
match !output_file with
| Some output ->
output
| None ->
Format.asprintf "proto_%a" Protocol_hash.pp hash
in
Lwt_main.run (Lwt_utils_unix.create_dir ~perm:0o755 build_dir) ;
Lwt_main.run
(Lwt_utils_unix.create_dir ~perm:0o755 (Filename.dirname output)) ;
(* Generate the 'functor' *)
let functor_file = build_dir // "functor.ml" in
let oc = open_out functor_file in
Packer.dump
oc
hash
(Array.map
(fun {Protocol.name; _} ->
let name_lowercase = String.uncapitalize_ascii name in
(source_dir // name_lowercase) ^ ".ml")
(Array.of_list protocol.components)) ;
close_out oc ;
(* Compile the protocol *)
let proto_cmi = Filename.chop_extension functor_file ^ ".cmi" in
let functor_unit =
String.capitalize_ascii Filename.(basename (chop_extension functor_file))
in
let for_pack = String.capitalize_ascii (Filename.basename output) in
(* Initialize the compilers *)
Compenv.(readenv Format.err_formatter Before_args) ;
Clflags.nopervasives := true ;
Clflags.no_std_include := true ;
Clflags.include_dirs := [Filename.dirname functor_file] ;
Warnings.parse_options false warnings ;
Warnings.parse_options true warn_error ;
load_embeded_cmis tezos_protocol_env ;
let packed_protocol_object = compile_ml ~for_pack functor_file in
let register_objects =
if not !register then []
else (
load_embeded_cmis register_env ;
load_cmi_from_file proto_cmi ;
(* Compiler the 'registering module' *)
let register_file = Filename.dirname functor_file // "register.ml" in
create_file
register_file
(Printf.sprintf
"module Name = struct let name = %S end\n\
\ let () = Tezos_protocol_registerer__Registerer.register \
Name.name (module %s.Make)"
(Protocol_hash.to_b58check hash)
functor_unit) ;
let register_object = compile_ml ~for_pack register_file in
[register_object] )
in
let resulting_object =
pack_objects output (packed_protocol_object :: register_objects)
in
(* Create the final [cmxs] *)
if not !static then (
Clflags.link_everything := true ;
link_shared (output ^ ".cmxs") [resulting_object] ) ;
if !output_dep then (
let dsrc = Digest.file functor_file in
let dimpl = Digest.file resulting_object in
let dintf =
Digest.file (Filename.chop_extension resulting_object ^ ".cmi")
in
Format.printf "module Toto = struct include %s end ;; \n" for_pack ;
Format.printf "let src_digest = %S ;;\n" (Digest.to_hex dsrc) ;
Format.printf "let impl_digest = %S ;;\n" (Digest.to_hex dimpl) ;
Format.printf "let intf_digest = %S ;;\n" (Digest.to_hex dintf) ) ;
Format.printf "Success: %a.@." Protocol_hash.pp hash
src/lib_protocol_compiler/compiler.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition warnings : string := "+a-4-6-7-9-29-40..42-44-45-48" % string.
Definition warn_error : string := "-a+8" % string.
Definition preloaded_cmis
: Stdlib.Hashtbl.t string Env.Persistent_signature.t :=
Hashtbl.create (Some true) 42.
Definition load_cmi_from_file (file : string) : unit :=
Hashtbl.add preloaded_cmis
(String.capitalize_ascii (basename (chop_extension file)))
{| filename := file; cmi := Cmi_format.read_cmi file |}.
Definition load_embeded_cmi (function_parameter : string * string) : unit :=
let '(unit_name, content) := function_parameter in
let content := Stdlib.Bytes.of_string content in
let magic_len := String.length Config.cmi_magic_number in
let magic := String.sub content 0 magic_len in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb magic (Stdlib.Bytes.of_string Config.cmi_magic_number))
in
let pos := magic_len in
let '(cmi_name, cmi_sign) := Marshal.from_bytes content pos in
let pos := Z.add pos (Marshal.total_size content pos) in
let cmi_crcs := Marshal.from_bytes content pos in
let pos := Z.add pos (Marshal.total_size content pos) in
let cmi_flags := Marshal.from_bytes content pos in
Hashtbl.add preloaded_cmis (String.capitalize_ascii unit_name)
{| filename := String.append unit_name ".cmi" % string;
cmi :=
{| cmi_name := cmi_name; cmi_sign := cmi_sign; cmi_crcs := cmi_crcs;
cmi_flags := cmi_flags |} |}.
Definition load_embeded_cmis (cmis : list (string * string)) : unit :=
List.iter load_embeded_cmi cmis.
Definition tezos_protocol_env : list (string * string) :=
cons ("CamlinternalFormatBasics" % string, camlinternalFormatBasics_cmi)
(cons
("Tezos_protocol_environment_sigs" % string,
tezos_protocol_environment_sigs_cmi)
(cons
("Tezos_protocol_environment_sigs__V1" % string,
tezos_protocol_environment_sigs__V1_cmi) [])).
Definition register_env : list (string * string) :=
cons
("tezos_protocol_registerer__Registerer" % string,
tezos_protocol_registerer__Registerer_cmi) [].
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition create_file (op_staroptstar : option Unix.file_perm)
: string -> string -> unit :=
let perm :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 420
end in
fun name =>
fun content =>
let fd :=
openfile name
(cons Unix.O_TRUNC (cons Unix.O_CREAT (cons Unix.O_WRONLY []))) perm
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.ignore
(write_substring fd content 0 (String.length content)) in
close fd.
Definition safe_unlink (file : string) : unit :=
(* ❌ Try-with are not handled *)
try (Unix.unlink file).
Definition unlink_cmi {A : Type}
(dir : string) (function_parameter : string * A) : unit :=
let '(file, _) := function_parameter in
safe_unlink (String.append (op_divdiv dir file) ".cmi" % string).
Definition unlink_object (obj : string) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := safe_unlink obj in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
safe_unlink
(String.append (Filename.chop_suffix obj ".cmx" % string) ".cmi" % string)
in
safe_unlink
(String.append (Filename.chop_suffix obj ".cmx" % string) ".o" % string).
Definition debug_flag : Stdlib.ref bool := Stdlib.ref false.
Definition debug {A : Type} (fmt : Stdlib.format A Stdlib.Format.formatter unit)
: A :=
if Stdlib.op_exclamation debug_flag then
Format.eprintf fmt
else
Format.ifprintf Format.err_formatter fmt.
Definition mktemp_dir (function_parameter : unit) : string :=
let 'tt := function_parameter in
op_divdiv (Filename.get_temp_dir_name tt)
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"tezos-protocol-build-" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_X
(CamlinternalFormatBasics.Lit_padding CamlinternalFormatBasics.Zeros
6) CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"tezos-protocol-build-%06X" % string) (Random.int 16777215)).
Record driver := {
compile_ml : (option string) -> string -> string;
pack_objects : string -> (list string) -> string;
link_shared : string -> (list string) -> unit }.
Definition main (function_parameter : driver) : unit :=
let '{|
compile_ml := compile_ml;
pack_objects := pack_objects;
link_shared := link_shared
|} := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Random.self_init tt in
let anonymous : Stdlib.ref (list string) :=
Stdlib.ref []
with static : Stdlib.ref bool :=
Stdlib.ref false
with register : Stdlib.ref bool :=
Stdlib.ref false
with build_dir : Stdlib.ref (option string) :=
Stdlib.ref None
with output_file : Stdlib.ref (option string) :=
Stdlib.ref None
with output_dep : Stdlib.ref bool :=
Stdlib.ref false
with hash_only : Stdlib.ref bool :=
Stdlib.ref false
with check_protocol_hash : Stdlib.ref bool :=
Stdlib.ref true in
let args_spec :=
cons
("-o" % string,
(Stdlib.Arg.String (fun s => Stdlib.op_coloneq output_file (Some s))),
"" % string)
(cons
("-hash-only" % string, (Stdlib.Arg.Set hash_only),
" Only display the hash of the protocol and don't compile" % string)
(cons
("-no-hash-check" % string, (Stdlib.Arg.Clear check_protocol_hash),
" Don't check that TEZOS_PROTOCOL declares the expected protocol hash (if existent)"
% string)
(cons
("-static" % string, (Stdlib.Arg.Set static),
" Only build the static library (no .cmxs)" % string)
(cons
("-register" % string, (Stdlib.Arg.Set register),
" Generate the `Registerer` module" % string)
(cons
("-bin-annot" % string,
(Stdlib.Arg.Set Clflags.binary_annotations),
" (see ocamlopt)" % string)
(cons
("-g" % string, (Stdlib.Arg.Set Clflags.debug),
" (see ocamlopt)" % string)
(cons
("-output-dep" % string, (Stdlib.Arg.Set output_dep),
" ..." % string)
(cons
("-build-dir" % string,
(Stdlib.Arg.String
(fun s => Stdlib.op_coloneq build_dir (Some s))),
"use custom build directory and preserve build artifacts"
% string) [])))))))) in
let usage_msg :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Usage: " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" [options] <srcdir>
Options are:" % string
CamlinternalFormatBasics.End_of_format)))
"Usage: %s [options] <srcdir>
Options are:" % string)
(Array.get Sys.argv 0) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Arg.parse args_spec
(fun s =>
Stdlib.op_coloneq anonymous (cons s (Stdlib.op_exclamation anonymous)))
usage_msg in
let source_dir :=
match List.rev (Stdlib.op_exclamation anonymous) with
| cons protocol_dir [] => protocol_dir
| _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Arg.usage args_spec usage_msg in
Pervasives.exit 1
end in
let '(announced_hash, protocol) :=
match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir) with
| Stdlib.Ok (hash, proto) => (hash, proto)
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to read TEZOS_PROTOCOL: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Failed to read TEZOS_PROTOCOL: %a" % string) pp_print_error err in
Stdlib.exit 2
end in
let real_hash := Protocol.hash protocol in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if Stdlib.op_exclamation hash_only then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)) "%a@." % string)
Protocol_hash.pp real_hash in
Stdlib.exit 0
else
tt in
let hash :=
match announced_hash with
| None => real_hash
| Some hash =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Inconsistent hash for protocol in TEZOS_PROTOCOL." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.String_literal "Found: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.String_literal
"Expected: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))
"Inconsistent hash for protocol in TEZOS_PROTOCOL.@
Found: %a@
Expected: %a@."
% string) Protocol_hash.pp hash Protocol_hash.pp real_hash in
Stdlib.exit 2
| Some hash => hash
end in
let build_dir :=
match Stdlib.op_exclamation build_dir with
| None =>
let dir := mktemp_dir tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.at_exit
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_main.run (Lwt_utils_unix.remove_dir dir)) in
dir
| Some dir => dir
end in
let output :=
match Stdlib.op_exclamation output_file with
| Some output => output
| None =>
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "proto_" % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "proto_%a" % string)
Protocol_hash.pp hash
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_main.run (Lwt_utils_unix.create_dir (Some 493) build_dir) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_main.run
(Lwt_utils_unix.create_dir (Some 493) (Filename.dirname output)) in
let functor_file := op_divdiv build_dir "functor.ml" % string in
let oc := Stdlib.open_out functor_file in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Packer.dump oc hash
(Array.map
(fun function_parameter =>
let '{| Protocol.name := name |} := function_parameter in
let name_lowercase := String.uncapitalize_ascii name in
String.append (op_divdiv source_dir name_lowercase) ".ml" % string)
(Array.of_list (components protocol))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.close_out oc in
let proto_cmi :=
String.append (Filename.chop_extension functor_file) ".cmi" % string in
let functor_unit :=
String.capitalize_ascii (basename (chop_extension functor_file)) in
let for_pack := String.capitalize_ascii (Filename.basename output) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := readenv Format.err_formatter Compenv.Before_args in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq Clflags.nopervasives true in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq Clflags.no_std_include true in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq Clflags.include_dirs
(cons (Filename.dirname functor_file) []) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Warnings.parse_options false warnings in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Warnings.parse_options true warn_error in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := load_embeded_cmis tezos_protocol_env in
let packed_protocol_object := compile_ml (Some for_pack) functor_file in
let register_objects :=
if negb (Stdlib.op_exclamation register) then
[]
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := load_embeded_cmis register_env in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := load_cmi_from_file proto_cmi in
let register_file :=
op_divdiv (Filename.dirname functor_file) "register.ml" % string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
create_file None register_file
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"module Name = struct let name = " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" end
let () = Tezos_protocol_registerer__Registerer.register Name.name (module "
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ".Make)" % string
CamlinternalFormatBasics.End_of_format)))))
"module Name = struct let name = %S end
let () = Tezos_protocol_registerer__Registerer.register Name.name (module %s.Make)"
% string) (Protocol_hash.to_b58check hash) functor_unit) in
let register_object := compile_ml (Some for_pack) register_file in
cons register_object [] in
let resulting_object :=
pack_objects output (cons packed_protocol_object register_objects) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if negb (Stdlib.op_exclamation static) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq Clflags.link_everything true in
link_shared (String.append output ".cmxs" % string)
(cons resulting_object [])
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if Stdlib.op_exclamation output_dep then
let dsrc := Digest.file functor_file in
let dimpl := Digest.file resulting_object in
let dintf :=
Digest.file
(String.append (Filename.chop_extension resulting_object)
".cmi" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"module Toto = struct include " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " end ;;
" % string
CamlinternalFormatBasics.End_of_format)))
"module Toto = struct include %s end ;;
" % string) for_pack in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"let src_digest = " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " ;;
" % string
CamlinternalFormatBasics.End_of_format)))
"let src_digest = %S ;;
" % string) (Digest.to_hex dsrc) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"let impl_digest = " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " ;;
" % string
CamlinternalFormatBasics.End_of_format)))
"let impl_digest = %S ;;
" % string) (Digest.to_hex dimpl) in
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "let intf_digest = " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " ;;
" % string
CamlinternalFormatBasics.End_of_format)))
"let intf_digest = %S ;;
" % string) (Digest.to_hex dintf)
else
tt in
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Success: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Success: %a.@." % string) Protocol_hash.pp hash.
src/lib_protocol_compiler/main_byte.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let () =
try
Tezos_protocol_compiler.Compiler.main
Tezos_protocol_compiler_byte.Byte.driver ;
Pervasives.exit 0
with exn ->
Format.eprintf "%a\n%!" Errors.report_error exn ;
Pervasives.exit 1
src/lib_protocol_compiler/main_byte.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations.
src/lib_protocol_compiler/main_embedded_packer.ml 4 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let srcdir = Sys.argv.(1)
let version = Sys.argv.(2)
let srcdir =
if Filename.basename srcdir = "TEZOS_PROTOCOL" then Filename.dirname srcdir
else srcdir
let (hash, sources) =
match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir srcdir) with
| Ok (None, proto) ->
(Protocol.hash proto, proto)
| Ok (Some hash, proto) ->
(hash, proto)
| Error err ->
Format.kasprintf
Pervasives.failwith
"Failed to read TEZOS_PROTOCOL: %a"
pp_print_error
err
let () =
Format.printf
{|
module Source = struct
let hash =
Some (Tezos_crypto.Protocol_hash.of_b58check_exn %S)
let sources = Tezos_base.Protocol.%a
end
@.|}
(Protocol_hash.to_b58check hash)
Protocol.pp_ocaml
sources
let () =
Format.printf
{|
module Registered =
Tezos_protocol_updater.Registered_protocol.Register_embedded
(Tezos_protocol_environment_%s.Environment)
(Tezos_raw_protocol_%s.Main)
(Source)
@.|}
version
version
src/lib_protocol_compiler/main_embedded_packer.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition srcdir : string := Array.get Sys.argv 1.
Definition version : string := Array.get Sys.argv 2.
Definition srcdir : string :=
if equiv_decb (Filename.basename srcdir) "TEZOS_PROTOCOL" % string then
Filename.dirname srcdir
else
srcdir.
src/lib_protocol_compiler/main_native.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let () =
try
Tezos_protocol_compiler.Compiler.main
Tezos_protocol_compiler_native.Native.driver ;
Pervasives.exit 0
with exn ->
Format.eprintf "%a\n%!" Opterrors.report_error exn ;
Pervasives.exit 1
src/lib_protocol_compiler/main_native.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations.
src/lib_protocol_compiler/main_packer.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let ( // ) = Filename.concat
let () =
Random.self_init () ;
let anonymous = ref [] in
let args_spec = [] in
let usage_msg = Printf.sprintf "Usage: %s [options] <srcdir>" Sys.argv.(0) in
Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) usage_msg ;
let source_dir =
match List.rev !anonymous with
| [source_dir] when Filename.basename source_dir = "TEZOS_PROTOCOL" ->
Filename.dirname source_dir
| [source_dir] ->
source_dir
| _ ->
Arg.usage args_spec usage_msg ;
Pervasives.exit 1
in
let (hash, protocol) =
match
Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir)
with
| Ok (None, proto) ->
(Protocol.hash proto, proto)
| Ok (Some hash, proto) ->
(hash, proto)
| Error err ->
Format.kasprintf
Pervasives.failwith
"Failed to read TEZOS_PROTOCOL: %a"
pp_print_error
err
in
(* Generate the 'functor' *)
Packer.dump
stdout
hash
(Array.map
(fun {Protocol.name; _} ->
let name_lowercase = String.uncapitalize_ascii name in
(source_dir // name_lowercase) ^ ".ml")
(Array.of_list protocol.components))
src/lib_protocol_compiler/main_packer.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. Definition op_divdiv : string -> string -> string := Filename.concat.
src/lib_protocol_compiler/native.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** The OCaml compiler not being implemented with Lwt, the compilation
take place in a separated process (by using [Lwt_process.exec]).
The [main] function is the entry point for the forked process.
While [Updater.compile] is the 'forking' function to be called by
the [tezos-node] process.
*)
open Compiler
(* TODO: fail in the presence of "external" *)
module Backend = struct
(* See backend_intf.mli. *)
let symbol_for_global' = Compilenv.symbol_for_global'
let closure_symbol = Compilenv.closure_symbol
let really_import_approx = Import_approx.really_import_approx
let import_symbol = Import_approx.import_symbol
let size_int = Arch.size_int
let big_endian = Arch.big_endian
let max_sensible_number_of_arguments =
(* The "-1" is to allow for a potential closure environment parameter. *)
Proc.max_arguments_for_tailcalls - 1
end
let backend = (module Backend : Backend_intf.S)
(** Semi-generic compilation functions *)
let pack_objects output objects =
let output = output ^ ".cmx" in
Compmisc.init_path true ;
Asmpackager.package_files
~backend
Format.err_formatter
Env.initial_safe_string
objects
output ;
Warnings.check_fatal () ;
output
let link_shared output objects =
Compenv.(readenv Format.err_formatter Before_link) ;
Compmisc.init_path true ;
Asmlink.link_shared Format.err_formatter objects output ;
Warnings.check_fatal ()
let compile_ml ?for_pack ml =
let target = Filename.chop_extension ml in
Clflags.for_package := for_pack ;
Compenv.(readenv Format.err_formatter (Before_compile ml)) ;
Optcompile.implementation ~backend Format.err_formatter ml target ;
Clflags.for_package := None ;
target ^ ".cmx"
let () = Clflags.native_code := true
let driver = {compile_ml; link_shared; pack_objects}
src/lib_protocol_compiler/native.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Compiler.
Module Backend.
Definition symbol_for_global' : Ident.t -> Symbol.t :=
Compilenv.symbol_for_global'.
Definition closure_symbol : Closure_id.t -> Symbol.t :=
Compilenv.closure_symbol.
Definition really_import_approx
: Simple_value_approx.t -> Simple_value_approx.t :=
Import_approx.really_import_approx.
Definition import_symbol : Symbol.t -> Simple_value_approx.t :=
Import_approx.import_symbol.
Definition size_int : Z := Arch.size_int.
Definition big_endian : bool := Arch.big_endian.
Definition max_sensible_number_of_arguments : Z :=
Z.sub Proc.max_arguments_for_tailcalls 1.
End Backend.
Definition backend : {_ : unit & Backend_intf.S.signature } := Backend.
Definition pack_objects (output : string) (objects : list string) : string :=
let output := String.append output ".cmx" % string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Compmisc.init_path None true in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Asmpackager.package_files Format.err_formatter Env.initial_safe_string
objects output backend in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Warnings.check_fatal tt in
output.
Definition link_shared (output : string) (objects : list string) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := readenv Format.err_formatter Compenv.Before_link in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Compmisc.init_path None true in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Asmlink.link_shared Format.err_formatter objects output in
Warnings.check_fatal tt.
Definition compile_ml (for_pack : option string) (ml : Compenv.filename)
: string :=
let target := Filename.chop_extension ml in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq Clflags.for_package for_pack in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := readenv Format.err_formatter (Compenv.Before_compile ml) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Optcompile.implementation backend Format.err_formatter ml target in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq Clflags.for_package None in
String.append target ".cmx" % string.
Definition driver : Tezos_protocol_compiler.Compiler.driver :=
{| compile_ml := compile_ml; pack_objects := pack_objects;
link_shared := link_shared |}.
src/lib_protocol_compiler/packer.ml 19 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let dump_file oc file =
let ic = open_in file in
let buflen = 8096 in
let buf = Bytes.create buflen in
let rec loop () =
let len = input ic buf 0 buflen in
if len <> 0 then (
Printf.fprintf
oc
"%s"
( if len = buflen then Bytes.unsafe_to_string buf
else Bytes.sub_string buf 0 len ) ;
loop () )
in
loop () ; close_in ic
let include_ml oc file =
let unit =
String.capitalize_ascii (Filename.chop_extension (Filename.basename file))
in
(* FIXME insert .mli... *)
Printf.fprintf oc "module %s " unit ;
if Sys.file_exists (file ^ "i") then (
Printf.fprintf oc ": sig\n" ;
Printf.fprintf oc "# 1 %S\n" (file ^ "i") ;
dump_file oc (file ^ "i") ;
Printf.fprintf oc "end " ) ;
Printf.fprintf oc "= struct\n" ;
Printf.fprintf oc "# 1 %S\n" file ;
dump_file oc file ;
Printf.fprintf oc "end\n%!"
let opened_modules =
["Tezos_protocol_environment"; "Pervasives"; "Error_monad"; "Logging"]
let dump oc hash files =
Printf.fprintf
oc
"module Make (Tezos_protocol_environment : \
Tezos_protocol_environment_sigs__V1.T) = struct\n" ;
Printf.fprintf oc "[@@@ocaml.warning \"-33\"]\n" ;
List.iter (Printf.fprintf oc "open %s\n") opened_modules ;
Printf.fprintf oc "[@@@ocaml.warning \"+33\"]\n" ;
Printf.fprintf
oc
"let hash = Protocol_hash.of_b58check_exn %S;;\n"
(Protocol_hash.to_b58check hash) ;
for i = 0 to Array.length files - 1 do
include_ml oc files.(i)
done ;
Printf.fprintf
oc
" include %s\n"
(String.capitalize_ascii
(Filename.basename
(Filename.chop_extension files.(Array.length files - 1)))) ;
Printf.fprintf oc "end\n%!"
src/lib_protocol_compiler/packer.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition dump_file (oc : Stdlib.out_channel) (file : string) : unit :=
let ic := Stdlib.open_in file in
let buflen := 8096 in
let buf := Stdlib.Bytes.create buflen in
let fix loop (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let len := Stdlib.input ic buf 0 buflen in
if nequiv_decb len 0 then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
(if equiv_decb len buflen then
Stdlib.Bytes.unsafe_to_string buf
else
Stdlib.Bytes.sub_string buf 0 len) in
loop tt
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := loop tt in
Stdlib.close_in ic.
Definition include_ml (oc : Stdlib.out_channel) (file : string) : unit :=
let unit :=
String.capitalize_ascii (Filename.chop_extension (Filename.basename file))
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "module " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
CamlinternalFormatBasics.End_of_format))) "module %s " % string)
unit in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if Sys.file_exists (String.append file "i" % string) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal ": sig
" % string
CamlinternalFormatBasics.End_of_format) ": sig
" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "# 1 " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
CamlinternalFormatBasics.End_of_format))) "# 1 %S
" % string)
(String.append file "i" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := dump_file oc (String.append file "i" % string) in
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "end " % string
CamlinternalFormatBasics.End_of_format) "end " % string)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "= struct
" % string
CamlinternalFormatBasics.End_of_format) "= struct
" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "# 1 " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
CamlinternalFormatBasics.End_of_format))) "# 1 %S
" % string) file
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := dump_file oc file in
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "end
" % string
(CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format))
"end
%!" % string).
Definition opened_modules : list string :=
cons "Tezos_protocol_environment" % string
(cons "Pervasives" % string
(cons "Error_monad" % string (cons "Logging" % string []))).
Definition dump
(oc : Stdlib.out_channel) (hash : Tezos_base__TzPervasives.Protocol_hash.t)
(files : array string) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"module Make (Tezos_protocol_environment : Tezos_protocol_environment_sigs__V1.T) = struct
"
% string CamlinternalFormatBasics.End_of_format)
"module Make (Tezos_protocol_environment : Tezos_protocol_environment_sigs__V1.T) = struct
"
% string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Escaped_at
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Scan_indic "o" % char)
(CamlinternalFormatBasics.String_literal
"caml.warning ""-33""]
" % string
CamlinternalFormatBasics.End_of_format))))
"[@@@ocaml.warning ""-33""]
" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "open " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
CamlinternalFormatBasics.End_of_format))) "open %s
" % string))
opened_modules in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Escaped_at
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Scan_indic "o" % char)
(CamlinternalFormatBasics.String_literal
"caml.warning ""+33""]
" % string
CamlinternalFormatBasics.End_of_format))))
"[@@@ocaml.warning ""+33""]
" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"let hash = Protocol_hash.of_b58check_exn " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ";;
" % string
CamlinternalFormatBasics.End_of_format)))
"let hash = Protocol_hash.of_b58check_exn %S;;
" % string)
(Protocol_hash.to_b58check hash) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ For loops not handled. *)
for in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal " include " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
CamlinternalFormatBasics.End_of_format))) " include %s
" % string)
(String.capitalize_ascii
(Filename.basename
(Filename.chop_extension
(Array.get files (Z.sub (Array.length files) 1))))) in
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "end
" % string
(CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format))
"end
%!" % string).
src/lib_protocol_compiler/registerer.ml 7 errors
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) module type PROTOCOL_V1 = functor (Env : Tezos_protocol_environment_sigs.V1.T) -> Env.Updater.PROTOCOL module VersionTable = Protocol_hash.Table let versions : (module PROTOCOL_V1) VersionTable.t = VersionTable.create 20 let register hash proto = let hash = Protocol_hash.of_b58check_exn hash in VersionTable.add versions hash proto let mem hash = VersionTable.mem versions hash let get hash = try Some (VersionTable.find versions hash) with Not_found -> None
src/lib_protocol_compiler/registerer.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ This kind of signature is not handled. *)
unhandled_module_type
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition versions : VersionTable.t {_ : unit & PROTOCOL_V1.signature } :=
VersionTable.create 20.
Definition register
(hash : string) (proto : {_ : unit & PROTOCOL_V1.signature }) : unit :=
let hash := Protocol_hash.of_b58check_exn hash in
VersionTable.add versions hash proto.
Definition mem (hash : VersionTable.key) : bool :=
VersionTable.mem versions hash.
Definition get (hash : VersionTable.key)
: option {_ : unit & PROTOCOL_V1.signature } :=
(* ❌ Try-with are not handled *)
try (Some (VersionTable.find versions hash)).
src/lib_protocol_compiler/replace.ml 9 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module StringMap = Map.Make (String)
open Re
let regexp = Str.regexp "%%[^%]*%%"
let current_dir = Sys.getcwd ()
let guess_version () =
let prefix = "proto_" in
let rec loop dir =
let dirname = Filename.basename dir in
let x = String.length prefix in
let n = String.length dirname in
if n >= x && String.sub dirname 0 x = prefix then
String.sub dirname x (n - x)
else
let updir = Filename.dirname dir in
if updir = dir then (
Format.eprintf
"Cannot guess protocol version in path!@.Looking for `%s*` in `%s`@."
prefix
current_dir ;
exit 1 ) ;
loop updir
in
loop (Sys.getcwd ())
let warning_message =
{|
;
; /!\ /!\ Do not modify this file /!\ /!\
;
; but the original template in `tezos-protocol-compiler`
;
|}
let replace ~template ~destination vars =
let inch = open_in template in
let outch = open_out destination in
output_string outch warning_message ;
try
while true do
let line = input_line inch in
let line =
Str.global_substitute
regexp
(fun s ->
let matched = Str.matched_string s in
let var = String.sub matched 2 (String.length matched - 4) in
match StringMap.find_opt var vars with
| Some value ->
value
| None ->
prerr_endline ("Unknown variable: " ^ var) ;
exit 1)
line
in
output_string outch line ; output_string outch "\n"
done
with End_of_file -> flush outch ; close_out outch ; ()
let module_name (c : Protocol.component) = String.capitalize_ascii c.name
let sources_name (c : Protocol.component) =
let name = String.lowercase_ascii c.name in
match c.interface with
| None ->
Printf.sprintf "%s.ml" name
| Some _ ->
Printf.sprintf "%s.mli %s.ml" name name
let process ~template ~destination (protocol : Protocol.t) lib_version hash =
let version = String.concat "-" (String.split_on_char '_' lib_version) in
let vars =
StringMap.empty
|> StringMap.add "VERSION" version
|> StringMap.add "LIB_VERSION" lib_version
|> StringMap.add "HASH" (Protocol_hash.to_b58check hash)
|> StringMap.add
"MODULES"
(String.concat " " (List.map module_name protocol.components))
|> StringMap.add
"SOURCES"
(String.concat " " (List.map sources_name protocol.components))
in
replace ~template ~destination vars
let read_proto destination =
let source_dir =
if Filename.is_relative destination then
Filename.concat current_dir (Filename.dirname destination)
else Filename.dirname destination
in
match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir) with
| Ok (None, proto) ->
(Protocol.hash proto, proto)
| Ok (Some hash, proto) ->
(hash, proto)
| Error err ->
Format.kasprintf
Pervasives.failwith
"Failed to read TEZOS_PROTOCOL in %s:@ %a"
source_dir
pp_print_error
err
let main () =
let template = Sys.argv.(1) in
let destination = Sys.argv.(2) in
let version = try Sys.argv.(3) with _ -> guess_version () in
let (hash, proto) = read_proto destination in
process ~template ~destination proto version hash
let () = main ()
src/lib_protocol_compiler/replace.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
Import Re.
Definition regexp : Re.Str.regexp := Str.regexp "%%[^%]*%%" % string.
Definition current_dir : string := Sys.getcwd tt.
Definition guess_version (function_parameter : unit) : string :=
let 'tt := function_parameter in
let prefix := "proto_" % string in
let fix loop (dir : string) : string :=
let dirname := Filename.basename dir in
let x := String.length prefix in
let n := String.length dirname in
if andb (OCaml.Stdlib.ge n x) (equiv_decb (String.sub dirname 0 x) prefix)
then
String.sub dirname x (Z.sub n x)
else
let updir := Filename.dirname dir in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if equiv_decb updir dir then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot guess protocol version in path!" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
"Looking for `" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"*` in `" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "`" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))
"Cannot guess protocol version in path!@.Looking for `%s*` in `%s`@."
% string) prefix current_dir in
Stdlib.exit 1
else
tt in
loop updir in
loop (Sys.getcwd tt).
Definition warning_message : string :=
"
;
; /!\ /!\ Do not modify this file /!\ /!\
;
; but the original template in `tezos-protocol-compiler`
;
"
% string.
Definition replace
(template : string) (destination : string) (vars : StringMap.t string)
: unit :=
let inch := Stdlib.open_in template in
let outch := Stdlib.open_out destination in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.output_string outch warning_message in
(* ❌ Try-with are not handled *)
try
(* ❌ While loops not handled. *)
while.
Definition module_name (c : Tezos_base__TzPervasives.Protocol.component)
: string := String.capitalize_ascii (name c).
Definition sources_name (c : Tezos_base__TzPervasives.Protocol.component)
: string :=
let name := String.lowercase_ascii (name c) in
match interface c with
| None =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ".ml" % string
CamlinternalFormatBasics.End_of_format)) "%s.ml" % string) name
| Some _ =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ".mli " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ".ml" % string
CamlinternalFormatBasics.End_of_format))))
"%s.mli %s.ml" % string) name name
end.
Definition process
(template : string) (destination : string)
(protocol : Tezos_base__TzPervasives.Protocol.t) (lib_version : string)
(hash : Tezos_base__TzPervasives.Protocol_hash.t) : unit :=
let version :=
String.concat "-" % string (String.split_on_char "_" % char lib_version) in
let vars :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply StringMap.empty
(StringMap.add "VERSION" % string version))
(StringMap.add "LIB_VERSION" % string lib_version))
(StringMap.add "HASH" % string (Protocol_hash.to_b58check hash)))
(StringMap.add "MODULES" % string
(String.concat " " % string
(List.map module_name (components protocol)))))
(StringMap.add "SOURCES" % string
(String.concat " " % string
(List.map sources_name (components protocol)))) in
replace template destination vars.
Definition read_proto (destination : string)
: Tezos_crypto.Protocol_hash.t * Tezos_base.Protocol.t :=
let source_dir :=
if Filename.is_relative destination then
Filename.concat current_dir (Filename.dirname destination)
else
Filename.dirname destination in
match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir) with
| Stdlib.Ok (None, proto) => ((Protocol.hash proto), proto)
| Stdlib.Ok (Some hash, proto) => (hash, proto)
| Stdlib.Error err =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to read TEZOS_PROTOCOL in " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))))
"Failed to read TEZOS_PROTOCOL in %s:@ %a" % string) source_dir
pp_print_error err
end.
Definition main (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let template := Array.get Sys.argv 1 in
let destination := Array.get Sys.argv 2 in
let version :=
(* ❌ Try-with are not handled *)
try (Array.get Sys.argv 3) in
let '(hash, proto) := read_proto destination in
process template destination proto version hash.
src/lib_protocol_environment/dummy_context.ml 11 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module M = struct
type t = unit
type key = string list
type value = MBytes.t
let mem _ _ = assert false
let dir_mem _ _ = assert false
let get _ _ = assert false
let set _ _ _ = assert false
let copy _ ~from:_ ~to_:_ = assert false
let del _ _ = assert false
let remove_rec _ _ = assert false
let fold _ _ ~init:_ ~f:_ = assert false
let set_protocol _ _ = assert false
let fork_test_chain _ ~protocol:_ ~expiration:_ = assert false
end
open Tezos_protocol_environment
type _ Context.kind += Faked : unit Context.kind
let ops = (module M : CONTEXT with type t = 'ctxt)
let empty = Context.Context {ops; ctxt = (); kind = Faked}
src/lib_protocol_environment/dummy_context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module M.
Definition t := unit.
Definition key := list string.
Definition value := Tezos_base__TzPervasives.MBytes.t.
Definition mem {A B C : Type} (function_parameter : A) : B -> C :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
(* ❌ Assert instruction is not handled. *)
assert false.
Definition dir_mem {A B C : Type} (function_parameter : A) : B -> C :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
(* ❌ Assert instruction is not handled. *)
assert false.
Definition get {A B C : Type} (function_parameter : A) : B -> C :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
(* ❌ Assert instruction is not handled. *)
assert false.
Definition set {A B C D : Type} (function_parameter : A) : B -> C -> D :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
(* ❌ Assert instruction is not handled. *)
assert false.
Definition copy {A B C D : Type} (function_parameter : A) : B -> C -> D :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
(* ❌ Assert instruction is not handled. *)
assert false.
Definition del {A B C : Type} (function_parameter : A) : B -> C :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
(* ❌ Assert instruction is not handled. *)
assert false.
Definition remove_rec {A B C : Type} (function_parameter : A) : B -> C :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
(* ❌ Assert instruction is not handled. *)
assert false.
Definition fold {A B C D E : Type} (function_parameter : A)
: B -> C -> D -> E :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
(* ❌ Assert instruction is not handled. *)
assert false.
Definition set_protocol {A B C : Type} (function_parameter : A) : B -> C :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
(* ❌ Assert instruction is not handled. *)
assert false.
Definition fork_test_chain {A B C D : Type} (function_parameter : A)
: B -> C -> D :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
(* ❌ Assert instruction is not handled. *)
assert false.
End M.
Import Tezos_protocol_environment.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition ops
: {_ : unit &
Tezos_protocol_environment.CONTEXT.signature
M.(Tezos_protocol_environment.CONTEXT.t)} := M.
Definition empty : Tezos_protocol_environment.Context.t :=
Tezos_protocol_environment.Context.Context
{| kind := Tezos_protocol_environment.Context.Faked; ctxt := tt; ops := ops
|}.
src/lib_protocol_environment/memory_context.ml 7 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module M = struct
module StringMap = Map.Make (String)
type key = string list
type value = MBytes.t
type t = Dir of t StringMap.t | Key of value
let empty = Dir StringMap.empty
let rec raw_get m k =
match (k, m) with
| ([], m) ->
Some m
| (n :: k, Dir m) -> (
match StringMap.find_opt n m with
| Some res ->
raw_get res k
| None ->
None )
| (_ :: _, Key _) ->
None
let rec raw_set m k v =
match (k, m, v) with
| ([], (Key _ as m), Some v) ->
if m = v then None else Some v
| ([], (Dir _ as m), Some v) ->
if m == v then None else Some v
| ([], (Key _ | Dir _), None) ->
Some empty
| (n :: k, Dir m, _) -> (
match
raw_set (Option.unopt ~default:empty (StringMap.find_opt n m)) k v
with
| None ->
None
| Some rm when rm = empty ->
Some (Dir (StringMap.remove n m))
| Some rm ->
Some (Dir (StringMap.add n rm m)) )
| (_ :: _, Key _, None) ->
None
| (_ :: _, Key _, Some _) ->
Pervasives.failwith "Mem_context.set"
let mem m k =
match raw_get m k with
| Some (Key _) ->
Lwt.return_true
| Some (Dir _) | None ->
Lwt.return_false
let dir_mem m k =
match raw_get m k with
| Some (Dir _) ->
Lwt.return_true
| Some (Key _) | None ->
Lwt.return_false
let get m k =
match raw_get m k with
| Some (Key v) ->
Lwt.return_some v
| Some (Dir _) | None ->
Lwt.return_none
let set m k v =
match raw_set m k (Some (Key v)) with
| None ->
Lwt.return m
| Some m ->
Lwt.return m
let del m k =
(* TODO assert key *)
match raw_set m k None with None -> Lwt.return m | Some m -> Lwt.return m
let remove_rec m k =
match raw_set m k None with None -> Lwt.return m | Some m -> Lwt.return m
let copy m ~from ~to_ =
match raw_get m from with
| None ->
Lwt.return_none
| Some v ->
Lwt.return (raw_set m to_ (Some v))
let fold m k ~init ~f =
match raw_get m k with
| None ->
Lwt.return init
| Some (Key _) ->
Lwt.return init
| Some (Dir m) ->
StringMap.fold
(fun n m acc ->
acc
>>= fun acc ->
match m with
| Key _ ->
f (`Key (k @ [n])) acc
| Dir _ ->
f (`Dir (k @ [n])) acc)
m
(Lwt.return init)
let current_protocol_key = ["protocol"]
let set_protocol v key =
raw_set v current_protocol_key (Some (Key (Protocol_hash.to_bytes key)))
|> function Some m -> Lwt.return m | None -> assert false
let fork_test_chain c ~protocol:_ ~expiration:_ = Lwt.return c
end
open Tezos_protocol_environment
type t = M.t
type _ Context.kind += Memory : t Context.kind
let ops = (module M : CONTEXT with type t = 'ctxt)
let empty =
let ctxt = M.empty in
Context.Context {ops; ctxt; kind = Memory}
src/lib_protocol_environment/memory_context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module M.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition key := list string.
Definition value := Tezos_base__TzPervasives.MBytes.t.
Inductive t : Type :=
| Dir : (StringMap.(Stdlib__map.S.t) t) -> t
| Key : value -> t.
Definition empty : t := Dir StringMap.(Stdlib__map.S.empty).
Fixpoint raw_get (m : t) (k : list StringMap.(Stdlib__map.S.key))
: option t :=
match (k, m) with
| ([], m) => Some m
| (cons n k, Dir m) =>
match StringMap.(Stdlib__map.S.find_opt) n m with
| Some res => raw_get res k
| None => None
end
| (cons _ _, Key _) => None
end.
Fixpoint raw_set
(m : t) (k : list StringMap.(Stdlib__map.S.key)) (v : option t)
: option t :=
match (k, m, v) with
| ([], (Key _) as m, Some v) =>
if equiv_decb m v then
None
else
Some v
| ([], (Dir _) as m, Some v) =>
if Stdlib.op_eqeq m v then
None
else
Some v
| ([], Key _ | Dir _, None) => Some empty
| (cons n k, Dir m, _) =>
match
raw_set (Option.unopt empty (StringMap.(Stdlib__map.S.find_opt) n m)) k
v with
| None => None
| Some rm => Some (Dir (StringMap.(Stdlib__map.S.remove) n m))
| Some rm => Some (Dir (StringMap.(Stdlib__map.S.add) n rm m))
end
| (cons _ _, Key _, None) => None
| (cons _ _, Key _, Some _) =>
Pervasives.failwith "Mem_context.set" % string
end.
Definition mem (m : t) (k : list StringMap.(Stdlib__map.S.key))
: Lwt.t bool :=
match raw_get m k with
| Some (Key _) => Lwt.return_true
| Some (Dir _) | None => Lwt.return_false
end.
Definition dir_mem (m : t) (k : list StringMap.(Stdlib__map.S.key))
: Lwt.t bool :=
match raw_get m k with
| Some (Dir _) => Lwt.return_true
| Some (Key _) | None => Lwt.return_false
end.
Definition get (m : t) (k : list StringMap.(Stdlib__map.S.key))
: Lwt.t (option value) :=
match raw_get m k with
| Some (Key v) => Lwt.return_some v
| Some (Dir _) | None => Lwt.return_none
end.
Definition set (m : t) (k : list StringMap.(Stdlib__map.S.key)) (v : value)
: Lwt.t t :=
match raw_set m k (Some (Key v)) with
| None => Lwt._return m
| Some m => Lwt._return m
end.
Definition del (m : t) (k : list StringMap.(Stdlib__map.S.key)) : Lwt.t t :=
match raw_set m k None with
| None => Lwt._return m
| Some m => Lwt._return m
end.
Definition remove_rec (m : t) (k : list StringMap.(Stdlib__map.S.key))
: Lwt.t t :=
match raw_set m k None with
| None => Lwt._return m
| Some m => Lwt._return m
end.
Definition copy
(m : t) (from : list StringMap.(Stdlib__map.S.key))
(to_ : list StringMap.(Stdlib__map.S.key)) : Lwt.t (option t) :=
match raw_get m from with
| None => Lwt.return_none
| Some v => Lwt._return (raw_set m to_ (Some v))
end.
Definition fold {A : Type}
(m : t) (k : list StringMap.(Stdlib__map.S.key)) (init : A)
(f : variant -> A -> Lwt.t A) : Lwt.t A :=
match raw_get m k with
| None => Lwt._return init
| Some (Key _) => Lwt._return init
| Some (Dir m) =>
StringMap.(Stdlib__map.S.fold)
(fun n =>
fun m =>
fun acc =>
op_gtgteq acc
(fun acc =>
match m with
| Key _ =>
f
(* ❌ Variants not supported *)
variant acc
| Dir _ =>
f
(* ❌ Variants not supported *)
variant acc
end)) m (Lwt._return init)
end.
Definition current_protocol_key : list string := cons "protocol" % string [].
Definition set_protocol
(v : t) (key : Tezos_base__TzPervasives.Protocol_hash.t) : Lwt.t t :=
OCaml.Stdlib.reverse_apply
(raw_set v current_protocol_key (Some (Key (Protocol_hash.to_bytes key))))
(fun function_parameter =>
match function_parameter with
| Some m => Lwt._return m
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
end).
Definition fork_test_chain {A B C : Type} (c : A) (function_parameter : B)
: C -> Lwt.t A :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
Lwt._return c.
End M.
Import Tezos_protocol_environment.
Definition t := M.t.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition ops
: {_ : unit & Tezos_protocol_environment.CONTEXT.signature M.t} := M.
Definition empty : Tezos_protocol_environment.Context.t :=
let ctxt := M.empty in
Tezos_protocol_environment.Context.Context
{| kind := Tezos_protocol_environment.Context.Memory; ctxt := ctxt;
ops := ops |}.
src/lib_protocol_environment/shell_context.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Tezos_protocol_environment
open Context
let ( >>= ) = Lwt.( >>= )
type _ Context.kind += Shell : Tezos_storage.Context.t Context.kind
let ops = (module Tezos_storage.Context : CONTEXT with type t = 'ctxt)
let checkout index context_hash =
Tezos_storage.Context.checkout index context_hash
>>= function
| Some ctxt ->
Lwt.return_some (Context.Context {ops; ctxt; kind = Shell})
| None ->
Lwt.return_none
let checkout_exn index context_hash =
Tezos_storage.Context.checkout_exn index context_hash
>>= fun ctxt -> Lwt.return (Context.Context {ops; ctxt; kind = Shell})
let wrap_disk_context ctxt = Context.Context {ops; ctxt; kind = Shell}
let unwrap_disk_context : t -> Tezos_storage.Context.t = function
| Context.Context {ctxt; kind = Shell; _} ->
ctxt
| _ ->
assert false
src/lib_protocol_environment/shell_context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Tezos_protocol_environment.
Import Context.
Definition op_gtgteq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
Lwt.op_gtgteq.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition ops
: {_ : unit &
Tezos_protocol_environment.CONTEXT.signature Tezos_storage.Context.t} :=
Tezos_storage.Context.
Definition checkout
(index : Tezos_storage.Context.index)
(context_hash : Tezos_base__TzPervasives.Context_hash.t)
: Lwt.t (option Tezos_protocol_environment.Context.t) :=
op_gtgteq (Tezos_storage.Context.checkout index context_hash)
(fun function_parameter =>
match function_parameter with
| Some ctxt =>
Lwt.return_some
(Tezos_protocol_environment.Context.Context
{| kind := Tezos_protocol_environment.Context.Shell; ctxt := ctxt;
ops := ops |})
| None => Lwt.return_none
end).
Definition checkout_exn
(index : Tezos_storage.Context.index)
(context_hash : Tezos_base__TzPervasives.Context_hash.t)
: Lwt.t Tezos_protocol_environment.Context.t :=
op_gtgteq (Tezos_storage.Context.checkout_exn index context_hash)
(fun ctxt =>
Lwt._return
(Tezos_protocol_environment.Context.Context
{| kind := Tezos_protocol_environment.Context.Shell; ctxt := ctxt;
ops := ops |})).
Definition wrap_disk_context (ctxt : Tezos_storage.Context.t)
: Tezos_protocol_environment.Context.t :=
Tezos_protocol_environment.Context.Context
{| kind := Tezos_protocol_environment.Context.Shell; ctxt := ctxt;
ops := ops |}.
Definition unwrap_disk_context
(function_parameter : Tezos_protocol_environment.Context.t)
: Tezos_storage.Context.t :=
match function_parameter with
|
Tezos_protocol_environment.Context.Context {|
kind := Tezos_protocol_environment.Context.Shell; ctxt := ctxt |} =>
ctxt
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end.
src/lib_protocol_environment/sigs_packer/sigs_packer.ml 8 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let dump_file oc file =
let ic = open_in file in
let buflen = 8096 in
let buf = Bytes.create buflen in
let rec loop () =
let len = input ic buf 0 buflen in
if len <> 0 then (
Printf.fprintf
oc
"%s"
(Bytes.to_string (if len = buflen then buf else Bytes.sub buf 0 len)) ;
loop () )
in
loop () ; close_in ic
let opened_modules = ["Pervasives"; "Error_monad"]
let include_mli oc file =
let unit =
String.capitalize_ascii (Filename.chop_extension (Filename.basename file))
in
Printf.fprintf oc "module %s : sig\n" unit ;
Printf.fprintf oc "# 1 %S\n" file ;
dump_file oc file ;
Printf.fprintf oc "end\n" ;
if unit = "Result" then
Printf.fprintf
oc
"type ('a, 'b) result = ('a, 'b) Result.result = Ok of 'a | Error of 'b\n" ;
if List.mem unit opened_modules then Printf.fprintf oc "open %s\n" unit
let () =
Printf.fprintf stdout "module type T = sig\n" ;
for i = 1 to Array.length Sys.argv - 1 do
let file = Sys.argv.(i) in
include_mli stdout file
done ;
Printf.fprintf stdout "end\n%!"
src/lib_protocol_environment/sigs_packer/sigs_packer.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition dump_file (oc : Stdlib.out_channel) (file : string) : unit :=
let ic := Stdlib.open_in file in
let buflen := 8096 in
let buf := Stdlib.Bytes.create buflen in
let fix loop (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let len := Stdlib.input ic buf 0 buflen in
if nequiv_decb len 0 then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
(Stdlib.Bytes.to_string
(if equiv_decb len buflen then
buf
else
String.sub buf 0 len)) in
loop tt
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := loop tt in
Stdlib.close_in ic.
Definition opened_modules : list string :=
cons "Pervasives" % string (cons "Error_monad" % string []).
Definition include_mli (oc : Stdlib.out_channel) (file : string) : unit :=
let unit :=
Stdlib.String.capitalize_ascii
(Filename.chop_extension (Filename.basename file)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "module " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " : sig
" % string
CamlinternalFormatBasics.End_of_format)))
"module %s : sig
" % string) unit in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "# 1 " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
CamlinternalFormatBasics.End_of_format))) "# 1 %S
" % string) file
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := dump_file oc file in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "end
" % string
CamlinternalFormatBasics.End_of_format) "end
" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if equiv_decb unit "Result" % string then
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"type ('a, 'b) result = ('a, 'b) Result.result = Ok of 'a | Error of 'b
"
% string CamlinternalFormatBasics.End_of_format)
"type ('a, 'b) result = ('a, 'b) Result.result = Ok of 'a | Error of 'b
"
% string)
else
tt in
if Stdlib.List.mem unit opened_modules then
Printf.fprintf oc
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "open " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
CamlinternalFormatBasics.End_of_format))) "open %s
" % string)
unit
else
tt.
src/lib_protocol_environment/test/assert.ml success
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let fail expected given msg =
Format.kasprintf
Pervasives.failwith
"@[%s@ expected: %s@ got: %s@]"
msg
expected
given
let fail_msg fmt = Format.kasprintf (fail "" "") fmt
let default_printer _ = ""
let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
if not (eq x y) then fail (prn x) (prn y) msg
let equal_string_option ?msg o1 o2 =
let prn = function None -> "None" | Some s -> s in
equal ?msg ~prn o1 o2
let is_none ?(msg = "") x = if x <> None then fail "None" "Some _" msg
let make_equal_list eq prn ?(msg = "") x y =
let rec iter i x y =
match (x, y) with
| (hd_x :: tl_x, hd_y :: tl_y) ->
if eq hd_x hd_y then iter (succ i) tl_x tl_y
else
let fm = Printf.sprintf "%s (at index %d)" msg i in
fail (prn hd_x) (prn hd_y) fm
| (_ :: _, []) | ([], _ :: _) ->
let fm = Printf.sprintf "%s (lists of different sizes)" msg in
fail_msg "%s" fm
| ([], []) ->
()
in
iter 0 x y
let equal_string_list_list ?msg l1 l2 =
let pr_persist l =
let res =
String.concat ";" (List.map (fun s -> Printf.sprintf "%S" s) l)
in
Printf.sprintf "[%s]" res
in
make_equal_list ?msg ( = ) pr_persist l1 l2
src/lib_protocol_environment/test/assert.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition fail {A : Type} (expected : string) (given : string) (msg : string)
: A :=
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "expected: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "got: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[%s@ expected: %s@ got: %s@]" % string) msg expected given.
Definition fail_msg {A B : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
Format.kasprintf (fail "" % string "" % string) fmt.
Definition default_printer {A : Type} (function_parameter : A) : string :=
let '_ := function_parameter in
"" % string.
Definition equal {A : Type} (op_staroptstar : option (A -> A -> bool))
: (option (A -> string)) -> (option string) -> A -> A -> unit :=
let eq :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => equiv_decb
end in
fun op_staroptstar =>
let prn :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_printer
end in
fun op_staroptstar =>
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
fun y =>
if negb (eq x y) then
fail (prn x) (prn y) msg
else
tt.
Definition equal_string_option
(msg : option string) (o1 : option string) (o2 : option string) : unit :=
let prn (function_parameter : option string) : string :=
match function_parameter with
| None => "None" % string
| Some s => s
end in
equal None (Some prn) msg o1 o2.
Definition is_none {A : Type} (op_staroptstar : option string)
: (option A) -> unit :=
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
if nequiv_decb x None then
fail "None" % string "Some _" % string msg
else
tt.
Definition make_equal_list {A : Type}
(eq : A -> A -> bool) (prn : A -> string) (op_staroptstar : option string)
: (list A) -> (list A) -> unit :=
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
fun y =>
let fix iter (i : Z) (x : list A) (y : list A) : unit :=
match (x, y) with
| (cons hd_x tl_x, cons hd_y tl_y) =>
if eq hd_x hd_y then
iter (Z.succ i) tl_x tl_y
else
let fm :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (at index " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))
"%s (at index %d)" % string) msg i in
fail (prn hd_x) (prn hd_y) fm
| (cons _ _, []) | ([], cons _ _) =>
let fm :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (lists of different sizes)" % string
CamlinternalFormatBasics.End_of_format))
"%s (lists of different sizes)" % string) msg in
fail_msg
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) fm
| ([], []) => tt
end in
iter 0 x y.
Definition equal_string_list_list
(msg : option string) (l1 : list (list string)) (l2 : list (list string))
: unit :=
let pr_persist (l : list string) : string :=
let res :=
String.concat ";" % string
(List.map
(fun s =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%S" % string) s) l)
in
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "]" % char
CamlinternalFormatBasics.End_of_format))) "[%s]" % string) res in
make_equal_list equiv_decb pr_persist msg l1 l2.
src/lib_protocol_environment/test/test.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let () =
Alcotest.run "tezos-shell-context" [("mem_context", Test_mem_context.tests)]
src/lib_protocol_environment/test/test.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations.
src/lib_protocol_environment/test/test_mem_context.ml 104 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Context creation *)
let create_block2 ctxt =
Context.set ctxt ["a"; "b"] (MBytes.of_string "Novembre")
>>= fun ctxt ->
Context.set ctxt ["a"; "c"] (MBytes.of_string "Juin")
>>= fun ctxt ->
Context.set ctxt ["version"] (MBytes.of_string "0.0")
>>= fun ctxt -> Lwt.return ctxt
let create_block3a ctxt =
Context.del ctxt ["a"; "b"]
>>= fun ctxt ->
Context.set ctxt ["a"; "d"] (MBytes.of_string "Mars")
>>= fun ctxt -> Lwt.return ctxt
let create_block3b ctxt =
Context.del ctxt ["a"; "c"]
>>= fun ctxt ->
Context.set ctxt ["a"; "d"] (MBytes.of_string "Février")
>>= fun ctxt -> Lwt.return ctxt
type t = {
genesis : Context.t;
block2 : Context.t;
block3a : Context.t;
block3b : Context.t;
}
let wrap_context_init f _ () =
let genesis = Memory_context.empty in
create_block2 genesis
>>= fun block2 ->
create_block3a block2
>>= fun block3a ->
create_block3b block2
>>= fun block3b ->
f {genesis; block2; block3a; block3b} >>= fun result -> Lwt.return result
(** Simple test *)
let c = function None -> None | Some s -> Some (MBytes.to_string s)
let test_simple {block2 = ctxt; _} =
Context.get ctxt ["version"]
>>= fun version ->
Assert.equal_string_option ~msg:__LOC__ (c version) (Some "0.0") ;
Context.get ctxt ["a"; "b"]
>>= fun novembre ->
Assert.equal_string_option (Some "Novembre") (c novembre) ;
Context.get ctxt ["a"; "c"]
>>= fun juin ->
Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
Lwt.return_unit
let test_continuation {block3a = ctxt; _} =
Context.get ctxt ["version"]
>>= fun version ->
Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ;
Context.get ctxt ["a"; "b"]
>>= fun novembre ->
Assert.is_none ~msg:__LOC__ (c novembre) ;
Context.get ctxt ["a"; "c"]
>>= fun juin ->
Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
Context.get ctxt ["a"; "d"]
>>= fun mars ->
Assert.equal_string_option ~msg:__LOC__ (Some "Mars") (c mars) ;
Lwt.return_unit
let test_fork {block3b = ctxt; _} =
Context.get ctxt ["version"]
>>= fun version ->
Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ;
Context.get ctxt ["a"; "b"]
>>= fun novembre ->
Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
Context.get ctxt ["a"; "c"]
>>= fun juin ->
Assert.is_none ~msg:__LOC__ (c juin) ;
Context.get ctxt ["a"; "d"]
>>= fun mars ->
Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ;
Lwt.return_unit
let test_replay {genesis = ctxt0; _} =
Context.set ctxt0 ["version"] (MBytes.of_string "0.0")
>>= fun ctxt1 ->
Context.set ctxt1 ["a"; "b"] (MBytes.of_string "Novembre")
>>= fun ctxt2 ->
Context.set ctxt2 ["a"; "c"] (MBytes.of_string "Juin")
>>= fun ctxt3 ->
Context.set ctxt3 ["a"; "d"] (MBytes.of_string "July")
>>= fun ctxt4a ->
Context.set ctxt3 ["a"; "d"] (MBytes.of_string "Juillet")
>>= fun ctxt4b ->
Context.set ctxt4a ["a"; "b"] (MBytes.of_string "November")
>>= fun ctxt5a ->
Context.get ctxt4a ["a"; "b"]
>>= fun novembre ->
Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
Context.get ctxt5a ["a"; "b"]
>>= fun november ->
Assert.equal_string_option ~msg:__LOC__ (Some "November") (c november) ;
Context.get ctxt5a ["a"; "d"]
>>= fun july ->
Assert.equal_string_option ~msg:__LOC__ (Some "July") (c july) ;
Context.get ctxt4b ["a"; "b"]
>>= fun novembre ->
Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
Context.get ctxt4b ["a"; "d"]
>>= fun juillet ->
Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ;
Lwt.return_unit
let fold_keys s k ~init ~f =
let rec loop k acc =
Context.fold s k ~init:acc ~f:(fun file acc ->
match file with `Key k -> f k acc | `Dir k -> loop k acc)
in
loop k init
let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
let test_fold {genesis = ctxt; _} =
Context.set ctxt ["a"; "b"] (MBytes.of_string "Novembre")
>>= fun ctxt ->
Context.set ctxt ["a"; "c"] (MBytes.of_string "Juin")
>>= fun ctxt ->
Context.set ctxt ["a"; "d"; "e"] (MBytes.of_string "Septembre")
>>= fun ctxt ->
Context.set ctxt ["f"] (MBytes.of_string "Avril")
>>= fun ctxt ->
Context.set ctxt ["g"; "h"] (MBytes.of_string "Avril")
>>= fun ctxt ->
keys ctxt []
>>= fun l ->
Assert.equal_string_list_list
~msg:__LOC__
[["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]; ["f"]; ["g"; "h"]]
(List.sort compare l) ;
keys ctxt ["a"]
>>= fun l ->
Assert.equal_string_list_list
~msg:__LOC__
[["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]]
(List.sort compare l) ;
keys ctxt ["f"]
>>= fun l ->
Assert.equal_string_list_list ~msg:__LOC__ [] l ;
keys ctxt ["g"]
>>= fun l ->
Assert.equal_string_list_list ~msg:__LOC__ [["g"; "h"]] l ;
keys ctxt ["i"]
>>= fun l ->
Assert.equal_string_list_list ~msg:__LOC__ [] l ;
Lwt.return_unit
(******************************************************************************)
let tests =
[ ("simple", test_simple);
("continuation", test_continuation);
("fork", test_fork);
("replay", test_replay);
("fold", test_fold) ]
let tests =
List.map
(fun (n, f) -> Alcotest_lwt.test_case n `Quick (wrap_context_init f))
tests
src/lib_protocol_environment/test/test_mem_context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition create_block2 {A B : Type} (ctxt : A) : Lwt.t B :=
op_gtgteq
(op_startypeminuserrorstar ctxt (cons "a" % string (cons "b" % string []))
(MBytes.of_string "Novembre" % string))
(fun ctxt =>
op_gtgteq
(op_startypeminuserrorstar ctxt
(cons "a" % string (cons "c" % string []))
(MBytes.of_string "Juin" % string))
(fun ctxt =>
op_gtgteq
(op_startypeminuserrorstar ctxt (cons "version" % string [])
(MBytes.of_string "0.0" % string)) (fun ctxt => Lwt._return ctxt))).
Definition create_block3a {A B : Type} (ctxt : A) : Lwt.t B :=
op_gtgteq
(op_startypeminuserrorstar ctxt (cons "a" % string (cons "b" % string [])))
(fun ctxt =>
op_gtgteq
(op_startypeminuserrorstar ctxt
(cons "a" % string (cons "d" % string []))
(MBytes.of_string "Mars" % string)) (fun ctxt => Lwt._return ctxt)).
Definition create_block3b {A B : Type} (ctxt : A) : Lwt.t B :=
op_gtgteq
(op_startypeminuserrorstar ctxt (cons "a" % string (cons "c" % string [])))
(fun ctxt =>
op_gtgteq
(op_startypeminuserrorstar ctxt
(cons "a" % string (cons "d" % string []))
(MBytes.of_string "Février" % string)) (fun ctxt => Lwt._return ctxt)).
Definition wrap_context_init {A B C : Type}
(f : A -> Lwt.t B) (function_parameter : C) : unit -> Lwt.t B :=
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
let genesis := Memory_context.empty in
op_gtgteq (create_block2 genesis)
(fun block2 =>
op_gtgteq (create_block3a block2)
(fun block3a =>
op_gtgteq (create_block3b block2)
(fun block3b =>
op_gtgteq (f op_startypeminuserrorstar)
(fun result => Lwt._return result)))).
Definition c (function_parameter : option Tezos_base__TzPervasives.MBytes.t)
: option string :=
match function_parameter with
| None => None
| Some s => Some (MBytes.to_string s)
end.
Definition test_simple {A : Type} (function_parameter : A) : Lwt.t unit :=
let '_ := function_parameter in
op_gtgteq
(op_startypeminuserrorstar op_startypeminuserrorstar
(cons "version" % string []))
(fun version =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ (c version)
(Some "0.0" % string) in
op_gtgteq
(op_startypeminuserrorstar op_startypeminuserrorstar
(cons "a" % string (cons "b" % string [])))
(fun novembre =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar (Some "Novembre" % string) (c novembre) in
op_gtgteq
(op_startypeminuserrorstar op_startypeminuserrorstar
(cons "a" % string (cons "c" % string [])))
(fun juin =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ (Some "Juin" % string)
(c juin) in
Lwt.return_unit))).
Definition test_continuation {A : Type} (function_parameter : A) : Lwt.t unit :=
let '_ := function_parameter in
op_gtgteq
(op_startypeminuserrorstar op_startypeminuserrorstar
(cons "version" % string []))
(fun version =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ (Some "0.0" % string)
(c version) in
op_gtgteq
(op_startypeminuserrorstar op_startypeminuserrorstar
(cons "a" % string (cons "b" % string [])))
(fun novembre =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ (c novembre) in
op_gtgteq
(op_startypeminuserrorstar op_startypeminuserrorstar
(cons "a" % string (cons "c" % string [])))
(fun juin =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ (Some "Juin" % string)
(c juin) in
op_gtgteq
(op_startypeminuserrorstar op_startypeminuserrorstar
(cons "a" % string (cons "d" % string [])))
(fun mars =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(Some "Mars" % string) (c mars) in
Lwt.return_unit)))).
Definition test_fork {A : Type} (function_parameter : A) : Lwt.t unit :=
let '_ := function_parameter in
op_gtgteq
(op_startypeminuserrorstar op_startypeminuserrorstar
(cons "version" % string []))
(fun version =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ (Some "0.0" % string)
(c version) in
op_gtgteq
(op_startypeminuserrorstar op_startypeminuserrorstar
(cons "a" % string (cons "b" % string [])))
(fun novembre =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ (Some "Novembre" % string)
(c novembre) in
op_gtgteq
(op_startypeminuserrorstar op_startypeminuserrorstar
(cons "a" % string (cons "c" % string [])))
(fun juin =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ (c juin) in
op_gtgteq
(op_startypeminuserrorstar op_startypeminuserrorstar
(cons "a" % string (cons "d" % string [])))
(fun mars =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(Some "Février" % string) (c mars) in
Lwt.return_unit)))).
Definition test_replay {A : Type} (function_parameter : A) : Lwt.t unit :=
let '_ := function_parameter in
op_gtgteq
(op_startypeminuserrorstar op_startypeminuserrorstar
(cons "version" % string []) (MBytes.of_string "0.0" % string))
(fun ctxt1 =>
op_gtgteq
(op_startypeminuserrorstar ctxt1
(cons "a" % string (cons "b" % string []))
(MBytes.of_string "Novembre" % string))
(fun ctxt2 =>
op_gtgteq
(op_startypeminuserrorstar ctxt2
(cons "a" % string (cons "c" % string []))
(MBytes.of_string "Juin" % string))
(fun ctxt3 =>
op_gtgteq
(op_startypeminuserrorstar ctxt3
(cons "a" % string (cons "d" % string []))
(MBytes.of_string "July" % string))
(fun ctxt4a =>
op_gtgteq
(op_startypeminuserrorstar ctxt3
(cons "a" % string (cons "d" % string []))
(MBytes.of_string "Juillet" % string))
(fun ctxt4b =>
op_gtgteq
(op_startypeminuserrorstar ctxt4a
(cons "a" % string (cons "b" % string []))
(MBytes.of_string "November" % string))
(fun ctxt5a =>
op_gtgteq
(op_startypeminuserrorstar ctxt4a
(cons "a" % string (cons "b" % string [])))
(fun novembre =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(Some "Novembre" % string) (c novembre) in
op_gtgteq
(op_startypeminuserrorstar ctxt5a
(cons "a" % string (cons "b" % string [])))
(fun november =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(Some "November" % string) (c november) in
op_gtgteq
(op_startypeminuserrorstar ctxt5a
(cons "a" % string (cons "d" % string [])))
(fun july =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(Some "July" % string) (c july) in
op_gtgteq
(op_startypeminuserrorstar ctxt4b
(cons "a" % string
(cons "b" % string [])))
(fun novembre =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(Some "Novembre" % string)
(c novembre) in
op_gtgteq
(op_startypeminuserrorstar ctxt4b
(cons "a" % string
(cons "d" % string [])))
(fun juillet =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(Some "Juillet" % string)
(c juillet) in
Lwt.return_unit))))))))))).
Definition fold_keys {A B C D E : Type}
(s : A) (k : B) (init : C) (f : D -> C -> E) : E :=
let fix loop {F : Type} (k : F) (acc : C) : E :=
op_startypeminuserrorstar s k acc
(fun file =>
fun acc =>
match file with
| Key k => f k acc
| Dir k => loop k acc
end) in
loop k init.
Definition keys {A B C : Type} (t : A) : B -> Lwt.t (list C) :=
fold_keys t
(* ❌ expected an argument *)
expected_argument [] (fun k => fun acc => Lwt._return (cons k acc)).
Definition test_fold {A : Type} (function_parameter : A) : Lwt.t unit :=
let '_ := function_parameter in
op_gtgteq
(op_startypeminuserrorstar op_startypeminuserrorstar
(cons "a" % string (cons "b" % string []))
(MBytes.of_string "Novembre" % string))
(fun ctxt =>
op_gtgteq
(op_startypeminuserrorstar ctxt
(cons "a" % string (cons "c" % string []))
(MBytes.of_string "Juin" % string))
(fun ctxt =>
op_gtgteq
(op_startypeminuserrorstar ctxt
(cons "a" % string (cons "d" % string (cons "e" % string [])))
(MBytes.of_string "Septembre" % string))
(fun ctxt =>
op_gtgteq
(op_startypeminuserrorstar ctxt (cons "f" % string [])
(MBytes.of_string "Avril" % string))
(fun ctxt =>
op_gtgteq
(op_startypeminuserrorstar ctxt
(cons "g" % string (cons "h" % string []))
(MBytes.of_string "Avril" % string))
(fun ctxt =>
op_gtgteq (keys ctxt [])
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(cons (cons "a" % string (cons "b" % string []))
(cons (cons "a" % string (cons "c" % string []))
(cons
(cons "a" % string
(cons "d" % string (cons "e" % string [])))
(cons (cons "f" % string [])
(cons
(cons "g" % string
(cons "h" % string [])) [])))))
(List.sort OCaml.Stdlib.compare l) in
op_gtgteq (keys ctxt (cons "a" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(cons
(cons "a" % string (cons "b" % string []))
(cons
(cons "a" % string (cons "c" % string []))
(cons
(cons "a" % string
(cons "d" % string
(cons "e" % string []))) [])))
(List.sort OCaml.Stdlib.compare l) in
op_gtgteq (keys ctxt (cons "f" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ []
l in
op_gtgteq (keys ctxt (cons "g" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(cons
(cons "g" % string
(cons "h" % string [])) []) l in
op_gtgteq
(keys ctxt (cons "i" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__ [] l in
Lwt.return_unit)))))))))).
Definition tests {A : Type} : list (string * (A -> Lwt.t unit)) :=
cons ("simple" % string, test_simple)
(cons ("continuation" % string, test_continuation)
(cons ("fork" % string, test_fork)
(cons ("replay" % string, test_replay)
(cons ("fold" % string, test_fold) [])))).
Definition tests {A : Type} : list A :=
List.map
(fun function_parameter =>
let '(n, f) := function_parameter in
op_startypeminuserrorstar n
(* ❌ Variants not supported *)
variant (wrap_context_init f)) tests.
src/lib_protocol_environment/tezos_protocol_environment.ml 80 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
module type CONTEXT = sig
type t
type key = string list
type value = MBytes.t
val mem : t -> key -> bool Lwt.t
val dir_mem : t -> key -> bool Lwt.t
val get : t -> key -> value option Lwt.t
val set : t -> key -> value -> t Lwt.t
val copy : t -> from:key -> to_:key -> t option Lwt.t
val del : t -> key -> t Lwt.t
val remove_rec : t -> key -> t Lwt.t
val fold :
t ->
key ->
init:'a ->
f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
'a Lwt.t
val set_protocol : t -> Protocol_hash.t -> t Lwt.t
val fork_test_chain :
t -> protocol:Protocol_hash.t -> expiration:Time.Protocol.t -> t Lwt.t
end
module Context = struct
type key = string list
type value = MBytes.t
type 'ctxt ops = (module CONTEXT with type t = 'ctxt)
type _ kind = ..
type t = Context : {kind : 'a kind; ctxt : 'a; ops : 'a ops} -> t
let mem (Context {ops = (module Ops); ctxt; _}) key = Ops.mem ctxt key
let set (Context {ops = (module Ops) as ops; ctxt; kind}) key value =
Ops.set ctxt key value
>>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})
let dir_mem (Context {ops = (module Ops); ctxt; _}) key =
Ops.dir_mem ctxt key
let get (Context {ops = (module Ops); ctxt; _}) key = Ops.get ctxt key
let copy (Context {ops = (module Ops) as ops; ctxt; kind}) ~from ~to_ =
Ops.copy ctxt ~from ~to_
>>= function
| Some ctxt ->
Lwt.return_some (Context {ops; ctxt; kind})
| None ->
Lwt.return_none
let del (Context {ops = (module Ops) as ops; ctxt; kind}) key =
Ops.del ctxt key >>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})
let remove_rec (Context {ops = (module Ops) as ops; ctxt; kind}) key =
Ops.remove_rec ctxt key
>>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})
let fold (Context {ops = (module Ops); ctxt; _}) key ~init ~f =
Ops.fold ctxt key ~init ~f
let set_protocol (Context {ops = (module Ops) as ops; ctxt; kind})
protocol_hash =
Ops.set_protocol ctxt protocol_hash
>>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})
let fork_test_chain (Context {ops = (module Ops) as ops; ctxt; kind})
~protocol ~expiration =
Ops.fork_test_chain ctxt ~protocol ~expiration
>>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})
end
type validation_result = {
context : Context.t;
fitness : Fitness.t;
message : string option;
max_operations_ttl : int;
last_allowed_fork_level : Int32.t;
}
type quota = {max_size : int; max_op : int option}
type rpc_context = {
block_hash : Block_hash.t;
block_header : Block_header.shell_header;
context : Context.t;
}
module type T = sig
type context
type quota
type validation_result
type rpc_context
type 'a tzresult
val max_block_length : int
val max_operation_data_length : int
val validation_passes : quota list
type block_header_data
val block_header_data_encoding : block_header_data Data_encoding.t
type block_header = {
shell : Block_header.shell_header;
protocol_data : block_header_data;
}
type block_header_metadata
val block_header_metadata_encoding : block_header_metadata Data_encoding.t
type operation_data
type operation_receipt
type operation = {
shell : Operation.shell_header;
protocol_data : operation_data;
}
val operation_data_encoding : operation_data Data_encoding.t
val operation_receipt_encoding : operation_receipt Data_encoding.t
val operation_data_and_receipt_encoding :
(operation_data * operation_receipt) Data_encoding.t
val acceptable_passes : operation -> int list
val compare_operations : operation -> operation -> int
type validation_state
val current_context : validation_state -> context tzresult Lwt.t
val begin_partial_application :
chain_id:Chain_id.t ->
ancestor_context:context ->
predecessor_timestamp:Time.Protocol.t ->
predecessor_fitness:Fitness.t ->
block_header ->
validation_state tzresult Lwt.t
val begin_application :
chain_id:Chain_id.t ->
predecessor_context:context ->
predecessor_timestamp:Time.Protocol.t ->
predecessor_fitness:Fitness.t ->
block_header ->
validation_state tzresult Lwt.t
val begin_construction :
chain_id:Chain_id.t ->
predecessor_context:context ->
predecessor_timestamp:Time.Protocol.t ->
predecessor_level:Int32.t ->
predecessor_fitness:Fitness.t ->
predecessor:Block_hash.t ->
timestamp:Time.Protocol.t ->
?protocol_data:block_header_data ->
unit ->
validation_state tzresult Lwt.t
val apply_operation :
validation_state ->
operation ->
(validation_state * operation_receipt) tzresult Lwt.t
val finalize_block :
validation_state ->
(validation_result * block_header_metadata) tzresult Lwt.t
val rpc_services : rpc_context RPC_directory.t
val init :
context -> Block_header.shell_header -> validation_result tzresult Lwt.t
end
module type PROTOCOL =
T
with type context := Context.t
and type quota := quota
and type validation_result := validation_result
and type rpc_context := rpc_context
and type 'a tzresult := 'a Error_monad.tzresult
module type V1 = sig
include
Tezos_protocol_environment_sigs.V1.T
with type Format.formatter = Format.formatter
and type 'a Data_encoding.t = 'a Data_encoding.t
and type 'a Data_encoding.lazy_t = 'a Data_encoding.lazy_t
and type 'a Lwt.t = 'a Lwt.t
and type ('a, 'b) Pervasives.result = ('a, 'b) result
and type Chain_id.t = Chain_id.t
and type Block_hash.t = Block_hash.t
and type Operation_hash.t = Operation_hash.t
and type Operation_list_hash.t = Operation_list_hash.t
and type Operation_list_list_hash.t = Operation_list_list_hash.t
and type Context.t = Context.t
and type Context_hash.t = Context_hash.t
and type Protocol_hash.t = Protocol_hash.t
and type Time.t = Time.Protocol.t
and type MBytes.t = MBytes.t
and type Operation.shell_header = Operation.shell_header
and type Operation.t = Operation.t
and type Block_header.shell_header = Block_header.shell_header
and type Block_header.t = Block_header.t
and type 'a RPC_directory.t = 'a RPC_directory.t
and type Ed25519.Public_key_hash.t = Ed25519.Public_key_hash.t
and type Ed25519.Public_key.t = Ed25519.Public_key.t
and type Ed25519.t = Ed25519.t
and type Secp256k1.Public_key_hash.t = Secp256k1.Public_key_hash.t
and type Secp256k1.Public_key.t = Secp256k1.Public_key.t
and type Secp256k1.t = Secp256k1.t
and type P256.Public_key_hash.t = P256.Public_key_hash.t
and type P256.Public_key.t = P256.Public_key.t
and type P256.t = P256.t
and type Signature.public_key_hash = Signature.public_key_hash
and type Signature.public_key = Signature.public_key
and type Signature.t = Signature.t
and type Signature.watermark = Signature.watermark
and type 'a Micheline.canonical = 'a Micheline.canonical
and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t
and type Z.t = Z.t
and type ('a, 'b) Micheline.node = ('a, 'b) Micheline.node
and type Data_encoding.json_schema = Data_encoding.json_schema
and type RPC_service.meth = RPC_service.meth
and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t =
('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t
and type Error_monad.shell_error = Error_monad.error
and type Z.t = Z.t
type error += Ecoproto_error of Error_monad.error
val wrap_error : 'a Error_monad.tzresult -> 'a tzresult
module Lift (P : Updater.PROTOCOL) :
PROTOCOL
with type block_header_data = P.block_header_data
and type block_header = P.block_header
and type operation_data = P.operation_data
and type operation_receipt = P.operation_receipt
and type operation = P.operation
and type validation_state = P.validation_state
class ['chain, 'block] proto_rpc_context :
Tezos_rpc.RPC_context.t
-> (unit, (unit * 'chain) * 'block) RPC_path.t
-> ['chain * 'block] RPC_context.simple
class ['block] proto_rpc_context_of_directory :
('block -> RPC_context.t)
-> RPC_context.t RPC_directory.t
-> ['block] RPC_context.simple
end
module MakeV1 (Param : sig
val name : string
end)
() =
struct
include Pervasives
module Pervasives = Pervasives
module Compare = Compare
module Array = Array
module List = List
module Bytes = struct
include Bytes
include EndianBytes.BigEndian
module LE = EndianBytes.LittleEndian
end
module String = struct
include String
include EndianString.BigEndian
module LE = EndianString.LittleEndian
end
module Set = Set
module Map = Map
module Int32 = Int32
module Int64 = Int64
module Nativeint = Nativeint
module Buffer = Buffer
module Format = Format
module Option = Option
module MBytes = MBytes
module Raw_hashes = struct
let conv f x = Bigstring.to_bytes (f (Bigstring.of_bytes x))
let sha256 msg = conv Hacl.Hash.SHA256.digest msg
let sha512 msg = conv Hacl.Hash.SHA512.digest msg
let blake2b msg = Blake2B.to_bytes (Blake2B.hash_bytes [msg])
end
module Z = struct
include Z
let to_bits ?(pad_to = 0) z =
let bits = to_bits z in
let len = Pervasives.((numbits z + 7) / 8) in
let full_len = Tezos_stdlib.Compare.Int.max pad_to len in
if full_len = 0 then MBytes.create 0
else
let res = MBytes.create full_len in
Bytes.fill res 0 full_len '\000' ;
MBytes.blit_of_string bits 0 res 0 len ;
res
let of_bits bytes = of_bits (MBytes.to_string bytes)
end
module Lwt_sequence = Lwt_sequence
module Lwt = Lwt
module Lwt_list = Lwt_list
module Uri = Uri
module Data_encoding = Data_encoding
module Time = Time.Protocol
module Ed25519 = Ed25519
module Secp256k1 = Secp256k1
module P256 = P256
module Signature = Signature
module S = struct
module type T = Tezos_base.S.T
module type HASHABLE = Tezos_base.S.HASHABLE
module type MINIMAL_HASH = S.MINIMAL_HASH
module type B58_DATA = sig
type t
val to_b58check : t -> string
val to_short_b58check : t -> string
val of_b58check_exn : string -> t
val of_b58check_opt : string -> t option
type Base58.data += Data of t
val b58check_encoding : t Base58.encoding
end
module type RAW_DATA = sig
type t
val size : int (* in bytes *)
val to_bytes : t -> MBytes.t
val of_bytes_opt : MBytes.t -> t option
val of_bytes_exn : MBytes.t -> t
end
module type ENCODER = sig
type t
val encoding : t Data_encoding.t
val rpc_arg : t RPC_arg.t
end
module type SET = Tezos_base.S.SET
module type MAP = Tezos_base.S.MAP
module type INDEXES = sig
type t
val to_path : t -> string list -> string list
val of_path : string list -> t option
val of_path_exn : string list -> t
val prefix_path : string -> string list
val path_length : int
module Set : sig
include Set.S with type elt = t
val encoding : t Data_encoding.t
end
module Map : sig
include Map.S with type key = t
val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
end
end
module type HASH = sig
include MINIMAL_HASH
include RAW_DATA with type t := t
include B58_DATA with type t := t
include ENCODER with type t := t
include INDEXES with type t := t
end
module type MERKLE_TREE = sig
type elt
include HASH
val compute : elt list -> t
val empty : t
type path = Left of path * t | Right of t * path | Op
val compute_path : elt list -> int -> path
val check_path : path -> elt -> t * int
val path_encoding : path Data_encoding.t
end
module type SIGNATURE = sig
module Public_key_hash : sig
type t
val pp : Format.formatter -> t -> unit
val pp_short : Format.formatter -> t -> unit
include Compare.S with type t := t
include RAW_DATA with type t := t
include B58_DATA with type t := t
include ENCODER with type t := t
include INDEXES with type t := t
val zero : t
end
module Public_key : sig
type t
val pp : Format.formatter -> t -> unit
include Compare.S with type t := t
include B58_DATA with type t := t
include ENCODER with type t := t
val hash : t -> Public_key_hash.t
end
type t
val pp : Format.formatter -> t -> unit
include RAW_DATA with type t := t
include Compare.S with type t := t
include B58_DATA with type t := t
include ENCODER with type t := t
val zero : t
type watermark
(** Check a signature *)
val check : ?watermark:watermark -> Public_key.t -> t -> MBytes.t -> bool
end
end
module Error_core = struct
include Tezos_error_monad.Core_maker.Make (struct
let id = Format.asprintf "proto.%s." Param.name
end)
end
type error += Ecoproto_error of Error_core.error
module Wrapped_error_monad = struct
type unwrapped = Error_core.error = ..
include (
Error_core :
sig
include Tezos_error_monad.Sig.CORE with type error := unwrapped
include Tezos_error_monad.Sig.EXT with type error := unwrapped
end )
let unwrap = function
| Ecoproto_error ecoerror ->
Some ecoerror
| _ ->
None
let wrap ecoerror = Ecoproto_error ecoerror
end
module Error_monad = struct
type 'a shell_tzresult = 'a Error_monad.tzresult
type shell_error = Error_monad.error = ..
type error_category = [`Branch | `Temporary | `Permanent]
include Error_core
include Tezos_error_monad.Monad_maker.Make (Error_core)
end
let () =
let id = Format.asprintf "proto.%s.wrapper" Param.name in
register_wrapped_error_kind
(module Wrapped_error_monad)
~id
~title:("Error returned by protocol " ^ Param.name)
~description:("Wrapped error for economic protocol " ^ Param.name ^ ".")
let wrap_error = function
| Ok _ as ok ->
ok
| Error errors ->
Error (List.map (fun error -> Ecoproto_error error) errors)
module Chain_id = Chain_id
module Block_hash = Block_hash
module Operation_hash = Operation_hash
module Operation_list_hash = Operation_list_hash
module Operation_list_list_hash = Operation_list_list_hash
module Context_hash = Context_hash
module Protocol_hash = Protocol_hash
module Blake2B = Blake2B
module Fitness = Fitness
module Operation = Operation
module Block_header = Block_header
module Protocol = Protocol
module RPC_arg = RPC_arg
module RPC_path = RPC_path
module RPC_query = RPC_query
module RPC_service = RPC_service
module RPC_answer = struct
type 'o t =
[ `Ok of 'o (* 200 *)
| `OkStream of 'o stream (* 200 *)
| `Created of string option (* 201 *)
| `No_content (* 204 *)
| `Unauthorized of Error_monad.error list option (* 401 *)
| `Forbidden of Error_monad.error list option (* 403 *)
| `Not_found of Error_monad.error list option (* 404 *)
| `Conflict of Error_monad.error list option (* 409 *)
| `Error of Error_monad.error list option (* 500 *) ]
and 'a stream = 'a Resto_directory.Answer.stream = {
next : unit -> 'a option Lwt.t;
shutdown : unit -> unit;
}
let return x = Lwt.return (`Ok x)
let return_stream x = Lwt.return (`OkStream x)
let not_found = Lwt.return (`Not_found None)
let fail err = Lwt.return (`Error (Some err))
end
module RPC_directory = struct
include RPC_directory
let gen_register dir service handler =
gen_register dir service (fun p q i ->
handler p q i
>>= function
| `Ok o ->
RPC_answer.return o
| `OkStream s ->
RPC_answer.return_stream s
| `Created s ->
Lwt.return (`Created s)
| `No_content ->
Lwt.return `No_content
| `Unauthorized e ->
let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
Lwt.return (`Unauthorized e)
| `Forbidden e ->
let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
Lwt.return (`Forbidden e)
| `Not_found e ->
let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
Lwt.return (`Not_found e)
| `Conflict e ->
let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
Lwt.return (`Conflict e)
| `Error e ->
let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
Lwt.return (`Error e))
let register dir service handler =
gen_register dir service (fun p q i ->
handler p q i
>>= function
| Ok o -> RPC_answer.return o | Error e -> RPC_answer.fail e)
let opt_register dir service handler =
gen_register dir service (fun p q i ->
handler p q i
>>= function
| Ok (Some o) ->
RPC_answer.return o
| Ok None ->
RPC_answer.not_found
| Error e ->
RPC_answer.fail e)
let lwt_register dir service handler =
gen_register dir service (fun p q i ->
handler p q i >>= fun o -> RPC_answer.return o)
open Curry
let register0 root s f = register root s (curry Z f)
let register1 root s f = register root s (curry (S Z) f)
let register2 root s f = register root s (curry (S (S Z)) f)
let register3 root s f = register root s (curry (S (S (S Z))) f)
let register4 root s f = register root s (curry (S (S (S (S Z)))) f)
let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f)
let opt_register0 root s f = opt_register root s (curry Z f)
let opt_register1 root s f = opt_register root s (curry (S Z) f)
let opt_register2 root s f = opt_register root s (curry (S (S Z)) f)
let opt_register3 root s f = opt_register root s (curry (S (S (S Z))) f)
let opt_register4 root s f =
opt_register root s (curry (S (S (S (S Z)))) f)
let opt_register5 root s f =
opt_register root s (curry (S (S (S (S (S Z))))) f)
let gen_register0 root s f = gen_register root s (curry Z f)
let gen_register1 root s f = gen_register root s (curry (S Z) f)
let gen_register2 root s f = gen_register root s (curry (S (S Z)) f)
let gen_register3 root s f = gen_register root s (curry (S (S (S Z))) f)
let gen_register4 root s f =
gen_register root s (curry (S (S (S (S Z)))) f)
let gen_register5 root s f =
gen_register root s (curry (S (S (S (S (S Z))))) f)
let lwt_register0 root s f = lwt_register root s (curry Z f)
let lwt_register1 root s f = lwt_register root s (curry (S Z) f)
let lwt_register2 root s f = lwt_register root s (curry (S (S Z)) f)
let lwt_register3 root s f = lwt_register root s (curry (S (S (S Z))) f)
let lwt_register4 root s f =
lwt_register root s (curry (S (S (S (S Z)))) f)
let lwt_register5 root s f =
lwt_register root s (curry (S (S (S (S (S Z))))) f)
end
module RPC_context = struct
type t = rpc_context
class type ['pr] simple =
object
method call_proto_service0 :
'm 'q 'i 'o.
(([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t ->
'pr -> 'q -> 'i -> 'o Error_monad.shell_tzresult Lwt.t
method call_proto_service1 :
'm 'a 'q 'i 'o.
(([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t ->
'pr -> 'a -> 'q -> 'i -> 'o Error_monad.shell_tzresult Lwt.t
method call_proto_service2 :
'm 'a 'b 'q 'i 'o.
( ([< RPC_service.meth] as 'm),
t,
(t * 'a) * 'b,
'q,
'i,
'o )
RPC_service.t -> 'pr -> 'a -> 'b -> 'q -> 'i ->
'o Error_monad.shell_tzresult Lwt.t
method call_proto_service3 :
'm 'a 'b 'c 'q 'i 'o.
( ([< RPC_service.meth] as 'm),
t,
((t * 'a) * 'b) * 'c,
'q,
'i,
'o )
RPC_service.t -> 'pr -> 'a -> 'b -> 'c -> 'q -> 'i ->
'o Error_monad.shell_tzresult Lwt.t
end
let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s
let make_call0 = (make_call0 : _ -> _ simple -> _ :> _ -> _ #simple -> _)
let make_call1 s (ctxt : _ simple) = ctxt#call_proto_service1 s
let make_call1 = (make_call1 : _ -> _ simple -> _ :> _ -> _ #simple -> _)
let make_call2 s (ctxt : _ simple) = ctxt#call_proto_service2 s
let make_call2 = (make_call2 : _ -> _ simple -> _ :> _ -> _ #simple -> _)
let make_call3 s (ctxt : _ simple) = ctxt#call_proto_service3 s
let make_call3 = (make_call3 : _ -> _ simple -> _ :> _ -> _ #simple -> _)
let make_opt_call0 s ctxt block q i =
make_call0 s ctxt block q i
>>= function
| Error [RPC_context.Not_found _] ->
Lwt.return_ok None
| Error _ as v ->
Lwt.return v
| Ok v ->
Lwt.return_ok (Some v)
let make_opt_call1 s ctxt block a1 q i =
make_call1 s ctxt block a1 q i
>>= function
| Error [RPC_context.Not_found _] ->
Lwt.return_ok None
| Error _ as v ->
Lwt.return v
| Ok v ->
Lwt.return_ok (Some v)
let make_opt_call2 s ctxt block a1 a2 q i =
make_call2 s ctxt block a1 a2 q i
>>= function
| Error [RPC_context.Not_found _] ->
Lwt.return_ok None
| Error _ as v ->
Lwt.return v
| Ok v ->
Lwt.return_ok (Some v)
let make_opt_call3 s ctxt block a1 a2 a3 q i =
make_call3 s ctxt block a1 a2 a3 q i
>>= function
| Error [RPC_context.Not_found _] ->
Lwt.return_ok None
| Error _ as v ->
Lwt.return v
| Ok v ->
Lwt.return_ok (Some v)
end
module Micheline = struct
include Micheline
let canonical_encoding_v1 = canonical_encoding_v1
let canonical_encoding = canonical_encoding_v0
end
module Logging = Internal_event.Legacy_logging.Make (Param)
module Updater = struct
type nonrec validation_result = validation_result = {
context : Context.t;
fitness : Fitness.t;
message : string option;
max_operations_ttl : int;
last_allowed_fork_level : Int32.t;
}
type nonrec quota = quota = {max_size : int; max_op : int option}
type nonrec rpc_context = rpc_context = {
block_hash : Block_hash.t;
block_header : Block_header.shell_header;
context : Context.t;
}
let activate = Context.set_protocol
let fork_test_chain = Context.fork_test_chain
module type PROTOCOL =
T
with type context := Context.t
and type quota := quota
and type validation_result := validation_result
and type rpc_context := rpc_context
and type 'a tzresult := 'a Error_monad.tzresult
end
module Base58 = struct
include Tezos_crypto.Base58
let simple_encode enc s = simple_encode enc s
let simple_decode enc s = simple_decode enc s
include Make (struct
type context = Context.t
end)
let decode s = decode s
end
module Context = struct
include Context
let fold_keys s k ~init ~f =
let rec loop k acc =
fold s k ~init:acc ~f:(fun file acc ->
match file with `Key k -> f k acc | `Dir k -> loop k acc)
in
loop k init
let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
let register_resolver = Base58.register_resolver
let complete ctxt s = Base58.complete ctxt s
end
module Lift (P : Updater.PROTOCOL) = struct
include P
let begin_partial_application ~chain_id ~ancestor_context
~predecessor_timestamp ~predecessor_fitness raw_block =
begin_partial_application
~chain_id
~ancestor_context
~predecessor_timestamp
~predecessor_fitness
raw_block
>|= wrap_error
let begin_application ~chain_id ~predecessor_context ~predecessor_timestamp
~predecessor_fitness raw_block =
begin_application
~chain_id
~predecessor_context
~predecessor_timestamp
~predecessor_fitness
raw_block
>|= wrap_error
let begin_construction ~chain_id ~predecessor_context
~predecessor_timestamp ~predecessor_level ~predecessor_fitness
~predecessor ~timestamp ?protocol_data () =
begin_construction
~chain_id
~predecessor_context
~predecessor_timestamp
~predecessor_level
~predecessor_fitness
~predecessor
~timestamp
?protocol_data
()
>|= wrap_error
let current_context c = current_context c >|= wrap_error
let apply_operation c o = apply_operation c o >|= wrap_error
let finalize_block c = finalize_block c >|= wrap_error
let init c bh = init c bh >|= wrap_error
end
class ['chain, 'block] proto_rpc_context (t : Tezos_rpc.RPC_context.t)
(prefix : (unit, (unit * 'chain) * 'block) RPC_path.t) =
object
method call_proto_service0
: 'm 'q 'i 'o.
( ([< RPC_service.meth] as 'm),
RPC_context.t,
RPC_context.t,
'q,
'i,
'o )
RPC_service.t -> 'chain * 'block -> 'q -> 'i -> 'o tzresult Lwt.t =
fun s (chain, block) q i ->
let s = RPC_service.subst0 s in
let s = RPC_service.prefix prefix s in
t#call_service s (((), chain), block) q i
method call_proto_service1
: 'm 'a 'q 'i 'o.
( ([< RPC_service.meth] as 'm),
RPC_context.t,
RPC_context.t * 'a,
'q,
'i,
'o )
RPC_service.t -> 'chain * 'block -> 'a -> 'q -> 'i ->
'o tzresult Lwt.t =
fun s (chain, block) a1 q i ->
let s = RPC_service.subst1 s in
let s = RPC_service.prefix prefix s in
t#call_service s ((((), chain), block), a1) q i
method call_proto_service2
: 'm 'a 'b 'q 'i 'o.
( ([< RPC_service.meth] as 'm),
RPC_context.t,
(RPC_context.t * 'a) * 'b,
'q,
'i,
'o )
RPC_service.t -> 'chain * 'block -> 'a -> 'b -> 'q -> 'i ->
'o tzresult Lwt.t =
fun s (chain, block) a1 a2 q i ->
let s = RPC_service.subst2 s in
let s = RPC_service.prefix prefix s in
t#call_service s (((((), chain), block), a1), a2) q i
method call_proto_service3
: 'm 'a 'b 'c 'q 'i 'o.
( ([< RPC_service.meth] as 'm),
RPC_context.t,
((RPC_context.t * 'a) * 'b) * 'c,
'q,
'i,
'o )
RPC_service.t -> 'chain * 'block -> 'a -> 'b -> 'c -> 'q -> 'i ->
'o tzresult Lwt.t =
fun s (chain, block) a1 a2 a3 q i ->
let s = RPC_service.subst3 s in
let s = RPC_service.prefix prefix s in
t#call_service s ((((((), chain), block), a1), a2), a3) q i
end
class ['block] proto_rpc_context_of_directory conv dir :
['block] RPC_context.simple =
let lookup = new Tezos_rpc.RPC_context.of_directory dir in
object
method call_proto_service0
: 'm 'q 'i 'o.
( ([< RPC_service.meth] as 'm),
RPC_context.t,
RPC_context.t,
'q,
'i,
'o )
RPC_service.t -> 'block -> 'q -> 'i -> 'o tzresult Lwt.t =
fun s block q i ->
let rpc_context = conv block in
lookup#call_service s rpc_context q i
method call_proto_service1
: 'm 'a 'q 'i 'o.
( ([< RPC_service.meth] as 'm),
RPC_context.t,
RPC_context.t * 'a,
'q,
'i,
'o )
RPC_service.t -> 'block -> 'a -> 'q -> 'i -> 'o tzresult Lwt.t =
fun s block a1 q i ->
let rpc_context = conv block in
lookup#call_service s (rpc_context, a1) q i
method call_proto_service2
: 'm 'a 'b 'q 'i 'o.
( ([< RPC_service.meth] as 'm),
RPC_context.t,
(RPC_context.t * 'a) * 'b,
'q,
'i,
'o )
RPC_service.t -> 'block -> 'a -> 'b -> 'q -> 'i ->
'o tzresult Lwt.t =
fun s block a1 a2 q i ->
let rpc_context = conv block in
lookup#call_service s ((rpc_context, a1), a2) q i
method call_proto_service3
: 'm 'a 'b 'c 'q 'i 'o.
( ([< RPC_service.meth] as 'm),
RPC_context.t,
((RPC_context.t * 'a) * 'b) * 'c,
'q,
'i,
'o )
RPC_service.t -> 'block -> 'a -> 'b -> 'c -> 'q -> 'i ->
'o tzresult Lwt.t =
fun s block a1 a2 a3 q i ->
let rpc_context = conv block in
lookup#call_service s (((rpc_context, a1), a2), a3) q i
end
end
src/lib_protocol_environment/tezos_protocol_environment.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Module CONTEXT.
Record signature {t : Type} := {
t := t;
key := list string;
value := Tezos_base__TzPervasives.MBytes.t;
mem : t -> key -> Lwt.t bool;
dir_mem : t -> key -> Lwt.t bool;
get : t -> key -> Lwt.t (option value);
set : t -> key -> value -> Lwt.t t;
copy : t -> key -> key -> Lwt.t (option t);
del : t -> key -> Lwt.t t;
remove_rec : t -> key -> Lwt.t t;
fold : forall {a variant : Type}, t ->
key -> a -> (variant -> a -> Lwt.t a) -> Lwt.t a;
set_protocol : t -> Tezos_base__TzPervasives.Protocol_hash.t -> Lwt.t t;
fork_test_chain : t ->
Tezos_base__TzPervasives.Protocol_hash.t ->
Tezos_base__TzPervasives.Time.Protocol.t -> Lwt.t t;
}.
Arguments signature : clear implicits.
End CONTEXT.
Module Context.
Definition key := list string.
Definition value := Tezos_base__TzPervasives.MBytes.t.
Definition ops (ctxt : Type) := {_ : unit & CONTEXT.signature ctxt}.
Definition kind := False.
Inductive t : Type :=
| Context : forall {a : Type}, (kind a) -> a -> (ops a) -> t.
Definition mem (function_parameter : t) : (list string) -> Lwt.t bool :=
let 'Context {| ctxt := ctxt; ops := Ops |} := function_parameter in
let Ops := projT2 Ops in
fun key => Ops.(CONTEXT.mem) ctxt key.
Definition set (function_parameter : t)
: (list string) -> Tezos_base__TzPervasives.MBytes.t -> Lwt.t t :=
let 'Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} :=
function_parameter in
let Ops := projT2 Ops in
fun key =>
fun value =>
op_gtgteq (Ops.(CONTEXT.set) ctxt key value)
(fun ctxt =>
Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |})).
Definition dir_mem (function_parameter : t) : (list string) -> Lwt.t bool :=
let 'Context {| ctxt := ctxt; ops := Ops |} := function_parameter in
let Ops := projT2 Ops in
fun key => Ops.(CONTEXT.dir_mem) ctxt key.
Definition get (function_parameter : t)
: (list string) -> Lwt.t (option Tezos_base__TzPervasives.MBytes.t) :=
let 'Context {| ctxt := ctxt; ops := Ops |} := function_parameter in
let Ops := projT2 Ops in
fun key => Ops.(CONTEXT.get) ctxt key.
Definition copy (function_parameter : t)
: (list string) -> (list string) -> Lwt.t (option t) :=
let 'Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} :=
function_parameter in
let Ops := projT2 Ops in
fun from =>
fun to_ =>
op_gtgteq (Ops.(CONTEXT.copy) ctxt from to_)
(fun function_parameter =>
match function_parameter with
| Some ctxt =>
Lwt.return_some
(Context {| kind := kind; ctxt := ctxt; ops := ops |})
| None => Lwt.return_none
end).
Definition del (function_parameter : t) : (list string) -> Lwt.t t :=
let 'Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} :=
function_parameter in
let Ops := projT2 Ops in
fun key =>
op_gtgteq (Ops.(CONTEXT.del) ctxt key)
(fun ctxt =>
Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |})).
Definition remove_rec (function_parameter : t) : (list string) -> Lwt.t t :=
let 'Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} :=
function_parameter in
let Ops := projT2 Ops in
fun key =>
op_gtgteq (Ops.(CONTEXT.remove_rec) ctxt key)
(fun ctxt =>
Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |})).
Definition fold {A : Type} (function_parameter : t)
: (list string) -> A -> (variant -> A -> Lwt.t A) -> Lwt.t A :=
let 'Context {| ctxt := ctxt; ops := Ops |} := function_parameter in
let Ops := projT2 Ops in
fun key => fun init => fun f => Ops.(CONTEXT.fold) ctxt key init f.
Definition set_protocol (function_parameter : t)
: Tezos_base__TzPervasives.Protocol_hash.t -> Lwt.t t :=
let 'Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} :=
function_parameter in
let Ops := projT2 Ops in
fun protocol_hash =>
op_gtgteq (Ops.(CONTEXT.set_protocol) ctxt protocol_hash)
(fun ctxt =>
Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |})).
Definition fork_test_chain (function_parameter : t)
: Tezos_base__TzPervasives.Protocol_hash.t ->
Tezos_base__TzPervasives.Time.Protocol.t -> Lwt.t t :=
let 'Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} :=
function_parameter in
let Ops := projT2 Ops in
fun protocol =>
fun expiration =>
op_gtgteq (Ops.(CONTEXT.fork_test_chain) ctxt protocol expiration)
(fun ctxt =>
Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |})).
End Context.
Record validation_result := {
context : Context.t;
fitness : Tezos_base__TzPervasives.Fitness.t;
message : option string;
max_operations_ttl : Z;
last_allowed_fork_level : Stdlib.Int32.t }.
Record quota := {
max_size : Z;
max_op : option Z }.
Record rpc_context := {
block_hash : Tezos_base__TzPervasives.Block_hash.t;
block_header : Tezos_base__TzPervasives.Block_header.shell_header;
context : Context.t }.
Module T.
Record signature {context quota validation_result rpc_context tzresult
block_header_data block_header block_header_metadata operation_data
operation_receipt operation validation_state : Type} := {
context := context;
quota := quota;
validation_result := validation_result;
rpc_context := rpc_context;
polymorphic_abstract_type;
max_block_length : Z;
max_operation_data_length : Z;
validation_passes : list quota;
block_header_data := block_header_data;
block_header_data_encoding : Tezos_base__TzPervasives.Data_encoding.t
block_header_data;
block_header := block_header;
block_header_metadata := block_header_metadata;
block_header_metadata_encoding : Tezos_base__TzPervasives.Data_encoding.t
block_header_metadata;
operation_data := operation_data;
operation_receipt := operation_receipt;
operation := operation;
operation_data_encoding : Tezos_base__TzPervasives.Data_encoding.t
operation_data;
operation_receipt_encoding : Tezos_base__TzPervasives.Data_encoding.t
operation_receipt;
operation_data_and_receipt_encoding : Tezos_base__TzPervasives.Data_encoding.t
(operation_data * operation_receipt);
acceptable_passes : operation -> list Z;
compare_operations : operation -> operation -> Z;
validation_state := validation_state;
current_context : validation_state -> Lwt.t (tzresult context);
begin_partial_application : Tezos_base__TzPervasives.Chain_id.t ->
context ->
Tezos_base__TzPervasives.Time.Protocol.t ->
Tezos_base__TzPervasives.Fitness.t ->
block_header -> Lwt.t (tzresult validation_state);
begin_application : Tezos_base__TzPervasives.Chain_id.t ->
context ->
Tezos_base__TzPervasives.Time.Protocol.t ->
Tezos_base__TzPervasives.Fitness.t ->
block_header -> Lwt.t (tzresult validation_state);
begin_construction : Tezos_base__TzPervasives.Chain_id.t ->
context ->
Tezos_base__TzPervasives.Time.Protocol.t ->
Stdlib.Int32.t ->
Tezos_base__TzPervasives.Fitness.t ->
Tezos_base__TzPervasives.Block_hash.t ->
Tezos_base__TzPervasives.Time.Protocol.t ->
(option block_header_data) ->
unit -> Lwt.t (tzresult validation_state);
apply_operation : validation_state ->
operation -> Lwt.t (tzresult (validation_state * operation_receipt));
finalize_block : validation_state ->
Lwt.t (tzresult (validation_result * block_header_metadata));
rpc_services : Tezos_base__TzPervasives.RPC_directory.t rpc_context;
init : context ->
Tezos_base__TzPervasives.Block_header.shell_header ->
Lwt.t (tzresult validation_result);
}.
Arguments signature : clear implicits.
End T.
(* ❌ This kind of signature is not handled. *)
unhandled_module_type
Module V1.
Record signature {Pervasives_ref Data_encoding_field Data_encoding_case_tag
Data_encoding_case Data_encoding_Binary_write_error Error_monad_error
Error_monad_error_info RPC_arg_t RPC_arg_descr RPC_arg_eq RPC_query_t
RPC_query_field RPC_query_open_query RPC_answer_stream RPC_directory_step
RPC_directory_conflict Base58_encoding Base58_data
Ed25519_Public_key_hash_Set_t Ed25519_Public_key_hash_Map_t
Secp256k1_Public_key_hash_Set_t Secp256k1_Public_key_hash_Map_t
P256_Public_key_hash_Set_t P256_Public_key_hash_Map_t Chain_id_Set_t
Chain_id_Map_t Signature_Public_key_hash_Set_t
Signature_Public_key_hash_Map_t Block_hash_Set_t Block_hash_Map_t
Operation_hash_Set_t Operation_hash_Map_t Operation_list_hash_Set_t
Operation_list_hash_Map_t Operation_list_hash_path
Operation_list_list_hash_Set_t Operation_list_list_hash_Map_t
Operation_list_list_hash_path Protocol_hash_Set_t Protocol_hash_Map_t
Context_hash_Set_t Context_hash_Map_t Protocol_t Protocol_component
Protocol_env_version Updater_validation_result Updater_quota
Updater_rpc_context : Type} := {
include;
extensible_type;
wrap_error : forall {a : Type}, (Error_monad.tzresult a) ->
Tezos_base__TzPervasives.Error_monad.tzresult a;
Lift : functor;
class;
class;
}.
Arguments signature : clear implicits.
End V1.
(* ❌ Functors are not handled. *)
functor
src/lib_protocol_updater/registered_protocol.ml 14 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type T = sig
module P : sig
val hash : Protocol_hash.t
include Tezos_protocol_environment.PROTOCOL
end
include module type of struct
include P
end
module Block_services : module type of struct
include Block_services.Make (P) (P)
end
val complete_b58prefix :
Tezos_protocol_environment.Context.t -> string -> string list Lwt.t
end
type t = (module T)
let build_v1 hash =
match Tezos_protocol_registerer.Registerer.get hash with
| None ->
None
| Some protocol ->
let (module F) = protocol in
let module Name = struct
let name = Protocol_hash.to_b58check hash
end in
let module Env = Tezos_protocol_environment.MakeV1 (Name) () in
Some
( module struct
module Raw = F (Env)
module P = struct
let hash = hash
include Env.Lift (Raw)
end
include P
module Block_services = Block_services.Make (P) (P)
let complete_b58prefix = Env.Context.complete
end : T )
module VersionTable = Protocol_hash.Table
let versions : (module T) VersionTable.t = VersionTable.create 20
let sources : Protocol.t VersionTable.t = VersionTable.create 20
let mem hash =
VersionTable.mem versions hash
|| Tezos_protocol_registerer.Registerer.mem hash
let get hash =
try Some (VersionTable.find versions hash)
with Not_found -> (
match build_v1 hash with
| Some proto ->
VersionTable.add versions hash proto ;
Some proto
| None ->
None )
let list () = VersionTable.fold (fun _ p acc -> p :: acc) versions []
let list_embedded () = VersionTable.fold (fun k _ acc -> k :: acc) sources []
let get_embedded_sources_exn hash = VersionTable.find sources hash
let get_embedded_sources hash =
try Some (get_embedded_sources_exn hash) with Not_found -> None
module Register_embedded
(Env : Tezos_protocol_environment.V1)
(Proto : Env.Updater.PROTOCOL) (Source : sig
val hash : Protocol_hash.t option
val sources : Protocol.t
end) =
struct
let hash =
match Source.hash with
| None ->
Protocol.hash Source.sources
| Some hash ->
hash
module Self = struct
module P = struct
let hash = hash
include Env.Lift (Proto)
end
include P
module Block_services = Block_services.Make (P) (P)
let complete_b58prefix = Env.Context.complete
end
let () =
VersionTable.add sources hash Source.sources ;
VersionTable.add versions hash (module Self : T)
include Self
end
src/lib_protocol_updater/registered_protocol.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module T.
Record signature {P_block_header_data P_block_header P_block_header_metadata
P_operation_data P_operation_receipt P_operation P_validation_state : Type}
:= {
P : signature;
include;
Block_services : typeof;
complete_b58prefix : Tezos_protocol_environment.Context.t ->
string -> Lwt.t (list string);
}.
Arguments signature : clear implicits.
End T.
Definition t :=
{'(P_block_header_data, P_block_header, P_block_header_metadata,
P_operation_data, P_operation_receipt, P_operation, P_validation_state) : _
&
T.signature P_block_header_data P_block_header P_block_header_metadata
P_operation_data P_operation_receipt P_operation P_validation_state}.
Definition build_v1 (hash : Tezos_base__TzPervasives.Protocol_hash.t)
: option
{'(P_block_header_data, P_block_header, P_block_header_metadata,
P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
_ &
T.signature P_block_header_data P_block_header P_block_header_metadata
P_operation_data P_operation_receipt P_operation P_validation_state} :=
match Tezos_protocol_registerer.Registerer.get hash with
| None => None
| Some protocol =>
let F := protocol in
let F := projT2 F in
let Name :=
(* ❌ The signature name of this module could not be found *)
existT _ _
{|
unknown_signature_name.name := Protocol_hash.to_b58check hash
|} in
let Env :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
Some
(existT _ ((((((_, _), _), _), _), _), _)
{|
T.Raw :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application;
T.P :=
(* ❌ The signature name of this module could not be found *)
existT _ _
{|
unknown_signature_name.hash := hash;
(* ❌ Include is not handled inside first-class module values *)
unknown_signature_name._ := include
|};
(* ❌ Include is not handled inside first-class module values *)
T._ := include;
T.Block_services :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application;
T.complete_b58prefix := Env.Context.complete
|})
end.
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition versions
: VersionTable.t
{'(P_block_header_data, P_block_header, P_block_header_metadata,
P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
_ &
T.signature P_block_header_data P_block_header P_block_header_metadata
P_operation_data P_operation_receipt P_operation P_validation_state} :=
VersionTable.create 20.
Definition sources : VersionTable.t Tezos_base__TzPervasives.Protocol.t :=
VersionTable.create 20.
Definition mem (hash : VersionTable.key) : bool :=
orb (VersionTable.mem versions hash)
(Tezos_protocol_registerer.Registerer.mem hash).
Definition get (hash : VersionTable.key)
: option
{'(P_block_header_data, P_block_header, P_block_header_metadata,
P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
_ &
T.signature P_block_header_data P_block_header P_block_header_metadata
P_operation_data P_operation_receipt P_operation P_validation_state} :=
(* ❌ Try-with are not handled *)
try (Some (VersionTable.find versions hash)).
Definition list (function_parameter : unit)
: list
{'(P_block_header_data, P_block_header, P_block_header_metadata,
P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
_ &
T.signature P_block_header_data P_block_header P_block_header_metadata
P_operation_data P_operation_receipt P_operation P_validation_state} :=
let 'tt := function_parameter in
VersionTable.fold
(fun function_parameter =>
let '_ := function_parameter in
fun p => fun acc => cons p acc) versions [].
Definition list_embedded (function_parameter : unit) : list VersionTable.key :=
let 'tt := function_parameter in
VersionTable.fold
(fun k =>
fun function_parameter =>
let '_ := function_parameter in
fun acc => cons k acc) sources [].
Definition get_embedded_sources_exn (hash : VersionTable.key)
: Tezos_base__TzPervasives.Protocol.t := VersionTable.find sources hash.
Definition get_embedded_sources (hash : VersionTable.key)
: option Tezos_base__TzPervasives.Protocol.t :=
(* ❌ Try-with are not handled *)
try (Some (get_embedded_sources_exn hash)).
(* ❌ Functors are not handled. *)
functor
src/lib_protocol_updater/updater.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Updater_logging
let ( // ) = Filename.concat
(** Compiler *)
let datadir = ref None
let get_datadir () =
match !datadir with
| None ->
fatal_error "Node not initialized" ;
Lwt_exit.exit 1
| Some m ->
m
let init dir = datadir := Some dir
let compiler_name = "tezos-protocol-compiler"
let do_compile hash p =
assert (p.Protocol.expected_env = V1) ;
let datadir = get_datadir () in
let source_dir = datadir // Protocol_hash.to_short_b58check hash // "src" in
let log_file = datadir // Protocol_hash.to_short_b58check hash // "LOG" in
let plugin_file =
datadir
// Protocol_hash.to_short_b58check hash
// Format.asprintf "protocol_%a" Protocol_hash.pp hash
in
Tezos_base_unix.Protocol_files.write_dir source_dir ~hash p
>>=? (fun () ->
let compiler_command =
( Sys.executable_name,
Array.of_list
[compiler_name; "-register"; "-o"; plugin_file; source_dir] )
in
let fd =
Unix.(openfile log_file [O_WRONLY; O_CREAT; O_TRUNC] 0o644)
in
Lwt_process.exec
~stdin:`Close
~stdout:(`FD_copy fd)
~stderr:(`FD_move fd)
compiler_command
>>= return)
>>= function
| Error err ->
log_error "Error %a" pp_print_error err ;
Lwt.return_false
| Ok (Unix.WSIGNALED _ | Unix.WSTOPPED _) ->
log_error "INTERRUPTED COMPILATION (%s)" log_file ;
Lwt.return_false
| Ok (Unix.WEXITED x) when x <> 0 ->
log_error "COMPILATION ERROR (%s)" log_file ;
Lwt.return_false
| Ok (Unix.WEXITED _) -> (
try
Dynlink.loadfile_private (plugin_file ^ ".cmxs") ;
Lwt.return_true
with Dynlink.Error err ->
log_error
"Can't load plugin: %s (%s)"
(Dynlink.error_message err)
plugin_file ;
Lwt.return_false )
let compile hash p =
if Tezos_protocol_registerer.Registerer.mem hash then Lwt.return_true
else
do_compile hash p
>>= fun success ->
let loaded = Tezos_protocol_registerer.Registerer.mem hash in
if success && not loaded then
log_error "Internal error while compiling %a" Protocol_hash.pp hash ;
Lwt.return loaded
src/lib_protocol_updater/updater.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Updater_logging.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition datadir : Stdlib.ref (option string) := Stdlib.ref None.
Definition get_datadir (function_parameter : unit) : string :=
let 'tt := function_parameter in
match Stdlib.op_exclamation datadir with
| None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
fatal_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Node not initialized" % string
CamlinternalFormatBasics.End_of_format)
"Node not initialized" % string) in
Lwt_exit.exit 1
| Some m => m
end.
Definition init (dir : string) : unit := Stdlib.op_coloneq datadir (Some dir).
Definition compiler_name : string := "tezos-protocol-compiler" % string.
Definition do_compile
(hash : Tezos_base__TzPervasives.Protocol_hash.t)
(p : Tezos_base__TzPervasives.Protocol.t) : Lwt.t bool :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(equiv_decb (Protocol.expected_env p) Tezos_base__TzPervasives.Protocol.V1)
in
let datadir := get_datadir tt in
let source_dir :=
op_divdiv (op_divdiv datadir (Protocol_hash.to_short_b58check hash))
"src" % string in
let log_file :=
op_divdiv (op_divdiv datadir (Protocol_hash.to_short_b58check hash))
"LOG" % string in
let plugin_file :=
op_divdiv (op_divdiv datadir (Protocol_hash.to_short_b58check hash))
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "protocol_" % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "protocol_%a" % string)
Protocol_hash.pp hash) in
op_gtgteq
(op_gtgteqquestion
(Tezos_base_unix.Protocol_files.write_dir source_dir (Some hash) p)
(fun function_parameter =>
let 'tt := function_parameter in
let compiler_command :=
(Sys.executable_name,
(Array.of_list
(cons compiler_name
(cons "-register" % string
(cons "-o" % string (cons plugin_file (cons source_dir [])))))))
in
let fd :=
openfile log_file
(cons Unix.O_WRONLY (cons Unix.O_CREAT (cons Unix.O_TRUNC []))) 420
in
op_gtgteq
(Lwt_process.exec None None
(Some
(* ❌ Variants not supported *)
variant)
(Some
(* ❌ Variants not supported *)
variant)
(Some
(* ❌ Variants not supported *)
variant) compiler_command) _return))
(fun function_parameter =>
match function_parameter with
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Error " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "Error %a" % string)
pp_print_error err in
Lwt.return_false
| Stdlib.Ok (Unix.WSIGNALED _ | Unix.WSTOPPED _) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"INTERRUPTED COMPILATION (" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"INTERRUPTED COMPILATION (%s)" % string) log_file in
Lwt.return_false
| Stdlib.Ok (Unix.WEXITED x) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"COMPILATION ERROR (" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"COMPILATION ERROR (%s)" % string) log_file in
Lwt.return_false
| Stdlib.Ok (Unix.WEXITED _) =>
(* ❌ Try-with are not handled *)
try
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ :=
Dynlink.loadfile_private
(String.append plugin_file ".cmxs" % string) in
Lwt.return_true)
end).
Definition compile
(hash : Tezos_base__TzPervasives.Protocol_hash.t)
(p : Tezos_base__TzPervasives.Protocol.t) : Lwt.t bool :=
if Tezos_protocol_registerer.Registerer.mem hash then
Lwt.return_true
else
op_gtgteq (do_compile hash p)
(fun success =>
let loaded := Tezos_protocol_registerer.Registerer.mem hash in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if andb success (negb loaded) then
log_error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Internal error while compiling " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Internal error while compiling %a" % string) Protocol_hash.pp
hash
else
tt in
Lwt._return loaded).
src/lib_protocol_updater/updater_logging.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Internal_event.Legacy_logging.Make (struct let name = "updater" end)
src/lib_protocol_updater/updater_logging.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/lib_rpc/RPC_answer.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Return type for service handler *)
type 'o t =
[ `Ok of 'o (* 200 *)
| `OkStream of 'o stream (* 200 *)
| `Created of string option (* 201 *)
| `No_content (* 204 *)
| `Unauthorized of RPC_service.error option (* 401 *)
| `Forbidden of RPC_service.error option (* 403 *)
| `Not_found of RPC_service.error option (* 404 *)
| `Conflict of RPC_service.error option (* 409 *)
| `Error of RPC_service.error option (* 500 *) ]
and 'a stream = 'a Resto_directory.Answer.stream = {
next : unit -> 'a option Lwt.t;
shutdown : unit -> unit;
}
let return x = Lwt.return (`Ok x)
let return_unit = Lwt.return (`Ok ())
let return_stream x = Lwt.return (`OkStream x)
let not_found = Lwt.return (`Not_found None)
let fail err = Lwt.return (`Error (Some err))
src/lib_rpc/RPC_answer.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Reserved Notation "'t".
where "'t" := (fun (o : Type) => variant).
Definition t := 't.
Definition _return {A : Type} (x : A) : Lwt.t variant :=
Lwt._return
(* ❌ Variants not supported *)
variant.
Definition return_unit : Lwt.t variant :=
Lwt._return
(* ❌ Variants not supported *)
variant.
Definition return_stream {A : Type} (x : A) : Lwt.t variant :=
Lwt._return
(* ❌ Variants not supported *)
variant.
Definition not_found : Lwt.t variant :=
Lwt._return
(* ❌ Variants not supported *)
variant.
Definition fail {A : Type} (err : A) : Lwt.t variant :=
Lwt._return
(* ❌ Variants not supported *)
variant.
src/lib_rpc/RPC_arg.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type ('i, 'j) eq = ('i, 'j) Resto.eq = Eq : ('a, 'a) eq
include Resto.Arg
src/lib_rpc/RPC_arg.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive eq : forall (i j : Type), Type :=
| Eq : forall {a : Type}, eq a a.
(* ❌ Structure item `include` not handled. *)
include
src/lib_rpc/RPC_context.ml 40 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
class type ['pr] gen_simple =
object
method call_service :
'm 'p 'q 'i 'o.
(([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p ->
'q -> 'i -> 'o tzresult Lwt.t
end
class type ['pr] gen_streamed =
object
method call_streamed_service :
'm 'p 'q 'i 'o.
(([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t ->
on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q -> 'i ->
(unit -> unit) tzresult Lwt.t
end
class type ['pr] gen =
object
inherit ['pr] gen_simple
inherit ['pr] gen_streamed
end
class type simple =
object
inherit [unit] gen_simple
end
class type streamed =
object
inherit [unit] gen_streamed
end
class type t =
object
inherit simple
inherit streamed
end
type ('o, 'e) rest_result =
[ `Ok of 'o
| `Conflict of 'e
| `Error of 'e
| `Forbidden of 'e
| `Not_found of 'e
| `Unauthorized of 'e ]
tzresult
class type json =
object
inherit t
method generic_json_call :
RPC_service.meth ->
?body:Data_encoding.json ->
Uri.t ->
(Data_encoding.json, Data_encoding.json option) rest_result Lwt.t
method base : Uri.t
end
type error +=
| Not_found of {meth : RPC_service.meth; uri : Uri.t}
| Generic_error of {meth : RPC_service.meth; uri : Uri.t}
let base = Uri.make ~scheme:"ocaml" ()
let not_found s p q =
let {RPC_service.meth; uri; _} =
RPC_service.forge_partial_request s ~base p q
in
fail (Not_found {meth; uri})
let generic_error s p q =
let {RPC_service.meth; uri; _} =
RPC_service.forge_partial_request s ~base p q
in
fail (Generic_error {meth; uri})
class ['pr] of_directory (dir : 'pr RPC_directory.t) =
object
method call_service
: 'm 'p 'q 'i 'o.
(([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p ->
'q -> 'i -> 'o tzresult Lwt.t =
fun s p q i ->
RPC_directory.transparent_lookup dir s p q i
>>= function
| `Ok v ->
return v
| `OkStream {next; shutdown} -> (
next ()
>>= function
| Some v ->
shutdown () ; return v
| None ->
shutdown () ; not_found s p q )
| `Not_found None ->
not_found s p q
| `Unauthorized (Some err)
| `Forbidden (Some err)
| `Not_found (Some err)
| `Conflict (Some err)
| `Error (Some err) ->
Lwt.return_error err
| `Unauthorized None
| `Error None
| `Forbidden None
| `Created _
| `Conflict None
| `No_content ->
generic_error s p q
method call_streamed_service
: 'm 'p 'q 'i 'o.
(([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t ->
on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q -> 'i ->
(unit -> unit) tzresult Lwt.t =
fun s ~on_chunk ~on_close p q i ->
RPC_directory.transparent_lookup dir s p q i
>>= function
| `OkStream {next; shutdown} ->
let rec loop () =
next ()
>>= function
| None ->
on_close () ; Lwt.return_unit
| Some v ->
on_chunk v ; loop ()
in
let _ = loop () in
return shutdown
| `Ok v ->
on_chunk v ;
on_close () ;
return (fun () -> ())
| `Not_found None ->
not_found s p q
| `Unauthorized (Some err)
| `Forbidden (Some err)
| `Not_found (Some err)
| `Conflict (Some err)
| `Error (Some err) ->
Lwt.return_error err
| `Unauthorized None
| `Error None
| `Forbidden None
| `Created _
| `Conflict None
| `No_content ->
generic_error s p q
end
let make_call s (ctxt : #simple) = ctxt#call_service s
let make_call1 s ctxt x = make_call s ctxt ((), x)
let make_call2 s ctxt x y = make_call s ctxt (((), x), y)
let make_call3 s ctxt x y z = make_call s ctxt ((((), x), y), z)
type stopper = unit -> unit
let make_streamed_call s (ctxt : #streamed) p q i =
let (stream, push) = Lwt_stream.create () in
let on_chunk v = push (Some v) and on_close () = push None in
ctxt#call_streamed_service s ~on_chunk ~on_close p q i
>>=? fun close -> return (stream, close)
let () =
let open Data_encoding in
register_error_kind
`Branch
~id:"RPC_context.Not_found"
~title:"RPC lookup failed"
~description:
"RPC lookup failed. No RPC exists at the URL or the RPC tried to access \
non-existent data."
(obj2
(req "method" RPC_service.meth_encoding)
(req "uri" RPC_encoding.uri_encoding))
~pp:(fun ppf (meth, uri) ->
Format.fprintf
ppf
"Did not find service: %s %a"
(RPC_service.string_of_meth meth)
Uri.pp_hum
uri)
(function Not_found {meth; uri} -> Some (meth, uri) | _ -> None)
(fun (meth, uri) -> Not_found {meth; uri})
src/lib_rpc/RPC_context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class_type` not handled. *)
class_type
Definition rest_result (o e : Type) :=
Tezos_error_monad.Error_monad.tzresult variant.
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition base : Uri.t :=
Uri.make (Some "ocaml" % string) None None None None None None tt.
Definition not_found {A B C D E F G : Type}
(s : Tezos_rpc.RPC_service.raw variant A B C D E F) (p : B) (q : C)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult G) :=
let '{| RPC_service.meth := meth; RPC_service.uri := uri |} :=
RPC_service.forge_partial_request s (Some base) p q in
fail (Tezos_error_monad.Error_monad.Not_found {| meth := meth; uri := uri |}).
Definition generic_error {A B C D E F G : Type}
(s : Tezos_rpc.RPC_service.raw variant A B C D E F) (p : B) (q : C)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult G) :=
let '{| RPC_service.meth := meth; RPC_service.uri := uri |} :=
RPC_service.forge_partial_request s (Some base) p q in
fail
(Tezos_error_monad.Error_monad.Generic_error {| meth := meth; uri := uri |}).
(* ❌ Structure item `class` not handled. *)
class
Definition make_call {A B C D I J i o p q : Type}
(s : Tezos_rpc.RPC_service.t variant unit A B C D)
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(I * p * q * i * o)) * J) * J)
: A -> B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D) :=
(* ❌ Sending method message is not handled *)
send s.
Definition make_call1 {A B C D I J i o p q : Type}
(s : Tezos_rpc.RPC_service.t variant unit (unit * A) B C D)
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(I * p * q * i * o)) * J) * J) (x : A)
: B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D) :=
make_call s ctxt (tt, x).
Definition make_call2 {A B C D E J K i o p q : Type}
(s : Tezos_rpc.RPC_service.t variant unit ((unit * A) * B) C D E)
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(J * p * q * i * o)) * K) * K) (x : A) (y : B)
: C -> D -> Lwt.t (Tezos_error_monad.Error_monad.tzresult E) :=
make_call s ctxt ((tt, x), y).
Definition make_call3 {A B C D E F K L i o p q : Type}
(s : Tezos_rpc.RPC_service.t variant unit (((unit * A) * B) * C) D E F)
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(K * p * q * i * o)) * L) * L) (x : A) (y : B) (z : C)
: D -> E -> Lwt.t (Tezos_error_monad.Error_monad.tzresult F) :=
make_call s ctxt (((tt, x), y), z).
Definition stopper := unit -> unit.
Definition make_streamed_call {A B C D I J i o p q : Type}
(s : Tezos_rpc.RPC_service.t variant unit A B C D)
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
* (I * p * q * i * o)) * J) * J) (p : A) (q : B) (i : C)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult ((Lwt_stream.t D) * (unit -> unit))) :=
let '(stream, push) := Lwt_stream.create tt in
let on_chunk (v : D) : unit :=
push (Some v)
with on_close (function_parameter : unit) : unit :=
let 'tt := function_parameter in
push None in
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send s on_chunk on_close p q i) (fun close => _return (stream, close)).
src/lib_rpc/RPC_description.ml 5 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Resto.Description
let describe ctxt ?(recurse = false) path =
RPC_context.make_call1 RPC_service.description_service ctxt path {recurse} ()
src/lib_rpc/RPC_description.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition describe {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F) (op_staroptstar : option bool)
: (list string) ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(Resto.Description.directory Tezos_rpc.RPC_encoding.schema)) :=
let recurse :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun path =>
RPC_context.make_call1 RPC_service.description_service ctxt path
{| recurse := recurse |} tt.
src/lib_rpc/RPC_directory.ml 37 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
include Resto_directory.Make (RPC_encoding)
let gen_register dir service handler =
register dir service (fun p q i ->
Lwt.catch
(fun () -> handler p q i)
(function
| Not_found -> RPC_answer.not_found | exn -> RPC_answer.fail [Exn exn]))
let gen_register =
( gen_register
: _ -> _ -> (_ -> _ -> _ -> _ RPC_answer.t Lwt.t) -> _
:> _ -> _ -> (_ -> _ -> _ -> [< _ RPC_answer.t] Lwt.t) -> _ )
let register dir service handler =
gen_register dir service (fun p q i ->
handler p q i
>>= function Ok o -> RPC_answer.return o | Error e -> RPC_answer.fail e)
let opt_register dir service handler =
gen_register dir service (fun p q i ->
handler p q i
>>= function
| Ok (Some o) ->
RPC_answer.return o
| Ok None ->
RPC_answer.not_found
| Error e ->
RPC_answer.fail e)
let lwt_register dir service handler =
gen_register dir service (fun p q i ->
handler p q i >>= fun o -> RPC_answer.return o)
open Curry
let register0 root s f = register root s (curry Z f)
let register1 root s f = register root s (curry (S Z) f)
let register2 root s f = register root s (curry (S (S Z)) f)
let register3 root s f = register root s (curry (S (S (S Z))) f)
let register4 root s f = register root s (curry (S (S (S (S Z)))) f)
let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f)
let opt_register0 root s f = opt_register root s (curry Z f)
let opt_register1 root s f = opt_register root s (curry (S Z) f)
let opt_register2 root s f = opt_register root s (curry (S (S Z)) f)
let opt_register3 root s f = opt_register root s (curry (S (S (S Z))) f)
let opt_register4 root s f = opt_register root s (curry (S (S (S (S Z)))) f)
let opt_register5 root s f =
opt_register root s (curry (S (S (S (S (S Z))))) f)
let gen_register0 root s f = gen_register root s (curry Z f)
let gen_register1 root s f = gen_register root s (curry (S Z) f)
let gen_register2 root s f = gen_register root s (curry (S (S Z)) f)
let gen_register3 root s f = gen_register root s (curry (S (S (S Z))) f)
let gen_register4 root s f = gen_register root s (curry (S (S (S (S Z)))) f)
let gen_register5 root s f =
gen_register root s (curry (S (S (S (S (S Z))))) f)
let lwt_register0 root s f = lwt_register root s (curry Z f)
let lwt_register1 root s f = lwt_register root s (curry (S Z) f)
let lwt_register2 root s f = lwt_register root s (curry (S (S Z)) f)
let lwt_register3 root s f = lwt_register root s (curry (S (S (S Z))) f)
let lwt_register4 root s f = lwt_register root s (curry (S (S (S (S Z)))) f)
let lwt_register5 root s f =
lwt_register root s (curry (S (S (S (S (S Z))))) f)
src/lib_rpc/RPC_directory.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
(* ❌ Structure item `include` not handled. *)
include
Definition gen_register {A B C D E : Type}
(dir : directory A)
(service : Service.t variant A B C D E Tezos_rpc.RPC_service.error)
(handler : B -> C -> D -> Lwt.t (Tezos_rpc.RPC_answer.t E)) : directory A :=
register dir service
(fun p =>
fun q =>
fun i =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
handler p q i)
(fun function_parameter =>
match function_parameter with
| OCaml.Not_found => RPC_answer.not_found
| exn =>
RPC_answer.fail
(cons (Tezos_error_monad.Error_monad.Exn exn) [])
end)).
Definition gen_register {A B C D E : Type}
: (directory A) ->
(Service.t variant A B C D E Tezos_rpc.RPC_service.error) ->
(B -> C -> D -> Lwt.t variant) -> directory A := gen_register.
Definition register {A B C D E : Type}
(dir : directory A)
(service : Service.t variant A B C D E Tezos_rpc.RPC_service.error)
(handler :
B -> C -> D -> Lwt.t (sum E (list Tezos_error_monad.Error_monad.error)))
: directory A :=
gen_register dir service
(fun p =>
fun q =>
fun i =>
op_gtgteq (handler p q i)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok o => RPC_answer._return o
| Stdlib.Error e => RPC_answer.fail e
end)).
Definition opt_register {A B C D E : Type}
(dir : directory A)
(service : Service.t variant A B C D E Tezos_rpc.RPC_service.error)
(handler :
B ->
C ->
D -> Lwt.t (sum (option E) (list Tezos_error_monad.Error_monad.error)))
: directory A :=
gen_register dir service
(fun p =>
fun q =>
fun i =>
op_gtgteq (handler p q i)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok (Some o) => RPC_answer._return o
| Stdlib.Ok None => RPC_answer.not_found
| Stdlib.Error e => RPC_answer.fail e
end)).
Definition lwt_register {A B C D E : Type}
(dir : directory A)
(service : Service.t variant A B C D E Tezos_rpc.RPC_service.error)
(handler : B -> C -> D -> Lwt.t E) : directory A :=
gen_register dir service
(fun p =>
fun q =>
fun i => op_gtgteq (handler p q i) (fun o => RPC_answer._return o)).
Import Curry.
Definition register0 {A B C D : Type}
(root : directory A)
(s : Service.t variant A unit B C D Tezos_rpc.RPC_service.error)
(f : B -> C -> Lwt.t (sum D (list Tezos_error_monad.Error_monad.error)))
: directory A := register root s (curry Curry.Z f).
Definition register1 {A B C D E : Type}
(root : directory A)
(s : Service.t variant A (unit * B) C D E Tezos_rpc.RPC_service.error)
(f : B -> C -> D -> Lwt.t (sum E (list Tezos_error_monad.Error_monad.error)))
: directory A := register root s (curry (Curry.S Curry.Z) f).
Definition register2 {A B C D E F : Type}
(root : directory A)
(s : Service.t variant A ((unit * B) * C) D E F Tezos_rpc.RPC_service.error)
(f :
B -> C -> D -> E -> Lwt.t (sum F (list Tezos_error_monad.Error_monad.error)))
: directory A := register root s (curry (Curry.S (Curry.S Curry.Z)) f).
Definition register3 {A B C D E F G : Type}
(root : directory A)
(s :
Service.t variant A (((unit * B) * C) * D) E F G Tezos_rpc.RPC_service.error)
(f :
B ->
C ->
D -> E -> F -> Lwt.t (sum G (list Tezos_error_monad.Error_monad.error)))
: directory A :=
register root s (curry (Curry.S (Curry.S (Curry.S Curry.Z))) f).
Definition register4 {A B C D E F G H : Type}
(root : directory A)
(s :
Service.t variant A ((((unit * B) * C) * D) * E) F G H
Tezos_rpc.RPC_service.error)
(f :
B ->
C ->
D ->
E ->
F -> G -> Lwt.t (sum H (list Tezos_error_monad.Error_monad.error)))
: directory A :=
register root s (curry (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z)))) f).
Definition register5 {A B C D E F G H I : Type}
(root : directory A)
(s :
Service.t variant A (((((unit * B) * C) * D) * E) * F) G H I
Tezos_rpc.RPC_service.error)
(f :
B ->
C ->
D ->
E ->
F ->
G -> H -> Lwt.t (sum I (list Tezos_error_monad.Error_monad.error)))
: directory A :=
register root s
(curry (Curry.S (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z))))) f).
Definition opt_register0 {A B C D : Type}
(root : directory A)
(s : Service.t variant A unit B C D Tezos_rpc.RPC_service.error)
(f :
B -> C -> Lwt.t (sum (option D) (list Tezos_error_monad.Error_monad.error)))
: directory A := opt_register root s (curry Curry.Z f).
Definition opt_register1 {A B C D E : Type}
(root : directory A)
(s : Service.t variant A (unit * B) C D E Tezos_rpc.RPC_service.error)
(f :
B ->
C ->
D -> Lwt.t (sum (option E) (list Tezos_error_monad.Error_monad.error)))
: directory A := opt_register root s (curry (Curry.S Curry.Z) f).
Definition opt_register2 {A B C D E F : Type}
(root : directory A)
(s : Service.t variant A ((unit * B) * C) D E F Tezos_rpc.RPC_service.error)
(f :
B ->
C ->
D ->
E -> Lwt.t (sum (option F) (list Tezos_error_monad.Error_monad.error)))
: directory A := opt_register root s (curry (Curry.S (Curry.S Curry.Z)) f).
Definition opt_register3 {A B C D E F G : Type}
(root : directory A)
(s :
Service.t variant A (((unit * B) * C) * D) E F G Tezos_rpc.RPC_service.error)
(f :
B ->
C ->
D ->
E ->
F ->
Lwt.t (sum (option G) (list Tezos_error_monad.Error_monad.error)))
: directory A :=
opt_register root s (curry (Curry.S (Curry.S (Curry.S Curry.Z))) f).
Definition opt_register4 {A B C D E F G H : Type}
(root : directory A)
(s :
Service.t variant A ((((unit * B) * C) * D) * E) F G H
Tezos_rpc.RPC_service.error)
(f :
B ->
C ->
D ->
E ->
F ->
G ->
Lwt.t
(sum (option H) (list Tezos_error_monad.Error_monad.error)))
: directory A :=
opt_register root s (curry (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z)))) f).
Definition opt_register5 {A B C D E F G H I : Type}
(root : directory A)
(s :
Service.t variant A (((((unit * B) * C) * D) * E) * F) G H I
Tezos_rpc.RPC_service.error)
(f :
B ->
C ->
D ->
E ->
F ->
G ->
H ->
Lwt.t
(sum (option I) (list Tezos_error_monad.Error_monad.error)))
: directory A :=
opt_register root s
(curry (Curry.S (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z))))) f).
Definition gen_register0 {A B C D : Type}
(root : directory A)
(s : Service.t variant A unit B C D Tezos_rpc.RPC_service.error)
(f : B -> C -> Lwt.t variant) : directory A :=
gen_register root s (curry Curry.Z f).
Definition gen_register1 {A B C D E : Type}
(root : directory A)
(s : Service.t variant A (unit * B) C D E Tezos_rpc.RPC_service.error)
(f : B -> C -> D -> Lwt.t variant) : directory A :=
gen_register root s (curry (Curry.S Curry.Z) f).
Definition gen_register2 {A B C D E F : Type}
(root : directory A)
(s : Service.t variant A ((unit * B) * C) D E F Tezos_rpc.RPC_service.error)
(f : B -> C -> D -> E -> Lwt.t variant) : directory A :=
gen_register root s (curry (Curry.S (Curry.S Curry.Z)) f).
Definition gen_register3 {A B C D E F G : Type}
(root : directory A)
(s :
Service.t variant A (((unit * B) * C) * D) E F G Tezos_rpc.RPC_service.error)
(f : B -> C -> D -> E -> F -> Lwt.t variant) : directory A :=
gen_register root s (curry (Curry.S (Curry.S (Curry.S Curry.Z))) f).
Definition gen_register4 {A B C D E F G H : Type}
(root : directory A)
(s :
Service.t variant A ((((unit * B) * C) * D) * E) F G H
Tezos_rpc.RPC_service.error)
(f : B -> C -> D -> E -> F -> G -> Lwt.t variant) : directory A :=
gen_register root s (curry (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z)))) f).
Definition gen_register5 {A B C D E F G H I : Type}
(root : directory A)
(s :
Service.t variant A (((((unit * B) * C) * D) * E) * F) G H I
Tezos_rpc.RPC_service.error)
(f : B -> C -> D -> E -> F -> G -> H -> Lwt.t variant) : directory A :=
gen_register root s
(curry (Curry.S (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z))))) f).
Definition lwt_register0 {A B C D : Type}
(root : directory A)
(s : Service.t variant A unit B C D Tezos_rpc.RPC_service.error)
(f : B -> C -> Lwt.t D) : directory A := lwt_register root s (curry Curry.Z f).
Definition lwt_register1 {A B C D E : Type}
(root : directory A)
(s : Service.t variant A (unit * B) C D E Tezos_rpc.RPC_service.error)
(f : B -> C -> D -> Lwt.t E) : directory A :=
lwt_register root s (curry (Curry.S Curry.Z) f).
Definition lwt_register2 {A B C D E F : Type}
(root : directory A)
(s : Service.t variant A ((unit * B) * C) D E F Tezos_rpc.RPC_service.error)
(f : B -> C -> D -> E -> Lwt.t F) : directory A :=
lwt_register root s (curry (Curry.S (Curry.S Curry.Z)) f).
Definition lwt_register3 {A B C D E F G : Type}
(root : directory A)
(s :
Service.t variant A (((unit * B) * C) * D) E F G Tezos_rpc.RPC_service.error)
(f : B -> C -> D -> E -> F -> Lwt.t G) : directory A :=
lwt_register root s (curry (Curry.S (Curry.S (Curry.S Curry.Z))) f).
Definition lwt_register4 {A B C D E F G H : Type}
(root : directory A)
(s :
Service.t variant A ((((unit * B) * C) * D) * E) F G H
Tezos_rpc.RPC_service.error) (f : B -> C -> D -> E -> F -> G -> Lwt.t H)
: directory A :=
lwt_register root s (curry (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z)))) f).
Definition lwt_register5 {A B C D E F G H I : Type}
(root : directory A)
(s :
Service.t variant A (((((unit * B) * C) * D) * E) * F) G H I
Tezos_rpc.RPC_service.error)
(f : B -> C -> D -> E -> F -> G -> H -> Lwt.t I) : directory A :=
lwt_register root s
(curry (Curry.S (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z))))) f).
src/lib_rpc/RPC_encoding.ml 29 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type 'a t = 'a Data_encoding.t
type schema = Data_encoding.json_schema * Data_encoding.Binary_schema.t
let unit = Data_encoding.empty
let untyped = Data_encoding.(obj1 (req "untyped" string))
let conv f g t = Data_encoding.conv ~schema:(Data_encoding.Json.schema t) f g t
let schema ?definitions_path t =
( Data_encoding.Json.schema ?definitions_path t,
Data_encoding.Binary.describe t )
let schema_encoding =
let open Data_encoding in
obj2
(req "json_schema" json_schema)
(req "binary_schema" Data_encoding.Binary_schema.encoding)
module StringMap = Resto.StringMap
let arg_encoding =
let open Data_encoding in
conv
(fun {Resto.Arg.name; descr} -> ((), name, descr))
(fun ((), name, descr) -> {name; descr})
(obj3
(req "id" (constant "single"))
(req "name" string)
(opt "descr" string))
let multi_arg_encoding =
let open Data_encoding in
conv
(fun {Resto.Arg.name; descr} -> ((), name, descr))
(fun ((), name, descr) -> {name; descr})
(obj3
(req "id" (constant "multiple"))
(req "name" string)
(opt "descr" string))
open Resto.Description
let meth_encoding =
Data_encoding.string_enum
[ ("GET", `GET);
("POST", `POST);
("DELETE", `DELETE);
("PUT", `PUT);
("PATCH", `PATCH) ]
let path_item_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
string
~title:"PStatic"
(function PStatic s -> Some s | _ -> None)
(fun s -> PStatic s);
case
(Tag 1)
arg_encoding
~title:"PDynamic"
(function PDynamic s -> Some s | _ -> None)
(fun s -> PDynamic s);
case
(Tag 2)
multi_arg_encoding
~title:"PDynamicTail"
(function PDynamicTail s -> Some s | _ -> None)
(fun s -> PDynamicTail s) ]
let query_kind_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Single"
(obj1 (req "single" arg_encoding))
(function Single s -> Some s | _ -> None)
(fun s -> Single s);
case
(Tag 1)
~title:"Optional"
(obj1 (req "optional" arg_encoding))
(function Optional s -> Some s | _ -> None)
(fun s -> Optional s);
case
(Tag 2)
~title:"Flag"
(obj1 (req "flag" empty))
(function Flag -> Some () | _ -> None)
(fun () -> Flag);
case
(Tag 3)
~title:"Multi"
(obj1 (req "multi" arg_encoding))
(function Multi s -> Some s | _ -> None)
(fun s -> Multi s) ]
let query_item_encoding =
let open Data_encoding in
conv
(fun {name; description; kind} -> (name, description, kind))
(fun (name, description, kind) -> {name; description; kind})
(obj3
(req "name" string)
(opt "description" string)
(req "kind" query_kind_encoding))
let service_descr_encoding =
let open Data_encoding in
conv
(fun {meth; path; description; query; input; output; error} ->
(meth, path, description, query, input, output, error))
(fun (meth, path, description, query, input, output, error) ->
{meth; path; description; query; input; output; error})
(obj7
(req "meth" meth_encoding)
(req "path" (list path_item_encoding))
(opt "description" string)
(req "query" (list query_item_encoding))
(opt "input" schema_encoding)
(req "output" schema_encoding)
(req "error" schema_encoding))
let directory_descr_encoding =
let open Data_encoding in
mu "service_tree"
@@ fun directory_descr_encoding ->
let static_subdirectories_descr_encoding =
union
[ case
(Tag 0)
~title:"Suffixes"
(obj1
(req
"suffixes"
(list
(obj2
(req "name" string)
(req "tree" directory_descr_encoding)))))
(function
| Suffixes map -> Some (StringMap.bindings map) | _ -> None)
(fun m ->
let add acc (n, t) = StringMap.add n t acc in
Suffixes (List.fold_left add StringMap.empty m));
case
(Tag 1)
~title:"Arg"
(obj1
(req
"dynamic_dispatch"
(obj2
(req "arg" arg_encoding)
(req "tree" directory_descr_encoding))))
(function Arg (ty, tree) -> Some (ty, tree) | _ -> None)
(fun (ty, tree) -> Arg (ty, tree)) ]
in
let static_directory_descr_encoding =
conv
(fun {services; subdirs} ->
let find s =
try Some (Resto.MethMap.find s services) with Not_found -> None
in
(find `GET, find `POST, find `DELETE, find `PUT, find `PATCH, subdirs))
(fun (get, post, delete, put, patch, subdirs) ->
let add meth s services =
match s with
| None ->
services
| Some s ->
Resto.MethMap.add meth s services
in
let services =
Resto.MethMap.empty
|> add `GET get
|> add `POST post
|> add `DELETE delete
|> add `PUT put
|> add `PATCH patch
in
{services; subdirs})
(obj6
(opt "get_service" service_descr_encoding)
(opt "post_service" service_descr_encoding)
(opt "delete_service" service_descr_encoding)
(opt "put_service" service_descr_encoding)
(opt "patch_service" service_descr_encoding)
(opt "subdirs" static_subdirectories_descr_encoding))
in
union
[ case
(Tag 0)
~title:"Static"
(obj1 (req "static" static_directory_descr_encoding))
(function Static descr -> Some descr | _ -> None)
(fun descr -> Static descr);
case
(Tag 1)
~title:"Dynamic"
(obj1 (req "dynamic" (option string)))
(function Dynamic descr -> Some descr | _ -> None)
(fun descr -> Dynamic descr) ]
let description_request_encoding =
let open Data_encoding in
conv
(fun {recurse} -> recurse)
(function recurse -> {recurse})
(obj1 (dft "recursive" bool false))
let description_answer_encoding = directory_descr_encoding
let uri_encoding =
let open Data_encoding in
conv Uri.to_string Uri.of_string string
src/lib_rpc/RPC_encoding.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t (a : Type) := Tezos_data_encoding.Data_encoding.t a.
Definition schema :=
Tezos_data_encoding.Data_encoding.json_schema *
Tezos_data_encoding.Data_encoding.Binary_schema.t.
Definition unit : Tezos_data_encoding.Data_encoding.encoding unit :=
Data_encoding.empty.
Definition untyped : Tezos_data_encoding.Data_encoding.encoding string :=
obj1 (req None None "untyped" % string string).
Definition conv {A B : Type}
(f : A -> B) (g : B -> A)
(t : Tezos_data_encoding__Data_encoding.Encoding.t B)
: Tezos_data_encoding.Data_encoding.encoding A :=
Data_encoding.conv f g (Some (Data_encoding.Json.schema None t)) t.
Definition schema {A : Type}
(definitions_path : option string)
(t : Tezos_data_encoding__Data_encoding.Encoding.t A)
: Tezos_data_encoding.Data_encoding.Json.schema *
Tezos_data_encoding__Data_encoding.Binary_schema.t :=
((Data_encoding.Json.schema definitions_path t),
(Data_encoding.Binary.describe t)).
Definition schema_encoding
: Tezos_data_encoding.Data_encoding.encoding
(Tezos_data_encoding.Data_encoding.json_schema *
Tezos_data_encoding.Data_encoding.Binary_schema.t) :=
obj2 (req None None "json_schema" % string json_schema)
(req None None "binary_schema" % string Data_encoding.Binary_schema.encoding).
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition arg_encoding
: Tezos_data_encoding.Data_encoding.encoding Resto.Arg.descr :=
conv
(fun function_parameter =>
let '{| Resto.Arg.name := name; Resto.Arg.descr := descr |} :=
function_parameter in
(tt, name, descr))
(fun function_parameter =>
let '(tt, name, descr) := function_parameter in
{| name := name; descr := descr |}) None
(obj3 (req None None "id" % string (constant "single" % string))
(req None None "name" % string string)
(opt None None "descr" % string string)).
Definition multi_arg_encoding
: Tezos_data_encoding.Data_encoding.encoding Resto.Arg.descr :=
conv
(fun function_parameter =>
let '{| Resto.Arg.name := name; Resto.Arg.descr := descr |} :=
function_parameter in
(tt, name, descr))
(fun function_parameter =>
let '(tt, name, descr) := function_parameter in
{| name := name; descr := descr |}) None
(obj3 (req None None "id" % string (constant "multiple" % string))
(req None None "name" % string string)
(opt None None "descr" % string string)).
Import Resto.Description.
Definition meth_encoding : Tezos_data_encoding.Data_encoding.encoding variant :=
Data_encoding.string_enum
(cons
("GET" % string,
(* ❌ Variants not supported *)
variant)
(cons
("POST" % string,
(* ❌ Variants not supported *)
variant)
(cons
("DELETE" % string,
(* ❌ Variants not supported *)
variant)
(cons
("PUT" % string,
(* ❌ Variants not supported *)
variant)
(cons
("PATCH" % string,
(* ❌ Variants not supported *)
variant) []))))).
Definition path_item_encoding
: Tezos_data_encoding.Data_encoding.encoding Resto.Description.path_item :=
union None
(cons
(case "PStatic" % string None (Tezos_data_encoding.Data_encoding.Tag 0)
string
(fun function_parameter =>
match function_parameter with
| Resto.Description.PStatic s => Some s
| _ => None
end) (fun s => Resto.Description.PStatic s))
(cons
(case "PDynamic" % string None (Tezos_data_encoding.Data_encoding.Tag 1)
arg_encoding
(fun function_parameter =>
match function_parameter with
| Resto.Description.PDynamic s => Some s
| _ => None
end) (fun s => Resto.Description.PDynamic s))
(cons
(case "PDynamicTail" % string None
(Tezos_data_encoding.Data_encoding.Tag 2) multi_arg_encoding
(fun function_parameter =>
match function_parameter with
| Resto.Description.PDynamicTail s => Some s
| _ => None
end) (fun s => Resto.Description.PDynamicTail s)) []))).
Definition query_kind_encoding
: Tezos_data_encoding.Data_encoding.encoding Resto.Description.query_kind :=
union None
(cons
(case "Single" % string None (Tezos_data_encoding.Data_encoding.Tag 0)
(obj1 (req None None "single" % string arg_encoding))
(fun function_parameter =>
match function_parameter with
| Resto.Description.Single s => Some s
| _ => None
end) (fun s => Resto.Description.Single s))
(cons
(case "Optional" % string None (Tezos_data_encoding.Data_encoding.Tag 1)
(obj1 (req None None "optional" % string arg_encoding))
(fun function_parameter =>
match function_parameter with
| Resto.Description.Optional s => Some s
| _ => None
end) (fun s => Resto.Description.Optional s))
(cons
(case "Flag" % string None (Tezos_data_encoding.Data_encoding.Tag 2)
(obj1 (req None None "flag" % string empty))
(fun function_parameter =>
match function_parameter with
| Resto.Description.Flag => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Resto.Description.Flag))
(cons
(case "Multi" % string None
(Tezos_data_encoding.Data_encoding.Tag 3)
(obj1 (req None None "multi" % string arg_encoding))
(fun function_parameter =>
match function_parameter with
| Resto.Description.Multi s => Some s
| _ => None
end) (fun s => Resto.Description.Multi s)) [])))).
Definition query_item_encoding
: Tezos_data_encoding.Data_encoding.encoding Resto.Description.query_item :=
conv
(fun function_parameter =>
let '{| name := name; description := description; kind := kind |} :=
function_parameter in
(name, description, kind))
(fun function_parameter =>
let '(name, description, kind) := function_parameter in
{| name := name; description := description; kind := kind |}) None
(obj3 (req None None "name" % string string)
(opt None None "description" % string string)
(req None None "kind" % string query_kind_encoding)).
Definition service_descr_encoding
: Tezos_data_encoding.Data_encoding.encoding
(Resto.Description.service
(Tezos_data_encoding.Data_encoding.json_schema *
Tezos_data_encoding.Data_encoding.Binary_schema.t)) :=
conv
(fun function_parameter =>
let '{|
description := description;
path := path;
meth := meth;
query := query;
input := input;
output := output;
error := error
|} := function_parameter in
(meth, path, description, query, input, output, error))
(fun function_parameter =>
let '(meth, path, description, query, input, output, error) :=
function_parameter in
{| description := description; path := path; meth := meth; query := query;
input := input; output := output; error := error |}) None
(obj7 (req None None "meth" % string meth_encoding)
(req None None "path" % string (list None path_item_encoding))
(opt None None "description" % string string)
(req None None "query" % string (list None query_item_encoding))
(opt None None "input" % string schema_encoding)
(req None None "output" % string schema_encoding)
(req None None "error" % string schema_encoding)).
Definition directory_descr_encoding
: Tezos_data_encoding.Data_encoding.encoding
(Resto.Description.directory
(Tezos_data_encoding.Data_encoding.json_schema *
Tezos_data_encoding.Data_encoding.Binary_schema.t)) :=
apply
(let arg := mu "service_tree" % string in
fun eta => arg None None eta)
(fun directory_descr_encoding =>
let static_subdirectories_descr_encoding :=
union None
(cons
(case "Suffixes" % string None
(Tezos_data_encoding.Data_encoding.Tag 0)
(obj1
(req None None "suffixes" % string
(list None
(obj2 (req None None "name" % string string)
(req None None "tree" % string directory_descr_encoding)))))
(fun function_parameter =>
match function_parameter with
| Resto.Description.Suffixes map =>
Some (StringMap.bindings map)
| _ => None
end)
(fun m =>
let add {A : Type}
(acc : StringMap.t A) (function_parameter : StringMap.key * A)
: StringMap.t A :=
let '(n, t) := function_parameter in
StringMap.add n t acc in
Resto.Description.Suffixes
(Stdlib.List.fold_left add StringMap.empty m)))
(cons
(case "Arg" % string None
(Tezos_data_encoding.Data_encoding.Tag 1)
(obj1
(req None None "dynamic_dispatch" % string
(obj2 (req None None "arg" % string arg_encoding)
(req None None "tree" % string directory_descr_encoding))))
(fun function_parameter =>
match function_parameter with
| Resto.Description.Arg ty tree => Some (ty, tree)
| _ => None
end)
(fun function_parameter =>
let '(ty, tree) := function_parameter in
Resto.Description.Arg ty tree)) [])) in
let static_directory_descr_encoding :=
conv
(fun function_parameter =>
let '{| services := services; subdirs := subdirs |} :=
function_parameter in
let find (s : Resto.MethMap.(Stdlib__map.S.key))
: option
(Resto.Description.service
(Tezos_data_encoding.Data_encoding.json_schema *
Tezos_data_encoding.Data_encoding.Binary_schema.t)) :=
(* ❌ Try-with are not handled *)
try (Some (Resto.MethMap.(Stdlib__map.S.find) s services)) in
((find
(* ❌ Variants not supported *)
variant),
(find
(* ❌ Variants not supported *)
variant),
(find
(* ❌ Variants not supported *)
variant),
(find
(* ❌ Variants not supported *)
variant),
(find
(* ❌ Variants not supported *)
variant), subdirs))
(fun function_parameter =>
let '(get, post, delete, put, patch, subdirs) := function_parameter
in
let add {A : Type}
(meth : Resto.MethMap.(Stdlib__map.S.key)) (s : option A)
(services : Resto.MethMap.(Stdlib__map.S.t) A)
: Resto.MethMap.(Stdlib__map.S.t) A :=
match s with
| None => services
| Some s => Resto.MethMap.(Stdlib__map.S.add) meth s services
end in
let services :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
Resto.MethMap.(Stdlib__map.S.empty)
(add
(* ❌ Variants not supported *)
variant get))
(add
(* ❌ Variants not supported *)
variant post))
(add
(* ❌ Variants not supported *)
variant delete))
(add
(* ❌ Variants not supported *)
variant put))
(add
(* ❌ Variants not supported *)
variant patch) in
{| services := services; subdirs := subdirs |}) None
(obj6 (opt None None "get_service" % string service_descr_encoding)
(opt None None "post_service" % string service_descr_encoding)
(opt None None "delete_service" % string service_descr_encoding)
(opt None None "put_service" % string service_descr_encoding)
(opt None None "patch_service" % string service_descr_encoding)
(opt None None "subdirs" % string
static_subdirectories_descr_encoding)) in
union None
(cons
(case "Static" % string None (Tezos_data_encoding.Data_encoding.Tag 0)
(obj1
(req None None "static" % string static_directory_descr_encoding))
(fun function_parameter =>
match function_parameter with
| Resto.Description.Static descr => Some descr
| _ => None
end) (fun descr => Resto.Description.Static descr))
(cons
(case "Dynamic" % string None
(Tezos_data_encoding.Data_encoding.Tag 1)
(obj1 (req None None "dynamic" % string (option string)))
(fun function_parameter =>
match function_parameter with
| Resto.Description.Dynamic descr => Some descr
| _ => None
end) (fun descr => Resto.Description.Dynamic descr)) []))).
Definition description_request_encoding
: Tezos_data_encoding.Data_encoding.encoding Resto.Description.request :=
conv
(fun function_parameter =>
let '{| recurse := recurse |} := function_parameter in
recurse) (fun recurse => {| recurse := recurse |}) None
(obj1 (dft None None "recursive" % string bool false)).
Definition description_answer_encoding
: Tezos_data_encoding.Data_encoding.encoding
(Resto.Description.directory
(Tezos_data_encoding.Data_encoding.json_schema *
Tezos_data_encoding.Data_encoding.Binary_schema.t)) :=
directory_descr_encoding.
Definition uri_encoding : Tezos_data_encoding.Data_encoding.encoding Uri.t :=
conv Uri.to_string Uri.of_string None string.
src/lib_rpc/RPC_error.ml 4 errors
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) let list ctxt = RPC_context.make_call RPC_service.error_service ctxt () () () let encoding = RPC_service.error_encoding
src/lib_rpc/RPC_error.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition list {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult Json_schema.schema) :=
RPC_context.make_call RPC_service.error_service ctxt tt tt tt.
Definition encoding
: Tezos_data_encoding.Data_encoding.t Tezos_rpc.RPC_service.error :=
RPC_service.error_encoding.
src/lib_rpc/RPC_path.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Resto.Path
src/lib_rpc/RPC_path.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/lib_rpc/RPC_query.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Resto.Query
src/lib_rpc/RPC_query.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/lib_rpc_http/RPC_client.ml 10 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type S = sig
module type LOGGER = sig
type request
val log_empty_request : Uri.t -> request Lwt.t
val log_request :
?media:Media_type.t ->
'a Data_encoding.t ->
Uri.t ->
string ->
request Lwt.t
val log_response :
request ->
?media:Media_type.t ->
'a Data_encoding.t ->
Cohttp.Code.status_code ->
string Lwt.t Lazy.t ->
unit Lwt.t
end
type logger = (module LOGGER)
val null_logger : logger
val timings_logger :
gettimeofday:(unit -> float) -> Format.formatter -> logger
val full_logger : Format.formatter -> logger
type config = {host : string; port : int; tls : bool; logger : logger}
val config_encoding : config Data_encoding.t
val default_config : config
class http_ctxt : config -> Media_type.t list -> RPC_context.json
(**/**)
val call_service :
Media_type.t list ->
?logger:logger ->
?headers:(string * string) list ->
base:Uri.t ->
([< Resto.meth], unit, 'p, 'q, 'i, 'o) RPC_service.t ->
'p ->
'q ->
'i ->
'o tzresult Lwt.t
val call_streamed_service :
Media_type.t list ->
?logger:logger ->
?headers:(string * string) list ->
base:Uri.t ->
([< Resto.meth], unit, 'p, 'q, 'i, 'o) RPC_service.t ->
on_chunk:('o -> unit) ->
on_close:(unit -> unit) ->
'p ->
'q ->
'i ->
(unit -> unit) tzresult Lwt.t
val generic_json_call :
?headers:(string * string) list ->
?body:Data_encoding.json ->
[< RPC_service.meth] ->
Uri.t ->
(Data_encoding.json, Data_encoding.json option) RPC_context.rest_result
Lwt.t
type content_type = string * string
type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option
val generic_call :
?headers:(string * string) list ->
?accept:Media_type.t list ->
?body:Cohttp_lwt.Body.t ->
?media:Media_type.t ->
[< RPC_service.meth] ->
Uri.t ->
(content, content) RPC_context.rest_result Lwt.t
end
module Make (Client : Cohttp_lwt.S.Client) = struct
module Client = Resto_cohttp_client.Client.Make (RPC_encoding) (Client)
module type LOGGER = Client.LOGGER
type logger = (module LOGGER)
let null_logger = Client.null_logger
let timings_logger = Client.timings_logger
let full_logger = Client.full_logger
type content_type = string * string
type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option
let request_failed meth uri error =
let meth = (meth : [< RPC_service.meth] :> RPC_service.meth) in
fail (RPC_client_errors.Request_failed {meth; uri; error})
let generic_call ?headers ?accept ?body ?media meth uri :
(content, content) RPC_context.rest_result Lwt.t =
Client.generic_call meth ?headers ?accept ?body ?media uri
>>= function
| `Ok (Some v) ->
return (`Ok v)
| `Ok None ->
request_failed meth uri Empty_answer
| (`Conflict _ | `Error _ | `Forbidden _ | `Unauthorized _ | `Not_found _)
as v ->
return v
| `Unexpected_status_code (code, (content, _, media_type)) ->
let media_type = Option.map media_type ~f:Media_type.name in
Cohttp_lwt.Body.to_string content
>>= fun content ->
request_failed
meth
uri
(Unexpected_status_code {code; content; media_type})
| `Method_not_allowed allowed ->
let allowed = List.filter_map RPC_service.meth_of_string allowed in
request_failed meth uri (Method_not_allowed allowed)
| `Unsupported_media_type ->
let media = Option.map media ~f:Media_type.name in
request_failed meth uri (Unsupported_media_type media)
| `Not_acceptable acceptable ->
let proposed =
Option.unopt_map accept ~default:"" ~f:Media_type.accept_header
in
request_failed meth uri (Not_acceptable {proposed; acceptable})
| `Bad_request msg ->
request_failed meth uri (Bad_request msg)
| `Connection_failed msg ->
request_failed meth uri (Connection_failed msg)
| `OCaml_exception msg ->
request_failed meth uri (OCaml_exception msg)
| `Unauthorized_host host ->
request_failed meth uri (Unauthorized_host host)
let handle_error meth uri (body, media, _) f =
Cohttp_lwt.Body.is_empty body
>>= fun empty ->
if empty then return (f None)
else
match media with
| Some ("application", "json") | None -> (
Cohttp_lwt.Body.to_string body
>>= fun body ->
match Data_encoding.Json.from_string body with
| Ok body ->
return (f (Some body))
| Error msg ->
request_failed
meth
uri
(Unexpected_content
{
content = body;
media_type = Media_type.(name json);
error = msg;
}) )
| Some (l, r) ->
Cohttp_lwt.Body.to_string body
>>= fun body ->
request_failed
meth
uri
(Unexpected_content_type
{
received = l ^ "/" ^ r;
acceptable = [Media_type.(name json)];
body;
})
let generic_json_call ?headers ?body meth uri :
(Data_encoding.json, Data_encoding.json option) RPC_context.rest_result
Lwt.t =
let body =
Option.map body ~f:(fun b ->
Cohttp_lwt.Body.of_string (Data_encoding.Json.to_string b))
in
let media = Media_type.json in
generic_call meth ?headers ~accept:Media_type.[bson; json] ?body ~media uri
>>=? function
| `Ok (body, (Some ("application", "json") | None), _) -> (
Cohttp_lwt.Body.to_string body
>>= fun body ->
match Data_encoding.Json.from_string body with
| Ok json ->
return (`Ok json)
| Error msg ->
request_failed
meth
uri
(Unexpected_content
{
content = body;
media_type = Media_type.(name json);
error = msg;
}) )
| `Ok (body, Some ("application", "bson"), _) -> (
Cohttp_lwt.Body.to_string body
>>= fun body ->
match
Json_repr_bson.bytes_to_bson
~laziness:false
~copy:false
(Bytes.unsafe_of_string body)
with
| exception Json_repr_bson.Bson_decoding_error (msg, _, pos) ->
let error = Format.asprintf "(at offset: %d) %s" pos msg in
request_failed
meth
uri
(Unexpected_content
{content = body; media_type = Media_type.(name bson); error})
| bson ->
return
(`Ok
(Json_repr.convert
(module Json_repr_bson.Repr)
(module Json_repr.Ezjsonm)
bson)) )
| `Ok (body, Some (l, r), _) ->
Cohttp_lwt.Body.to_string body
>>= fun body ->
request_failed
meth
uri
(Unexpected_content_type
{
received = l ^ "/" ^ r;
acceptable = [Media_type.(name json)];
body;
})
| `Conflict body ->
handle_error meth uri body (fun v -> `Conflict v)
| `Error body ->
handle_error meth uri body (fun v -> `Error v)
| `Forbidden body ->
handle_error meth uri body (fun v -> `Forbidden v)
| `Not_found body ->
handle_error meth uri body (fun v -> `Not_found v)
| `Unauthorized body ->
handle_error meth uri body (fun v -> `Unauthorized v)
let handle accept (meth, uri, ans) =
match ans with
| `Ok (Some v) ->
return v
| `Ok None ->
request_failed meth uri Empty_answer
| `Not_found None ->
fail (RPC_context.Not_found {meth; uri})
| `Conflict (Some err)
| `Error (Some err)
| `Forbidden (Some err)
| `Unauthorized (Some err)
| `Not_found (Some err) ->
Lwt.return_error err
| `Conflict None | `Error None | `Forbidden None | `Unauthorized None ->
fail (RPC_context.Generic_error {meth; uri})
| `Unexpected_status_code (code, (content, _, media_type)) ->
let media_type = Option.map media_type ~f:Media_type.name in
Cohttp_lwt.Body.to_string content
>>= fun content ->
request_failed
meth
uri
(Unexpected_status_code {code; content; media_type})
| `Method_not_allowed allowed ->
let allowed = List.filter_map RPC_service.meth_of_string allowed in
request_failed meth uri (Method_not_allowed allowed)
| `Unsupported_media_type ->
let name =
match Media_type.first_complete_media accept with
| None ->
None
| Some ((l, r), _) ->
Some (l ^ "/" ^ r)
in
request_failed meth uri (Unsupported_media_type name)
| `Not_acceptable acceptable ->
let proposed =
Option.unopt_map
(Some accept)
~default:""
~f:Media_type.accept_header
in
request_failed meth uri (Not_acceptable {proposed; acceptable})
| `Bad_request msg ->
request_failed meth uri (Bad_request msg)
| `Unexpected_content ((content, media_type), error)
| `Unexpected_error_content ((content, media_type), error) ->
let media_type = Media_type.name media_type in
request_failed
meth
uri
(Unexpected_content {content; media_type; error})
| `Unexpected_error_content_type (body, media)
| `Unexpected_content_type (body, media) ->
Cohttp_lwt.Body.to_string body
>>= fun body ->
let received =
Option.unopt_map media ~default:"" ~f:(fun (l, r) -> l ^ "/" ^ r)
in
request_failed
meth
uri
(Unexpected_content_type
{received; acceptable = List.map Media_type.name accept; body})
| `Connection_failed msg ->
request_failed meth uri (Connection_failed msg)
| `OCaml_exception msg ->
request_failed meth uri (OCaml_exception msg)
| `Unauthorized_host host ->
request_failed meth uri (Unauthorized_host host)
let call_streamed_service (type p q i o) accept ?logger ?headers ~base
(service : (_, _, p, q, i, o) RPC_service.t) ~on_chunk ~on_close
(params : p) (query : q) (body : i) : (unit -> unit) tzresult Lwt.t =
Client.call_streamed_service
accept
?logger
?headers
~base
~on_chunk
~on_close
service
params
query
body
>>= fun ans -> handle accept ans
let call_service (type p q i o) accept ?logger ?headers ~base
(service : (_, _, p, q, i, o) RPC_service.t) (params : p) (query : q)
(body : i) : o tzresult Lwt.t =
Client.call_service ?logger ?headers ~base accept service params query body
>>= fun ans -> handle accept ans
type config = {host : string; port : int; tls : bool; logger : logger}
let config_encoding =
let open Data_encoding in
conv
(fun {host; port; tls; logger = _} -> (host, port, tls))
(fun (host, port, tls) -> {host; port; tls; logger = null_logger})
(obj3 (req "host" string) (req "port" uint16) (req "tls" bool))
let default_config =
{host = "localhost"; port = 8732; tls = false; logger = null_logger}
class http_ctxt config media_types : RPC_context.json =
let base =
Uri.make
~scheme:(if config.tls then "https" else "http")
~host:config.host
~port:config.port
()
in
let logger = config.logger in
object
method generic_json_call meth ?body uri =
let path = Uri.path uri and query = Uri.query uri in
let uri = Uri.with_path base path in
let uri = Uri.with_query uri query in
generic_json_call meth ?body uri
method call_service
: 'm 'p 'q 'i 'o.
(([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t ->
'p -> 'q -> 'i -> 'o tzresult Lwt.t =
fun service params query body ->
call_service media_types ~logger ~base service params query body
method call_streamed_service
: 'm 'p 'q 'i 'o.
(([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t ->
on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q ->
'i -> (unit -> unit) tzresult Lwt.t =
fun service ~on_chunk ~on_close params query body ->
call_streamed_service
media_types
service
~logger
~base
~on_chunk
~on_close
params
query
body
method base = base
end
end
src/lib_rpc_http/RPC_client.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module S.
Record signature {config : Type} := {
module_type;
logger := {request : _ & LOGGER.signature request};
null_logger : logger;
timings_logger : (unit -> Z) -> Stdlib.Format.formatter -> logger;
full_logger : Stdlib.Format.formatter -> logger;
config := config;
config_encoding : Tezos_base__TzPervasives.Data_encoding.t config;
default_config : config;
class;
call_service : forall {i o p q variant : Type}, (list
Tezos_rpc_http.Media_type.t) ->
(option logger) ->
(option (list (string * string))) ->
Uri.t ->
(Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o);
call_streamed_service : forall {i o p q variant : Type}, (list
Tezos_rpc_http.Media_type.t) ->
(option logger) ->
(option (list (string * string))) ->
Uri.t ->
(Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t (Tezos_base__TzPervasives.tzresult (unit -> unit));
generic_json_call : forall {variant : Type}, (option
(list (string * string))) ->
(option Tezos_base__TzPervasives.Data_encoding.json) ->
variant ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_base__TzPervasives.Data_encoding.json
(option Tezos_base__TzPervasives.Data_encoding.json));
content_type := string * string;
content := Cohttp_lwt.Body.t * (option content_type) *
(option Tezos_rpc_http.Media_type.t);
generic_call : forall {variant : Type}, (option (list (string * string))) ->
(option (list Tezos_rpc_http.Media_type.t)) ->
(option Cohttp_lwt.Body.t) ->
(option Tezos_rpc_http.Media_type.t) ->
variant ->
Uri.t -> Lwt.t (Tezos_rpc.RPC_context.rest_result content content);
}.
Arguments signature : clear implicits.
End S.
(* ❌ Functors are not handled. *)
functor
src/lib_rpc_http/RPC_client_errors.ml 6 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type rpc_error =
| Empty_answer
| Connection_failed of string
| Bad_request of string
| Method_not_allowed of RPC_service.meth list
| Unsupported_media_type of string option
| Not_acceptable of {proposed : string; acceptable : string}
| Unexpected_status_code of {
code : Cohttp.Code.status_code;
content : string;
media_type : string option;
}
| Unexpected_content_type of {
received : string;
acceptable : string list;
body : string;
}
| Unexpected_content of {
content : string;
media_type : string;
error : string;
}
| OCaml_exception of string
| Unauthorized_host of string option
type error +=
| Request_failed of {meth : RPC_service.meth; uri : Uri.t; error : rpc_error}
let rpc_error_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Empty_answer"
(obj1 (req "kind" (constant "empty_answer")))
(function Empty_answer -> Some () | _ -> None)
(fun () -> Empty_answer);
case
(Tag 1)
~title:"Connection_failed"
(obj2
(req "kind" (constant "connection_failed"))
(req "message" string))
(function Connection_failed msg -> Some ((), msg) | _ -> None)
(function ((), msg) -> Connection_failed msg);
case
(Tag 2)
~title:"Bad_request"
(obj2 (req "kind" (constant "bad_request")) (req "message" string))
(function Bad_request msg -> Some ((), msg) | _ -> None)
(function ((), msg) -> Bad_request msg);
case
(Tag 3)
~title:"Method_not_allowed"
(obj2
(req "kind" (constant "method_not_allowed"))
(req "allowed" (list RPC_service.meth_encoding)))
(function Method_not_allowed meths -> Some ((), meths) | _ -> None)
(function ((), meths) -> Method_not_allowed meths);
case
(Tag 4)
~title:"Unsupported_media_type"
(obj2
(req "kind" (constant "unsupported_media_type"))
(opt "content_type" string))
(function Unsupported_media_type m -> Some ((), m) | _ -> None)
(function ((), m) -> Unsupported_media_type m);
case
(Tag 5)
~title:"Not_acceptable"
(obj3
(req "kind" (constant "not_acceptable"))
(req "proposed" string)
(req "acceptable" string))
(function
| Not_acceptable {proposed; acceptable} ->
Some ((), proposed, acceptable)
| _ ->
None)
(function
| ((), proposed, acceptable) -> Not_acceptable {proposed; acceptable});
case
(Tag 6)
~title:"Unexpected_status_code"
(obj4
(req "kind" (constant "unexpected_status_code"))
(req "code" uint16)
(req "content" string)
(opt "media_type" string))
(function
| Unexpected_status_code {code; content; media_type} ->
Some ((), Cohttp.Code.code_of_status code, content, media_type)
| _ ->
None)
(function
| ((), code, content, media_type) ->
let code = Cohttp.Code.status_of_code code in
Unexpected_status_code {code; content; media_type});
case
(Tag 7)
~title:"Unexpected_content_type"
(obj4
(req "kind" (constant "unexpected_content_type"))
(req "received" string)
(req "acceptable" (list string))
(req "body" string))
(function
| Unexpected_content_type {received; acceptable; body} ->
Some ((), received, acceptable, body)
| _ ->
None)
(function
| ((), received, acceptable, body) ->
Unexpected_content_type {received; acceptable; body});
case
(Tag 8)
~title:"Unexpected_content"
(obj4
(req "kind" (constant "unexpected_content"))
(req "content" string)
(req "media_type" string)
(req "error" string))
(function
| Unexpected_content {content; media_type; error} ->
Some ((), content, media_type, error)
| _ ->
None)
(function
| ((), content, media_type, error) ->
Unexpected_content {content; media_type; error});
case
(Tag 9)
~title:"OCaml_exception"
(obj2 (req "kind" (constant "ocaml_exception")) (req "content" string))
(function OCaml_exception msg -> Some ((), msg) | _ -> None)
(function ((), msg) -> OCaml_exception msg) ]
let pp_rpc_error ppf err =
match err with
| Empty_answer ->
Format.fprintf ppf "The server answered with an empty response."
| Connection_failed msg ->
Format.fprintf ppf "Unable to connect to the node: \"%s\"" msg
| Bad_request msg ->
Format.fprintf
ppf
"@[<v 2>Oups! It looks like we forged an invalid HTTP request.@,%s@]"
msg
| Method_not_allowed meths ->
Format.fprintf
ppf
"@[<v 2>The requested service only accepts the following method:@ %a@]"
(Format.pp_print_list (fun ppf m ->
Format.pp_print_string ppf (RPC_service.string_of_meth m)))
meths
| Unsupported_media_type None ->
Format.fprintf
ppf
"@[<v 2>The server wants to known the media type we used.@]"
| Unsupported_media_type (Some media) ->
Format.fprintf
ppf
"@[<v 2>The server does not support the media type we used: %s.@]"
media
| Not_acceptable {proposed; acceptable} ->
Format.fprintf
ppf
"@[<v 2>No intersection between the media types we accept and the \
ones the server is able to send.@,\
\ We proposed: %s@,\
\ The server is only able to serve: %s."
proposed
acceptable
| Unexpected_status_code {code; content; _} ->
Format.fprintf
ppf
"@[<v 2>Unexpected error %d:@,%S"
(Cohttp.Code.code_of_status code)
content
| Unexpected_content_type {received; acceptable = _; body} ->
Format.fprintf
ppf
"@[<v 0>The server answered with a media type we do not understand: \
%s.@,\
The response body was:@,\
%s@]"
received
body
| Unexpected_content {content; media_type; error} ->
Format.fprintf
ppf
"@[<v 2>Failed to parse the answer (%s):@,\
@[<v 2>error:@ %s@]@,\
@[<v 2>content:@ %S@]@]"
media_type
error
content
| OCaml_exception msg ->
Format.fprintf
ppf
"@[<v 2>The server failed with an unexpected exception:@ %s@]"
msg
| Unauthorized_host host ->
Format.fprintf
ppf
"@[<v 2>The server refused connection to host \"%s\", please check \
the node settings for CORS allowed origins.@]"
(Option.unopt ~default:"" host)
let () =
register_error_kind
`Permanent
~id:"rpc_client.request_failed"
~title:""
~description:""
~pp:(fun ppf (meth, uri, error) ->
Format.fprintf
ppf
"@[<v 2>Rpc request failed:@ - meth: %s@ - uri: %s@ - error: %a@]"
(RPC_service.string_of_meth meth)
(Uri.to_string uri)
pp_rpc_error
error)
Data_encoding.(
obj3
(req "meth" RPC_service.meth_encoding)
(req "uri" RPC_encoding.uri_encoding)
(req "error" rpc_error_encoding))
(function
| Request_failed {uri; error; meth} ->
Some (meth, uri, error)
| _ ->
None)
(fun (meth, uri, error) -> Request_failed {uri; meth; error})
src/lib_rpc_http/RPC_client_errors.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive rpc_error : Type :=
| Empty_answer : rpc_error
| Connection_failed : string -> rpc_error
| Bad_request : string -> rpc_error
| Method_not_allowed : (list Tezos_rpc.RPC_service.meth) -> rpc_error
| Unsupported_media_type : (option string) -> rpc_error
| Not_acceptable : string -> string -> rpc_error
| Unexpected_status_code : Cohttp.Code.status_code -> string -> (option string)
-> rpc_error
| Unexpected_content_type : string -> (list string) -> string -> rpc_error
| Unexpected_content : string -> string -> string -> rpc_error
| OCaml_exception : string -> rpc_error
| Unauthorized_host : (option string) -> rpc_error.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition rpc_error_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding rpc_error :=
union None
(cons
(case "Empty_answer" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(obj1 (req None None "kind" % string (constant "empty_answer" % string)))
(fun function_parameter =>
match function_parameter with
| Empty_answer => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Empty_answer))
(cons
(case "Connection_failed" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj2
(req None None "kind" % string
(constant "connection_failed" % string))
(req None None "message" % string string))
(fun function_parameter =>
match function_parameter with
| Connection_failed msg => Some (tt, msg)
| _ => None
end)
(fun function_parameter =>
let '(tt, msg) := function_parameter in
Connection_failed msg))
(cons
(case "Bad_request" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 2)
(obj2
(req None None "kind" % string (constant "bad_request" % string))
(req None None "message" % string string))
(fun function_parameter =>
match function_parameter with
| Bad_request msg => Some (tt, msg)
| _ => None
end)
(fun function_parameter =>
let '(tt, msg) := function_parameter in
Bad_request msg))
(cons
(case "Method_not_allowed" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 3)
(obj2
(req None None "kind" % string
(constant "method_not_allowed" % string))
(req None None "allowed" % string
(list None RPC_service.meth_encoding)))
(fun function_parameter =>
match function_parameter with
| Method_not_allowed meths => Some (tt, meths)
| _ => None
end)
(fun function_parameter =>
let '(tt, meths) := function_parameter in
Method_not_allowed meths))
(cons
(case "Unsupported_media_type" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 4)
(obj2
(req None None "kind" % string
(constant "unsupported_media_type" % string))
(opt None None "content_type" % string string))
(fun function_parameter =>
match function_parameter with
| Unsupported_media_type m => Some (tt, m)
| _ => None
end)
(fun function_parameter =>
let '(tt, m) := function_parameter in
Unsupported_media_type m))
(cons
(case "Not_acceptable" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 5)
(obj3
(req None None "kind" % string
(constant "not_acceptable" % string))
(req None None "proposed" % string string)
(req None None "acceptable" % string string))
(fun function_parameter =>
match function_parameter with
|
Not_acceptable {|
proposed := proposed; acceptable := acceptable |} =>
Some (tt, proposed, acceptable)
| _ => None
end)
(fun function_parameter =>
let '(tt, proposed, acceptable) := function_parameter in
Not_acceptable
{| proposed := proposed; acceptable := acceptable |}))
(cons
(case "Unexpected_status_code" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 6)
(obj4
(req None None "kind" % string
(constant "unexpected_status_code" % string))
(req None None "code" % string uint16)
(req None None "content" % string string)
(opt None None "media_type" % string string))
(fun function_parameter =>
match function_parameter with
|
Unexpected_status_code {|
code := code;
content := content;
media_type := media_type
|} =>
Some
(tt, (Cohttp.Code.code_of_status code), content,
media_type)
| _ => None
end)
(fun function_parameter =>
let '(tt, code, content, media_type) := function_parameter
in
let code := Cohttp.Code.status_of_code code in
Unexpected_status_code
{| code := code; content := content;
media_type := media_type |}))
(cons
(case "Unexpected_content_type" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 7)
(obj4
(req None None "kind" % string
(constant "unexpected_content_type" % string))
(req None None "received" % string string)
(req None None "acceptable" % string (list None string))
(req None None "body" % string string))
(fun function_parameter =>
match function_parameter with
|
Unexpected_content_type {|
received := received;
acceptable := acceptable;
body := body
|} => Some (tt, received, acceptable, body)
| _ => None
end)
(fun function_parameter =>
let '(tt, received, acceptable, body) :=
function_parameter in
Unexpected_content_type
{| received := received; acceptable := acceptable;
body := body |}))
(cons
(case "Unexpected_content" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 8)
(obj4
(req None None "kind" % string
(constant "unexpected_content" % string))
(req None None "content" % string string)
(req None None "media_type" % string string)
(req None None "error" % string string))
(fun function_parameter =>
match function_parameter with
|
Unexpected_content {|
content := content;
media_type := media_type;
error := error
|} => Some (tt, content, media_type, error)
| _ => None
end)
(fun function_parameter =>
let '(tt, content, media_type, error) :=
function_parameter in
Unexpected_content
{| content := content; media_type := media_type;
error := error |}))
(cons
(case "OCaml_exception" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 9)
(obj2
(req None None "kind" % string
(constant "ocaml_exception" % string))
(req None None "content" % string string))
(fun function_parameter =>
match function_parameter with
| OCaml_exception msg => Some (tt, msg)
| _ => None
end)
(fun function_parameter =>
let '(tt, msg) := function_parameter in
OCaml_exception msg)) [])))))))))).
Definition pp_rpc_error (ppf : Stdlib.Format.formatter) (err : rpc_error)
: unit :=
match err with
| Empty_answer =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The server answered with an empty response." % string
CamlinternalFormatBasics.End_of_format)
"The server answered with an empty response." % string)
| Connection_failed msg =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unable to connect to the node: """ % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal """" % char
CamlinternalFormatBasics.End_of_format)))
"Unable to connect to the node: ""%s""" % string) msg
| Bad_request msg =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Oups! It looks like we forged an invalid HTTP request." % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>Oups! It looks like we forged an invalid HTTP request.@,%s@]" %
string) msg
| Method_not_allowed meths =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"The requested service only accepts the following method:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>The requested service only accepts the following method:@ %a@]"
% string)
(Format.pp_print_list None
(fun ppf =>
fun m => Format.pp_print_string ppf (RPC_service.string_of_meth m)))
meths
| Unsupported_media_type None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"The server wants to known the media type we used." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))
"@[<v 2>The server wants to known the media type we used.@]" % string)
| Unsupported_media_type (Some media) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"The server does not support the media type we used: " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>The server does not support the media type we used: %s.@]" %
string) media
| Not_acceptable {| proposed := proposed; acceptable := acceptable |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"No intersection between the media types we accept and the ones the server is able to send."
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal " We proposed: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" The server is only able to serve: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))))))))
"@[<v 2>No intersection between the media types we accept and the ones the server is able to send.@, We proposed: %s@, The server is only able to serve: %s."
% string) proposed acceptable
| Unexpected_status_code {| code := code; content := content |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Unexpected error " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))))
"@[<v 2>Unexpected error %d:@,%S" % string)
(Cohttp.Code.code_of_status code) content
|
Unexpected_content_type {|
received := received; acceptable := _; body := body |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"The server answered with a media type we do not understand: " %
string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"The response body was:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[<v 0>The server answered with a media type we do not understand: %s.@,The response body was:@,%s@]"
% string) received body
|
Unexpected_content {|
content := content; media_type := media_type; error := error |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Failed to parse the answer (" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal "):" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal "error:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"content:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))))))
"@[<v 2>Failed to parse the answer (%s):@,@[<v 2>error:@ %s@]@,@[<v 2>content:@ %S@]@]"
% string) media_type error content
| OCaml_exception msg =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"The server failed with an unexpected exception:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>The server failed with an unexpected exception:@ %s@]" % string)
msg
| Unauthorized_host host =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"The server refused connection to host """ % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
""", please check the node settings for CORS allowed origins." %
string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>The server refused connection to host ""%s"", please check the node settings for CORS allowed origins.@]"
% string) (Option.unopt "" % string host)
end.
src/lib_rpc_http/RPC_client_unix.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type attempt_event = {attempt : int; delay : float; text : string}
module Attempt_logging = Internal_event.Make (struct
type t = attempt_event
let name = "rpc_http_attempt"
let doc = "Error emmited when an HTTP request returned a 502 error."
let encoding =
Data_encoding.(
conv
(fun {attempt; delay; text} -> (attempt, delay, text))
(fun (attempt, delay, text) -> {attempt; delay; text})
(obj3 (req "attempt" int8) (req "delay" float) (req "text" string)))
let pp f {attempt; delay; text} =
Format.fprintf
f
"Attempt number %d/10, will retry after %g seconds.\n\
Original body follows.\n\
%s"
attempt
delay
text
let level _ = Internal_event.Error
end)
include RPC_client.Make (struct
include Cohttp_lwt_unix.Client
let clone_body = function
| `Stream s ->
`Stream (Lwt_stream.clone s)
| x ->
x
let call ?ctx ?headers ?body ?chunked meth uri =
let rec call_and_retry_on_502 attempt delay =
call ?ctx ?headers ?body ?chunked meth uri
>>= fun (response, ansbody) ->
let status = Cohttp.Response.status response in
match status with
| `Bad_gateway ->
let log_ansbody = clone_body ansbody in
Cohttp_lwt.Body.to_string log_ansbody
>>= fun text ->
Attempt_logging.emit (fun () -> {attempt; delay; text})
>>= fun _ ->
if attempt >= 10 then Lwt.return (response, ansbody)
else
Lwt_unix.sleep delay
>>= fun () -> call_and_retry_on_502 (attempt + 1) (delay +. 0.1)
| _ ->
Lwt.return (response, ansbody)
in
call_and_retry_on_502 1 0.
end)
src/lib_rpc_http/RPC_client_unix.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record attempt_event := {
attempt : Z;
delay : Z;
text : string }.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Structure item `include` not handled. *)
include
src/lib_rpc_http/RPC_server.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type cors = Resto_cohttp.Cors.t = {
allowed_headers : string list;
allowed_origins : string list;
}
module RPC_logging = Internal_event.Legacy_logging.Make (struct
let name = "rpc"
end)
include Resto_cohttp_server.Server.Make (RPC_encoding) (RPC_logging)
src/lib_rpc_http/RPC_server.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record cors := {
allowed_headers : list string;
allowed_origins : list string }.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Structure item `include` not handled. *)
include
src/lib_rpc_http/media_type.ml 19 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Resto_cohttp.Media_type.Make (RPC_encoding)
let json =
{
name = Cohttp.Accept.MediaType ("application", "json");
q = Some 1000;
pp =
(fun _enc ppf raw ->
match Data_encoding.Json.from_string raw with
| Error err ->
Format.fprintf
ppf
"@[Invalid JSON:@ - @[<v 2>Error:@ %s@] - @[<v 2>Raw data:@ \
%s@]@]"
err
raw
| Ok json ->
Data_encoding.Json.pp ppf json);
construct =
(fun enc v ->
Data_encoding.Json.to_string ~newline:true ~minify:true
@@ Data_encoding.Json.construct enc v);
destruct =
(fun enc body ->
match Data_encoding.Json.from_string body with
| Error _ as err ->
err
| Ok json -> (
try Ok (Data_encoding.Json.destruct enc json)
with Data_encoding.Json.Cannot_destruct (_, exn) ->
Error
(Format.asprintf
"%a"
(fun fmt -> Data_encoding.Json.print_error fmt)
exn) ));
}
let bson =
{
name = Cohttp.Accept.MediaType ("application", "bson");
q = Some 100;
pp =
(fun _enc ppf raw ->
match
Json_repr_bson.bytes_to_bson
~laziness:false
~copy:false
(Bytes.unsafe_of_string raw)
with
| exception Json_repr_bson.Bson_decoding_error (msg, _, _) ->
Format.fprintf ppf "@[Invalid BSON:@ %s@]" msg
| bson ->
let json =
Json_repr.convert
(module Json_repr_bson.Repr)
(module Json_repr.Ezjsonm)
bson
in
Data_encoding.Json.pp ppf json);
construct =
(fun enc v ->
Bytes.unsafe_to_string @@ Json_repr_bson.bson_to_bytes
@@ Data_encoding.Bson.construct enc v);
destruct =
(fun enc body ->
match
Json_repr_bson.bytes_to_bson
~laziness:false
~copy:false
(Bytes.unsafe_of_string body)
with
| exception Json_repr_bson.Bson_decoding_error (msg, _, pos) ->
Error (Format.asprintf "(at offset: %d) %s" pos msg)
| bson -> (
try Ok (Data_encoding.Bson.destruct enc bson)
with Data_encoding.Json.Cannot_destruct (_, exn) ->
Error
(Format.asprintf
"%a"
(fun fmt -> Data_encoding.Json.print_error fmt)
exn) ));
}
let octet_stream =
{
name = Cohttp.Accept.MediaType ("application", "octet-stream");
q = Some 200;
pp =
(fun enc ppf raw ->
match Data_encoding.Binary.of_bytes enc (Bytes.of_string raw) with
| None ->
Format.fprintf ppf "Invalid binary data."
| Some v ->
Format.fprintf
ppf
";; binary equivalent of the following json@.%a"
Data_encoding.Json.pp
(Data_encoding.Json.construct enc v));
construct =
(fun enc v -> Bytes.to_string @@ Data_encoding.Binary.to_bytes_exn enc v);
destruct =
(fun enc s ->
match Data_encoding.Binary.of_bytes enc (Bytes.of_string s) with
| None ->
Error "Failed to parse binary data."
| Some data ->
Ok data);
}
let all_media_types = [json; bson; octet_stream]
src/lib_rpc_http/media_type.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition json : t :=
{| name := Cohttp.Accept.MediaType "application" % string "json" % string;
q := Some 1000;
pp :=
fun _enc =>
fun ppf =>
fun raw =>
match Data_encoding.Json.from_string raw with
| Stdlib.Error err =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Invalid JSON:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal " - " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Error:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1
0)
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.String_literal
" - " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Raw data:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))))
"@[Invalid JSON:@ - @[<v 2>Error:@ %s@] - @[<v 2>Raw data:@ %s@]@]"
% string) err raw
| Stdlib.Ok json => Data_encoding.Json.pp ppf json
end;
construct :=
fun enc =>
fun v =>
apply (Data_encoding.Json.to_string (Some true) (Some true))
(Data_encoding.Json.construct enc v);
destruct :=
fun enc =>
fun body =>
match Data_encoding.Json.from_string body with
| (Stdlib.Error _) as err => err
| Stdlib.Ok json =>
(* ❌ Try-with are not handled *)
try (Stdlib.Ok (Data_encoding.Json.destruct enc json))
end |}.
Definition bson : t :=
{| name := Cohttp.Accept.MediaType "application" % string "bson" % string;
q := Some 100;
pp :=
fun _enc =>
fun ppf =>
fun raw =>
let 'bson :=
Json_repr_bson.bytes_to_bson (Some false) None None false
(Stdlib.Bytes.unsafe_of_string raw) in
let json :=
Json_repr.convert Json_repr_bson.Repr Json_repr.Ezjsonm bson in
Data_encoding.Json.pp ppf json;
construct :=
fun enc =>
fun v =>
apply Stdlib.Bytes.unsafe_to_string
(apply
(let arg := Json_repr_bson.bson_to_bytes in
fun eta => arg None None eta) (Data_encoding.Bson.construct enc v));
destruct :=
fun enc =>
fun body =>
let 'bson :=
Json_repr_bson.bytes_to_bson (Some false) None None false
(Stdlib.Bytes.unsafe_of_string body) in
(* ❌ Try-with are not handled *)
try (Stdlib.Ok (Data_encoding.Bson.destruct enc bson)) |}.
Definition octet_stream : t :=
{|
name :=
Cohttp.Accept.MediaType "application" % string "octet-stream" % string;
q := Some 200;
pp :=
fun enc =>
fun ppf =>
fun raw =>
match Data_encoding.Binary.of_bytes enc (Stdlib.Bytes.of_string raw)
with
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid binary data." % string
CamlinternalFormatBasics.End_of_format)
"Invalid binary data." % string)
| Some v =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
";; binary equivalent of the following json" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))
";; binary equivalent of the following json@.%a" % string)
Data_encoding.Json.pp (Data_encoding.Json.construct enc v)
end;
construct :=
fun enc =>
fun v =>
apply Stdlib.Bytes.to_string (Data_encoding.Binary.to_bytes_exn enc v);
destruct :=
fun enc =>
fun s =>
match Data_encoding.Binary.of_bytes enc (Stdlib.Bytes.of_string s)
with
| None => Stdlib.Error "Failed to parse binary data." % string
| Some data => Stdlib.Ok data
end |}.
Definition all_media_types : list t :=
cons json (cons bson (cons octet_stream [])).
src/lib_shell/bench/bench_simple.ml 7 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let make_simple blocks =
let rec loop pred n =
if n <= 0 then return pred
else Block.bake pred >>=? fun block -> loop block (n - 1)
in
Context.init 5 >>=? fun (genesis, _) -> loop genesis blocks
type args = {blocks : int; accounts : int}
let default_args = {blocks = 1000; accounts = 5}
let set_blocks cf blocks = cf := {!cf with blocks}
let set_accounts cf accounts = cf := {!cf with accounts}
let read_args () =
let args = ref default_args in
let specific =
[ ("--blocks", Arg.Int (set_blocks args), "number of blocks");
("--accounts", Arg.Int (set_accounts args), "number of acount") ]
in
let usage = "Usage: [--blocks n] [--accounts n] " in
Arg.parse specific (fun _ -> ()) usage ;
!args
let () =
let args = read_args () in
match Lwt_main.run (make_simple args.blocks) with
| Ok _head ->
Format.printf "Success.@." ; exit 0
| Error err ->
Format.eprintf "%a@." pp_print_error err ;
exit 1
src/lib_shell/bench/bench_simple.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition make_simple {A : Type} (blocks : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
let fix loop {B : Type} (pred : B) (n : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
if OCaml.Stdlib.le n 0 then
_return pred
else
op_gtgteqquestion (op_startypeminuserrorstar pred)
(fun block => loop block (Z.sub n 1)) in
op_gtgteqquestion op_startypeminuserrorstar
(fun function_parameter =>
let '(genesis, _) := function_parameter in
loop genesis blocks).
Record args := {
blocks : Z;
accounts : Z }.
Definition default_args : args := {| blocks := 1000; accounts := 5 |}.
Definition set_blocks (cf : Stdlib.ref args) (blocks : Z) : unit :=
Stdlib.op_coloneq cf
(* ❌ Record substitution not handled *)
record_substitution.
Definition set_accounts (cf : Stdlib.ref args) (accounts : Z) : unit :=
Stdlib.op_coloneq cf
(* ❌ Record substitution not handled *)
record_substitution.
Definition read_args (function_parameter : unit) : args :=
let 'tt := function_parameter in
let args := Stdlib.ref default_args in
let specific :=
cons
("--blocks" % string, (Stdlib.Arg.Int (set_blocks args)),
"number of blocks" % string)
(cons
("--accounts" % string, (Stdlib.Arg.Int (set_accounts args)),
"number of acount" % string) []) in
let usage := "Usage: [--blocks n] [--accounts n] " % string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Arg.parse specific
(fun function_parameter =>
let '_ := function_parameter in
tt) usage in
Stdlib.op_exclamation args.
src/lib_shell/bench/bench_tool.ml 120 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Helpers_Nonce = Nonce
open Protocol
open Parameters_repr
open Constants_repr
open Alpha_context
(** Args *)
type args = {
mutable length : int;
mutable seed : int;
mutable accounts : int;
mutable nb_commitments : int;
mutable params : Parameters_repr.t;
}
let default_args =
{
length = 100;
seed = 0;
accounts = 100;
nb_commitments = 200;
params =
{
bootstrap_accounts = [];
commitments = [];
bootstrap_contracts = [];
constants = Default_parameters.constants_mainnet;
security_deposit_ramp_up_cycles = None;
no_reward_cycles = None;
};
}
let debug = ref false
let if_debug k = if !debug then k ()
let if_debug_s k = if !debug then k () else return_unit
let args = default_args
let parse_param_file name =
if not (Sys.file_exists name) then
failwith "Parameters : Inexistent JSON file"
else
Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file name
>>=? fun json ->
match Data_encoding.Json.destruct Parameters_repr.encoding json with
| exception exn ->
failwith "Parameters : Invalid JSON file - %a" Error_monad.pp_exn exn
| param ->
return param
let read_args () =
let parse_param name =
parse_param_file name
>>= (function
| Ok p ->
Lwt.return p
| Error errs ->
Format.printf
"Parameters parsing error : %a ==> using default parameters\n\
%!"
Error_monad.pp_print_error
errs ;
Lwt.return default_args.params)
|> Lwt_main.run
in
let specific =
[ ( "--length",
Arg.Int (fun n -> args.length <- n),
"Length of the chain (nb of blocks)" );
("--seed", Arg.Int (fun n -> args.seed <- n), "Used seed (default 0)");
( "--random-commitments",
Arg.Int (fun n -> args.nb_commitments <- n),
"Number of randomly generated commitments. Defaults to 200. If less \
than 0, commitments in protocol parameter files are used." );
( "--accounts",
Arg.Int (fun n -> args.accounts <- n),
"Number of initial randomly generated accounts. Still adds bootstrap \
account if present in the parameters file." );
( "--parameters",
Arg.String (fun s -> args.params <- parse_param s),
"JSON protocol parameters file" );
("--debug", Arg.Set debug, "Print more info") ]
in
let usage =
"Usage: [--length n] [--seed n] [--accounts n] [--parameters json_file]"
in
Arg.parse specific (fun _ -> ()) usage
(** Utils *)
let choose_exp_nat n =
(* seems fine *)
let lambda = 1. /. log (float n) in
let u = Random.float 1. in
-.log u /. lambda |> int_of_float
let pi = 3.1415926502
let two_pi = 2. *. 3.1415926502
let round x = x +. 0.5 |> int_of_float
let rec choose_gaussian_nat (a, b) =
assert (b >= a) ;
let sigma = 4. in
let mu = ((b - a) / 2) + a |> float in
let gauss () =
let u1 = Random.float 1. (* |> fun x -> 1. -. x *) in
let u2 = Random.float 1. in
let r = sqrt (-.(2. *. log u1)) in
let theta = cos (two_pi *. u2) in
r *. theta
in
let z = gauss () in
let z = (z *. sigma) +. mu |> round in
if z > a && z < b then z else choose_gaussian_nat (a, b)
let list_shuffle l =
List.map (fun c -> (Random.bits (), c)) l
|> List.sort compare |> List.map snd
(******************************************************************)
type gen_state = {
mutable possible_transfers : (Account.t * Account.t) list;
mutable remaining_transfers : (Account.t * Account.t) list;
mutable remaining_activations : (Account.t * Commitment_repr.t) list;
mutable nonce_to_reveal : (Cycle.t * Raw_level.t * Nonce.t) list;
}
let get_n_endorsements ctxt n =
Context.get_endorsers ctxt
>>=? fun endorsing_rights ->
let endorsing_rights = List.sub endorsing_rights n in
map_s
(fun {Delegate_services.Endorsing_rights.delegate; level; _} ->
Op.endorsement ~delegate ~level ctxt ())
endorsing_rights
let generate_and_add_random_endorsements inc =
let pred inc = Incremental.predecessor inc in
let nb_endorsements =
let n = args.params.constants.endorsers_per_block in
n - choose_exp_nat n
in
if_debug (fun () ->
Format.printf
"[DEBUG] Generating up to %d endorsements...\n%!"
nb_endorsements) ;
get_n_endorsements (B (pred inc)) (nb_endorsements - 1)
>>=? fun endorsements ->
let compare op1 op2 =
Operation_hash.compare (Operation.hash op1) (Operation.hash op2)
in
let endorsements = List.sort_uniq compare endorsements in
let endorsements = List.map Operation.pack endorsements in
fold_left_s Incremental.add_operation inc endorsements
let regenerate_transfers = ref false
let generate_random_activation ({remaining_activations; _} as gen_state) inc =
regenerate_transfers := true ;
let open Account in
match remaining_activations with
| [] ->
assert false
| (({pkh; _} as account), _) :: l ->
if_debug (fun () ->
Format.printf "[DEBUG] Generating an activation.\n%!") ;
gen_state.remaining_activations <- l ;
add_account account ;
Op.activation inc pkh Account.commitment_secret
exception No_transfer_left
let rec generate_random_transfer ({remaining_transfers; _} as gen_state) ctxt =
if remaining_transfers = [] then raise No_transfer_left ;
let (a1, a2) = List.hd remaining_transfers in
gen_state.remaining_transfers <- List.tl remaining_transfers ;
let open Account in
let c1 = Alpha_context.Contract.implicit_contract a1.pkh in
let c2 = Alpha_context.Contract.implicit_contract a2.pkh in
Context.Contract.balance ctxt c1
>>=? fun b1 ->
if Tez.(b1 < Tez.one) then generate_random_transfer gen_state ctxt
else Op.transaction ctxt c1 c2 Tez.one
let generate_random_operation (inc : Incremental.t) gen_state =
let rnd = Random.int 100 in
match rnd with
| x when x < 2 && gen_state.remaining_activations <> [] ->
generate_random_activation gen_state (I inc)
| _ ->
generate_random_transfer gen_state (I inc)
(* Build a random block *)
let step gen_state blk : Block.t tzresult Lwt.t =
let priority = choose_exp_nat 5 in
(* let nb_operations_per_block = choose_gaussian_nat (10, List.length (Account.get_known_accounts ())) in *)
let nb_operations_per_block = choose_gaussian_nat (10, 100) in
if !regenerate_transfers then (
let l =
Signature.Public_key_hash.Table.fold
(fun _ v acc -> v :: acc)
Account.known_accounts
[]
in
(* TODO : make possible transfer computations efficient.. *)
gen_state.possible_transfers <-
List.product l l |> List.filter (fun (a, b) -> a <> b) ;
regenerate_transfers := false ) ;
gen_state.remaining_transfers <- list_shuffle gen_state.possible_transfers ;
let nb_operations =
min nb_operations_per_block (List.length gen_state.remaining_transfers)
in
(* Nonce *)
Alpha_services.Helpers.current_level ~offset:1l Block.rpc_ctxt blk
>>|? (function
| Level.{expected_commitment = true; cycle; level; _} ->
if_debug (fun () -> Format.printf "[DEBUG] Commiting a nonce\n%!") ;
let (hash, nonce) = Helpers_Nonce.generate () in
gen_state.nonce_to_reveal <-
(cycle, level, nonce) :: gen_state.nonce_to_reveal ;
Some hash
| _ ->
None)
>>=? fun seed_nonce_hash ->
Incremental.begin_construction ~priority ?seed_nonce_hash blk
>>=? fun inc ->
let open Cycle in
if_debug (fun () ->
Format.printf
"[DEBUG] Generating %d random operations...\n%!"
nb_operations) ;
(* Generate random operations *)
fold_left_s
(fun inc _ ->
try
generate_random_operation inc gen_state
>>=? fun op -> Incremental.add_operation inc op
with No_transfer_left -> return inc)
inc
(1 -- nb_operations)
>>=? fun inc ->
(* Endorsements *)
generate_and_add_random_endorsements inc
>>=? fun inc ->
(* Revelations *)
(* TODO debug cycle *)
Alpha_services.Helpers.current_level ~offset:1l Incremental.rpc_ctxt inc
>>|? (function
| {cycle; level; _} -> (
if_debug (fun () ->
Format.printf "[DEBUG] Current cycle : %a\n%!" Cycle.pp cycle) ;
if_debug (fun () ->
Format.printf
"[DEBUG] Current level : %a\n%!"
Raw_level.pp
level) ;
match gen_state.nonce_to_reveal with
| (pred_cycle, _, _) :: _ as l when succ pred_cycle = cycle ->
if_debug (fun () ->
Format.printf
"[DEBUG] Seed nonce revelation : %d nonces to reveal.\n\
%!"
@@ List.length l) ;
gen_state.nonce_to_reveal <- [] ;
(* fold_left_s (fun inc (_, level, nonce) -> *)
(* Op.seed_nonce_revelation inc level nonce >>=? fun op ->
* Incremental.add_operation inc op *)
(* return *)
inc
(* TODO reactivate the seeds *)
(* ) inc l *)
| _ ->
inc ))
>>=? fun inc ->
(* (\* Shuffle the operations a bit (why not) *\)
* let operations = endorsements @ operations |> list_shuffle in *)
Incremental.finalize_block inc
let init () =
Random.init args.seed ;
let parameters = args.params in
(* keys randomness is delegated to module Signature's bindings *)
(* TODO : distribute the tokens randomly *)
(* Right now, we split half of 80.000 rolls between generated accounts *)
(* TODO : ensure we don't overflow with the underlying commitments *)
Tez_repr.(
Lwt.return @@ Environment.wrap_error
@@ args.params.Parameters_repr.constants.Constants_repr.tokens_per_roll
*? 80_000L
>>=? fun total_amount ->
Lwt.return @@ Environment.wrap_error @@ (total_amount /? 2L)
>>=? fun amount ->
Lwt.return @@ Environment.wrap_error
@@ (amount /? Int64.of_int args.accounts))
>>=? fun initial_amount ->
(* Ensure a deterministic run *)
let new_seed () : Bytes.t =
Bytes.(make 32 '\000' |> map (fun _ -> Random.int 0x100 |> char_of_int))
in
map_s
(fun _ ->
return (Account.new_account ~seed:(new_seed ()) (), initial_amount))
(1 -- args.accounts)
>>=? fun initial_accounts ->
if_debug (fun () ->
List.iter
(fun (Account.{pkh; _}, _) ->
Format.printf
"[DEBUG] Account %a created\n%!"
Signature.Public_key_hash.pp_short
pkh)
initial_accounts) ;
let possible_transfers =
let l = List.map fst initial_accounts in
List.product l l |> List.filter (fun (a, b) -> a <> b)
in
( match args.nb_commitments with
| x when x < 0 ->
return ([], parameters)
| x ->
map_s (fun _ -> Account.new_commitment ~seed:(new_seed ()) ()) (1 -- x)
>>=? fun commitments ->
return
(commitments, {parameters with commitments = List.map snd commitments})
)
>>=? fun ( remaining_activations,
{ bootstrap_accounts = _;
commitments;
constants;
security_deposit_ramp_up_cycles;
no_reward_cycles;
_ } ) ->
let gen_state =
{
possible_transfers;
remaining_transfers = [];
nonce_to_reveal = [];
remaining_activations;
}
in
let bootstrap_accounts =
List.map
(fun (Account.{pk; pkh; _}, amount) ->
Default_parameters.make_bootstrap_account (pkh, pk, amount))
initial_accounts
in
let parameters =
{
Parameters_repr.bootstrap_accounts;
bootstrap_contracts = [];
commitments;
constants;
security_deposit_ramp_up_cycles;
no_reward_cycles;
}
in
Block.genesis_with_parameters parameters
>>=? fun genesis ->
if_debug_s (fun () ->
iter_s
(let open Account in
fun (({pkh; _} as acc), _) ->
let contract = Alpha_context.Contract.implicit_contract acc.pkh in
Context.Contract.manager (B genesis) contract
>>=? fun {pkh = pkh'; _} ->
Context.Contract.balance (B genesis) contract
>>=? fun balance ->
return
@@ Format.printf
"[DEBUG] %a's manager is %a with a balance of %a\n%!"
Signature.Public_key_hash.pp_short
pkh
Signature.Public_key_hash.pp_short
pkh'
Tez.pp
balance)
initial_accounts)
>>=? fun () ->
if_debug (fun () ->
Format.printf
"[DEBUG] Constants : %a\n%!"
Data_encoding.Json.pp
(Data_encoding.Json.construct
Constants_repr.parametric_encoding
parameters.Parameters_repr.constants)) ;
let print_block block =
let open Block in
Format.printf
"@[%6i %s@]\n%!"
(Int32.to_int block.header.shell.level)
(Block_hash.to_b58check block.hash)
in
Format.printf
"@[<v 2>Starting generation with :@ @[length = %d@]@ @[seed = \
%d@]@ @[nb_commi. = %d@]@ @[#accounts = %d@]@ @]@."
args.length
args.seed
args.nb_commitments
args.accounts ;
let rec loop gen_state blk = function
| 0 ->
return (gen_state, blk)
| n ->
print_block blk ;
step gen_state blk >>=? fun blk' -> loop gen_state blk' (n - 1)
in
return (loop gen_state genesis args.length)
let () =
Lwt_main.run (read_args () ; init ())
|> function
| Ok _head ->
Format.printf "Success.@." ; exit 0
| Error err ->
Format.eprintf "%a@." pp_print_error err ;
exit 1
src/lib_shell/bench/bench_tool.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ This kind of module is not handled. *)
unhandled_module
Import Protocol.
Definition default_args {A : Type} : A := op_startypeminuserrorstar.
Definition debug : Stdlib.ref bool := Stdlib.ref false.
Definition if_debug (k : unit -> unit) : unit :=
if Stdlib.op_exclamation debug then
k tt
else
tt.
Definition if_debug_s
(k : unit -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if Stdlib.op_exclamation debug then
k tt
else
return_unit.
Definition args {A : Type} : A := default_args.
Definition parse_param_file {A : Type} (name : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
if negb (Sys.file_exists name) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Parameters : Inexistent JSON file" % string
CamlinternalFormatBasics.End_of_format)
"Parameters : Inexistent JSON file" % string)
else
op_gtgteqquestion (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file name)
(fun json =>
let 'param := Data_encoding.Json.destruct op_startypeminuserrorstar json
in
_return param).
Definition read_args (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let parse_param {A : Type} (name : string) : A :=
OCaml.Stdlib.reverse_apply
(op_gtgteq (parse_param_file name)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok p => Lwt._return p
| Stdlib.Error errs =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Parameters parsing error : " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" ==> using default parameters
" % string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))))
"Parameters parsing error : %a ==> using default parameters
%!"
% string) Error_monad.pp_print_error errs in
Lwt._return (params default_args)
end)) Lwt_main.run in
let specific :=
cons
("--length" % string,
(Stdlib.Arg.Int
(fun n =>
(* ❌ Set record field not handled. *)
set_record_field args "" % string n)),
"Length of the chain (nb of blocks)" % string)
(cons
("--seed" % string,
(Stdlib.Arg.Int
(fun n =>
(* ❌ Set record field not handled. *)
set_record_field args "" % string n)),
"Used seed (default 0)" % string)
(cons
("--random-commitments" % string,
(Stdlib.Arg.Int
(fun n =>
(* ❌ Set record field not handled. *)
set_record_field args "" % string n)),
"Number of randomly generated commitments. Defaults to 200. If less than 0, commitments in protocol parameter files are used."
% string)
(cons
("--accounts" % string,
(Stdlib.Arg.Int
(fun n =>
(* ❌ Set record field not handled. *)
set_record_field args "" % string n)),
"Number of initial randomly generated accounts. Still adds bootstrap account if present in the parameters file."
% string)
(cons
("--parameters" % string,
(Stdlib.Arg.String
(fun s =>
(* ❌ Set record field not handled. *)
set_record_field args "" % string (parse_param s))),
"JSON protocol parameters file" % string)
(cons
("--debug" % string, (Stdlib.Arg.Set debug),
"Print more info" % string) []))))) in
let usage :=
"Usage: [--length n] [--seed n] [--accounts n] [--parameters json_file]" %
string in
Arg.parse specific
(fun function_parameter =>
let '_ := function_parameter in
tt) usage.
Definition choose_exp_nat (n : Z) : Z :=
let lambda :=
Stdlib.op_divpoint
(* ❌ Float constant 1. is approximated by the integer 1 *)
1 (Stdlib.log (Stdlib.float n)) in
let u :=
Random.float
(* ❌ Float constant 1. is approximated by the integer 1 *)
1 in
OCaml.Stdlib.reverse_apply
(Stdlib.op_divpoint (Stdlib.op_tildeminuspoint (Stdlib.log u)) lambda)
Stdlib.int_of_float.
Definition pi : Z :=
(* ❌ Float constant 3.1415926502 is approximated by the integer 3 *)
3.
Definition two_pi : Z :=
Stdlib.op_starpoint
(* ❌ Float constant 2. is approximated by the integer 2 *)
2
(* ❌ Float constant 3.1415926502 is approximated by the integer 3 *)
3.
Definition round (x : Z) : Z :=
OCaml.Stdlib.reverse_apply
(Stdlib.op_pluspoint x
(* ❌ Float constant 0.5 is approximated by the integer 0 *)
0) Stdlib.int_of_float.
Fixpoint choose_gaussian_nat
(function_parameter :
Tezos_base__TzPervasives.Protocol.t * Tezos_base__TzPervasives.Protocol.t)
: Z :=
let '(a, b) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (op_gteq b a) in
let sigma :=
(* ❌ Float constant 4. is approximated by the integer 4 *)
4 in
let mu :=
OCaml.Stdlib.reverse_apply
(Z.add
(Z.div (Z.sub op_startypeminuserrorstar op_startypeminuserrorstar) 2)
op_startypeminuserrorstar) Stdlib.float in
let gauss (function_parameter : unit) : Z :=
let 'tt := function_parameter in
let u1 :=
Random.float
(* ❌ Float constant 1. is approximated by the integer 1 *)
1 in
let u2 :=
Random.float
(* ❌ Float constant 1. is approximated by the integer 1 *)
1 in
let r :=
Stdlib.sqrt
(Stdlib.op_tildeminuspoint
(Stdlib.op_starpoint
(* ❌ Float constant 2. is approximated by the integer 2 *)
2 (Stdlib.log u1))) in
let theta := Stdlib.cos (Stdlib.op_starpoint two_pi u2) in
Stdlib.op_starpoint r theta in
let z := gauss tt in
let z :=
OCaml.Stdlib.reverse_apply
(Stdlib.op_pluspoint (Stdlib.op_starpoint z sigma) mu) round in
if
andb (op_gt op_startypeminuserrorstar a) (op_lt op_startypeminuserrorstar b)
then
z
else
choose_gaussian_nat (a, b).
Definition list_shuffle {A B : Type} (l : list A) : list B :=
OCaml.Stdlib.reverse_apply op_startypeminuserrorstar (List.map snd).
Definition get_n_endorsements {A B : Type} (ctxt : A) (n : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult (list B)) :=
op_gtgteqquestion (op_startypeminuserrorstar ctxt)
(fun endorsing_rights =>
let endorsing_rights := List.sub endorsing_rights n in
map_s
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar ctxt tt) endorsing_rights).
Definition generate_and_add_random_endorsements {A : Type} (inc : A)
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
let pred {B C : Type} (inc : B) : C :=
op_startypeminuserrorstar inc in
let nb_endorsements :=
let n := endorsers_per_block (constants (params args)) in
Z.sub n (choose_exp_nat n) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if_debug
(fun function_parameter =>
let 'tt := function_parameter in
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"[DEBUG] Generating up to " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" endorsements...
" % string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))))
"[DEBUG] Generating up to %d endorsements...
%!" % string)
nb_endorsements) in
op_gtgteqquestion
(get_n_endorsements op_startypeminuserrorstar (Z.sub nb_endorsements 1))
(fun endorsements =>
let compare
(op1 : Tezos_base__TzPervasives.Operation.t) (op2 :
Tezos_base__TzPervasives.Operation.t) : Z :=
Operation_hash.compare (Operation.hash op1) (Operation.hash op2) in
let endorsements := List.sort_uniq compare endorsements in
let endorsements := List.map op_startypeminuserrorstar endorsements in
fold_left_s op_startypeminuserrorstar inc endorsements).
Definition regenerate_transfers : Stdlib.ref bool := Stdlib.ref false.
Definition generate_random_activation {A B C : Type} (function_parameter : A)
: B -> C :=
let '_ := function_parameter in
fun inc =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq regenerate_transfers true in
op_startypeminuserrorstar.
(* ❌ The definition of exceptions is not handled. *)
exception
Fixpoint generate_random_transfer {A B C : Type} (function_parameter : A)
: B -> C :=
let '_ := function_parameter in
fun ctxt =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if op_eq op_startypeminuserrorstar op_startypeminuserrorstar then
Stdlib.raise No_transfer_left
else
tt in
let '(a1, a2) := List.hd op_startypeminuserrorstar in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field op_startypeminuserrorstar "" % string
(List.tl op_startypeminuserrorstar) in
op_startypeminuserrorstar.
Definition generate_random_operation {A B C : Type} (function_parameter : A)
: B -> C :=
let '_ := function_parameter in
fun gen_state =>
let rnd := Random.int 100 in
match rnd with
| x => generate_random_activation gen_state op_startypeminuserrorstar
| _ => generate_random_transfer gen_state op_startypeminuserrorstar
end.
Definition step {A B : Type} (gen_state : A) (blk : B)
: Lwt.t (Tezos_base__TzPervasives.tzresult B) := op_startypeminuserrorstar.
Definition init {A B : Type} (function_parameter : unit)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Lwt.t (Tezos_base__TzPervasives.tzresult (A * B)))) :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Random.init (seed args) in
let parameters := params args in
op_gtgteqquestion op_startypeminuserrorstar
(fun initial_amount =>
let new_seed (function_parameter : unit) : Stdlib.Bytes.t :=
let 'tt := function_parameter in
OCaml.Stdlib.reverse_apply (Stdlib.Bytes.make 32 "000" % char)
(Stdlib.Bytes.map
(fun function_parameter =>
let '_ := function_parameter in
OCaml.Stdlib.reverse_apply (Random.int 256)
OCaml.Stdlib.char_of_int)) in
op_gtgteqquestion
(map_s
(fun function_parameter =>
let '_ := function_parameter in
_return
((op_startypeminuserrorstar (new_seed tt) tt), initial_amount))
(op_minusminus 1 (accounts args)))
(fun initial_accounts =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if_debug
(fun function_parameter =>
let 'tt := function_parameter in
List.iter
(fun function_parameter =>
let '_ := function_parameter in
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"[DEBUG] Account " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" created
" % string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))))
"[DEBUG] Account %a created
%!" % string)
Signature.Public_key_hash.pp_short
op_startypeminuserrorstar) initial_accounts) in
let possible_transfers :=
let l := List.map fst initial_accounts in
OCaml.Stdlib.reverse_apply (List.product l l)
(List.filter
(fun function_parameter =>
let '(a, b) := function_parameter in
op_ltgt a b)) in
op_gtgteqquestion
match nb_commitments args with
| x => _return ([], parameters)
| x =>
op_gtgteqquestion
(map_s
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar (new_seed tt) tt)
(op_minusminus 1 x))
(fun commitments =>
_return (commitments, op_startypeminuserrorstar))
end
(fun function_parameter =>
let '_ := function_parameter in
let gen_state := op_startypeminuserrorstar in
let bootstrap_accounts :=
List.map
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_startypeminuserrorstar, op_startypeminuserrorstar,
op_startypeminuserrorstar)) initial_accounts in
let parameters := op_startypeminuserrorstar in
op_gtgteqquestion (op_startypeminuserrorstar parameters)
(fun genesis =>
op_gtgteqquestion
(if_debug_s
(fun function_parameter =>
let 'tt := function_parameter in
iter_s op_startypeminuserrorstar initial_accounts))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if_debug
(fun function_parameter =>
let 'tt := function_parameter in
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"[DEBUG] Constants : " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))))
"[DEBUG] Constants : %a
%!" % string)
Data_encoding.Json.pp
(Data_encoding.Json.construct
op_startypeminuserrorstar
(Parameters_repr.constants parameters))) in
let print_block {C D : Type} (block : C) : D :=
op_startypeminuserrorstar in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Starting generation with :" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string
1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.String_literal
"length = " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.String_literal
"seed = " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.String_literal
"nb_commi. = " %
string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string
1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" %
string))
(CamlinternalFormatBasics.String_literal
"#accounts = "
% string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ "
%
string
1 0)
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))))))))))))))))))
"@[<v 2>Starting generation with :@ @[length = %d@]@ @[seed = %d@]@ @[nb_commi. = %d@]@ @[#accounts = %d@]@ @]@."
% string) (length args) (seed args)
(nb_commitments args) (accounts args) in
let fix loop
(gen_state : A) (blk : B) (function_parameter : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult (A * B)) :=
match function_parameter with
| 0 => _return (gen_state, blk)
| n =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := print_block blk in
op_gtgteqquestion (step gen_state blk)
(fun blk' => loop gen_state blk' (Z.sub n 1))
end in
_return (loop gen_state genesis (length args))))))).
src/lib_shell/block_directory.ml 167 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let rec read_partial_context context path depth =
(* non tail-recursive *)
if depth = 0 then Lwt.return Block_services.Cut
else
(* try to read as file *)
Context.get context path
>>= function
| Some v ->
Lwt.return (Block_services.Key v)
| None ->
(* try to read as directory *)
Context.fold context path ~init:[] ~f:(fun k acc ->
match k with
| `Key k | `Dir k ->
read_partial_context context k (depth - 1)
>>= fun v ->
let k = List.nth k (List.length k - 1) in
Lwt.return ((k, v) :: acc))
>>= fun l -> Lwt.return (Block_services.Dir (List.rev l))
let build_raw_header_rpc_directory (module Proto : Block_services.PROTO) =
let dir : (State.Chain.t * Block_hash.t * Block_header.t) RPC_directory.t ref
=
ref RPC_directory.empty
in
let register0 s f =
dir :=
RPC_directory.register !dir (RPC_service.subst0 s) (fun block p q ->
f block p q)
in
let module Block_services = Block_services.Make (Proto) (Proto) in
let module S = Block_services.S in
register0 S.hash (fun (_, hash, _) () () -> return hash) ;
(* block header *)
register0 S.header (fun (chain_state, hash, header) () () ->
let protocol_data =
Data_encoding.Binary.of_bytes_exn
Proto.block_header_data_encoding
header.protocol_data
in
return
{
Block_services.hash;
chain_id = State.Chain.id chain_state;
shell = header.shell;
protocol_data;
}) ;
register0 S.raw_header (fun (_, _, header) () () ->
return (Data_encoding.Binary.to_bytes_exn Block_header.encoding header)) ;
register0 S.Header.shell_header (fun (_, _, header) () () ->
return header.shell) ;
register0 S.Header.protocol_data (fun (_, _, header) () () ->
return
(Data_encoding.Binary.of_bytes_exn
Proto.block_header_data_encoding
header.protocol_data)) ;
register0 S.Header.raw_protocol_data (fun (_, _, header) () () ->
return header.protocol_data) ;
(* helpers *)
register0 S.Helpers.Forge.block_header (fun _block () header ->
return (Data_encoding.Binary.to_bytes_exn Block_header.encoding header)) ;
(* protocols *)
register0 S.protocols (fun (chain_state, _hash, header) () () ->
State.Chain.get_level_indexed_protocol chain_state header
>>= fun next_protocol_hash ->
State.Block.header_of_hash chain_state header.shell.predecessor
>>= function
| None ->
return
{
Tezos_shell_services.Block_services.current_protocol =
next_protocol_hash;
next_protocol = next_protocol_hash;
}
| Some pred_header ->
State.Chain.get_level_indexed_protocol chain_state pred_header
>>= fun protocol_hash ->
return
{
Tezos_shell_services.Block_services.current_protocol =
protocol_hash;
next_protocol = next_protocol_hash;
}) ;
!dir
let build_raw_rpc_directory (module Proto : Block_services.PROTO)
(module Next_proto : Registered_protocol.T) =
let dir : State.Block.block RPC_directory.t ref = ref RPC_directory.empty in
let merge d = dir := RPC_directory.merge d !dir in
let register0 s f =
dir :=
RPC_directory.register !dir (RPC_service.subst0 s) (fun block p q ->
f block p q)
in
let register1 s f =
dir :=
RPC_directory.register !dir (RPC_service.subst1 s) (fun (block, a) p q ->
f block a p q)
in
let register2 s f =
dir :=
RPC_directory.register
!dir
(RPC_service.subst2 s)
(fun ((block, a), b) p q -> f block a b p q)
in
let module Block_services = Block_services.Make (Proto) (Next_proto) in
let module S = Block_services.S in
register0 S.live_blocks (fun block () () ->
State.Block.max_operations_ttl block
>>=? fun max_op_ttl ->
Chain_traversal.live_blocks block max_op_ttl
>>=? fun (live_blocks, _) -> return live_blocks) ;
(* block metadata *)
let metadata block =
State.Block.metadata block
>>=? fun metadata ->
let protocol_data =
Data_encoding.Binary.of_bytes_exn
Proto.block_header_metadata_encoding
metadata
in
State.Block.test_chain block
>>= fun (test_chain_status, _) ->
State.Block.max_operations_ttl block
>>=? fun max_operations_ttl ->
return
{
Block_services.protocol_data;
test_chain_status;
max_operations_ttl;
max_operation_data_length = Next_proto.max_operation_data_length;
max_block_header_length = Next_proto.max_block_length;
operation_list_quota =
List.map
(fun {Tezos_protocol_environment.max_size; max_op} ->
{Tezos_shell_services.Block_services.max_size; max_op})
Next_proto.validation_passes;
}
in
register0 S.metadata (fun block () () -> metadata block) ;
(* operations *)
let convert chain_id (op : Operation.t) metadata : Block_services.operation =
let protocol_data =
Data_encoding.Binary.of_bytes_exn Proto.operation_data_encoding op.proto
in
let receipt =
Data_encoding.Binary.of_bytes_exn
Proto.operation_receipt_encoding
metadata
in
{
Block_services.chain_id;
hash = Operation.hash op;
shell = op.shell;
protocol_data;
receipt;
}
in
let operations block =
State.Block.all_operations block
>>= fun ops ->
State.Block.all_operations_metadata block
>>= fun metadata ->
let chain_id = State.Block.chain_id block in
return (List.map2 (List.map2 (convert chain_id)) ops metadata)
in
register0 S.Operations.operations (fun block () () -> operations block) ;
register1 S.Operations.operations_in_pass (fun block i () () ->
let chain_id = State.Block.chain_id block in
try
State.Block.operations block i
>>= fun (ops, _path) ->
State.Block.operations_metadata block i
>>= fun metadata -> return (List.map2 (convert chain_id) ops metadata)
with _ -> Lwt.fail Not_found) ;
register2 S.Operations.operation (fun block i j () () ->
let chain_id = State.Block.chain_id block in
( try
State.Block.operations block i
>>= fun (ops, _path) ->
State.Block.operations_metadata block i
>>= fun metadata -> Lwt.return (List.nth ops j, List.nth metadata j)
with _ -> Lwt.fail Not_found )
>>= fun (op, md) -> return (convert chain_id op md)) ;
(* operation_hashes *)
register0 S.Operation_hashes.operation_hashes (fun block () () ->
State.Block.all_operation_hashes block >>= return) ;
register1 S.Operation_hashes.operation_hashes_in_pass (fun block i () () ->
State.Block.operation_hashes block i >>= fun (ops, _) -> return ops) ;
register2 S.Operation_hashes.operation_hash (fun block i j () () ->
( try
State.Block.operation_hashes block i
>>= fun (ops, _) -> Lwt.return (List.nth ops j)
with _ -> Lwt.fail Not_found )
>>= fun op -> return op) ;
(* context *)
register1 S.Context.read (fun block path q () ->
let depth = Option.unopt ~default:max_int q#depth in
fail_unless
(depth >= 0)
(Tezos_shell_services.Block_services.Invalid_depth_arg depth)
>>=? fun () ->
State.Block.context_exn block
>>= fun context ->
Context.mem context path
>>= fun mem ->
Context.dir_mem context path
>>= fun dir_mem ->
if not (mem || dir_mem) then Lwt.fail Not_found
else read_partial_context context path depth >>= fun dir -> return dir) ;
(* info *)
register0 S.info (fun block () () ->
let chain_id = State.Block.chain_id block in
let hash = State.Block.hash block in
let header = State.Block.header block in
let shell = header.shell in
let protocol_data =
Data_encoding.Binary.of_bytes_exn
Proto.block_header_data_encoding
header.protocol_data
in
metadata block
>>=? fun metadata ->
operations block
>>=? fun operations ->
return
{
Block_services.hash;
chain_id;
header = {shell; protocol_data};
metadata;
operations;
}) ;
(* helpers *)
register0 S.Helpers.Preapply.block (fun block q p ->
let timestamp =
match q#timestamp with
| None ->
Time.System.to_protocol (Systime_os.now ())
| Some time ->
time
in
let protocol_data =
Data_encoding.Binary.to_bytes_exn
Next_proto.block_header_data_encoding
p.protocol_data
in
let operations =
List.map
(List.map (fun op ->
let proto =
Data_encoding.Binary.to_bytes_exn
Next_proto.operation_data_encoding
op.Next_proto.protocol_data
in
{Operation.shell = op.shell; proto}))
p.operations
in
Prevalidation.preapply
~predecessor:block
~timestamp
~protocol_data
operations) ;
register0 S.Helpers.Preapply.operations (fun block () ops ->
State.Block.context_exn block
>>= fun ctxt ->
let predecessor = State.Block.hash block in
let header = State.Block.shell_header block in
let predecessor_context = Shell_context.wrap_disk_context ctxt in
Next_proto.begin_construction
~chain_id:(State.Block.chain_id block)
~predecessor_context
~predecessor_timestamp:header.timestamp
~predecessor_level:header.level
~predecessor_fitness:header.fitness
~predecessor
~timestamp:(Time.System.to_protocol (Systime_os.now ()))
()
>>=? fun state ->
fold_left_s
(fun (state, acc) op ->
Next_proto.apply_operation state op
>>=? fun (state, result) ->
return (state, (op.protocol_data, result) :: acc))
(state, [])
ops
>>=? fun (state, acc) ->
Next_proto.finalize_block state >>=? fun _ -> return (List.rev acc)) ;
register1 S.Helpers.complete (fun block prefix () () ->
State.Block.context_exn block
>>= fun ctxt ->
Base58.complete prefix
>>= fun l1 ->
let ctxt = Shell_context.wrap_disk_context ctxt in
Next_proto.complete_b58prefix ctxt prefix >>= fun l2 -> return (l1 @ l2)) ;
(* merge protocol rpcs... *)
merge
(RPC_directory.map
(fun block ->
let chain_state = State.Block.chain_state block in
let hash = State.Block.hash block in
let header = State.Block.header block in
Lwt.return (chain_state, hash, header))
(build_raw_header_rpc_directory (module Proto))) ;
merge
(RPC_directory.map
(fun block ->
State.Block.context_exn block
>|= fun context ->
let context = Shell_context.wrap_disk_context context in
{
Tezos_protocol_environment.block_hash = State.Block.hash block;
block_header = State.Block.shell_header block;
context;
})
Next_proto.rpc_services) ;
!dir
let get_protocol hash =
match Registered_protocol.get hash with
| None ->
raise Not_found
| Some protocol ->
protocol
let get_directory chain_state block =
State.Block.get_rpc_directory block
>>= function
| Some dir ->
Lwt.return dir
| None -> (
State.Block.protocol_hash_exn block
>>= fun next_protocol_hash ->
let next_protocol = get_protocol next_protocol_hash in
State.Block.predecessor block
>>= function
| None ->
Lwt.return
(build_raw_rpc_directory
(module Block_services.Fake_protocol)
next_protocol)
| Some pred -> (
State.Chain.save_point chain_state
>>= fun (save_point_level, _) ->
( if Compare.Int32.(State.Block.level pred < save_point_level) then
State.Chain.get_level_indexed_protocol
chain_state
(State.Block.header pred)
else State.Block.protocol_hash_exn pred )
>>= fun protocol_hash ->
let (module Proto) = get_protocol protocol_hash in
State.Block.get_rpc_directory block
>>= function
| Some dir ->
Lwt.return dir
| None ->
let dir = build_raw_rpc_directory (module Proto) next_protocol in
State.Block.set_rpc_directory block dir
>>= fun () -> Lwt.return dir ) )
let get_header_directory chain_state header =
State.Block.header_of_hash chain_state header.Block_header.shell.predecessor
>>= function
| None ->
(* should not happen *)
Lwt.fail Not_found
| Some pred -> (
State.Chain.get_level_indexed_protocol chain_state pred
>>= fun protocol_hash ->
let (module Proto) = get_protocol protocol_hash in
State.Block.get_header_rpc_directory chain_state header
>>= function
| Some dir ->
Lwt.return dir
| None ->
let dir = build_raw_header_rpc_directory (module Proto) in
State.Block.set_header_rpc_directory chain_state header dir
>>= fun () -> Lwt.return dir )
let get_block chain_state = function
| `Genesis ->
Chain.genesis chain_state >>= fun genesis -> Lwt.return_some genesis
| `Head n ->
Chain.head chain_state
>>= fun head ->
if n < 0 then Lwt.return_none
else if n = 0 then Lwt.return_some head
else
State.Block.read_predecessor
chain_state
~pred:n
~below_save_point:true
(State.Block.hash head)
| (`Alias (_, n) | `Hash (_, n)) as b ->
( match b with
| `Alias (`Checkpoint, _) ->
State.Chain.checkpoint chain_state
>>= fun checkpoint -> Lwt.return (Block_header.hash checkpoint)
| `Alias (`Save_point, _) ->
State.Chain.save_point chain_state
>>= fun (_, save_point) -> Lwt.return save_point
| `Alias (`Caboose, _) ->
State.Chain.caboose chain_state
>>= fun (_, caboose) -> Lwt.return caboose
| `Hash (h, _) ->
Lwt.return h )
>>= fun hash ->
if n < 0 then
State.Block.read_opt chain_state hash
>|= Option.unopt_assert ~loc:__POS__
>>= fun block ->
Chain.head chain_state
>>= fun head ->
let head_level = State.Block.level head in
let block_level = State.Block.level block in
let target =
Int32.(to_int (sub head_level (sub block_level (of_int n))))
in
if target < 0 then Lwt.return_none
else
State.Block.read_predecessor
chain_state
~pred:target
~below_save_point:true
(State.Block.hash head)
else if n = 0 then
Chain.genesis chain_state
>>= fun genesis ->
let genesis_hash = State.Block.hash genesis in
if Block_hash.equal hash genesis_hash then Lwt.return_some genesis
else
State.Block.read_predecessor
chain_state
~pred:0
~below_save_point:true
hash
else
State.Block.read_predecessor
chain_state
~pred:n
~below_save_point:true
hash
| `Level i ->
Chain.head chain_state
>>= fun head ->
let target = Int32.(to_int (sub (State.Block.level head) i)) in
if target < 0 then Lwt.fail Not_found
else
State.Block.read_predecessor
chain_state
~pred:target
~below_save_point:true
(State.Block.hash head)
let build_rpc_directory chain_state block =
get_block chain_state block
>>= function
| None ->
Lwt.fail Not_found
| Some b ->
State.Chain.save_point chain_state
>>= fun (save_point_level, _) ->
let block_level = State.Block.level b in
let block_hash = State.Block.hash b in
let genesis = State.Chain.genesis chain_state in
if
block_level >= save_point_level
|| Block_hash.equal block_hash genesis.block
then
get_directory chain_state b
>>= fun dir ->
Lwt.return (RPC_directory.map (fun _ -> Lwt.return b) dir)
else
let header = State.Block.header b in
let hash = State.Block.hash b in
get_header_directory chain_state header
>>= fun dir ->
Lwt.return
(RPC_directory.map
(fun _ -> Lwt.return (chain_state, hash, header))
dir)
src/lib_shell/block_directory.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Fixpoint read_partial_context
(context : Tezos_storage.Context.context) (path : Tezos_storage.Context.key)
(depth : Z) : Lwt.t Tezos_shell_services.Block_services.raw_context :=
if equiv_decb depth 0 then
Lwt._return Tezos_shell_services.Block_services.Cut
else
op_gtgteq (Context.get context path)
(fun function_parameter =>
match function_parameter with
| Some v => Lwt._return (Tezos_shell_services.Block_services.Key v)
| None =>
op_gtgteq
(Context.fold context path []
(fun k =>
fun acc =>
let 'Key k | Dir k := k in
op_gtgteq (read_partial_context context k (Z.sub depth 1))
(fun v =>
let k := List.nth k (Z.sub (List.length k) 1) in
Lwt._return (cons (k, v) acc))))
(fun l =>
Lwt._return (Tezos_shell_services.Block_services.Dir (List.rev l)))
end).
Definition build_raw_header_rpc_directory
(Proto :
{'(block_header_data, block_header_metadata, operation_data,
operation_receipt, operation) : _ &
Tezos_shell_services.Block_services.PROTO.signature block_header_data
block_header_metadata operation_data operation_receipt operation})
: Tezos_base__TzPervasives.RPC_directory.t
(Tezos_shell.State.Chain.t * Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t) :=
let Proto := projT2 Proto in
let dir := Stdlib.ref RPC_directory.empty in
let register0 {A B C D : Type}
(s :
Tezos_base__TzPervasives.RPC_service.raw variant A A B C D
Tezos_rpc.RPC_service.error) (f :
(Tezos_shell.State.Chain.t * Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t) ->
B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
Stdlib.op_coloneq dir
(RPC_directory.register (Stdlib.op_exclamation dir) (RPC_service.subst0 s)
(fun block => fun p => fun q => f block p q)) in
let Block_services :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
let S := Block_services.S in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.hash
(fun function_parameter =>
let '(_, hash, _) := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
_return hash) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.header
(fun function_parameter =>
let '(chain_state, hash, header) := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
let protocol_data :=
Data_encoding.Binary.of_bytes_exn
Proto.(Tezos_shell_services__Block_services.PROTO.block_header_data_encoding)
(protocol_data header) in
_return
{| Block_services.chain_id := State.Chain.id chain_state;
Block_services.hash := hash;
Block_services.shell := shell header;
Block_services.protocol_data := protocol_data |}) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.raw_header
(fun function_parameter =>
let '(_, _, header) := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
_return
(Data_encoding.Binary.to_bytes_exn Block_header.encoding header))
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.Header.shell_header
(fun function_parameter =>
let '(_, _, header) := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
_return (shell header)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.Header.protocol_data
(fun function_parameter =>
let '(_, _, header) := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
_return
(Data_encoding.Binary.of_bytes_exn
Proto.(Tezos_shell_services__Block_services.PROTO.block_header_data_encoding)
(protocol_data header))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.Header.raw_protocol_data
(fun function_parameter =>
let '(_, _, header) := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
_return (protocol_data header)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.Helpers.Forge.block_header
(fun _block =>
fun function_parameter =>
let 'tt := function_parameter in
fun header =>
_return
(Data_encoding.Binary.to_bytes_exn Block_header.encoding header))
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.protocols
(fun function_parameter =>
let '(chain_state, _hash, header) := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(State.Chain.get_level_indexed_protocol chain_state header)
(fun next_protocol_hash =>
op_gtgteq
(State.Block.header_of_hash chain_state
(predecessor (shell header)))
(fun function_parameter =>
match function_parameter with
| None =>
_return
{|
Tezos_shell_services.Block_services.current_protocol :=
next_protocol_hash;
Tezos_shell_services.Block_services.next_protocol :=
next_protocol_hash |}
| Some pred_header =>
op_gtgteq
(State.Chain.get_level_indexed_protocol chain_state
pred_header)
(fun protocol_hash =>
_return
{|
Tezos_shell_services.Block_services.current_protocol :=
protocol_hash;
Tezos_shell_services.Block_services.next_protocol :=
next_protocol_hash |})
end))) in
Stdlib.op_exclamation dir.
Definition build_raw_rpc_directory
(Proto :
{'(block_header_data, block_header_metadata, operation_data,
operation_receipt, operation) : _ &
Tezos_shell_services.Block_services.PROTO.signature block_header_data
block_header_metadata operation_data operation_receipt operation})
: {'(P_block_header_data, P_block_header, P_block_header_metadata,
P_operation_data, P_operation_receipt, P_operation, P_validation_state) : _
&
Tezos_protocol_updater.Registered_protocol.T.signature P_block_header_data
P_block_header P_block_header_metadata P_operation_data
P_operation_receipt P_operation P_validation_state} ->
Tezos_base__TzPervasives.RPC_directory.t Tezos_shell.State.Block.block :=
let Proto := projT2 Proto in
fun Next_proto =>
let Next_proto := projT2 Next_proto in
let dir := Stdlib.ref RPC_directory.empty in
let merge
(d :
Tezos_base__TzPervasives.RPC_directory.directory
Tezos_shell.State.Block.block) : unit :=
Stdlib.op_coloneq dir (RPC_directory.merge d (Stdlib.op_exclamation dir))
in
let register0 {A B C D : Type}
(s :
Tezos_base__TzPervasives.RPC_service.raw variant A A B C D
Tezos_rpc.RPC_service.error) (f :
Tezos_shell.State.Block.block ->
B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
Stdlib.op_coloneq dir
(RPC_directory.register (Stdlib.op_exclamation dir)
(RPC_service.subst0 s) (fun block => fun p => fun q => f block p q))
in
let register1 {A B C D E : Type}
(s :
Tezos_base__TzPervasives.RPC_service.raw variant A (A * B) C D E
Tezos_rpc.RPC_service.error) (f :
Tezos_shell.State.Block.block ->
B -> C -> D -> Lwt.t (Tezos_error_monad.Error_monad.tzresult E))
: unit :=
Stdlib.op_coloneq dir
(RPC_directory.register (Stdlib.op_exclamation dir)
(RPC_service.subst1 s)
(fun function_parameter =>
let '(block, a) := function_parameter in
fun p => fun q => f block a p q)) in
let register2 {A B C D E F : Type}
(s :
Tezos_base__TzPervasives.RPC_service.raw variant A ((A * B) * C) D E F
Tezos_rpc.RPC_service.error) (f :
Tezos_shell.State.Block.block ->
B -> C -> D -> E -> Lwt.t (Tezos_error_monad.Error_monad.tzresult F))
: unit :=
Stdlib.op_coloneq dir
(RPC_directory.register (Stdlib.op_exclamation dir)
(RPC_service.subst2 s)
(fun function_parameter =>
let '((block, a), b) := function_parameter in
fun p => fun q => f block a b p q)) in
let Block_services :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
let S := Block_services.S in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.live_blocks
(fun block =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (State.Block.max_operations_ttl block)
(fun max_op_ttl =>
op_gtgteqquestion
(Chain_traversal.live_blocks block max_op_ttl)
(fun function_parameter =>
let '(live_blocks, _) := function_parameter in
_return live_blocks))) in
let metadata (block : Tezos_shell.State.Block.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Block_services.block_metadata) :=
op_gtgteqquestion (State.Block.metadata block)
(fun metadata =>
let protocol_data :=
Data_encoding.Binary.of_bytes_exn
Proto.(Tezos_shell_services__Block_services.PROTO.block_header_metadata_encoding)
metadata in
op_gtgteq (State.Block.test_chain block)
(fun function_parameter =>
let '(test_chain_status, _) := function_parameter in
op_gtgteqquestion (State.Block.max_operations_ttl block)
(fun max_operations_ttl =>
_return
{| Block_services.protocol_data := protocol_data;
Block_services.test_chain_status := test_chain_status;
Block_services.max_operations_ttl := max_operations_ttl;
Block_services.max_operation_data_length :=
Next_proto.(Tezos_protocol_updater__Registered_protocol.T.max_operation_data_length);
Block_services.max_block_header_length :=
Next_proto.(Tezos_protocol_updater__Registered_protocol.T.max_block_length);
Block_services.operation_list_quota :=
List.map
(fun function_parameter =>
let '{|
Tezos_protocol_environment.max_size := max_size;
Tezos_protocol_environment.max_op := max_op
|} := function_parameter in
{|
Tezos_shell_services.Block_services.max_size :=
max_size;
Tezos_shell_services.Block_services.max_op :=
max_op |})
Next_proto.(Tezos_protocol_updater__Registered_protocol.T.validation_passes)
|}))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.metadata
(fun block =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
metadata block) in
let convert
(chain_id : Tezos_base__TzPervasives.Chain_id.t) (op :
Tezos_base__TzPervasives.Operation.t) (metadata : Stdlib.Bytes.t)
: Block_services.operation :=
let protocol_data :=
Data_encoding.Binary.of_bytes_exn
Proto.(Tezos_shell_services__Block_services.PROTO.operation_data_encoding)
(proto op) in
let receipt :=
Data_encoding.Binary.of_bytes_exn
Proto.(Tezos_shell_services__Block_services.PROTO.operation_receipt_encoding)
metadata in
{| Block_services.chain_id := chain_id;
Block_services.hash := Operation.hash op;
Block_services.shell := shell op;
Block_services.protocol_data := protocol_data;
Block_services.receipt := receipt |} in
let operations (block : Tezos_shell.State.Block.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list (list Block_services.operation))) :=
op_gtgteq (State.Block.all_operations block)
(fun ops =>
op_gtgteq (State.Block.all_operations_metadata block)
(fun metadata =>
let chain_id := State.Block.chain_id block in
_return (List.map2 (List.map2 (convert chain_id)) ops metadata)))
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.Operations.operations
(fun block =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
operations block) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.Operations.operations_in_pass
(fun block =>
fun i =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
let chain_id := State.Block.chain_id block in
(* ❌ Try-with are not handled *)
try
(op_gtgteq (State.Block.operations block i)
(fun function_parameter =>
let '(ops, _path) := function_parameter in
op_gtgteq (State.Block.operations_metadata block i)
(fun metadata =>
_return (List.map2 (convert chain_id) ops metadata)))))
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register2 S.Operations.operation
(fun block =>
fun i =>
fun j =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
let chain_id := State.Block.chain_id block in
op_gtgteq
(* ❌ Try-with are not handled *)
(try
(op_gtgteq (State.Block.operations block i)
(fun function_parameter =>
let '(ops, _path) := function_parameter in
op_gtgteq (State.Block.operations_metadata block i)
(fun metadata =>
Lwt._return
((List.nth ops j), (List.nth metadata j))))))
(fun function_parameter =>
let '(op, md) := function_parameter in
_return (convert chain_id op md))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.Operation_hashes.operation_hashes
(fun block =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Block.all_operation_hashes block) _return) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.Operation_hashes.operation_hashes_in_pass
(fun block =>
fun i =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Block.operation_hashes block i)
(fun function_parameter =>
let '(ops, _) := function_parameter in
_return ops)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register2 S.Operation_hashes.operation_hash
(fun block =>
fun i =>
fun j =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(* ❌ Try-with are not handled *)
(try
(op_gtgteq (State.Block.operation_hashes block i)
(fun function_parameter =>
let '(ops, _) := function_parameter in
Lwt._return (List.nth ops j)))) (fun op => _return op))
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.Context.read
(fun block =>
fun path =>
fun q =>
fun function_parameter =>
let 'tt := function_parameter in
let depth :=
Option.unopt Stdlib.max_int
(* ❌ Sending method message is not handled *)
send in
op_gtgteqquestion
(fail_unless (OCaml.Stdlib.ge depth 0)
(Tezos_base__TzPervasives.Invalid_depth_arg depth))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Block.context_exn block)
(fun context =>
op_gtgteq (Context.mem context path)
(fun mem =>
op_gtgteq (Context.dir_mem context path)
(fun dir_mem =>
if negb (orb mem dir_mem) then
Lwt.fail OCaml.Not_found
else
op_gtgteq
(read_partial_context context path depth)
(fun dir => _return dir)))))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.info
(fun block =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
let chain_id := State.Block.chain_id block in
let hash := State.Block.hash block in
let header := State.Block.header block in
let shell := shell header in
let protocol_data :=
Data_encoding.Binary.of_bytes_exn
Proto.(Tezos_shell_services__Block_services.PROTO.block_header_data_encoding)
(protocol_data header) in
op_gtgteqquestion (metadata block)
(fun metadata =>
op_gtgteqquestion (operations block)
(fun operations =>
_return
{| Block_services.chain_id := chain_id;
Block_services.hash := hash;
Block_services.header :=
{| shell := shell; protocol_data := protocol_data |};
Block_services.metadata := metadata;
Block_services.operations := operations |}))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.Helpers.Preapply.block
(fun block =>
fun q =>
fun p =>
let timestamp :=
match
(* ❌ Sending method message is not handled *)
send with
| None => Time.System.to_protocol (Systime_os.now tt)
| Some time => time
end in
let protocol_data :=
Data_encoding.Binary.to_bytes_exn
Next_proto.(Tezos_protocol_updater__Registered_protocol.T.block_header_data_encoding)
(protocol_data p) in
let operations :=
List.map
(List.map
(fun op =>
let proto :=
Data_encoding.Binary.to_bytes_exn
Next_proto.(Tezos_protocol_updater__Registered_protocol.T.operation_data_encoding)
(Next_proto.protocol_data op) in
{| Operation.shell := shell op; Operation.proto := proto
|})) (operations p) in
Prevalidation.preapply block timestamp protocol_data operations)
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.Helpers.Preapply.operations
(fun block =>
fun function_parameter =>
let 'tt := function_parameter in
fun ops =>
op_gtgteq (State.Block.context_exn block)
(fun ctxt =>
let predecessor := State.Block.hash block in
let header := State.Block.shell_header block in
let predecessor_context :=
Shell_context.wrap_disk_context ctxt in
op_gtgteqquestion
(Next_proto.(Tezos_protocol_updater__Registered_protocol.T.begin_construction)
(State.Block.chain_id block) predecessor_context
(timestamp header) (level header) (fitness header)
predecessor (Time.System.to_protocol (Systime_os.now tt))
None tt)
(fun state =>
op_gtgteqquestion
(fold_left_s
(fun function_parameter =>
let '(state, acc) := function_parameter in
fun op =>
op_gtgteqquestion
(Next_proto.(Tezos_protocol_updater__Registered_protocol.T.apply_operation)
state op)
(fun function_parameter =>
let '(state, result) := function_parameter in
_return
(state,
(cons ((protocol_data op), result) acc))))
(state, []) ops)
(fun function_parameter =>
let '(state, acc) := function_parameter in
op_gtgteqquestion
(Next_proto.(Tezos_protocol_updater__Registered_protocol.T.finalize_block)
state)
(fun function_parameter =>
let '_ := function_parameter in
_return (List.rev acc)))))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.Helpers.complete
(fun block =>
fun prefix =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Block.context_exn block)
(fun ctxt =>
op_gtgteq (Base58.complete None prefix)
(fun l1 =>
let ctxt := Shell_context.wrap_disk_context ctxt in
op_gtgteq
(Next_proto.(Tezos_protocol_updater__Registered_protocol.T.complete_b58prefix)
ctxt prefix)
(fun l2 => _return (OCaml.Stdlib.app l1 l2))))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
merge
(RPC_directory.map
(fun block =>
let chain_state := State.Block.chain_state block in
let hash := State.Block.hash block in
let header := State.Block.header block in
Lwt._return (chain_state, hash, header))
(build_raw_header_rpc_directory Proto)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
merge
(RPC_directory.map
(fun block =>
op_gtpipeeq (State.Block.context_exn block)
(fun context =>
let context := Shell_context.wrap_disk_context context in
{|
Tezos_protocol_environment.block_hash :=
State.Block.hash block;
Tezos_protocol_environment.block_header :=
State.Block.shell_header block;
Tezos_protocol_environment.context := context |}))
Next_proto.(Tezos_protocol_updater__Registered_protocol.T.rpc_services))
in
Stdlib.op_exclamation dir.
Definition get_protocol (hash : Tezos_base__TzPervasives.Protocol_hash.t)
: Tezos_protocol_updater.Registered_protocol.t :=
match Registered_protocol.get hash with
| None => Stdlib.raise OCaml.Not_found
| Some protocol => protocol
end.
Definition get_directory
(chain_state : Tezos_shell.State.Chain.chain_state)
(block : Tezos_shell.State.Block.t)
: Lwt.t (Tezos_base__TzPervasives.RPC_directory.t Tezos_shell.State.Block.t) :=
op_gtgteq (State.Block.get_rpc_directory block)
(fun function_parameter =>
match function_parameter with
| Some dir => Lwt._return dir
| None =>
op_gtgteq (State.Block.protocol_hash_exn block)
(fun next_protocol_hash =>
let next_protocol := get_protocol next_protocol_hash in
op_gtgteq (State.Block.predecessor block)
(fun function_parameter =>
match function_parameter with
| None =>
Lwt._return
(build_raw_rpc_directory Block_services.Fake_protocol
next_protocol)
| Some pred =>
op_gtgteq (State.Chain.save_point chain_state)
(fun function_parameter =>
let '(save_point_level, _) := function_parameter in
op_gtgteq
(if op_lt (State.Block.level pred) save_point_level then
State.Chain.get_level_indexed_protocol chain_state
(State.Block.header pred)
else
State.Block.protocol_hash_exn pred)
(fun protocol_hash =>
let Proto := get_protocol protocol_hash in
let Proto := projT2 Proto in
op_gtgteq (State.Block.get_rpc_directory block)
(fun function_parameter =>
match function_parameter with
| Some dir => Lwt._return dir
| None =>
let dir :=
build_raw_rpc_directory Proto next_protocol in
op_gtgteq
(State.Block.set_rpc_directory block dir)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return dir)
end)))
end))
end).
Definition get_header_directory
(chain_state : Tezos_shell__State.Chain.t)
(header : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t
(Tezos_base__TzPervasives.RPC_directory.t
(Tezos_shell.State.Chain.t * Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t)) :=
op_gtgteq
(State.Block.header_of_hash chain_state
(predecessor (Block_header.shell header)))
(fun function_parameter =>
match function_parameter with
| None => Lwt.fail OCaml.Not_found
| Some pred =>
op_gtgteq (State.Chain.get_level_indexed_protocol chain_state pred)
(fun protocol_hash =>
let Proto := get_protocol protocol_hash in
let Proto := projT2 Proto in
op_gtgteq (State.Block.get_header_rpc_directory chain_state header)
(fun function_parameter =>
match function_parameter with
| Some dir => Lwt._return dir
| None =>
let dir := build_raw_header_rpc_directory Proto in
op_gtgteq
(State.Block.set_header_rpc_directory chain_state header dir)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return dir)
end))
end).
Definition get_block
(chain_state : Tezos_shell.State.Chain.t) (function_parameter : variant)
: Lwt.t (option Tezos_shell.State.Block.t) :=
match function_parameter with
| Genesis =>
op_gtgteq (Chain.genesis chain_state)
(fun genesis => Lwt.return_some genesis)
| Head n =>
op_gtgteq (Chain.head chain_state)
(fun head =>
if OCaml.Stdlib.lt n 0 then
Lwt.return_none
else
if equiv_decb n 0 then
Lwt.return_some head
else
State.Block.read_predecessor chain_state n (Some true)
(State.Block.hash head))
| (Alias (_, n) | Hash (_, n)) as b =>
op_gtgteq
match b with
| Alias (Checkpoint, _) =>
op_gtgteq (State.Chain.checkpoint chain_state)
(fun checkpoint => Lwt._return (Block_header.hash checkpoint))
| Alias (Save_point, _) =>
op_gtgteq (State.Chain.save_point chain_state)
(fun function_parameter =>
let '(_, save_point) := function_parameter in
Lwt._return save_point)
| Alias (Caboose, _) =>
op_gtgteq (State.Chain.caboose chain_state)
(fun function_parameter =>
let '(_, caboose) := function_parameter in
Lwt._return caboose)
| Hash (h, _) => Lwt._return h
end
(fun hash =>
if OCaml.Stdlib.lt n 0 then
op_gtgteq
(op_gtpipeeq (State.Block.read_opt chain_state hash)
(Option.unopt_assert Stdlib.__POS__))
(fun block =>
op_gtgteq (Chain.head chain_state)
(fun head =>
let head_level := State.Block.level head in
let block_level := State.Block.level block in
let target :=
to_int (sub head_level (sub block_level (of_int n))) in
if OCaml.Stdlib.lt target 0 then
Lwt.return_none
else
State.Block.read_predecessor chain_state target (Some true)
(State.Block.hash head)))
else
if equiv_decb n 0 then
op_gtgteq (Chain.genesis chain_state)
(fun genesis =>
let genesis_hash := State.Block.hash genesis in
if Block_hash.equal hash genesis_hash then
Lwt.return_some genesis
else
State.Block.read_predecessor chain_state 0 (Some true) hash)
else
State.Block.read_predecessor chain_state n (Some true) hash)
| Level i =>
op_gtgteq (Chain.head chain_state)
(fun head =>
let target := to_int (sub (State.Block.level head) i) in
if OCaml.Stdlib.lt target 0 then
Lwt.fail OCaml.Not_found
else
State.Block.read_predecessor chain_state target (Some true)
(State.Block.hash head))
end.
Definition build_rpc_directory {A : Type}
(chain_state : Tezos_shell.State.Chain.t) (block : variant)
: Lwt.t (Tezos_base__TzPervasives.RPC_directory.directory A) :=
op_gtgteq (get_block chain_state block)
(fun function_parameter =>
match function_parameter with
| None => Lwt.fail OCaml.Not_found
| Some b =>
op_gtgteq (State.Chain.save_point chain_state)
(fun function_parameter =>
let '(save_point_level, _) := function_parameter in
let block_level := State.Block.level b in
let block_hash := State.Block.hash b in
let genesis := State.Chain.genesis chain_state in
if
orb (OCaml.Stdlib.ge block_level save_point_level)
(Block_hash.equal block_hash (block genesis)) then
op_gtgteq (get_directory chain_state b)
(fun dir =>
Lwt._return
(RPC_directory.map
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return b) dir))
else
let header := State.Block.header b in
let hash := State.Block.hash b in
op_gtgteq (get_header_directory chain_state header)
(fun dir =>
Lwt._return
(RPC_directory.map
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (chain_state, hash, header)) dir)))
end).
src/lib_shell/block_validator.ml 45 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Block_validator_worker_state
open Block_validator_errors
type limits = {
protocol_timeout : Time.System.Span.t;
worker_limits : Worker_types.limits;
}
module Name = struct
type t = unit
let encoding = Data_encoding.empty
let base = ["validator"; "block"]
let pp _ () = ()
end
module Types = struct
include Worker_state
type state = {
protocol_validator : Protocol_validator.t;
validation_process : Block_validator_process.t;
limits : limits;
start_testchain : bool;
}
type parameters =
limits * bool * Distributed_db.t * Block_validator_process.t
let view _state _parameters = ()
end
module Request = struct
include Request
type 'a t =
| Request_validation : {
chain_db : Distributed_db.chain_db;
notify_new_block : State.Block.t -> unit;
canceler : Lwt_canceler.t option;
peer : P2p_peer.Id.t option;
hash : Block_hash.t;
header : Block_header.t;
operations : Operation.t list list;
}
-> State.Block.t option tzresult t
let view : type a. a t -> view =
fun (Request_validation {chain_db; peer; hash; _}) ->
let chain_id = chain_db |> Distributed_db.chain_state |> State.Chain.id in
{chain_id; block = hash; peer}
end
module Logger = Worker_logger.Make (Event) (Request)
module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)
type t = Worker.infinite Worker.queue Worker.t
let debug w = Format.kasprintf (fun msg -> Worker.record_event w (Debug msg))
let check_chain_liveness chain_db hash (header : Block_header.t) =
let chain_state = Distributed_db.chain_state chain_db in
match State.Chain.expiration chain_state with
| Some eol when Time.Protocol.(eol <= header.shell.timestamp) ->
fail @@ invalid_block hash
@@ Expired_chain
{
chain_id = State.Chain.id chain_state;
expiration = eol;
timestamp = header.shell.timestamp;
}
| None | Some _ ->
return_unit
let on_request : type r. t -> r Request.t -> r tzresult Lwt.t =
fun w
(Request.Request_validation
{chain_db; notify_new_block; canceler; peer; hash; header; operations}) ->
let bv = Worker.state w in
let chain_state = Distributed_db.chain_state chain_db in
State.Block.read_opt chain_state hash
>>= function
| Some block ->
debug
w
"previously validated block %a (after pipe)"
Block_hash.pp_short
hash ;
Protocol_validator.prefetch_and_compile_protocols
bv.protocol_validator
?peer
~timeout:bv.limits.protocol_timeout
block ;
return (Ok None)
| None -> (
State.Block.read_invalid chain_state hash
>>= function
| Some {errors; _} ->
return (Error errors)
| None -> (
State.Chain.save_point chain_state
>>= fun (save_point_lvl, _) ->
(* Safety and late workers in partial mode. *)
if Compare.Int32.(header.shell.level < save_point_lvl) then
return (Ok None)
else
( debug w "validating block %a" Block_hash.pp_short hash ;
State.Block.read chain_state header.shell.predecessor
>>=? fun pred ->
Worker.protect w (fun () ->
protect ?canceler (fun () ->
Block_validator_process.apply_block
bv.validation_process
~predecessor:pred
header
operations
>>= function
| Ok x ->
return x
| Error (Missing_test_protocol protocol :: _) ->
Protocol_validator.fetch_and_compile_protocol
bv.protocol_validator
?peer
~timeout:bv.limits.protocol_timeout
protocol
>>=? fun _ ->
Block_validator_process.apply_block
bv.validation_process
~predecessor:pred
header
operations
| Error _ as x ->
Lwt.return x)
>>=? fun { validation_store;
block_metadata;
ops_metadata;
forking_testchain } ->
let validation_store =
( {
context_hash = validation_store.context_hash;
message = validation_store.message;
max_operations_ttl =
validation_store.max_operations_ttl;
last_allowed_fork_level =
validation_store.last_allowed_fork_level;
}
: Block_validation.validation_store )
in
Distributed_db.commit_block
chain_db
hash
header
block_metadata
operations
ops_metadata
validation_store
~forking_testchain
>>=? function
| None ->
assert false (* should not happen *)
| Some block ->
return block) )
>>= function
| Ok block ->
Protocol_validator.prefetch_and_compile_protocols
bv.protocol_validator
?peer
~timeout:bv.limits.protocol_timeout
block ;
notify_new_block block ;
return (Ok (Some block))
| Error err as error ->
if
List.exists
(function Invalid_block _ -> true | _ -> false)
err
then (
Worker.protect w (fun () ->
Distributed_db.commit_invalid_block
chain_db
hash
header
err)
>>=? fun commited ->
assert commited ;
return error )
else (
debug
w
"Error during %a block validation: %a"
Block_hash.pp_short
hash
Error_monad.pp_print_error
err ;
return error ) ) )
let on_launch _ _ (limits, start_testchain, db, validation_process) =
let protocol_validator = Protocol_validator.create db in
return
{Types.protocol_validator; validation_process; limits; start_testchain}
let on_error w r st errs =
Worker.record_event w (Validation_failure (r, st, errs)) ;
Lwt.return_error errs
let on_completion :
type a. t -> a Request.t -> a -> Worker_types.request_status -> unit Lwt.t
=
fun w (Request.Request_validation _ as r) v st ->
match v with
| Ok (Some _) ->
Worker.record_event w (Event.Validation_success (Request.view r, st)) ;
Lwt.return_unit
| Ok None ->
Lwt.return_unit
| Error errs ->
Worker.record_event
w
(Event.Validation_failure (Request.view r, st, errs)) ;
Lwt.return_unit
let on_close w =
let bv = Worker.state w in
Block_validator_process.close bv.validation_process
let table = Worker.create_table Queue
let create limits db validation_process ~start_testchain =
let module Handlers = struct
type self = t
let on_launch = on_launch
let on_request = on_request
let on_close = on_close
let on_error = on_error
let on_completion = on_completion
let on_no_request _ = return_unit
end in
Worker.launch
table
limits.worker_limits
()
(limits, start_testchain, db, validation_process)
(module Handlers)
let shutdown = Worker.shutdown
let validate w ?canceler ?peer ?(notify_new_block = fun _ -> ()) chain_db hash
(header : Block_header.t) operations =
let bv = Worker.state w in
let chain_state = Distributed_db.chain_state chain_db in
State.Block.read_opt chain_state hash
>>= function
| Some block ->
debug
w
"previously validated block %a (before pipe)"
Block_hash.pp_short
hash ;
Protocol_validator.prefetch_and_compile_protocols
bv.protocol_validator
?peer
~timeout:bv.limits.protocol_timeout
block ;
return_none
| None ->
map_p
(map_p (fun op ->
let op_hash = Operation.hash op in
return op_hash))
operations
>>=? fun hashes ->
let computed_hash =
Operation_list_list_hash.compute
(List.map Operation_list_hash.compute hashes)
in
fail_when
( Operation_list_list_hash.compare
computed_hash
header.shell.operations_hash
<> 0 )
(Inconsistent_operations_hash
{
block = hash;
expected = header.shell.operations_hash;
found = computed_hash;
})
>>=? fun () ->
check_chain_liveness chain_db hash header
>>=? fun () ->
Worker.Queue.push_request_and_wait
w
(Request_validation
{
chain_db;
notify_new_block;
canceler;
peer;
hash;
header;
operations;
})
>>=? fun result -> Lwt.return result
let fetch_and_compile_protocol w =
let bv = Worker.state w in
Protocol_validator.fetch_and_compile_protocol bv.protocol_validator
let status = Worker.status
let running_worker () =
match Worker.list table with
| [(_, single)] ->
single
| [] ->
raise Not_found
| _ :: _ :: _ ->
(* NOTE: names of workers must be unique, [Name.t = unit] which has only
one inhabitant. *)
assert false
let pending_requests t = Worker.Queue.pending_requests t
let current_request t = Worker.current_request t
let last_events = Worker.last_events
src/lib_shell/block_validator.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Block_validator_worker_state.
Import Block_validator_errors.
Record limits := {
protocol_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
worker_limits : Tezos_shell_services.Worker_types.limits }.
Module Name.
Definition t := unit.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
Data_encoding.empty.
Definition base : list string :=
cons "validator" % string (cons "block" % string []).
Definition pp {A : Type} (function_parameter : A) : unit -> unit :=
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
tt.
End Name.
Module Types.
(* ❌ Structure item `include` not handled. *)
include
Record state := {
protocol_validator : Tezos_shell.Protocol_validator.t;
validation_process : Tezos_shell.Block_validator_process.t;
limits : limits;
start_testchain : bool }.
Definition parameters :=
limits * bool * Tezos_shell.Distributed_db.t *
Tezos_shell.Block_validator_process.t.
Definition view {A B : Type} (_state : A) (_parameters : B) : unit := tt.
End Types.
Module Request.
(* ❌ Structure item `include` not handled. *)
include
Inductive t : forall (a : Type), Type :=
| Request_validation : Tezos_shell.Distributed_db.chain_db ->
(Tezos_shell.State.Block.t -> unit) ->
(option Tezos_base__TzPervasives.Lwt_canceler.t) ->
(option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
Tezos_base__TzPervasives.Block_hash.t ->
Tezos_base__TzPervasives.Block_header.t ->
(list (list Tezos_base__TzPervasives.Operation.t)) ->
t (Tezos_base__TzPervasives.tzresult (option Tezos_shell.State.Block.t)).
Definition view {a : Type} (function_parameter : t a) : view :=
let
'Request_validation {| chain_db := chain_db; peer := peer; hash := hash |} :=
function_parameter in
let chain_id :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply chain_db Distributed_db.chain_state)
State.Chain.id in
{| chain_id := chain_id; block := hash; peer := peer |}.
End Request.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Definition t := Worker.t (Worker.queue Worker.infinite).
Definition debug {A B : Type} (w : Worker.t A)
: (Stdlib.format4 B Stdlib.Format.formatter unit unit) -> B :=
Format.kasprintf
(fun msg =>
Worker.record_event w
(Tezos_shell_services.Block_validator_worker_state.Event.Debug msg)).
Definition check_chain_liveness
(chain_db : Tezos_shell.Distributed_db.chain_db)
(hash : Tezos_base__TzPervasives.Block_hash.t)
(header : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let chain_state := Distributed_db.chain_state chain_db in
match State.Chain.expiration chain_state with
| Some eol =>
apply fail
(apply (invalid_block hash)
(Tezos_shell_services.Block_validator_errors.Expired_chain
{| chain_id := State.Chain.id chain_state; expiration := eol;
timestamp := timestamp (shell header) |}))
| None | Some _ => return_unit
end.
Definition on_request {r : Type}
(w : t) (function_parameter : Request.(Tezos_shell__Worker.REQUEST.t) r)
: Lwt.t (Tezos_base__TzPervasives.tzresult r) :=
let
'Request.Request_validation {|
chain_db := chain_db;
notify_new_block := notify_new_block;
canceler := canceler;
peer := peer;
hash := hash;
header := header;
operations := operations
|} := function_parameter in
let bv := Worker.state w in
let chain_state := Distributed_db.chain_state chain_db in
op_gtgteq (State.Block.read_opt chain_state hash)
(fun function_parameter =>
match function_parameter with
| Some block =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"previously validated block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (after pipe)" % string
CamlinternalFormatBasics.End_of_format)))
"previously validated block %a (after pipe)" % string)
Block_hash.pp_short hash in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Protocol_validator.prefetch_and_compile_protocols
(protocol_validator bv) peer (Some (protocol_timeout (limits bv)))
block in
_return (Stdlib.Ok None)
| None =>
op_gtgteq (State.Block.read_invalid chain_state hash)
(fun function_parameter =>
match function_parameter with
| Some {| errors := errors |} => _return (Stdlib.Error errors)
| None =>
op_gtgteq (State.Chain.save_point chain_state)
(fun function_parameter =>
let '(save_point_lvl, _) := function_parameter in
if op_lt (level (shell header)) save_point_lvl then
_return (Stdlib.Ok None)
else
op_gtgteq
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"validating block " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"validating block %a" % string) Block_hash.pp_short
hash in
op_gtgteqquestion
(State.Block.read chain_state
(predecessor (shell header)))
(fun pred =>
Worker.protect w None
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(protect None canceler
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Block_validator_process.apply_block
(validation_process bv) pred header
operations)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok x => _return x
|
Stdlib.Error
(cons
(Tezos_base__TzPervasives.Missing_test_protocol
protocol) _) =>
op_gtgteqquestion
(Protocol_validator.fetch_and_compile_protocol
(protocol_validator bv) peer
(Some
(protocol_timeout (limits bv)))
protocol)
(fun function_parameter =>
let '_ := function_parameter in
Block_validator_process.apply_block
(validation_process bv) pred
header operations)
| (Stdlib.Error _) as x => Lwt._return x
end)))
(fun function_parameter =>
let '{|
validation_store := validation_store;
block_metadata := block_metadata;
ops_metadata := ops_metadata;
forking_testchain := forking_testchain
|} := function_parameter in
let validation_store :=
{|
context_hash :=
context_hash validation_store;
message := message validation_store;
max_operations_ttl :=
max_operations_ttl validation_store;
last_allowed_fork_level :=
last_allowed_fork_level validation_store
|} in
op_gtgteqquestion
(Distributed_db.commit_block chain_db hash
header block_metadata operations
ops_metadata validation_store
forking_testchain)
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some block => _return block
end)))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok block =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Protocol_validator.prefetch_and_compile_protocols
(protocol_validator bv) peer
(Some (protocol_timeout (limits bv))) block in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := notify_new_block block in
_return (Stdlib.Ok (Some block))
| (Stdlib.Error err) as error =>
if
List._exists
(fun function_parameter =>
match function_parameter with
| Tezos_base__TzPervasives.Invalid_block _ =>
true
| _ => false
end) err then
op_gtgteqquestion
(Worker.protect w None
(fun function_parameter =>
let 'tt := function_parameter in
Distributed_db.commit_invalid_block chain_db
hash header err))
(fun commited =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert commited in
_return error)
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error during " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" block validation: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Error during %a block validation: %a" %
string) Block_hash.pp_short hash
Error_monad.pp_print_error err in
_return error
end))
end)
end).
Definition on_launch {A B : Type} (function_parameter : A)
: B ->
(limits * bool * Tezos_shell.Distributed_db.t *
Tezos_shell.Block_validator_process.t) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Types.(Tezos_shell__Worker.TYPES.state)) :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '(limits, start_testchain, db, validation_process) :=
function_parameter in
let protocol_validator := Protocol_validator.create db in
_return
{| Types.protocol_validator := protocol_validator;
Types.validation_process := validation_process;
Types.limits := limits; Types.start_testchain := start_testchain |}.
Definition on_error {A B : Type}
(w : Worker.t A)
(r : Tezos_shell_services__Block_validator_worker_state.Request.view)
(st : Tezos_shell_services.Worker_types.request_status)
(errs : list Tezos_base__TzPervasives.error)
: Lwt.t (Result.result B (list Tezos_base__TzPervasives.error)) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Worker.record_event w
(Tezos_shell_services.Block_validator_worker_state.Event.Validation_failure
r st errs) in
Lwt.return_error errs.
Definition on_completion {a : Type}
(w : t) (function_parameter : Request.(Tezos_shell__Worker.REQUEST.t) a)
: a -> Tezos_shell_services.Worker_types.request_status -> Lwt.t unit :=
let '(Request.Request_validation _) as r := function_parameter in
fun v =>
fun st =>
match v with
| Stdlib.Ok (Some _) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Worker.record_event w
(Tezos_shell_services.Block_validator_worker_state.Event.Validation_success
(Request.(Tezos_shell__Worker.REQUEST.view) r) st) in
Lwt.return_unit
| Stdlib.Ok None => Lwt.return_unit
| Stdlib.Error errs =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Worker.record_event w
(Tezos_shell_services.Block_validator_worker_state.Event.Validation_failure
(Request.(Tezos_shell__Worker.REQUEST.view) r) st errs) in
Lwt.return_unit
end.
Definition on_close {A : Type} (w : Worker.t A) : Lwt.t unit :=
let bv := Worker.state w in
Block_validator_process.close (validation_process bv).
Definition table : Worker.table (Worker.queue Worker.infinite) :=
Worker.create_table Worker.Queue.
Definition create
(limits : limits) (db : Tezos_shell.Distributed_db.t)
(validation_process : Tezos_shell.Block_validator_process.t)
(start_testchain : bool)
: Lwt.t
(Tezos_base__TzPervasives.tzresult (Worker.t (Worker.queue Worker.infinite))) :=
let Handlers :=
existT _ unit
{|
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_launch := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_request := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_close := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_error := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_completion := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_no_request := unhandled
|} in
Worker.launch table None (worker_limits limits) tt
(limits, start_testchain, db, validation_process) Handlers.
Definition shutdown {A : Type} : (Worker.t A) -> Lwt.t unit := Worker.shutdown.
Definition validate {A : Type}
(w : Worker.t (Worker.queue A))
(canceler : option Tezos_base__TzPervasives.Lwt_canceler.t)
(peer : option Tezos_base__TzPervasives.P2p_peer.Id.t)
(op_staroptstar : option (Tezos_shell.State.Block.t -> unit))
: Tezos_shell.Distributed_db.chain_db ->
Tezos_base__TzPervasives.Block_hash.t ->
Tezos_base__TzPervasives.Block_header.t ->
(list (list Tezos_base__TzPervasives.Operation.t)) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(option Tezos_shell.State.Block.t)) :=
let notify_new_block :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
fun function_parameter =>
let '_ := function_parameter in
tt
end in
fun chain_db =>
fun hash =>
fun header =>
fun operations =>
let bv := Worker.state w in
let chain_state := Distributed_db.chain_state chain_db in
op_gtgteq (State.Block.read_opt chain_state hash)
(fun function_parameter =>
match function_parameter with
| Some block =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"previously validated block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (before pipe)" % string
CamlinternalFormatBasics.End_of_format)))
"previously validated block %a (before pipe)" % string)
Block_hash.pp_short hash in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Protocol_validator.prefetch_and_compile_protocols
(protocol_validator bv) peer
(Some (protocol_timeout (limits bv))) block in
return_none
| None =>
op_gtgteqquestion
(map_p
(map_p
(fun op =>
let op_hash := Operation.hash op in
_return op_hash)) operations)
(fun hashes =>
let computed_hash :=
Operation_list_list_hash.compute
(List.map Operation_list_hash.compute hashes) in
op_gtgteqquestion
(fail_when
(nequiv_decb
(Operation_list_list_hash.compare computed_hash
(operations_hash (shell header))) 0)
(Tezos_base__TzPervasives.Inconsistent_operations_hash
{| block := hash;
expected := operations_hash (shell header);
found := computed_hash |}))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(check_chain_liveness chain_db hash header)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Worker.Queue.push_request_and_wait w
(Request.Request_validation
{| chain_db := chain_db;
notify_new_block := notify_new_block;
canceler := canceler; peer := peer;
hash := hash; header := header;
operations := operations |}))
(fun result => Lwt._return result))))
end).
Definition fetch_and_compile_protocol {A : Type} (w : Worker.t A)
: (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
(option Ptime.Span.t) ->
Tezos_base__TzPervasives.Protocol_hash.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_updater.Registered_protocol.t) :=
let bv := Worker.state w in
Protocol_validator.fetch_and_compile_protocol (protocol_validator bv).
Definition status {A : Type}
: (Worker.t A) -> Tezos_shell_services.Worker_types.worker_status :=
Worker.status.
Definition running_worker (function_parameter : unit)
: Worker.t (Worker.queue Worker.infinite) :=
let 'tt := function_parameter in
match Worker.list table with
| cons (_, single) [] => single
| [] => Stdlib.raise OCaml.Not_found
| cons _ (cons _ _) =>
(* ❌ Assert instruction is not handled. *)
assert false
end.
Definition pending_requests {A : Type} (t : Worker.t (Worker.queue A))
: list
(Tezos_base__TzPervasives.Time.System.t *
Worker.Request.(Tezos_shell__Worker.REQUEST.view)) :=
Worker.Queue.pending_requests t.
Definition current_request {A : Type} (t : Worker.t A)
: option
(Tezos_base__TzPervasives.Time.System.t *
Tezos_base__TzPervasives.Time.System.t *
Worker.Request.(Tezos_shell__Worker.REQUEST.view)) :=
Worker.current_request t.
Definition last_events {A : Type}
: (Worker.t A) ->
list
(Tezos_base__TzPervasives.Internal_event.level *
(list Worker.Event.(Tezos_shell__Worker.EVENT.t))) := Worker.last_events.
src/lib_shell/block_validator_process.ml 49 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let get_context index hash =
Context.checkout index hash
>>= function
| None ->
fail (Block_validator_errors.Failed_to_checkout_context hash)
| Some ctx ->
return ctx
(** The standard block validation method *)
module Seq_validator = struct
include Internal_event.Legacy_logging.Make (struct
let name = "validation_process.sequential"
end)
type validation_context = {context_index : Context.index}
type t = validation_context
let init context_index =
lwt_log_notice "Initialized" >>= fun () -> Lwt.return {context_index}
let close _ = lwt_log_notice "Shutting down..."
let apply_block validator_process chain_state ~max_operations_ttl
~(predecessor_block_header : Block_header.t) ~block_header operations =
let chain_id = State.Chain.id chain_state in
get_context
validator_process.context_index
predecessor_block_header.shell.context
>>=? fun predecessor_context ->
Block_validation.apply
chain_id
~max_operations_ttl
~predecessor_block_header
~predecessor_context
~block_header
operations
end
(* Block validation using an external processes *)
module External_validator = struct
include Internal_event.Legacy_logging.Make_semantic (struct
let name = "shell.validation_process.external"
end)
type validation_context = {
context_root : string;
protocol_root : string;
process_path : string;
mutable validator_process : Lwt_process.process_full option;
lock : Lwt_mutex.t;
sandbox_parameters : Data_encoding.json option;
}
type t = validation_context
let init ?sandbox_parameters ~context_root ~protocol_root ~process_path =
lwt_log_notice (fun f -> f "Initialized")
>>= fun () ->
Lwt.return
{
context_root;
protocol_root;
process_path;
validator_process = None;
lock = Lwt_mutex.create ();
sandbox_parameters;
}
let check_process_status =
let open Unix in
let int_tag = Tag.def "int" Format.pp_print_int in
function
| WEXITED 0 ->
lwt_log_notice (fun f -> f "The process terminated normally")
| WEXITED i ->
lwt_fatal_error
Tag.DSL.(
fun f ->
f "The process terminated abnormally with value %a"
-% a int_tag i)
| WSIGNALED i ->
lwt_fatal_error
Tag.DSL.(
fun f -> f "The process was killed by signal %a" -% a int_tag i)
| WSTOPPED i ->
lwt_fatal_error
Tag.DSL.(
fun f -> f "The process was stopped by signal %a" -% a int_tag i)
let close vp =
lwt_log_notice (fun f -> f "Shutting down ...")
>>= fun () ->
match vp.validator_process with
| Some process ->
External_validation.send
process#stdin
External_validation.request_encoding
External_validation.Terminate
>>= fun () ->
process#status
>>= (function
| Unix.WEXITED 0 ->
Lwt.return_unit
| _ ->
process#terminate ; Lwt.return_unit)
>>= fun () ->
vp.validator_process <- None ;
Lwt.return_unit
| None ->
Lwt.return_unit
let send_request vp request result_encoding =
let start_process () =
let process =
Lwt_process.open_process_full (vp.process_path, [|"tezos-validator"|])
in
lwt_log_notice
Tag.DSL.(
fun f ->
f "Block validation started on pid %a"
-% a (Tag.def "int" Format.pp_print_int) process#pid)
>>= fun () ->
let parameters =
{
External_validation.context_root = vp.context_root;
protocol_root = vp.protocol_root;
sandbox_parameters = vp.sandbox_parameters;
}
in
vp.validator_process <- Some process ;
External_validation.send
process#stdin
Data_encoding.Variable.bytes
External_validation.magic
>>= fun () ->
External_validation.send
process#stdin
External_validation.parameters_encoding
parameters
>>= fun () -> Lwt.return process
in
( match vp.validator_process with
| Some process -> (
match process#state with
| Running ->
Lwt.return process
| Exited status ->
vp.validator_process <- None ;
check_process_status status
>>= fun () ->
vp.validator_process <- None ;
lwt_log_notice (fun f -> f "restarting validation process...")
>>= fun () -> start_process () )
| None ->
start_process () )
>>= fun process ->
Lwt.catch
(fun () ->
(* Make sure that the promise is not canceled between a send and recv *)
Lwt.protected
(Lwt_mutex.with_lock vp.lock (fun () ->
External_validation.send
process#stdin
External_validation.request_encoding
request
>>= fun () ->
External_validation.recv_result process#stdout result_encoding))
>>=? fun res ->
match process#state with
| Running ->
return res
| Exited status ->
vp.validator_process <- None ;
check_process_status status >>= fun () -> return res)
(function
| errors ->
process#status
>>= fun status ->
check_process_status status
>>= fun () ->
vp.validator_process <- None ;
Lwt.return (error_exn errors))
end
type validator_kind =
| Internal of Context.index
| External of {
context_root : string;
protocol_root : string;
process_path : string;
sandbox_parameters : Data_encoding.json option;
}
type t = Sequential of Seq_validator.t | External of External_validator.t
let init = function
| Internal index ->
Seq_validator.init index >>= fun v -> return (Sequential v)
| External {context_root; protocol_root; process_path; sandbox_parameters} ->
External_validator.init
?sandbox_parameters
~context_root
~protocol_root
~process_path
>>= fun v ->
External_validator.send_request
v
External_validation.Init
Data_encoding.empty
>>=? fun () -> return (External v)
let close = function
| Sequential vp ->
Seq_validator.close vp
| External vp ->
External_validator.close vp
let apply_block bvp ~predecessor block_header operations =
let chain_state = State.Block.chain_state predecessor in
let predecessor_block_header = State.Block.header predecessor in
State.Block.max_operations_ttl predecessor
>>=? fun max_operations_ttl ->
let block_hash = Block_header.hash block_header in
Chain.data chain_state
>>= (fun chain_data ->
if State.Block.equal chain_data.current_head predecessor then
return (chain_data.live_blocks, chain_data.live_operations)
else Chain_traversal.live_blocks predecessor max_operations_ttl)
>>=? fun (live_blocks, live_operations) ->
Block_validation.check_liveness
~live_operations
~live_blocks
block_hash
operations
>>=? fun () ->
match bvp with
| Sequential vp ->
Seq_validator.apply_block
vp
~max_operations_ttl
chain_state
~predecessor_block_header
~block_header
operations
| External vp ->
let chain_id = State.Chain.id chain_state in
let request =
External_validation.Validate
{
chain_id;
block_header;
predecessor_block_header;
operations;
max_operations_ttl;
}
in
External_validator.send_request
vp
request
Block_validation.result_encoding
let commit_genesis bvp ~genesis_hash ~chain_id ~time ~protocol =
match bvp with
| Sequential {context_index} ->
Context.commit_genesis context_index ~chain_id ~time ~protocol
>>= fun res -> return res
| External vp ->
let request =
External_validation.Commit_genesis
{genesis_hash; chain_id; time; protocol}
in
External_validator.send_request vp request Context_hash.encoding
let init_test_chain bvp forking_block =
let forked_header = State.Block.header forking_block in
match bvp with
| Sequential _ ->
State.Block.context forking_block
>>=? fun context ->
Block_validation.init_test_chain context forked_header
| External vp ->
let context_hash = forked_header.shell.context in
let request =
External_validation.Fork_test_chain {context_hash; forked_header}
in
External_validator.send_request vp request Block_header.encoding
src/lib_shell/block_validator_process.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition get_context
(index : Tezos_storage.Context.index)
(hash : Tezos_base__TzPervasives.Context_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_storage.Context.context) :=
op_gtgteq (Context.checkout index hash)
(fun function_parameter =>
match function_parameter with
| None => fail (Tezos_base__TzPervasives.Failed_to_checkout_context hash)
| Some ctx => _return ctx
end).
Module Seq_validator.
(* ❌ Structure item `include` not handled. *)
include
Record validation_context := {
context_index : Tezos_storage.Context.index }.
Definition t := validation_context.
Definition init (context_index : Tezos_storage.Context.index)
: Lwt.t validation_context :=
op_gtgteq
(lwt_log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Initialized" % string
CamlinternalFormatBasics.End_of_format) "Initialized" % string))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return {| context_index := context_index |}).
Definition close {A : Type} (function_parameter : A) : Lwt.t unit :=
let '_ := function_parameter in
lwt_log_notice
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Shutting down..." % string
CamlinternalFormatBasics.End_of_format) "Shutting down..." % string).
Definition apply_block
(validator_process : validation_context)
(chain_state : Tezos_shell.State.Chain.chain_state) (max_operations_ttl : Z)
(predecessor_block_header : Tezos_base__TzPervasives.Block_header.t)
(block_header : Tezos_base__TzPervasives.Block_header.t)
(operations : list (list Tezos_base__TzPervasives.Operation.t))
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_validation.Block_validation.result) :=
let chain_id := State.Chain.id chain_state in
op_gtgteqquestion
(get_context (context_index validator_process)
(context (shell predecessor_block_header)))
(fun predecessor_context =>
Block_validation.apply chain_id max_operations_ttl
predecessor_block_header predecessor_context block_header operations).
End Seq_validator.
Module External_validator.
(* ❌ Structure item `include` not handled. *)
include
Record validation_context := {
context_root : string;
protocol_root : string;
process_path : string;
validator_process : option Lwt_process.process_full;
lock : Lwt_mutex.t;
sandbox_parameters : option Tezos_base__TzPervasives.Data_encoding.json }.
Definition t := validation_context.
Definition init
(sandbox_parameters : option Tezos_base__TzPervasives.Data_encoding.json)
(context_root : string) (protocol_root : string) (process_path : string)
: Lwt.t validation_context :=
op_gtgteq
(lwt_log_notice
(fun f =>
f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Initialized" % string
CamlinternalFormatBasics.End_of_format) "Initialized" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return
{| context_root := context_root; protocol_root := protocol_root;
process_path := process_path; validator_process := None;
lock := Lwt_mutex.create tt;
sandbox_parameters := sandbox_parameters |}).
Definition check_process_status : Unix.process_status -> Lwt.t unit :=
let int_tag := Tag.def None "int" % string Format.pp_print_int in
fun function_parameter =>
match function_parameter with
| Unix.WEXITED 0 =>
lwt_log_notice
(fun f =>
f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The process terminated normally" % string
CamlinternalFormatBasics.End_of_format)
"The process terminated normally" % string))
| Unix.WEXITED i =>
lwt_fatal_error
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The process terminated abnormally with value " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"The process terminated abnormally with value %a" % string))
(a int_tag i))
| Unix.WSIGNALED i =>
lwt_fatal_error
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The process was killed by signal " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"The process was killed by signal %a" % string)) (a int_tag i))
| Unix.WSTOPPED i =>
lwt_fatal_error
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The process was stopped by signal " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"The process was stopped by signal %a" % string))
(a int_tag i))
end.
Definition close (vp : validation_context) : Lwt.t unit :=
op_gtgteq
(lwt_log_notice
(fun f =>
f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down ..." % string
CamlinternalFormatBasics.End_of_format)
"Shutting down ..." % string)))
(fun function_parameter =>
let 'tt := function_parameter in
match validator_process vp with
| Some process =>
op_gtgteq
(External_validation.send
(* ❌ Sending method message is not handled *)
send External_validation.request_encoding
Tezos_validation.External_validation.Terminate)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtgteq
(* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
match function_parameter with
| Unix.WEXITED 0 => Lwt.return_unit
| _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Sending method message is not handled *)
send in
Lwt.return_unit
end))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field vp "validator_process" % string None in
Lwt.return_unit))
| None => Lwt.return_unit
end).
Definition send_request {A : Type}
(vp : validation_context)
(request : Tezos_validation.External_validation.request)
(result_encoding : Tezos_base__TzPervasives.Data_encoding.t A)
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
let start_process (function_parameter : unit)
: Lwt.t Lwt_process.process_full :=
let 'tt := function_parameter in
let process :=
Lwt_process.open_process_full None None
((process_path vp),
(* ❌ Arrays not handled. *)
[ "tezos-validator" % string ]) in
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Block validation started on pid " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Block validation started on pid %a" % string))
(a (Tag.def None "int" % string Format.pp_print_int)
(* ❌ Sending method message is not handled *)
send)))
(fun function_parameter =>
let 'tt := function_parameter in
let parameters :=
{| External_validation.context_root := context_root vp;
External_validation.protocol_root := protocol_root vp;
External_validation.sandbox_parameters := sandbox_parameters vp |}
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field vp "validator_process" % string (Some process) in
op_gtgteq
(External_validation.send
(* ❌ Sending method message is not handled *)
send Data_encoding.Variable.bytes External_validation.magic)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(External_validation.send
(* ❌ Sending method message is not handled *)
send External_validation.parameters_encoding parameters)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return process))) in
op_gtgteq
match validator_process vp with
| Some process =>
match
(* ❌ Sending method message is not handled *)
send with
| Lwt_process.Running => Lwt._return process
| Lwt_process.Exited status =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field vp "validator_process" % string None in
op_gtgteq (check_process_status status)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field vp "validator_process" % string None in
op_gtgteq
(lwt_log_notice
(fun f =>
f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"restarting validation process..." % string
CamlinternalFormatBasics.End_of_format)
"restarting validation process..." % string)))
(fun function_parameter =>
let 'tt := function_parameter in
start_process tt))
end
| None => start_process tt
end
(fun process =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt.protected
(Lwt_mutex.with_lock (lock vp)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(External_validation.send
(* ❌ Sending method message is not handled *)
send External_validation.request_encoding request)
(fun function_parameter =>
let 'tt := function_parameter in
External_validation.recv_result
(* ❌ Sending method message is not handled *)
send result_encoding))))
(fun res =>
match
(* ❌ Sending method message is not handled *)
send with
| Lwt_process.Running => _return res
| Lwt_process.Exited status =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field vp "validator_process" % string None in
op_gtgteq (check_process_status status)
(fun function_parameter =>
let 'tt := function_parameter in
_return res)
end))
(fun errors =>
op_gtgteq
(* ❌ Sending method message is not handled *)
send
(fun status =>
op_gtgteq (check_process_status status)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field vp "validator_process" % string None in
Lwt._return (error_exn errors))))).
End External_validator.
Inductive validator_kind : Type :=
| Internal : Tezos_storage.Context.index -> validator_kind
| External : string -> string -> string ->
(option Tezos_base__TzPervasives.Data_encoding.json) -> validator_kind.
Inductive t : Type :=
| Sequential : Seq_validator.t -> t
| External : External_validator.t -> t.
Definition init (function_parameter : validator_kind)
: Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
match function_parameter with
| Internal index =>
op_gtgteq (Seq_validator.init index) (fun v => _return (Sequential v))
|
External {|
context_root := context_root;
protocol_root := protocol_root;
process_path := process_path;
sandbox_parameters := sandbox_parameters
|} =>
op_gtgteq
(External_validator.init sandbox_parameters context_root protocol_root
process_path)
(fun v =>
op_gtgteqquestion
(External_validator.send_request v
Tezos_validation.External_validation.Init Data_encoding.empty)
(fun function_parameter =>
let 'tt := function_parameter in
_return (External v)))
end.
Definition close (function_parameter : t) : Lwt.t unit :=
match function_parameter with
| Sequential vp => Seq_validator.close vp
| External vp => External_validator.close vp
end.
Definition apply_block
(bvp : t) (predecessor : Tezos_shell.State.Block.t)
(block_header : Tezos_base__TzPervasives.Block_header.t)
(operations : list (list Tezos_base__TzPervasives.Operation.t))
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_validation.Block_validation.result) :=
let chain_state := State.Block.chain_state predecessor in
let predecessor_block_header := State.Block.header predecessor in
op_gtgteqquestion (State.Block.max_operations_ttl predecessor)
(fun max_operations_ttl =>
let block_hash := Block_header.hash block_header in
op_gtgteqquestion
(op_gtgteq (Chain.data chain_state)
(fun chain_data =>
if State.Block.equal (current_head chain_data) predecessor then
_return ((live_blocks chain_data), (live_operations chain_data))
else
Chain_traversal.live_blocks predecessor max_operations_ttl))
(fun function_parameter =>
let '(live_blocks, live_operations) := function_parameter in
op_gtgteqquestion
(Block_validation.check_liveness live_blocks live_operations
block_hash operations)
(fun function_parameter =>
let 'tt := function_parameter in
match bvp with
| Sequential vp =>
Seq_validator.apply_block vp chain_state max_operations_ttl
predecessor_block_header block_header operations
| External vp =>
let chain_id := State.Chain.id chain_state in
let request :=
Tezos_validation.External_validation.Validate
{| chain_id := chain_id; block_header := block_header;
predecessor_block_header := predecessor_block_header;
operations := operations;
max_operations_ttl := max_operations_ttl |} in
External_validator.send_request vp request
Block_validation.result_encoding
end))).
Definition commit_genesis
(bvp : t) (genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
(chain_id : Tezos_base__TzPervasives.Chain_id.t)
(time : Tezos_base__TzPervasives.Time.Protocol.t)
(protocol : Tezos_base__TzPervasives.Protocol_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Context_hash.t) :=
match bvp with
| Sequential {| context_index := context_index |} =>
op_gtgteq (Context.commit_genesis context_index chain_id time protocol)
(fun res => _return res)
| External vp =>
let request :=
Tezos_validation.External_validation.Commit_genesis
{| chain_id := chain_id; genesis_hash := genesis_hash; time := time;
protocol := protocol |} in
External_validator.send_request vp request Context_hash.encoding
end.
Definition init_test_chain (bvp : t) (forking_block : Tezos_shell.State.Block.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_header.t) :=
let forked_header := State.Block.header forking_block in
match bvp with
| Sequential _ =>
op_gtgteqquestion (State.Block.context forking_block)
(fun context => Block_validation.init_test_chain context forked_header)
| External vp =>
let context_hash := context (shell forked_header) in
let request :=
Tezos_validation.External_validation.Fork_test_chain
{| context_hash := context_hash; forked_header := forked_header |} in
External_validator.send_request vp request Block_header.encoding
end.
src/lib_shell/bootstrap_pipeline.ml 187 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make_semantic (struct
let name = "node.validator.bootstrap_pipeline"
end)
let node_time_tag =
Tag.def ~doc:"local time at this node" "node_time" Time.System.pp_hum
let block_time_tag =
Tag.def
~doc:"claimed creation time of block"
"block_time"
(fun fmt prot_time -> Time.System.(pp_hum fmt (of_protocol_exn prot_time)))
open Validation_errors
type t = {
canceler : Lwt_canceler.t;
block_header_timeout : Time.System.Span.t;
block_operations_timeout : Time.System.Span.t;
mutable headers_fetch_worker : unit Lwt.t;
mutable operations_fetch_worker : unit Lwt.t;
mutable validation_worker : unit Lwt.t;
peer_id : P2p_peer.Id.t;
chain_db : Distributed_db.chain_db;
locator : Block_locator.t;
block_validator : Block_validator.t;
notify_new_block : State.Block.t -> unit;
fetched_headers : (Block_hash.t * Block_header.t) list Lwt_pipe.t;
fetched_blocks :
(Block_hash.t * Block_header.t * Operation.t list list tzresult Lwt.t)
Lwt_pipe.t;
(* HACK, a worker should be able to return the 'error'. *)
mutable errors : Error_monad.error list;
}
let operations_index_tag =
Tag.def ~doc:"Operations index" "operations_index" Format.pp_print_int
let assert_acceptable_header pipeline hash (header : Block_header.t) =
let chain_state = Distributed_db.chain_state pipeline.chain_db in
let time_now = Systime_os.now () in
fail_unless
( Time.Protocol.compare
(Time.Protocol.add (Time.System.to_protocol (Systime_os.now ())) 15L)
header.shell.timestamp
>= 0 )
(Future_block_header
{block = hash; time = time_now; block_time = header.shell.timestamp})
>>=? fun () ->
State.Chain.checkpoint chain_state
>>= fun checkpoint ->
fail_when
( Int32.equal header.shell.level checkpoint.shell.level
&& not (Block_header.equal checkpoint header) )
(Checkpoint_error (hash, Some pipeline.peer_id))
>>=? fun () ->
Chain.head chain_state
>>= fun head ->
let checkpoint_reached =
(State.Block.header head).shell.level >= checkpoint.shell.level
in
if checkpoint_reached then
(* If reached the checkpoint, every block before the checkpoint
must be part of the chain. *)
if header.shell.level <= checkpoint.shell.level then
Chain.mem chain_state hash
>>= fun in_chain ->
fail_unless in_chain (Checkpoint_error (hash, Some pipeline.peer_id))
else return_unit
else return_unit
let fetch_step pipeline (step : Block_locator.step) =
( if step.step > 2000 then
lwt_log_notice
Tag.DSL.(
fun f ->
f
"fetching a large bootstrap step (%a headers) from peer %a, this \
may take a while."
-% t event "fetching_large_step_from_peer"
-% a (Tag.def ~doc:"" "length" Format.pp_print_int) step.step
-% a P2p_peer.Id.Logging.tag pipeline.peer_id)
else
lwt_log_info
Tag.DSL.(
fun f ->
f "fetching step %a -> %a (%a) from peer %a."
-% t event "fetching_step_from_peer"
-% a Block_hash.Logging.tag step.block
-% a Block_hash.Logging.predecessor_tag step.predecessor
-% a (Tag.def ~doc:"" "" Block_locator.pp_step) step
-% a P2p_peer.Id.Logging.tag pipeline.peer_id) )
>>= fun () ->
let rec fetch_loop acc hash cpt =
Lwt_unix.yield ()
>>= fun () ->
( if step.step > 2000 && step.step <> cpt && (step.step - cpt) mod 1000 = 0
then
lwt_log_notice
Tag.DSL.(
fun f ->
f "fetched %a/%a headers from peer %a, and continuing."
-% t event "still_fetching_large_step_from_peer"
-% a
(Tag.def ~doc:"" "fetched" Format.pp_print_int)
(step.step - cpt)
-% a (Tag.def ~doc:"" "length" Format.pp_print_int) step.step
-% a P2p_peer.Id.Logging.tag pipeline.peer_id)
else Lwt.return_unit )
>>= fun () ->
if cpt < 0 then
lwt_log_info
Tag.DSL.(
fun f ->
f "invalid step from peer %a (too long)."
-% t event "step_too_long"
-% a P2p_peer.Id.Logging.tag pipeline.peer_id)
>>= fun () -> fail (Invalid_locator (pipeline.peer_id, pipeline.locator))
else if Block_hash.equal hash step.predecessor then
if step.strict_step && cpt <> 0 then
lwt_log_info
Tag.DSL.(
fun f ->
f "invalid step from peer %a (too short)."
-% t event "step_too_short"
-% a P2p_peer.Id.Logging.tag pipeline.peer_id)
>>= fun () ->
fail (Invalid_locator (pipeline.peer_id, pipeline.locator))
else return acc
else
let chain_state = Distributed_db.chain_state pipeline.chain_db in
Chain.mem chain_state hash
>>= fun in_chain ->
if in_chain then return acc
else
lwt_log_info
Tag.DSL.(
fun f ->
f "fetching block header %a from peer %a."
-% t event "fetching_block_header_from_peer"
-% a Block_hash.Logging.tag hash
-% a P2p_peer.Id.Logging.tag pipeline.peer_id)
>>= fun () ->
protect ~canceler:pipeline.canceler (fun () ->
Distributed_db.Block_header.fetch
~timeout:pipeline.block_header_timeout
pipeline.chain_db
~peer:pipeline.peer_id
hash
())
>>=? fun header ->
assert_acceptable_header pipeline hash header
>>=? fun () ->
lwt_log_info
Tag.DSL.(
fun f ->
f "fetched block header %a from peer %a."
-% t event "fetched_block_header_from_peer"
-% a Block_hash.Logging.tag hash
-% a P2p_peer.Id.Logging.tag pipeline.peer_id)
>>= fun () ->
fetch_loop ((hash, header) :: acc) header.shell.predecessor (cpt - 1)
in
fetch_loop [] step.block step.step
let headers_fetch_worker_loop pipeline =
(let sender_id = Distributed_db.my_peer_id pipeline.chain_db in
(* sender and receiver are inverted here because they are from
the point of view of the node sending the locator *)
let seed =
{Block_locator.sender_id = pipeline.peer_id; receiver_id = sender_id}
in
let chain_state = Distributed_db.chain_state pipeline.chain_db in
let state = State.Chain.global_state chain_state in
State.history_mode state
>>= fun history_mode ->
( match history_mode with
| History_mode.Archive ->
Lwt.return_none
| Full | Rolling ->
let chain_state = Distributed_db.chain_state pipeline.chain_db in
State.Chain.save_point chain_state >>= Lwt.return_some )
>>= fun save_point ->
(* In Full and Rolling mode, we do not want to receive blocks
that are past our save point's level, otherwise we would
start validating them again. *)
let steps =
match save_point with
| None ->
Block_locator.to_steps seed pipeline.locator
| Some (save_point_level, save_point) ->
let (head, _) = (pipeline.locator : Block_locator.t :> _ * _) in
let head_level = head.shell.level in
let truncate_limit = Int32.(sub head_level save_point_level) in
Block_locator.to_steps_truncate
~limit:(Int32.to_int truncate_limit)
~save_point
seed
pipeline.locator
in
match steps with
| [] ->
fail (Too_short_locator (sender_id, pipeline.locator))
| {Block_locator.predecessor; _} :: _ ->
State.Block.known chain_state predecessor
>>= fun predecessor_known ->
(* Check that the locator is anchored in a block locally known *)
fail_unless
predecessor_known
(Too_short_locator (sender_id, pipeline.locator))
>>=? fun () ->
let rec process_headers headers =
let (batch, remaining_headers) = List.split_n 20 headers in
protect ~canceler:pipeline.canceler (fun () ->
Lwt_pipe.push pipeline.fetched_headers batch
>>= fun () -> return_unit)
>>=? fun () ->
match remaining_headers with
| [] ->
return_unit
| _ ->
process_headers remaining_headers
in
let rec pipe ?pred = function
| [] ->
return_unit
| first :: (second :: _ as rest) ->
let fetch =
match pred with
| None ->
fetch_step pipeline first
| Some fetch ->
fetch
in
let pred = fetch_step pipeline second in
fetch
>>=? fun headers ->
process_headers headers >>=? fun () -> pipe ~pred rest
| [last] ->
let fetch =
match pred with
| None ->
fetch_step pipeline last
| Some fetch ->
fetch
in
fetch >>=? process_headers
in
pipe steps)
>>= function
| Ok () ->
lwt_log_info
Tag.DSL.(
fun f ->
f "fetched all steps from peer %a."
-% t event "fetched_all_steps_from_peer"
-% a P2p_peer.Id.Logging.tag pipeline.peer_id)
>>= fun () ->
Lwt_pipe.close pipeline.fetched_headers ;
Lwt.return_unit
| Error (Exn Lwt.Canceled :: _)
| Error (Canceled :: _)
| Error (Exn Lwt_pipe.Closed :: _) ->
Lwt.return_unit
| Error (Distributed_db.Block_header.Timeout bh :: _) ->
lwt_log_info
Tag.DSL.(
fun f ->
f "request for header %a from peer %a timed out."
-% t event "header_request_timeout"
-% a Block_hash.Logging.tag bh
-% a P2p_peer.Id.Logging.tag pipeline.peer_id)
>>= fun () -> Lwt_canceler.cancel pipeline.canceler
| Error (Future_block_header {block; block_time; time} :: _) ->
lwt_log_notice
Tag.DSL.(
fun f ->
f
"Block locator %a from peer %a contains future blocks. local \
time: %a, block time: %a"
-% t event "locator_contains_future_blocks"
-% a Block_hash.Logging.tag block
-% a P2p_peer.Id.Logging.tag pipeline.peer_id
-% a node_time_tag time
-% a block_time_tag block_time)
>>= fun () -> Lwt_canceler.cancel pipeline.canceler
| Error (Too_short_locator _ :: _ as err) ->
pipeline.errors <- pipeline.errors @ err ;
lwt_log_info
Tag.DSL.(
fun f ->
f "Too short locator received" -% t event "too_short_locator")
>>= fun () -> Lwt_canceler.cancel pipeline.canceler
| Error err ->
pipeline.errors <- pipeline.errors @ err ;
lwt_log_error
Tag.DSL.(
fun f ->
f "@[Unexpected error (headers fetch):@ %a@]"
-% t event "unexpected_error" -% a errs_tag err)
>>= fun () -> Lwt_canceler.cancel pipeline.canceler
let rec operations_fetch_worker_loop pipeline =
Lwt_unix.yield ()
>>= (fun () ->
protect ~canceler:pipeline.canceler (fun () ->
Lwt_pipe.pop pipeline.fetched_headers >>= return)
>>=? fun batch ->
map_p
(fun (hash, header) ->
lwt_log_info
Tag.DSL.(
fun f ->
f "fetching operations of block %a from peer %a."
-% t event "fetching_operations"
-% a Block_hash.Logging.tag hash
-% a P2p_peer.Id.Logging.tag pipeline.peer_id)
>>= fun () ->
let operations =
map_p
(fun i ->
protect ~canceler:pipeline.canceler (fun () ->
Distributed_db.Operations.fetch
~timeout:pipeline.block_operations_timeout
pipeline.chain_db
~peer:pipeline.peer_id
(hash, i)
header.Block_header.shell.operations_hash
>>= fun res -> Lwt.return res))
(0 -- (header.shell.validation_passes - 1))
>>=? fun operations ->
lwt_log_info
Tag.DSL.(
fun f ->
f "fetched operations of block %a from peer %a."
-% t event "fetched_operations"
-% a Block_hash.Logging.tag hash
-% a P2p_peer.Id.Logging.tag pipeline.peer_id)
>>= fun () -> return operations
in
return (hash, header, operations))
batch
>>=? fun operationss ->
iter_s
(fun (hash, header, operations) ->
protect ~canceler:pipeline.canceler (fun () ->
Lwt_pipe.push pipeline.fetched_blocks (hash, header, operations)
>>= fun () -> return_unit))
operationss)
>>= function
| Ok () ->
operations_fetch_worker_loop pipeline
| Error (Exn Lwt.Canceled :: _)
| Error (Canceled :: _)
| Error (Exn Lwt_pipe.Closed :: _) ->
Lwt_pipe.close pipeline.fetched_blocks ;
Lwt.return_unit
| Error (Distributed_db.Operations.Timeout (bh, n) :: _) ->
lwt_log_info
Tag.DSL.(
fun f ->
f "request for operations %a:%d from peer %a timed out."
-% t event "request_operations_timeout"
-% a Block_hash.Logging.tag bh
-% s operations_index_tag n
-% a P2p_peer.Id.Logging.tag pipeline.peer_id)
>>= fun () -> Lwt_canceler.cancel pipeline.canceler
| Error err ->
pipeline.errors <- pipeline.errors @ err ;
lwt_log_error
Tag.DSL.(
fun f ->
f "@[Unexpected error (operations fetch):@ %a@]"
-% t event "unexpected_error" -% a errs_tag err)
>>= fun () -> Lwt_canceler.cancel pipeline.canceler
let rec validation_worker_loop pipeline =
Lwt_unix.yield ()
>>= (fun () ->
protect ~canceler:pipeline.canceler (fun () ->
Lwt_pipe.pop pipeline.fetched_blocks >>= return)
>>=? fun (hash, header, operations) ->
lwt_log_info
Tag.DSL.(
fun f ->
f "requesting validation for block %a from peer %a."
-% t event "requesting_validation"
-% a Block_hash.Logging.tag hash
-% a P2p_peer.Id.Logging.tag pipeline.peer_id)
>>= fun () ->
operations
>>=? fun operations ->
protect ~canceler:pipeline.canceler (fun () ->
Block_validator.validate
~canceler:pipeline.canceler
~notify_new_block:pipeline.notify_new_block
pipeline.block_validator
pipeline.chain_db
hash
header
operations)
>>=? fun _block ->
lwt_log_info
Tag.DSL.(
fun f ->
f "validated block %a from peer %a."
-% t event "validated_block"
-% a Block_hash.Logging.tag hash
-% a P2p_peer.Id.Logging.tag pipeline.peer_id)
>>= fun () -> return_unit)
>>= function
| Ok () ->
validation_worker_loop pipeline
| Error ((Exn Lwt.Canceled | Canceled | Exn Lwt_pipe.Closed) :: _) ->
Lwt.return_unit
| Error
( ( Block_validator_errors.Invalid_block _
| Block_validator_errors.Unavailable_protocol _
| Block_validator_errors.System_error _
| Timeout )
:: _ as err ) ->
(* Propagate the error to the peer validator. *)
pipeline.errors <- pipeline.errors @ err ;
Lwt_canceler.cancel pipeline.canceler
| Error err ->
pipeline.errors <- pipeline.errors @ err ;
lwt_log_error
Tag.DSL.(
fun f ->
f "@[Unexpected error (validator):@ %a@]"
-% t event "unexpected_error" -% a errs_tag err)
>>= fun () -> Lwt_canceler.cancel pipeline.canceler
let create ?(notify_new_block = fun _ -> ()) ~block_header_timeout
~block_operations_timeout block_validator peer_id chain_db locator =
let canceler = Lwt_canceler.create () in
let fetched_headers = Lwt_pipe.create ~size:(1024, fun _ -> 1) () in
let fetched_blocks = Lwt_pipe.create ~size:(128, fun _ -> 1) () in
let pipeline =
{
canceler;
block_header_timeout;
block_operations_timeout;
headers_fetch_worker = Lwt.return_unit;
operations_fetch_worker = Lwt.return_unit;
validation_worker = Lwt.return_unit;
notify_new_block;
peer_id;
chain_db;
locator;
block_validator;
fetched_headers;
fetched_blocks;
errors = [];
}
in
Lwt_canceler.on_cancel pipeline.canceler (fun () ->
Lwt_pipe.close fetched_blocks ;
Lwt_pipe.close fetched_headers ;
(* TODO proper cleanup of ressources... *)
Lwt.return_unit) ;
let (head, _) = (pipeline.locator : Block_locator.t :> _ * _) in
let hash = Block_header.hash head in
pipeline.headers_fetch_worker <-
Lwt_utils.worker
(Format.asprintf
"bootstrap_pipeline-headers_fetch.%a.%a"
P2p_peer.Id.pp_short
peer_id
Block_hash.pp_short
hash)
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> headers_fetch_worker_loop pipeline)
~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ;
pipeline.operations_fetch_worker <-
Lwt_utils.worker
(Format.asprintf
"bootstrap_pipeline-operations_fetch.%a.%a"
P2p_peer.Id.pp_short
peer_id
Block_hash.pp_short
hash)
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> operations_fetch_worker_loop pipeline)
~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ;
pipeline.validation_worker <-
Lwt_utils.worker
(Format.asprintf
"bootstrap_pipeline-validation.%a.%a"
P2p_peer.Id.pp_short
peer_id
Block_hash.pp_short
hash)
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> validation_worker_loop pipeline)
~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ;
pipeline
let wait_workers pipeline =
pipeline.headers_fetch_worker
>>= fun () ->
pipeline.operations_fetch_worker >>= fun () -> pipeline.validation_worker
let wait pipeline =
wait_workers pipeline
>>= fun () ->
match pipeline.errors with
| [] ->
return_unit
| errors ->
Lwt.return_error errors
let cancel pipeline =
Lwt_canceler.cancel pipeline.canceler >>= fun () -> wait_workers pipeline
let length pipeline =
Peer_validator_worker_state.Worker_state.
{
fetched_header_length = Lwt_pipe.length pipeline.fetched_headers;
fetched_block_length = Lwt_pipe.length pipeline.fetched_blocks;
}
let length_zero =
Peer_validator_worker_state.Worker_state.
{fetched_header_length = 0; fetched_block_length = 0}
src/lib_shell/bootstrap_pipeline.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition node_time_tag : Tag.def Tezos_base__TzPervasives.Time.System.t :=
Tag.def (Some "local time at this node" % string) "node_time" % string
Time.System.pp_hum.
Definition block_time_tag : Tag.def Tezos_base__Time.Protocol.t :=
Tag.def (Some "claimed creation time of block" % string) "block_time" % string
(fun fmt => fun prot_time => pp_hum fmt (of_protocol_exn prot_time)).
Import Validation_errors.
Record t := {
canceler : Tezos_base__TzPervasives.Lwt_canceler.t;
block_header_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
block_operations_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
headers_fetch_worker : Lwt.t unit;
operations_fetch_worker : Lwt.t unit;
validation_worker : Lwt.t unit;
peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
chain_db : Tezos_shell.Distributed_db.chain_db;
locator : Tezos_base__TzPervasives.Block_locator.t;
block_validator : Tezos_shell.Block_validator.t;
notify_new_block : Tezos_shell.State.Block.t -> unit;
fetched_headers :
Tezos_base__TzPervasives.Lwt_pipe.t
(list
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t));
fetched_blocks :
Tezos_base__TzPervasives.Lwt_pipe.t
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t *
(Lwt.t
(Tezos_base__TzPervasives.tzresult
(list (list Tezos_base__TzPervasives.Operation.t)))));
errors : list Tezos_base__TzPervasives.Error_monad.error }.
Definition operations_index_tag : Tag.def Z :=
Tag.def (Some "Operations index" % string) "operations_index" % string
Format.pp_print_int.
Definition assert_acceptable_header
(pipeline : t) (hash : Tezos_base__TzPervasives.Block_hash.t)
(header : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let chain_state := Distributed_db.chain_state (chain_db pipeline) in
let time_now := Systime_os.now tt in
op_gtgteqquestion
(fail_unless
(OCaml.Stdlib.ge
(Time.Protocol.compare
(Time.Protocol.add (Time.System.to_protocol (Systime_os.now tt))
(* ❌ Constant of type int64 is converted to int *)
15) (timestamp (shell header))) 0)
(Tezos_base__TzPervasives.Future_block_header
{| block := hash; block_time := timestamp (shell header);
time := time_now |}))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Chain.checkpoint chain_state)
(fun checkpoint =>
op_gtgteqquestion
(fail_when
(andb
(Int32.equal (level (shell header)) (level (shell checkpoint)))
(negb (Block_header.equal checkpoint header)))
(Tezos_base__TzPervasives.Checkpoint_error hash
(Some (peer_id pipeline))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Chain.head chain_state)
(fun head =>
let checkpoint_reached :=
OCaml.Stdlib.ge (level (shell (State.Block.header head)))
(level (shell checkpoint)) in
if checkpoint_reached then
if
OCaml.Stdlib.le (level (shell header))
(level (shell checkpoint)) then
op_gtgteq (Chain.mem chain_state hash)
(fun in_chain =>
fail_unless in_chain
(Tezos_base__TzPervasives.Checkpoint_error hash
(Some (peer_id pipeline))))
else
return_unit
else
return_unit)))).
Definition fetch_step
(pipeline : t) (step : Tezos_base__TzPervasives.Block_locator.step)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t))) :=
op_gtgteq
(if OCaml.Stdlib.gt (step step) 2000 then
lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"fetching a large bootstrap step (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" headers) from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", this may take a while." % string
CamlinternalFormatBasics.End_of_format)))))
"fetching a large bootstrap step (%a headers) from peer %a, this may take a while."
% string))
(t event "fetching_large_step_from_peer" % string))
(a
(Tag.def (Some "" % string) "length" % string
Format.pp_print_int) (step step)))
(a P2p_peer.Id.Logging.tag (peer_id pipeline)))
else
lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"fetching step " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" -> " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
") from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format)))))))))
"fetching step %a -> %a (%a) from peer %a." % string))
(t event "fetching_step_from_peer" % string))
(a Block_hash.Logging.tag (block step)))
(a Block_hash.Logging.predecessor_tag (predecessor step)))
(a (Tag.def (Some "" % string) "" % string Block_locator.pp_step)
step)) (a P2p_peer.Id.Logging.tag (peer_id pipeline))))
(fun function_parameter =>
let 'tt := function_parameter in
let fix fetch_loop
(acc :
list
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t)) (hash :
Tezos_base__TzPervasives.Block_hash.t) (cpt : Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t))) :=
op_gtgteq (Lwt_unix.yield tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(if
andb (OCaml.Stdlib.gt (step step) 2000)
(andb (nequiv_decb (step step) cpt)
(equiv_decb (Z.modulo (Z.sub (step step) cpt) 1000) 0)) then
lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"fetched " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"/" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" headers from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", and continuing." % string
CamlinternalFormatBasics.End_of_format)))))))
"fetched %a/%a headers from peer %a, and continuing."
% string))
(t event
"still_fetching_large_step_from_peer" % string))
(a
(Tag.def (Some "" % string) "fetched" % string
Format.pp_print_int) (Z.sub (step step) cpt)))
(a
(Tag.def (Some "" % string) "length" % string
Format.pp_print_int) (step step)))
(a P2p_peer.Id.Logging.tag (peer_id pipeline)))
else
Lwt.return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
if OCaml.Stdlib.lt cpt 0 then
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"invalid step from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (too long)." % string
CamlinternalFormatBasics.End_of_format)))
"invalid step from peer %a (too long)." % string))
(t event "step_too_long" % string))
(a P2p_peer.Id.Logging.tag (peer_id pipeline))))
(fun function_parameter =>
let 'tt := function_parameter in
fail
(Tezos_base__TzPervasives.Invalid_locator
(peer_id pipeline) (locator pipeline)))
else
if Block_hash.equal hash (predecessor step) then
if andb (strict_step step) (nequiv_decb cpt 0) then
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"invalid step from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (too short)." % string
CamlinternalFormatBasics.End_of_format)))
"invalid step from peer %a (too short)." %
string))
(t event "step_too_short" % string))
(a P2p_peer.Id.Logging.tag (peer_id pipeline))))
(fun function_parameter =>
let 'tt := function_parameter in
fail
(Tezos_base__TzPervasives.Invalid_locator
(peer_id pipeline) (locator pipeline)))
else
_return acc
else
let chain_state :=
Distributed_db.chain_state (chain_db pipeline) in
op_gtgteq (Chain.mem chain_state hash)
(fun in_chain =>
if in_chain then
_return acc
else
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"fetching block header " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format)))))
"fetching block header %a from peer %a."
% string))
(t event
"fetching_block_header_from_peer" %
string))
(a Block_hash.Logging.tag hash))
(a P2p_peer.Id.Logging.tag (peer_id pipeline))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(protect None (Some (canceler pipeline))
(fun function_parameter =>
let 'tt := function_parameter in
Distributed_db.Block_header.fetch
(chain_db pipeline)
(Some (peer_id pipeline))
(Some (block_header_timeout pipeline))
hash tt))
(fun header =>
op_gtgteqquestion
(assert_acceptable_header pipeline hash
header)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"fetched block header "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format)))))
"fetched block header %a from peer %a."
% string))
(t event
"fetched_block_header_from_peer"
% string))
(a Block_hash.Logging.tag hash))
(a P2p_peer.Id.Logging.tag
(peer_id pipeline))))
(fun function_parameter =>
let 'tt := function_parameter in
fetch_loop (cons (hash, header) acc)
(predecessor (shell header))
(Z.sub cpt 1)))))))) in
fetch_loop [] (block step) (step step)).
Definition headers_fetch_worker_loop (pipeline : t) : Lwt.t unit :=
op_gtgteq
(let sender_id := Distributed_db.my_peer_id (chain_db pipeline) in
let seed :=
{| Block_locator.sender_id := peer_id pipeline;
Block_locator.receiver_id := sender_id |} in
let chain_state := Distributed_db.chain_state (chain_db pipeline) in
let state := State.Chain.global_state chain_state in
op_gtgteq (State.history_mode state)
(fun history_mode =>
op_gtgteq
match history_mode with
| Tezos_shell_services.History_mode.Archive => Lwt.return_none
|
Tezos_shell_services.History_mode.Full |
Tezos_shell_services.History_mode.Rolling =>
let chain_state := Distributed_db.chain_state (chain_db pipeline) in
op_gtgteq (State.Chain.save_point chain_state) Lwt.return_some
end
(fun save_point =>
let steps :=
match save_point with
| None => Block_locator.to_steps seed (locator pipeline)
| Some (save_point_level, save_point) =>
let '(head, _) := locator pipeline in
let head_level := level (shell head) in
let truncate_limit := sub head_level save_point_level in
Block_locator.to_steps_truncate (Int32.to_int truncate_limit)
save_point seed (locator pipeline)
end in
match steps with
| [] =>
fail
(Tezos_base__TzPervasives.Too_short_locator sender_id
(locator pipeline))
| cons {| Block_locator.predecessor := predecessor |} _ =>
op_gtgteq (State.Block.known chain_state predecessor)
(fun predecessor_known =>
op_gtgteqquestion
(fail_unless predecessor_known
(Tezos_base__TzPervasives.Too_short_locator sender_id
(locator pipeline)))
(fun function_parameter =>
let 'tt := function_parameter in
let fix process_headers
(headers :
list
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '(batch, remaining_headers) :=
List.split_n 20 headers in
op_gtgteqquestion
(protect None (Some (canceler pipeline))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_pipe.push (fetched_headers pipeline) batch)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(fun function_parameter =>
let 'tt := function_parameter in
match remaining_headers with
| [] => return_unit
| _ => process_headers remaining_headers
end) in
let fix pipe
(pred :
option
(Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t)))))
(function_parameter :
list Tezos_base__TzPervasives.Block_locator.step)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match function_parameter with
| [] => return_unit
| cons first ((cons second _) as rest) =>
let fetch :=
match pred with
| None => fetch_step pipeline first
| Some fetch => fetch
end in
let pred := fetch_step pipeline second in
op_gtgteqquestion fetch
(fun headers =>
op_gtgteqquestion (process_headers headers)
(fun function_parameter =>
let 'tt := function_parameter in
pipe (Some pred) rest))
| cons last [] =>
let fetch :=
match pred with
| None => fetch_step pipeline last
| Some fetch => fetch
end in
op_gtgteqquestion fetch process_headers
end in
pipe None steps))
end)))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt =>
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"fetched all steps from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))
"fetched all steps from peer %a." % string))
(t event "fetched_all_steps_from_peer" % string))
(a P2p_peer.Id.Logging.tag (peer_id pipeline))))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_pipe.close (fetched_headers pipeline) in
Lwt.return_unit)
|
Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Canceled) _) |
Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) |
Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Closed) _) =>
Lwt.return_unit
| Stdlib.Error (cons (Tezos_base__TzPervasives.Timeout bh) _) =>
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"request for header " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" timed out." % string
CamlinternalFormatBasics.End_of_format)))))
"request for header %a from peer %a timed out." % string))
(t event "header_request_timeout" % string))
(a Block_hash.Logging.tag bh))
(a P2p_peer.Id.Logging.tag (peer_id pipeline))))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler pipeline))
|
Stdlib.Error
(cons
(Tezos_base__TzPervasives.Future_block_header {|
block := block; block_time := block_time; time := time |}) _)
=>
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Block locator " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" contains future blocks. local time: " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", block time: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))))))
"Block locator %a from peer %a contains future blocks. local time: %a, block time: %a"
% string))
(t event "locator_contains_future_blocks" % string))
(a Block_hash.Logging.tag block))
(a P2p_peer.Id.Logging.tag (peer_id pipeline)))
(a node_time_tag time)) (a block_time_tag block_time)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler pipeline))
|
Stdlib.Error
((cons (Tezos_base__TzPervasives.Too_short_locator _ _) _) as err) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pipeline "errors" % string
(OCaml.Stdlib.app (errors pipeline) err) in
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Too short locator received" % string
CamlinternalFormatBasics.End_of_format)
"Too short locator received" % string))
(t event "too_short_locator" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler pipeline))
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pipeline "errors" % string
(OCaml.Stdlib.app (errors pipeline) err) in
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Unexpected error (headers fetch):" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Unexpected error (headers fetch):@ %a@]" % string))
(t event "unexpected_error" % string)) (a errs_tag err)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler pipeline))
end).
Fixpoint operations_fetch_worker_loop (pipeline : t) : Lwt.t unit :=
op_gtgteq
(op_gtgteq (Lwt_unix.yield tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(protect None (Some (canceler pipeline))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_pipe.pop (fetched_headers pipeline)) _return))
(fun batch =>
op_gtgteqquestion
(map_p
(fun function_parameter =>
let '(hash, header) := function_parameter in
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"fetching operations of block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format)))))
"fetching operations of block %a from peer %a."
% string))
(t event "fetching_operations" % string))
(a Block_hash.Logging.tag hash))
(a P2p_peer.Id.Logging.tag (peer_id pipeline))))
(fun function_parameter =>
let 'tt := function_parameter in
let operations :=
op_gtgteqquestion
(map_p
(fun i =>
protect None (Some (canceler pipeline))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Distributed_db.Operations.fetch
(chain_db pipeline)
(Some (peer_id pipeline))
(Some (block_operations_timeout pipeline))
(hash, i)
(operations_hash
(Block_header.shell header)))
(fun res => Lwt._return res)))
(op_minusminus 0
(Z.sub (validation_passes (shell header)) 1)))
(fun operations =>
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"fetched operations of block " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format)))))
"fetched operations of block %a from peer %a."
% string))
(t event "fetched_operations" % string))
(a Block_hash.Logging.tag hash))
(a P2p_peer.Id.Logging.tag
(peer_id pipeline))))
(fun function_parameter =>
let 'tt := function_parameter in
_return operations)) in
_return (hash, header, operations))) batch)
(fun operationss =>
iter_s
(fun function_parameter =>
let '(hash, header, operations) := function_parameter in
protect None (Some (canceler pipeline))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_pipe.push (fetched_blocks pipeline)
(hash, header, operations))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))) operationss))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => operations_fetch_worker_loop pipeline
|
Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Canceled) _) |
Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) |
Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Closed) _) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_pipe.close (fetched_blocks pipeline) in
Lwt.return_unit
| Stdlib.Error (cons (Tezos_base__TzPervasives.Timeout (bh, n)) _) =>
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"request for operations " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" timed out." % string
CamlinternalFormatBasics.End_of_format)))))))
"request for operations %a:%d from peer %a timed out."
% string))
(t event "request_operations_timeout" % string))
(a Block_hash.Logging.tag bh)) (s operations_index_tag n))
(a P2p_peer.Id.Logging.tag (peer_id pipeline))))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler pipeline))
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pipeline "errors" % string
(OCaml.Stdlib.app (errors pipeline) err) in
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Unexpected error (operations fetch):" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Unexpected error (operations fetch):@ %a@]" % string))
(t event "unexpected_error" % string)) (a errs_tag err)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler pipeline))
end).
Fixpoint validation_worker_loop (pipeline : t) : Lwt.t unit :=
op_gtgteq
(op_gtgteq (Lwt_unix.yield tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(protect None (Some (canceler pipeline))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_pipe.pop (fetched_blocks pipeline)) _return))
(fun function_parameter =>
let '(hash, header, operations) := function_parameter in
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"requesting validation for block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format)))))
"requesting validation for block %a from peer %a." %
string))
(t event "requesting_validation" % string))
(a Block_hash.Logging.tag hash))
(a P2p_peer.Id.Logging.tag (peer_id pipeline))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion operations
(fun operations =>
op_gtgteqquestion
(protect None (Some (canceler pipeline))
(fun function_parameter =>
let 'tt := function_parameter in
Block_validator.validate (block_validator pipeline)
(Some (canceler pipeline)) None
(Some (notify_new_block pipeline))
(chain_db pipeline) hash header operations))
(fun _block =>
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"validated block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format)))))
"validated block %a from peer %a." %
string))
(t event "validated_block" % string))
(a Block_hash.Logging.tag hash))
(a P2p_peer.Id.Logging.tag (peer_id pipeline))))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => validation_worker_loop pipeline
|
Stdlib.Error
(cons
(Tezos_base__TzPervasives.Exn Canceled |
Tezos_base__TzPervasives.Canceled |
Tezos_base__TzPervasives.Exn Closed) _) => Lwt.return_unit
|
Stdlib.Error
((cons
(Tezos_base__TzPervasives.Invalid_block _ |
Tezos_base__TzPervasives.Unavailable_protocol _ |
Tezos_base__TzPervasives.System_error _ |
Tezos_base__TzPervasives.Timeout) _) as err) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pipeline "errors" % string
(OCaml.Stdlib.app (errors pipeline) err) in
Lwt_canceler.cancel (canceler pipeline)
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pipeline "errors" % string
(OCaml.Stdlib.app (errors pipeline) err) in
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Unexpected error (validator):" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Unexpected error (validator):@ %a@]" % string))
(t event "unexpected_error" % string)) (a errs_tag err)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler pipeline))
end).
Definition create (op_staroptstar : option (Tezos_shell.State.Block.t -> unit))
: Tezos_base__TzPervasives.Time.System.Span.t ->
Tezos_base__TzPervasives.Time.System.Span.t ->
Tezos_shell.Block_validator.t ->
Tezos_base__TzPervasives.P2p_peer.Id.t ->
Tezos_shell.Distributed_db.chain_db ->
Tezos_base__TzPervasives.Block_locator.t -> t :=
let notify_new_block :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
fun function_parameter =>
let '_ := function_parameter in
tt
end in
fun block_header_timeout =>
fun block_operations_timeout =>
fun block_validator =>
fun peer_id =>
fun chain_db =>
fun locator =>
let canceler := Lwt_canceler.create tt in
let fetched_headers :=
Lwt_pipe.create
(Some
(1024,
(fun function_parameter =>
let '_ := function_parameter in
1))) tt in
let fetched_blocks :=
Lwt_pipe.create
(Some
(128,
(fun function_parameter =>
let '_ := function_parameter in
1))) tt in
let pipeline :=
{| canceler := canceler;
block_header_timeout := block_header_timeout;
block_operations_timeout := block_operations_timeout;
headers_fetch_worker := Lwt.return_unit;
operations_fetch_worker := Lwt.return_unit;
validation_worker := Lwt.return_unit; peer_id := peer_id;
chain_db := chain_db; locator := locator;
block_validator := block_validator;
notify_new_block := notify_new_block;
fetched_headers := fetched_headers;
fetched_blocks := fetched_blocks; errors := [] |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_canceler.on_cancel (canceler pipeline)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_pipe.close fetched_blocks in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_pipe.close fetched_headers in
Lwt.return_unit) in
let '(head, _) := locator pipeline in
let hash := Block_header.hash head in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pipeline "headers_fetch_worker" % string
(Lwt_utils.worker
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"bootstrap_pipeline-headers_fetch." % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"bootstrap_pipeline-headers_fetch.%a.%a" % string)
P2p_peer.Id.pp_short peer_id Block_hash.pp_short hash)
Internal_event.Lwt_worker_event.on_event
(fun function_parameter =>
let 'tt := function_parameter in
headers_fetch_worker_loop pipeline)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler pipeline))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pipeline "operations_fetch_worker" % string
(Lwt_utils.worker
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"bootstrap_pipeline-operations_fetch." % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"bootstrap_pipeline-operations_fetch.%a.%a" % string)
P2p_peer.Id.pp_short peer_id Block_hash.pp_short hash)
Internal_event.Lwt_worker_event.on_event
(fun function_parameter =>
let 'tt := function_parameter in
operations_fetch_worker_loop pipeline)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler pipeline))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pipeline "validation_worker" % string
(Lwt_utils.worker
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"bootstrap_pipeline-validation." % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"bootstrap_pipeline-validation.%a.%a" % string)
P2p_peer.Id.pp_short peer_id Block_hash.pp_short hash)
Internal_event.Lwt_worker_event.on_event
(fun function_parameter =>
let 'tt := function_parameter in
validation_worker_loop pipeline)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler pipeline))) in
pipeline.
Definition wait_workers (pipeline : t) : Lwt.t unit :=
op_gtgteq (headers_fetch_worker pipeline)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (operations_fetch_worker pipeline)
(fun function_parameter =>
let 'tt := function_parameter in
validation_worker pipeline)).
Definition wait (pipeline : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (wait_workers pipeline)
(fun function_parameter =>
let 'tt := function_parameter in
match errors pipeline with
| [] => return_unit
| errors => Lwt.return_error errors
end).
Definition cancel (pipeline : t) : Lwt.t unit :=
op_gtgteq (Lwt_canceler.cancel (canceler pipeline))
(fun function_parameter =>
let 'tt := function_parameter in
wait_workers pipeline).
Definition length (pipeline : t)
: Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length :=
{| fetched_header_length := Lwt_pipe.length (fetched_headers pipeline);
fetched_block_length := Lwt_pipe.length (fetched_blocks pipeline) |}.
Definition length_zero
: Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length :=
{| fetched_header_length := 0; fetched_block_length := 0 |}.
src/lib_shell/chain.ml 58 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open State_logging
let genesis chain_state =
let genesis = State.Chain.genesis chain_state in
State.Block.read_opt chain_state genesis.block
>|= Option.unopt_assert ~loc:__POS__
let known_heads chain_state =
State.read_chain_data chain_state (fun chain_store _data ->
Store.Chain_data.Known_heads.elements chain_store)
>>= fun hashes ->
Lwt_list.map_p
(fun h ->
State.Block.read_opt chain_state h >|= Option.unopt_assert ~loc:__POS__)
hashes
let head chain_state =
State.read_chain_data chain_state (fun _chain_store data ->
Lwt.return data.current_head)
let mem chain_state hash =
State.read_chain_data chain_state (fun chain_store data ->
if Block_hash.equal (State.Block.hash data.current_head) hash then
Lwt.return_true
else Store.Chain_data.In_main_branch.known (chain_store, hash))
type data = State.chain_data = {
current_head : State.Block.t;
current_mempool : Mempool.t;
live_blocks : Block_hash.Set.t;
live_operations : Operation_hash.Set.t;
test_chain : Chain_id.t option;
save_point : Int32.t * Block_hash.t;
caboose : Int32.t * Block_hash.t;
}
let data chain_state =
State.read_chain_data chain_state (fun _chain_store data -> Lwt.return data)
let locator chain_state seed =
data chain_state
>>= fun data -> State.compute_locator chain_state data.current_head seed
let locked_set_head chain_store data block live_blocks live_operations =
let rec pop_blocks ancestor block =
let hash = State.Block.hash block in
if Block_hash.equal hash ancestor then Lwt.return_unit
else
lwt_debug
Tag.DSL.(
fun f ->
f "pop_block %a" -% t event "pop_block"
-% a Block_hash.Logging.tag hash)
>>= fun () ->
Store.Chain_data.In_main_branch.remove (chain_store, hash)
>>= fun () ->
State.Block.predecessor block
>>= function
| Some predecessor ->
pop_blocks ancestor predecessor
| None ->
assert false
(* Cannot pop the genesis... *)
in
let push_block pred_hash block =
let hash = State.Block.hash block in
lwt_debug
Tag.DSL.(
fun f ->
f "push_block %a" -% t event "push_block"
-% a Block_hash.Logging.tag hash)
>>= fun () ->
Store.Chain_data.In_main_branch.store (chain_store, pred_hash) hash
>>= fun () -> Lwt.return hash
in
Chain_traversal.new_blocks ~from_block:data.current_head ~to_block:block
>>= fun (ancestor, path) ->
let ancestor = State.Block.hash ancestor in
pop_blocks ancestor data.current_head
>>= fun () ->
Lwt_list.fold_left_s push_block ancestor path
>>= fun _ ->
Store.Chain_data.Current_head.store chain_store (State.Block.hash block)
>>= fun () ->
(* TODO more optimized updated of live_{blocks/operations} when the
new head is a direct successor of the current head...
Make sure to do the live blocks computation in `init_head`
when this TODO is resolved. *)
Lwt.return
{
data with
current_head = block;
current_mempool = Mempool.empty;
live_blocks;
live_operations;
}
let set_head chain_state block =
State.Block.max_operations_ttl block
>>=? fun max_op_ttl ->
Chain_traversal.live_blocks block max_op_ttl
>>=? fun (live_blocks, live_operations) ->
State.update_chain_data chain_state (fun chain_store data ->
locked_set_head chain_store data block live_blocks live_operations
>>= fun new_chain_data ->
Lwt.return (Some new_chain_data, data.current_head))
>>= fun chain_state -> return chain_state
let test_and_set_head chain_state ~old block =
State.Block.max_operations_ttl block
>>=? fun max_op_ttl ->
Chain_traversal.live_blocks block max_op_ttl
>>=? fun (live_blocks, live_operations) ->
State.update_chain_data chain_state (fun chain_store data ->
if not (State.Block.equal data.current_head old) then
Lwt.return (None, false)
else
locked_set_head chain_store data block live_blocks live_operations
>>= fun new_chain_data -> Lwt.return (Some new_chain_data, true))
>>= fun chain_state -> return chain_state
let init_head chain_state =
head chain_state
>>= fun block ->
set_head chain_state block >>=? fun (_ : State.Block.t) -> return_unit
src/lib_shell/chain.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import State_logging.
Definition genesis (chain_state : Tezos_shell.State.Chain.chain_state)
: Lwt.t Tezos_shell.State.Block.t :=
let genesis := State.Chain.genesis chain_state in
op_gtpipeeq (State.Block.read_opt chain_state (block genesis))
(Option.unopt_assert Stdlib.__POS__).
Definition known_heads (chain_state : Tezos_shell.State.Chain.t)
: Lwt.t (list Tezos_shell.State.Block.t) :=
op_gtgteq
(State.read_chain_data chain_state
(fun chain_store =>
fun _data => Store.Chain_data.Known_heads.elements chain_store))
(fun hashes =>
Lwt_list.map_p
(fun h =>
op_gtpipeeq (State.Block.read_opt chain_state h)
(Option.unopt_assert Stdlib.__POS__)) hashes).
Definition head (chain_state : Tezos_shell.State.Chain.t)
: Lwt.t Tezos_shell.State.Block.t :=
State.read_chain_data chain_state
(fun _chain_store => fun data => Lwt._return (current_head data)).
Definition mem
(chain_state : Tezos_shell.State.Chain.t)
(hash : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t bool :=
State.read_chain_data chain_state
(fun chain_store =>
fun data =>
if Block_hash.equal (State.Block.hash (current_head data)) hash then
Lwt.return_true
else
Store.Chain_data.In_main_branch.known (chain_store, hash)).
Record data := {
current_head : Tezos_shell.State.Block.t;
current_mempool : Tezos_base__TzPervasives.Mempool.t;
live_blocks : Tezos_base__TzPervasives.Block_hash.Set.t;
live_operations : Tezos_base__TzPervasives.Operation_hash.Set.t;
test_chain : option Tezos_base__TzPervasives.Chain_id.t;
save_point : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t;
caboose : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t }.
Definition data (chain_state : Tezos_shell.State.Chain.t)
: Lwt.t Tezos_shell.State.chain_data :=
State.read_chain_data chain_state
(fun _chain_store => fun data => Lwt._return data).
Definition locator
(chain_state : Tezos_shell.State.Chain.t)
(seed : Tezos_base__TzPervasives.Block_locator.seed)
: Lwt.t Tezos_base__TzPervasives.Block_locator.t :=
op_gtgteq (data chain_state)
(fun data => State.compute_locator chain_state None (current_head data) seed).
Definition locked_set_head
(chain_store : Tezos_shell__Store.Chain_data.store) (data : data)
(block : Tezos_shell.State.Block.t)
(live_blocks : Tezos_base__TzPervasives.Block_hash.Set.t)
(live_operations : Tezos_base__TzPervasives.Operation_hash.Set.t)
: Lwt.t data :=
let fix pop_blocks
(ancestor : Tezos_base__TzPervasives.Block_hash.t) (block :
Tezos_shell.State.Block.t) : Lwt.t unit :=
let hash := State.Block.hash block in
if Block_hash.equal hash ancestor then
Lwt.return_unit
else
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"pop_block " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"pop_block %a" % string)) (t event "pop_block" % string))
(a Block_hash.Logging.tag hash)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Store.Chain_data.In_main_branch.remove (chain_store, hash))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Block.predecessor block)
(fun function_parameter =>
match function_parameter with
| Some predecessor => pop_blocks ancestor predecessor
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
end))) in
let push_block
(pred_hash : Tezos_base__TzPervasives.Block_hash.t) (block :
Tezos_shell.State.Block.t) : Lwt.t Tezos_base__TzPervasives.Block_hash.t :=
let hash := State.Block.hash block in
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"push_block " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"push_block %a" % string)) (t event "push_block" % string))
(a Block_hash.Logging.tag hash)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Chain_data.In_main_branch.store (chain_store, pred_hash) hash)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return hash)) in
op_gtgteq (Chain_traversal.new_blocks (current_head data) block)
(fun function_parameter =>
let '(ancestor, path) := function_parameter in
let ancestor := State.Block.hash ancestor in
op_gtgteq (pop_blocks ancestor (current_head data))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_list.fold_left_s push_block ancestor path)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(Store.Chain_data.Current_head.store chain_store
(State.Block.hash block))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return
(* ❌ Record substitution not handled *)
record_substitution)))).
Definition set_head
(chain_state : Tezos_shell.State.Chain.t) (block : Tezos_shell.State.Block.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_shell.State.Block.t) :=
op_gtgteqquestion (State.Block.max_operations_ttl block)
(fun max_op_ttl =>
op_gtgteqquestion (Chain_traversal.live_blocks block max_op_ttl)
(fun function_parameter =>
let '(live_blocks, live_operations) := function_parameter in
op_gtgteq
(State.update_chain_data chain_state
(fun chain_store =>
fun data =>
op_gtgteq
(locked_set_head chain_store data block live_blocks
live_operations)
(fun new_chain_data =>
Lwt._return ((Some new_chain_data), (current_head data)))))
(fun chain_state => _return chain_state))).
Definition test_and_set_head
(chain_state : Tezos_shell.State.Chain.t) (old : Tezos_shell.State.Block.t)
(block : Tezos_shell.State.Block.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
op_gtgteqquestion (State.Block.max_operations_ttl block)
(fun max_op_ttl =>
op_gtgteqquestion (Chain_traversal.live_blocks block max_op_ttl)
(fun function_parameter =>
let '(live_blocks, live_operations) := function_parameter in
op_gtgteq
(State.update_chain_data chain_state
(fun chain_store =>
fun data =>
if negb (State.Block.equal (current_head data) old) then
Lwt._return (None, false)
else
op_gtgteq
(locked_set_head chain_store data block live_blocks
live_operations)
(fun new_chain_data =>
Lwt._return ((Some new_chain_data), true))))
(fun chain_state => _return chain_state))).
Definition init_head (chain_state : Tezos_shell.State.Chain.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (head chain_state)
(fun block =>
op_gtgteqquestion (set_head chain_state block)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)).
src/lib_shell/chain_directory.ml 69 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Chain_services
let get_chain_id state = function
| `Main ->
Lwt.return (State.Chain.main state)
| `Test -> (
State.Chain.get_exn state (State.Chain.main state)
>>= fun main_chain ->
State.Chain.test main_chain
>>= function
| None -> Lwt.fail Not_found | Some chain_id -> Lwt.return chain_id )
| `Hash chain_id ->
Lwt.return chain_id
let get_chain_id_opt state chain =
Lwt.catch
(fun () -> get_chain_id state chain >>= Lwt.return_some)
(fun _exn -> Lwt.return_none)
let get_chain state chain =
get_chain_id state chain
>>= fun chain_id -> State.Chain.get_exn state chain_id
let get_checkpoint state (chain : Chain_services.chain) =
get_chain state chain
>>= fun chain ->
State.Chain.checkpoint chain
>>= fun header -> Lwt.return (Block_header.hash header)
let predecessors ignored length head =
let rec loop acc length block =
if length <= 0 then Lwt.return (List.rev acc)
else
State.Block.predecessor block
>>= function
| None ->
Lwt.return (List.rev acc)
| Some pred ->
if Block_hash.Set.mem (State.Block.hash block) ignored then
Lwt.return (List.rev acc)
else loop (State.Block.hash pred :: acc) (length - 1) pred
in
loop [State.Block.hash head] (length - 1) head
let list_blocks chain_state ?(length = 1) ?min_date heads =
( match heads with
| [] ->
Chain.known_heads chain_state
>>= fun heads ->
let heads =
match min_date with
| None ->
heads
| Some min_date ->
List.fold_left
(fun acc block ->
let timestamp = State.Block.timestamp block in
if Time.Protocol.(min_date <= timestamp) then block :: acc
else acc)
[]
heads
in
let sorted_heads =
List.sort
(fun b1 b2 ->
let f1 = State.Block.fitness b1 in
let f2 = State.Block.fitness b2 in
~-(Fitness.compare f1 f2))
heads
in
Lwt.return (List.map (fun b -> Some b) sorted_heads)
| _ :: _ as heads ->
Lwt_list.map_p (State.Block.read_opt chain_state) heads )
>>= fun requested_heads ->
Lwt_list.fold_left_s
(fun (ignored, acc) head ->
match head with
| None ->
Lwt.return (ignored, [])
| Some block ->
predecessors ignored length block
>>= fun predecessors ->
let ignored =
List.fold_left
(fun acc v -> Block_hash.Set.add v acc)
ignored
predecessors
in
Lwt.return (ignored, predecessors :: acc))
(Block_hash.Set.empty, [])
requested_heads
>>= fun (_, blocks) -> return (List.rev blocks)
let rpc_directory =
let dir : State.Chain.t RPC_directory.t ref = ref RPC_directory.empty in
let register0 s f =
dir :=
RPC_directory.register !dir (RPC_service.subst0 s) (fun chain p q ->
f chain p q)
in
let register1 s f =
dir :=
RPC_directory.register !dir (RPC_service.subst1 s) (fun (chain, a) p q ->
f chain a p q)
in
let register_dynamic_directory2 ?descr s f =
dir :=
RPC_directory.register_dynamic_directory
!dir
?descr
(RPC_path.subst1 s)
(fun (chain, a) -> f chain a)
in
register0 S.chain_id (fun chain () () -> return (State.Chain.id chain)) ;
register0 S.checkpoint (fun chain () () ->
State.Chain.checkpoint chain
>>= fun checkpoint ->
State.Chain.save_point chain
>>= fun (save_point, _) ->
State.Chain.caboose chain
>>= fun (caboose, _) ->
State.history_mode (State.Chain.global_state chain)
>>= fun history_mode ->
return (checkpoint, save_point, caboose, history_mode)) ;
(* blocks *)
register0 S.Blocks.list (fun chain q () ->
list_blocks chain ?length:q#length ?min_date:q#min_date q#heads) ;
register_dynamic_directory2
Block_services.path
Block_directory.build_rpc_directory ;
(* invalid_blocks *)
register0 S.Invalid_blocks.list (fun chain () () ->
let convert (hash, level, errors) = {hash; level; errors} in
State.Block.list_invalid chain
>>= fun blocks -> return (List.map convert blocks)) ;
register1 S.Invalid_blocks.get (fun chain hash () () ->
State.Block.read_invalid chain hash
>>= function
| None ->
Lwt.fail Not_found
| Some {level; errors} ->
return {hash; level; errors}) ;
register1 S.Invalid_blocks.delete (fun chain hash () () ->
State.Block.unmark_invalid chain hash) ;
!dir
let build_rpc_directory validator =
let distributed_db = Validator.distributed_db validator in
let state = Distributed_db.state distributed_db in
let dir = ref rpc_directory in
(* Mempool *)
let merge d = dir := RPC_directory.merge !dir d in
merge
(RPC_directory.map
(fun chain ->
match Validator.get validator (State.Chain.id chain) with
| Error _ ->
Lwt.fail Not_found
| Ok chain_validator ->
Lwt.return (Chain_validator.prevalidator chain_validator))
Prevalidator.rpc_directory) ;
RPC_directory.prefix Chain_services.path
@@ RPC_directory.map (fun ((), chain) -> get_chain state chain) !dir
src/lib_shell/chain_directory.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Chain_services.
Definition get_chain_id
(state : Tezos_shell__State.global_state) (function_parameter : variant)
: Lwt.t Tezos_base__TzPervasives.Chain_id.t :=
match function_parameter with
| Main => Lwt._return (State.Chain.main state)
| Test =>
op_gtgteq (State.Chain.get_exn state (State.Chain.main state))
(fun main_chain =>
op_gtgteq (State.Chain.test main_chain)
(fun function_parameter =>
match function_parameter with
| None => Lwt.fail OCaml.Not_found
| Some chain_id => Lwt._return chain_id
end))
| Hash chain_id => Lwt._return chain_id
end.
Definition get_chain_id_opt
(state : Tezos_shell__State.global_state) (chain : variant)
: Lwt.t (option Tezos_base__TzPervasives.Chain_id.t) :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (get_chain_id state chain) Lwt.return_some)
(fun _exn => Lwt.return_none).
Definition get_chain (state : Tezos_shell__State.global_state) (chain : variant)
: Lwt.t Tezos_shell.State.Chain.chain_state :=
op_gtgteq (get_chain_id state chain)
(fun chain_id => State.Chain.get_exn state chain_id).
Definition get_checkpoint
(state : Tezos_shell__State.global_state)
(chain : Tezos_shell_services.Chain_services.chain)
: Lwt.t Tezos_crypto.Block_hash.t :=
op_gtgteq (get_chain state chain)
(fun chain =>
op_gtgteq (State.Chain.checkpoint chain)
(fun header => Lwt._return (Block_header.hash header))).
Definition predecessors
(ignored : Tezos_base__TzPervasives.Block_hash.Set.t) (length : Z)
(head : Tezos_shell.State.Block.t)
: Lwt.t (list Tezos_base__TzPervasives.Block_hash.t) :=
let fix loop
(acc : list Tezos_base__TzPervasives.Block_hash.t) (length : Z) (block :
Tezos_shell.State.Block.t)
: Lwt.t (list Tezos_base__TzPervasives.Block_hash.t) :=
if OCaml.Stdlib.le length 0 then
Lwt._return (List.rev acc)
else
op_gtgteq (State.Block.predecessor block)
(fun function_parameter =>
match function_parameter with
| None => Lwt._return (List.rev acc)
| Some pred =>
if Block_hash.Set.mem (State.Block.hash block) ignored then
Lwt._return (List.rev acc)
else
loop (cons (State.Block.hash pred) acc) (Z.sub length 1) pred
end) in
loop (cons (State.Block.hash head) []) (Z.sub length 1) head.
Definition list_blocks
(chain_state : Tezos_shell.State.Chain.t) (op_staroptstar : option Z)
: (option Tezos_base__TzPervasives.Time.Protocol.t) ->
(list Tezos_base__TzPervasives.Block_hash.t) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(list (list Tezos_base__TzPervasives.Block_hash.Set.elt))) :=
let length :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 1
end in
fun min_date =>
fun heads =>
op_gtgteq
match heads with
| [] =>
op_gtgteq (Chain.known_heads chain_state)
(fun heads =>
let heads :=
match min_date with
| None => heads
| Some min_date =>
List.fold_left
(fun acc =>
fun block =>
let timestamp := State.Block.timestamp block in
if op_lteq min_date timestamp then
cons block acc
else
acc) [] heads
end in
let sorted_heads :=
List.sort
(fun b1 =>
fun b2 =>
let f1 := State.Block.fitness b1 in
let f2 := State.Block.fitness b2 in
Z.opp (Fitness.compare f1 f2)) heads in
Lwt._return (List.map (fun b => Some b) sorted_heads))
| (cons _ _) as heads =>
Lwt_list.map_p (State.Block.read_opt chain_state) heads
end
(fun requested_heads =>
op_gtgteq
(Lwt_list.fold_left_s
(fun function_parameter =>
let '(ignored, acc) := function_parameter in
fun head =>
match head with
| None => Lwt._return (ignored, [])
| Some block =>
op_gtgteq (predecessors ignored length block)
(fun predecessors =>
let ignored :=
List.fold_left
(fun acc => fun v => Block_hash.Set.add v acc)
ignored predecessors in
Lwt._return (ignored, (cons predecessors acc)))
end) (Block_hash.Set.empty, []) requested_heads)
(fun function_parameter =>
let '(_, blocks) := function_parameter in
_return (List.rev blocks))).
Definition rpc_directory
: Tezos_base__TzPervasives.RPC_directory.t Tezos_shell.State.Chain.t :=
let dir := Stdlib.ref RPC_directory.empty in
let register0 {A B C D : Type}
(s :
Tezos_base__TzPervasives.RPC_service.raw variant A A B C D
Tezos_rpc.RPC_service.error) (f :
Tezos_shell.State.Chain.t ->
B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
Stdlib.op_coloneq dir
(RPC_directory.register (Stdlib.op_exclamation dir) (RPC_service.subst0 s)
(fun chain => fun p => fun q => f chain p q)) in
let register1 {A B C D E : Type}
(s :
Tezos_base__TzPervasives.RPC_service.raw variant A (A * B) C D E
Tezos_rpc.RPC_service.error) (f :
Tezos_shell.State.Chain.t ->
B -> C -> D -> Lwt.t (Tezos_error_monad.Error_monad.tzresult E)) : unit :=
Stdlib.op_coloneq dir
(RPC_directory.register (Stdlib.op_exclamation dir) (RPC_service.subst1 s)
(fun function_parameter =>
let '(chain, a) := function_parameter in
fun p => fun q => f chain a p q)) in
let register_dynamic_directory2 {A B : Type}
(descr : option string) (s :
Tezos_base__TzPervasives.RPC_path.path A (A * B)) (f :
Tezos_shell.State.Chain.t ->
B ->
Lwt.t
(Tezos_base__TzPervasives.RPC_directory.directory
(Tezos_shell.State.Chain.t * B))) : unit :=
Stdlib.op_coloneq dir
(RPC_directory.register_dynamic_directory descr
(Stdlib.op_exclamation dir) (RPC_path.subst1 s)
(fun function_parameter =>
let '(chain, a) := function_parameter in
f chain a)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.chain_id
(fun chain =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
_return (State.Chain.id chain)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.checkpoint
(fun chain =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Chain.checkpoint chain)
(fun checkpoint =>
op_gtgteq (State.Chain.save_point chain)
(fun function_parameter =>
let '(save_point, _) := function_parameter in
op_gtgteq (State.Chain.caboose chain)
(fun function_parameter =>
let '(caboose, _) := function_parameter in
op_gtgteq
(State.history_mode (State.Chain.global_state chain))
(fun history_mode =>
_return
(checkpoint, save_point, caboose, history_mode))))))
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.Blocks.list
(fun chain =>
fun q =>
fun function_parameter =>
let 'tt := function_parameter in
list_blocks chain
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register_dynamic_directory2 None Block_services.path
Block_directory.build_rpc_directory in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.Invalid_blocks.list
(fun chain =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
let convert
(function_parameter :
Tezos_base__TzPervasives.Block_hash.t * Stdlib.Int32.t *
(list Tezos_base__TzPervasives.error))
: Tezos_shell_services.Chain_services.invalid_block :=
let '(hash, level, errors) := function_parameter in
{| hash := hash; level := level; errors := errors |} in
op_gtgteq (State.Block.list_invalid chain)
(fun blocks => _return (List.map convert blocks))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.Invalid_blocks.get
(fun chain =>
fun hash =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Block.read_invalid chain hash)
(fun function_parameter =>
match function_parameter with
| None => Lwt.fail OCaml.Not_found
| Some {| level := level; errors := errors |} =>
_return {| hash := hash; level := level; errors := errors |}
end)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.Invalid_blocks.delete
(fun chain =>
fun hash =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
State.Block.unmark_invalid chain hash) in
Stdlib.op_exclamation dir.
Definition build_rpc_directory (validator : Tezos_shell.Validator.t)
: Tezos_base__TzPervasives.RPC_directory.directory unit :=
let distributed_db := Validator.distributed_db validator in
let state := Distributed_db.state distributed_db in
let dir := Stdlib.ref rpc_directory in
let merge
(d :
Tezos_base__TzPervasives.RPC_directory.directory Tezos_shell.State.Chain.t)
: unit :=
Stdlib.op_coloneq dir (RPC_directory.merge (Stdlib.op_exclamation dir) d) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
merge
(RPC_directory.map
(fun chain =>
match Validator.get validator (State.Chain.id chain) with
| Stdlib.Error _ => Lwt.fail OCaml.Not_found
| Stdlib.Ok chain_validator =>
Lwt._return (Chain_validator.prevalidator chain_validator)
end) Prevalidator.rpc_directory) in
apply (RPC_directory.prefix Chain_services.path)
(RPC_directory.map
(fun function_parameter =>
let '(tt, chain) := function_parameter in
get_chain state chain) (Stdlib.op_exclamation dir)).
src/lib_shell/chain_traversal.ml 85 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open State
let path (b1 : Block.t) (b2 : Block.t) =
if not (Chain_id.equal (Block.chain_id b1) (Block.chain_id b2)) then
invalid_arg "Chain_traversal.path" ;
let rec loop acc current =
if Block.equal b1 current then Lwt.return_some acc
else
Block.predecessor current
>>= function
| Some pred -> loop (current :: acc) pred | None -> Lwt.return_none
in
loop [] b2
let common_ancestor (b1 : Block.t) (b2 : Block.t) =
if not (Chain_id.equal (Block.chain_id b1) (Block.chain_id b2)) then
invalid_arg "Chain_traversal.path" ;
let rec loop (b1 : Block.t) (b2 : Block.t) =
if Block.equal b1 b2 then Lwt.return b1
else if Time.Protocol.(Block.timestamp b1 <= Block.timestamp b2) then
Block.predecessor b2
>>= function None -> assert false | Some b2 -> loop b1 b2
else
Block.predecessor b1
>>= function None -> assert false | Some b1 -> loop b1 b2
in
loop b1 b2
let iter_predecessors ?max ?min_fitness ?min_date heads ~f =
let module Local = struct
exception Exit
end in
let compare b1 b2 =
match Fitness.compare (Block.fitness b1) (Block.fitness b2) with
| 0 -> (
match
Time.Protocol.compare (Block.timestamp b1) (Block.timestamp b2)
with
| 0 ->
Block.compare b1 b2
| res ->
res )
| res ->
res
in
let (pop, push) =
(* Poor-man priority queue *)
let queue : Block.t list ref = ref [] in
let pop () =
match !queue with
| [] ->
None
| b :: bs ->
queue := bs ;
Some b
in
let push b =
let rec loop = function
| [] ->
[b]
| b' :: bs' as bs ->
let cmp = compare b b' in
if cmp = 0 then bs else if cmp < 0 then b' :: loop bs' else b :: bs
in
queue := loop !queue
in
(pop, push)
in
let check_count =
match max with
| None ->
fun () -> ()
| Some max ->
let cpt = ref 0 in
fun () ->
if !cpt >= max then raise Local.Exit ;
incr cpt
in
let check_fitness =
match min_fitness with
| None ->
fun _ -> true
| Some min_fitness ->
fun b -> Fitness.compare min_fitness (Block.fitness b) <= 0
in
let check_date =
match min_date with
| None ->
fun _ -> true
| Some min_date ->
fun b -> Time.Protocol.(min_date <= Block.timestamp b)
in
let rec loop () =
match pop () with
| None ->
Lwt.return_unit
| Some b -> (
check_count () ;
f b
>>= fun () ->
Block.predecessor b
>>= function
| None ->
loop ()
| Some p ->
if check_fitness p && check_date p then push p ;
loop () )
in
List.iter push heads ;
try loop () with Local.Exit -> Lwt.return_unit
let iter_predecessors ?max ?min_fitness ?min_date heads ~f =
match heads with
| [] ->
Lwt.return_unit
| b :: _ ->
let chain_id = Block.chain_id b in
if
not
(List.for_all
(fun b -> Chain_id.equal chain_id (Block.chain_id b))
heads)
then invalid_arg "State.Helpers.iter_predecessors" ;
iter_predecessors ?max ?min_fitness ?min_date heads ~f
let new_blocks ~from_block ~to_block =
common_ancestor from_block to_block
>>= fun ancestor ->
path ancestor to_block
>>= function None -> assert false | Some path -> Lwt.return (ancestor, path)
let live_blocks block n =
let rec loop bacc oacc chain_state block_head n =
Block.all_operation_hashes block_head
>>= fun hashes ->
let oacc =
List.fold_left
(List.fold_left (fun oacc op -> Operation_hash.Set.add op oacc))
oacc
hashes
in
let bacc = Block_hash.Set.add (Block.hash block_head) bacc in
if n = 0 then return (bacc, oacc)
else
State.Block.predecessor block_head
>>= function
| None ->
let genesis_hash = (State.Chain.genesis chain_state).block in
let block_hash = Block.hash block_head in
if Block_hash.equal genesis_hash block_hash then return (bacc, oacc)
else fail (State.Block_not_found block_hash)
| Some predecessor ->
loop bacc oacc chain_state predecessor (pred n)
in
loop
Block_hash.Set.empty
Operation_hash.Set.empty
(Block.chain_state block)
block
n
src/lib_shell/chain_traversal.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import State.
Definition path
(b1 : Tezos_shell.State.Block.t) (b2 : Tezos_shell.State.Block.t)
: Lwt.t (option (list Tezos_shell.State.Block.t)) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if negb (Chain_id.equal (Block.chain_id b1) (Block.chain_id b2)) then
OCaml.Stdlib.invalid_arg "Chain_traversal.path" % string
else
tt in
let fix loop
(acc : list Tezos_shell.State.Block.t) (current : Tezos_shell.State.Block.t)
: Lwt.t (option (list Tezos_shell.State.Block.t)) :=
if Block.equal b1 current then
Lwt.return_some acc
else
op_gtgteq (Block.predecessor current)
(fun function_parameter =>
match function_parameter with
| Some pred => loop (cons current acc) pred
| None => Lwt.return_none
end) in
loop [] b2.
Definition common_ancestor
(b1 : Tezos_shell.State.Block.t) (b2 : Tezos_shell.State.Block.t)
: Lwt.t Tezos_shell.State.Block.t :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if negb (Chain_id.equal (Block.chain_id b1) (Block.chain_id b2)) then
OCaml.Stdlib.invalid_arg "Chain_traversal.path" % string
else
tt in
let fix loop (b1 : Tezos_shell.State.Block.t) (b2 : Tezos_shell.State.Block.t)
: Lwt.t Tezos_shell.State.Block.t :=
if Block.equal b1 b2 then
Lwt._return b1
else
if op_lteq (Block.timestamp b1) (Block.timestamp b2) then
op_gtgteq (Block.predecessor b2)
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some b2 => loop b1 b2
end)
else
op_gtgteq (Block.predecessor b1)
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some b1 => loop b1 b2
end) in
loop b1 b2.
Definition iter_predecessors
(max : option Z) (min_fitness : option Tezos_base__TzPervasives.Fitness.t)
(min_date : option Tezos_base__TzPervasives.Time.Protocol.t)
(heads : list Tezos_shell.State.Block.t)
(f : Tezos_shell.State.Block.t -> Lwt.t unit) : Lwt.t unit :=
let Local :=
(* ❌ The signature name of this module could not be found *)
existT _ _
{|
(* ❌ Exception not handled *)
unknown_signature_name.Exit := exception
|} in
let compare (b1 : Tezos_shell.State.Block.t) (b2 : Tezos_shell.State.Block.t)
: Z :=
match Fitness.compare (Block.fitness b1) (Block.fitness b2) with
| 0 =>
match Time.Protocol.compare (Block.timestamp b1) (Block.timestamp b2) with
| 0 => Block.compare b1 b2
| res => res
end
| res => res
end in
let '(pop, push) :=
let queue := Stdlib.ref [] in
let pop (function_parameter : unit) : option Tezos_shell.State.Block.t :=
let 'tt := function_parameter in
match Stdlib.op_exclamation queue with
| [] => None
| cons b bs =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq queue bs in
Some b
end in
let push (b : Tezos_shell.State.Block.t) : unit :=
let fix loop (function_parameter : list Tezos_shell.State.Block.t)
: list Tezos_shell.State.Block.t :=
match function_parameter with
| [] => cons b []
| (cons b' bs') as bs =>
let cmp := compare b b' in
if equiv_decb cmp 0 then
bs
else
if OCaml.Stdlib.lt cmp 0 then
cons b' (loop bs')
else
cons b bs
end in
Stdlib.op_coloneq queue (loop (Stdlib.op_exclamation queue)) in
(pop, push) in
let check_count :=
match max with
| None =>
fun function_parameter =>
let 'tt := function_parameter in
tt
| Some max =>
let cpt := Stdlib.ref 0 in
fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.ge (Stdlib.op_exclamation cpt) max then
Stdlib.raise Exit
else
tt in
Stdlib.incr cpt
end in
let check_fitness :=
match min_fitness with
| None =>
fun function_parameter =>
let '_ := function_parameter in
true
| Some min_fitness =>
fun b => OCaml.Stdlib.le (Fitness.compare min_fitness (Block.fitness b)) 0
end in
let check_date :=
match min_date with
| None =>
fun function_parameter =>
let '_ := function_parameter in
true
| Some min_date => fun b => op_lteq min_date (Block.timestamp b)
end in
let fix loop (function_parameter : unit) : Lwt.t unit :=
let 'tt := function_parameter in
match pop tt with
| None => Lwt.return_unit
| Some b =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := check_count tt in
op_gtgteq (f b)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Block.predecessor b)
(fun function_parameter =>
match function_parameter with
| None => loop tt
| Some p =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if andb (check_fitness p) (check_date p) then
push p
else
tt in
loop tt
end))
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := List.iter push heads in
(* ❌ Try-with are not handled *)
try (loop tt).
Definition iter_predecessors
(max : option Z) (min_fitness : option Tezos_base__TzPervasives.Fitness.t)
(min_date : option Tezos_base__TzPervasives.Time.Protocol.t)
(heads : list Tezos_shell.State.Block.t)
(f : Tezos_shell.State.Block.t -> Lwt.t unit) : Lwt.t unit :=
match heads with
| [] => Lwt.return_unit
| cons b _ =>
let chain_id := Block.chain_id b in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
negb
(List.for_all (fun b => Chain_id.equal chain_id (Block.chain_id b))
heads) then
OCaml.Stdlib.invalid_arg "State.Helpers.iter_predecessors" % string
else
tt in
iter_predecessors max min_fitness min_date heads f
end.
Definition new_blocks
(from_block : Tezos_shell.State.Block.t)
(to_block : Tezos_shell.State.Block.t)
: Lwt.t (Tezos_shell.State.Block.t * (list Tezos_shell.State.Block.t)) :=
op_gtgteq (common_ancestor from_block to_block)
(fun ancestor =>
op_gtgteq (path ancestor to_block)
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some path => Lwt._return (ancestor, path)
end)).
Definition live_blocks (block : Tezos_shell.State.Block.t) (n : Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Block_hash.Set.t *
Tezos_base__TzPervasives.Operation_hash.Set.t)) :=
let fix loop
(bacc : Tezos_base__TzPervasives.Block_hash.Set.t) (oacc :
Tezos_base__TzPervasives.Operation_hash.Set.t) (chain_state :
Tezos_shell.State.Chain.chain_state) (block_head :
Tezos_shell.State.Block.t) (n : Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Block_hash.Set.t *
Tezos_base__TzPervasives.Operation_hash.Set.t)) :=
op_gtgteq (Block.all_operation_hashes block_head)
(fun hashes =>
let oacc :=
List.fold_left
(List.fold_left
(fun oacc => fun op => Operation_hash.Set.add op oacc)) oacc
hashes in
let bacc := Block_hash.Set.add (Block.hash block_head) bacc in
if equiv_decb n 0 then
_return (bacc, oacc)
else
op_gtgteq (State.Block.predecessor block_head)
(fun function_parameter =>
match function_parameter with
| None =>
let genesis_hash := block (State.Chain.genesis chain_state) in
let block_hash := Block.hash block_head in
if Block_hash.equal genesis_hash block_hash then
_return (bacc, oacc)
else
fail (Tezos_base__TzPervasives.Block_not_found block_hash)
| Some predecessor =>
loop bacc oacc chain_state predecessor (Z.pred n)
end)) in
loop Block_hash.Set.empty Operation_hash.Set.empty (Block.chain_state block)
block n.
src/lib_shell/chain_validator.ml 139 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Chain_validator_worker_state
module Log = Internal_event.Legacy_logging.Make (struct
let name = "node.chain_validator"
end)
module Name = struct
type t = Chain_id.t
let encoding = Chain_id.encoding
let base = ["validator"; "chain"]
let pp = Chain_id.pp_short
end
module Request = struct
include Request
type _ t = Validated : State.Block.t -> Event.update t
let view (type a) (Validated block : a t) : view = State.Block.hash block
end
type limits = {bootstrap_threshold : int; worker_limits : Worker_types.limits}
module Types = struct
include Worker_state
type parameters = {
parent : Name.t option;
db : Distributed_db.t;
chain_state : State.Chain.t;
chain_db : Distributed_db.chain_db;
block_validator : Block_validator.t;
block_validator_process : Block_validator_process.t;
global_valid_block_input : State.Block.t Lwt_watcher.input;
global_chains_input : (Chain_id.t * bool) Lwt_watcher.input;
prevalidator_limits : Prevalidator.limits;
peer_validator_limits : Peer_validator.limits;
limits : limits;
}
type state = {
parameters : parameters;
mutable bootstrapped : bool;
bootstrapped_waiter : unit Lwt.t;
bootstrapped_wakener : unit Lwt.u;
valid_block_input : State.Block.t Lwt_watcher.input;
new_head_input : State.Block.t Lwt_watcher.input;
mutable child : (state * (unit -> unit Lwt.t (* shutdown *))) option;
mutable prevalidator : Prevalidator.t option;
active_peers : Peer_validator.t P2p_peer.Error_table.t;
bootstrapped_peers : unit P2p_peer.Table.t;
}
let view (state : state) _ : view =
let {bootstrapped; active_peers; bootstrapped_peers; _} = state in
{
bootstrapped;
active_peers =
P2p_peer.Error_table.fold_keys (fun id l -> id :: l) active_peers [];
bootstrapped_peers =
P2p_peer.Table.fold (fun id _ l -> id :: l) bootstrapped_peers [];
}
end
module Logger = Worker_logger.Make (Event) (Request)
module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)
open Types
type t = Worker.infinite Worker.queue Worker.t
let table = Worker.create_table Queue
let shutdown w = Worker.shutdown w
let shutdown_child nv active_chains =
Lwt_utils.may
~f:
(fun ({parameters = {chain_state; global_chains_input; _}; _}, shutdown) ->
Lwt_watcher.notify global_chains_input (State.Chain.id chain_state, false) ;
Chain_id.Table.remove active_chains (State.Chain.id chain_state) ;
State.update_chain_data nv.parameters.chain_state (fun _ chain_data ->
Lwt.return (Some {chain_data with test_chain = None}, ()))
>>= fun () ->
shutdown ()
>>= fun () ->
nv.child <- None ;
Lwt.return_unit)
nv.child
let notify_new_block w block =
let nv = Worker.state w in
Option.iter nv.parameters.parent ~f:(fun id ->
try
let w = List.assoc id (Worker.list table) in
let nv = Worker.state w in
Lwt_watcher.notify nv.valid_block_input block
with Not_found -> ()) ;
Lwt_watcher.notify nv.valid_block_input block ;
Lwt_watcher.notify nv.parameters.global_valid_block_input block ;
Worker.Queue.push_request_now w (Validated block)
let may_toggle_bootstrapped_chain w =
let nv = Worker.state w in
if
(not nv.bootstrapped)
&& P2p_peer.Table.length nv.bootstrapped_peers
>= nv.parameters.limits.bootstrap_threshold
then (
Log.log_info "bootstrapped" ;
nv.bootstrapped <- true ;
Lwt.wakeup_later nv.bootstrapped_wakener () )
let with_activated_peer_validator w peer_id f =
let nv = Worker.state w in
P2p_peer.Error_table.find_or_make nv.active_peers peer_id (fun () ->
Peer_validator.create
~notify_new_block:(notify_new_block w)
~notify_bootstrapped:(fun () ->
P2p_peer.Table.add nv.bootstrapped_peers peer_id () ;
may_toggle_bootstrapped_chain w)
~notify_termination:(fun _pv ->
P2p_peer.Error_table.remove nv.active_peers peer_id ;
P2p_peer.Table.remove nv.bootstrapped_peers peer_id)
nv.parameters.peer_validator_limits
nv.parameters.block_validator
nv.parameters.chain_db
peer_id)
>>=? fun pv ->
match Peer_validator.status pv with
| Worker_types.Running _ ->
f pv
| Worker_types.Closing (_, _)
| Worker_types.Closed (_, _, _)
| Worker_types.Launching _ ->
return_unit
let may_update_checkpoint chain_state new_head =
State.Chain.checkpoint chain_state
>>= fun checkpoint ->
State.Block.last_allowed_fork_level new_head
>>=? fun new_level ->
if new_level <= checkpoint.shell.level then return_unit
else
let state = State.Chain.global_state chain_state in
State.history_mode state
>>= fun history_mode ->
let head_level = State.Block.level new_head in
State.Block.predecessor_n
new_head
(Int32.to_int (Int32.sub head_level new_level))
>>= function
| None ->
assert false (* should not happen *)
| Some new_checkpoint -> (
State.Block.read_opt chain_state new_checkpoint
>>= function
| None ->
assert false (* should not happen *)
| Some new_checkpoint -> (
Log.log_notice
"@[Update to checkpoint %a (running in mode %a).@]"
Block_hash.pp
(State.Block.hash new_checkpoint)
History_mode.pp
history_mode ;
let new_checkpoint = State.Block.header new_checkpoint in
match history_mode with
| History_mode.Archive ->
State.Chain.set_checkpoint chain_state new_checkpoint
>>= fun () -> return_unit
| Full ->
State.Chain.set_checkpoint_then_purge_full
chain_state
new_checkpoint
| Rolling ->
State.Chain.set_checkpoint_then_purge_rolling
chain_state
new_checkpoint ) )
let may_switch_test_chain w active_chains spawn_child block =
let nv = Worker.state w in
let create_child block protocol expiration forking_block =
let block_header = State.Block.header block in
let genesis =
Context.compute_testchain_genesis (State.Block.hash forking_block)
in
let chain_id = Context.compute_testchain_chain_id genesis in
let activated =
match nv.child with
| None ->
false
| Some (child, _) ->
Block_hash.equal
(State.Chain.genesis child.parameters.chain_state).block
genesis
in
let expired = expiration < block_header.shell.timestamp in
if expired && activated then
shutdown_child nv active_chains >>= fun () -> return_unit
else if
activated || expired
|| not (State.Chain.allow_forked_chain nv.parameters.chain_state)
then return_unit
else
State.Chain.get_opt
(State.Chain.global_state nv.parameters.chain_state)
chain_id
>>= (function
| Some chain_state ->
State.update_testchain block ~testchain_state:chain_state
>>= fun () -> return chain_state
| None ->
let try_init_test_chain cont =
let bvp = nv.parameters.block_validator_process in
Block_validator_process.init_test_chain bvp forking_block
>>= function
| Ok genesis_header ->
State.fork_testchain
block
chain_id
genesis
genesis_header
protocol
expiration
>>=? fun chain_state ->
Chain.head chain_state
>>= fun new_genesis_block ->
Lwt_watcher.notify
nv.parameters.global_valid_block_input
new_genesis_block ;
Lwt_watcher.notify nv.valid_block_input new_genesis_block ;
return chain_state
| Error
(Block_validator_errors.Missing_test_protocol
missing_protocol
:: _) ->
Block_validator.fetch_and_compile_protocol
nv.parameters.block_validator
missing_protocol
>>=? fun _ -> cont ()
| Error _ as error ->
Lwt.return error
in
try_init_test_chain
@@ fun () ->
try_init_test_chain
@@ fun () -> failwith "Could not retrieve test protocol")
>>=? fun chain_state ->
(* [spawn_child] is a callback to [create_node]. Thus, it takes care of
global initialization boilerplate (e.g. notifying [global_chains_input],
adding the chain to the correct tables, ...) *)
spawn_child
~parent:(State.Chain.id chain_state)
nv.parameters.peer_validator_limits
nv.parameters.prevalidator_limits
nv.parameters.block_validator
nv.parameters.global_valid_block_input
nv.parameters.global_chains_input
nv.parameters.db
chain_state
nv.parameters.limits
(* TODO: different limits main/test ? *)
>>=? fun child ->
nv.child <- Some child ;
return_unit
in
State.Block.test_chain block
>>= (function
| (Not_running, _) ->
shutdown_child nv active_chains >>= fun () -> return_unit
| ((Forking _ | Running _), None) ->
return_unit (* only for snapshots *)
| ( ( Forking {protocol; expiration; _}
| Running {protocol; expiration; _} ),
Some forking_block ) ->
create_child block protocol expiration forking_block)
>>= function
| Ok () ->
Lwt.return_unit
| Error err ->
Worker.record_event w (Could_not_switch_testchain err) ;
Lwt.return_unit
let broadcast_head w ~previous block =
let nv = Worker.state w in
if not nv.bootstrapped then Lwt.return_unit
else
State.Block.predecessor block
>>= (function
| None ->
Lwt.return_true
| Some predecessor ->
Lwt.return (State.Block.equal predecessor previous))
>>= fun successor ->
if successor then (
Distributed_db.Advertise.current_head nv.parameters.chain_db block ;
Lwt.return_unit )
else Distributed_db.Advertise.current_branch nv.parameters.chain_db
let safe_get_protocol hash =
match Registered_protocol.get hash with
| None ->
(* FIXME. *)
(* This should not happen: it should be handled in the validator. *)
failwith
"chain_validator: missing protocol '%a' for the current block."
Protocol_hash.pp_short
hash
| Some protocol ->
return protocol
let on_request (type a) w start_testchain active_chains spawn_child
(req : a Request.t) : a tzresult Lwt.t =
let (Request.Validated block) = req in
let nv = Worker.state w in
Chain.head nv.parameters.chain_state
>>= fun head ->
let head_header = State.Block.header head
and head_hash = State.Block.hash head
and block_header = State.Block.header block
and block_hash = State.Block.hash block in
( match nv.prevalidator with
| None ->
Lwt.return head_header.shell.fitness
| Some pv ->
Prevalidator.fitness pv )
>>= fun context_fitness ->
let head_fitness = head_header.shell.fitness in
let new_fitness = block_header.shell.fitness in
let accepted_head =
if Fitness.(context_fitness = head_fitness) then
Fitness.(new_fitness > head_fitness)
else Fitness.(new_fitness >= context_fitness)
in
if not accepted_head then return Event.Ignored_head
else
Chain.set_head nv.parameters.chain_state block
>>=? fun previous ->
may_update_checkpoint nv.parameters.chain_state block
>>=? fun () ->
broadcast_head w ~previous block
>>= fun () ->
( match nv.prevalidator with
| Some old_prevalidator ->
State.Block.protocol_hash block
>>=? fun new_protocol ->
let old_protocol = Prevalidator.protocol_hash old_prevalidator in
if not (Protocol_hash.equal old_protocol new_protocol) then (
safe_get_protocol new_protocol
>>=? fun (module Proto) ->
let (limits, chain_db) = Prevalidator.parameters old_prevalidator in
(* TODO inject in the new prevalidator the operation
from the previous one. *)
Prevalidator.create limits (module Proto) chain_db
>>= function
| Error errs ->
Log.lwt_log_error
"@[Failed to reinstantiate prevalidator:@ %a@]"
pp_print_error
errs
>>= fun () ->
nv.prevalidator <- None ;
Prevalidator.shutdown old_prevalidator >>= fun () -> return_unit
| Ok prevalidator ->
nv.prevalidator <- Some prevalidator ;
Prevalidator.shutdown old_prevalidator >>= fun () -> return_unit
)
else Prevalidator.flush old_prevalidator block_hash
| None ->
return_unit )
>>=? fun () ->
( if start_testchain then
may_switch_test_chain w active_chains spawn_child block
else Lwt.return_unit )
>>= fun () ->
Lwt_watcher.notify nv.new_head_input block ;
if Block_hash.equal head_hash block_header.shell.predecessor then
return Event.Head_increment
else return Event.Branch_switch
let on_completion (type a) w (req : a Request.t) (update : a) request_status =
let (Request.Validated block) = req in
let fitness = State.Block.fitness block in
let request = State.Block.hash block in
Worker.record_event
w
(Processed_block {request; request_status; update; fitness}) ;
Lwt.return_unit
let on_close w =
let nv = Worker.state w in
Distributed_db.deactivate nv.parameters.chain_db
>>= fun () ->
let pvs =
P2p_peer.Error_table.fold_promises
(fun _ pv acc ->
( pv
>>= function
| Error _ -> Lwt.return_unit | Ok pv -> Peer_validator.shutdown pv )
:: acc)
nv.active_peers
[]
in
Lwt.join
( ( match nv.prevalidator with
| Some prevalidator ->
Prevalidator.shutdown prevalidator
| None ->
Lwt.return_unit )
:: Lwt_utils.may ~f:(fun (_, shutdown) -> shutdown ()) nv.child
:: pvs )
let on_launch start_prevalidator w _ parameters =
( if start_prevalidator then
State.read_chain_data
parameters.chain_state
(fun _ {State.current_head; _} -> Lwt.return current_head)
>>= fun head ->
State.Block.protocol_hash head
>>=? fun head_hash ->
safe_get_protocol head_hash
>>= function
| Ok (module Proto) -> (
Prevalidator.create
parameters.prevalidator_limits
(module Proto)
parameters.chain_db
>>= function
| Error err ->
Log.lwt_log_error
"@[Failed to instantiate prevalidator:@ %a@]"
pp_print_error
err
>>= fun () -> return_none
| Ok prevalidator ->
return_some prevalidator )
| Error err ->
Log.lwt_log_error
"@[Failed to instantiate prevalidator:@ %a@]"
pp_print_error
err
>>= fun () -> return_none
else return_none )
>>=? fun prevalidator ->
let valid_block_input = Lwt_watcher.create_input () in
let new_head_input = Lwt_watcher.create_input () in
let (bootstrapped_waiter, bootstrapped_wakener) = Lwt.wait () in
let nv =
{
parameters;
valid_block_input;
new_head_input;
bootstrapped_wakener;
bootstrapped_waiter;
bootstrapped = parameters.limits.bootstrap_threshold <= 0;
active_peers = P2p_peer.Error_table.create 50;
(* TODO use `2 * max_connection` *)
bootstrapped_peers = P2p_peer.Table.create 50;
(* TODO use `2 * max_connection` *)
child = None;
prevalidator;
}
in
if nv.bootstrapped then Lwt.wakeup_later bootstrapped_wakener () ;
Distributed_db.set_callback
parameters.chain_db
{
notify_branch =
(fun peer_id locator ->
Lwt.async (fun () ->
with_activated_peer_validator w peer_id
@@ fun pv ->
Peer_validator.notify_branch pv locator ;
return_unit));
notify_head =
(fun peer_id block ops ->
Lwt.async (fun () ->
with_activated_peer_validator w peer_id (fun pv ->
Peer_validator.notify_head pv block ;
return_unit)
>>=? fun () ->
(* TODO notify prevalidator only if head is known ??? *)
match nv.prevalidator with
| Some prevalidator ->
Prevalidator.notify_operations prevalidator peer_id ops
>>= fun () -> return_unit
| None ->
return_unit));
disconnection =
(fun peer_id ->
Lwt.async (fun () ->
let nv = Worker.state w in
match P2p_peer.Error_table.find_opt nv.active_peers peer_id with
| None ->
return_unit
| Some pv ->
pv
>>=? fun pv ->
Peer_validator.shutdown pv >>= fun () -> return_unit));
} ;
return nv
let rec create ~start_prevalidator ~start_testchain ~active_chains ?parent
~block_validator_process peer_validator_limits prevalidator_limits
block_validator global_valid_block_input global_chains_input db chain_state
limits =
let spawn_child ~parent pvl pl bl gvbi gci db n l =
create
~start_prevalidator
~start_testchain
~active_chains
~parent
~block_validator_process
pvl
pl
bl
gvbi
gci
db
n
l
>>=? fun w -> return (Worker.state w, fun () -> Worker.shutdown w)
in
let module Handlers = struct
type self = t
let on_launch = on_launch start_prevalidator
let on_request w = on_request w start_testchain active_chains spawn_child
let on_close = on_close
let on_error _ _ _ errs = Lwt.return_error errs
let on_completion = on_completion
let on_no_request _ = return_unit
end in
let parameters =
{
parent;
peer_validator_limits;
prevalidator_limits;
block_validator;
block_validator_process;
global_valid_block_input;
global_chains_input;
db;
chain_db = Distributed_db.activate db chain_state;
chain_state;
limits;
}
in
Chain.init_head chain_state
>>=? fun () ->
Worker.launch
table
prevalidator_limits.worker_limits
(State.Chain.id chain_state)
parameters
(module Handlers)
>>=? fun w ->
Chain_id.Table.add active_chains (State.Chain.id chain_state) w ;
Lwt_watcher.notify global_chains_input (State.Chain.id chain_state, true) ;
return w
(** Current block computation *)
let create ~start_prevalidator ~start_testchain ~active_chains
~block_validator_process peer_validator_limits prevalidator_limits
block_validator global_valid_block_input global_chains_input global_db
state limits =
(* hide the optional ?parent *)
create
~start_prevalidator
~start_testchain
~active_chains
~block_validator_process
peer_validator_limits
prevalidator_limits
block_validator
global_valid_block_input
global_chains_input
global_db
state
limits
let chain_id w =
let {parameters = {chain_state; _}; _} = Worker.state w in
State.Chain.id chain_state
let chain_state w =
let {parameters = {chain_state; _}; _} = Worker.state w in
chain_state
let prevalidator w =
let {prevalidator; _} = Worker.state w in
prevalidator
let chain_db w =
let {parameters = {chain_db; _}; _} = Worker.state w in
chain_db
let child w =
match (Worker.state w).child with
| None ->
None
| Some ({parameters = {chain_state; _}; _}, _) -> (
try Some (List.assoc (State.Chain.id chain_state) (Worker.list table))
with Not_found -> None )
let assert_fitness_increases ?(force = false) w distant_header =
let pv = Worker.state w in
let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
Chain.head chain_state
>>= fun local_header ->
fail_when
( (not force)
&& Fitness.compare
distant_header.Block_header.shell.fitness
(State.Block.fitness local_header)
<= 0 )
(failure "Fitness too low")
let assert_checkpoint w (header : Block_header.t) =
let pv = Worker.state w in
let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
State.Chain.acceptable_block chain_state header
>>= fun acceptable ->
fail_unless
acceptable
(Validation_errors.Checkpoint_error (Block_header.hash header, None))
let validate_block w ?force hash block operations =
let nv = Worker.state w in
assert (Block_hash.equal hash (Block_header.hash block)) ;
assert_fitness_increases ?force w block
>>=? fun () ->
assert_checkpoint w block
>>=? fun () ->
Block_validator.validate
~canceler:(Worker.canceler w)
~notify_new_block:(notify_new_block w)
nv.parameters.block_validator
nv.parameters.chain_db
hash
block
operations
let bootstrapped w =
let {bootstrapped_waiter; _} = Worker.state w in
Lwt.protected bootstrapped_waiter
let valid_block_watcher w =
let {valid_block_input; _} = Worker.state w in
Lwt_watcher.create_stream valid_block_input
let new_head_watcher w =
let {new_head_input; _} = Worker.state w in
Lwt_watcher.create_stream new_head_input
let status = Worker.status
let information = Worker.information
let running_workers () = Worker.list table
let pending_requests t = Worker.Queue.pending_requests t
let pending_requests_length t = Worker.Queue.pending_requests_length t
let current_request t = Worker.current_request t
let last_events = Worker.last_events
let ddb_information t =
let state = Worker.state t in
let ddb = state.parameters.chain_db in
Distributed_db.information ddb
src/lib_shell/chain_validator.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Chain_validator_worker_state.
(* ❌ Applications of functors are not handled. *)
functor_application
Module Name.
Definition t := Tezos_base__TzPervasives.Chain_id.t.
Definition encoding
: Tezos_data_encoding.Data_encoding.t Tezos_base__TzPervasives.Chain_id.t :=
Chain_id.encoding.
Definition base : list string :=
cons "validator" % string (cons "chain" % string []).
Definition pp
: Stdlib.Format.formatter -> Tezos_base__TzPervasives.Chain_id.t -> unit :=
Chain_id.pp_short.
End Name.
Module Request.
(* ❌ Structure item `include` not handled. *)
include
Inductive t : forall (_ : Type), Type :=
| Validated : Tezos_shell.State.Block.t ->
t Tezos_shell_services.Chain_validator_worker_state.Event.update.
Definition view {A : Type} (function_parameter : t A) : view :=
let 'Validated block := function_parameter in
State.Block.hash block.
End Request.
Record limits := {
bootstrap_threshold : Z;
worker_limits : Tezos_shell_services.Worker_types.limits }.
Module Types.
(* ❌ Structure item `include` not handled. *)
include
Record parameters := {
parent : option Name.t;
db : Tezos_shell.Distributed_db.t;
chain_state : Tezos_shell.State.Chain.t;
chain_db : Tezos_shell.Distributed_db.chain_db;
block_validator : Tezos_shell.Block_validator.t;
block_validator_process : Tezos_shell.Block_validator_process.t;
global_valid_block_input :
Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t;
global_chains_input :
Tezos_base__TzPervasives.Lwt_watcher.input
(Tezos_base__TzPervasives.Chain_id.t * bool);
prevalidator_limits : Tezos_shell.Prevalidator.limits;
peer_validator_limits : Tezos_shell.Peer_validator.limits;
limits : limits }.
Record state := {
parameters : parameters;
bootstrapped : bool;
bootstrapped_waiter : Lwt.t unit;
bootstrapped_wakener : Lwt.u unit;
valid_block_input :
Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t;
new_head_input :
Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t;
child : option (state * (unit -> Lwt.t unit));
prevalidator : option Tezos_shell.Prevalidator.t;
active_peers :
Tezos_base__TzPervasives.P2p_peer.Error_table.t
Tezos_shell.Peer_validator.t;
bootstrapped_peers : Tezos_base__TzPervasives.P2p_peer.Table.t unit }.
Definition view {A : Type} (state : state) (function_parameter : A) : view :=
let '_ := function_parameter in
let '{|
bootstrapped := bootstrapped;
active_peers := active_peers;
bootstrapped_peers := bootstrapped_peers
|} := state in
{|
active_peers :=
P2p_peer.Error_table.fold_keys (fun id => fun l => cons id l)
active_peers [];
bootstrapped_peers :=
P2p_peer.Table.fold
(fun id =>
fun function_parameter =>
let '_ := function_parameter in
fun l => cons id l) bootstrapped_peers [];
bootstrapped := bootstrapped |}.
End Types.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Import Types.
Definition t := Worker.t (Worker.queue Worker.infinite).
Definition table : Worker.table (Worker.queue Worker.infinite) :=
Worker.create_table Worker.Queue.
Definition shutdown {A : Type} (w : Worker.t A) : Lwt.t unit :=
Worker.shutdown w.
Definition shutdown_child {A : Type}
(nv : Types.state)
(active_chains : Tezos_base__TzPervasives.Chain_id.Table.t A) : Lwt.t unit :=
Lwt_utils.may
(fun function_parameter =>
let
'({|
parameters := {|
chain_state := chain_state;
global_chains_input := global_chains_input
|}
|}, shutdown) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_watcher.notify global_chains_input
((State.Chain.id chain_state), false) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Chain_id.Table.remove active_chains (State.Chain.id chain_state)
in
op_gtgteq
(State.update_chain_data (chain_state (parameters nv))
(fun function_parameter =>
let '_ := function_parameter in
fun chain_data =>
Lwt._return
((Some
(* ❌ Record substitution not handled *)
record_substitution), tt)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (shutdown tt)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field nv "child" % string None in
Lwt.return_unit))) (child nv).
Definition notify_new_block
(w : Worker.t (Worker.queue Worker.infinite))
(block : Tezos_shell.State.Block.t) : unit :=
let nv := Worker.state w in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Option.iter
(fun id =>
(* ❌ Try-with are not handled *)
try
(let w := List.assoc id (Worker.list table) in
let nv := Worker.state w in
Lwt_watcher.notify (valid_block_input nv) block))
(parent (parameters nv)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_watcher.notify (valid_block_input nv) block in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_watcher.notify (global_valid_block_input (parameters nv)) block
in
Worker.Queue.push_request_now w (Request.Validated block).
Definition may_toggle_bootstrapped_chain {A : Type} (w : Worker.t A) : unit :=
let nv := Worker.state w in
if
andb (negb (bootstrapped nv))
(OCaml.Stdlib.ge (P2p_peer.Table.length (bootstrapped_peers nv))
(bootstrap_threshold (limits (parameters nv)))) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Log.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.log_info)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "bootstrapped" % string
CamlinternalFormatBasics.End_of_format) "bootstrapped" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field nv "bootstrapped" % string true in
Lwt.wakeup_later (bootstrapped_wakener nv) tt
else
tt.
Definition with_activated_peer_validator
(w : Worker.t (Worker.queue Worker.infinite))
(peer_id : Tezos_base__TzPervasives.P2p_peer.Error_table.key)
(f :
Tezos_shell.Peer_validator.t ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let nv := Worker.state w in
op_gtgteqquestion
(P2p_peer.Error_table.find_or_make (active_peers nv) peer_id
(fun function_parameter =>
let 'tt := function_parameter in
Peer_validator.create (Some (notify_new_block w))
(Some
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_peer.Table.add (bootstrapped_peers nv) peer_id tt in
may_toggle_bootstrapped_chain w))
(Some
(fun _pv =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_peer.Error_table.remove (active_peers nv) peer_id in
P2p_peer.Table.remove (bootstrapped_peers nv) peer_id))
(peer_validator_limits (parameters nv))
(block_validator (parameters nv)) (chain_db (parameters nv)) peer_id))
(fun pv =>
match Peer_validator.status pv with
| Tezos_shell_services.Worker_types.Running _ => f pv
|
Tezos_shell_services.Worker_types.Closing _ _ |
Tezos_shell_services.Worker_types.Closed _ _ _ |
Tezos_shell_services.Worker_types.Launching _ => return_unit
end).
Definition may_update_checkpoint
(chain_state : Tezos_shell.State.Chain.chain_state)
(new_head : Tezos_shell.State.Block.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (State.Chain.checkpoint chain_state)
(fun checkpoint =>
op_gtgteqquestion (State.Block.last_allowed_fork_level new_head)
(fun new_level =>
if OCaml.Stdlib.le new_level (level (shell checkpoint)) then
return_unit
else
let state := State.Chain.global_state chain_state in
op_gtgteq (State.history_mode state)
(fun history_mode =>
let head_level := State.Block.level new_head in
op_gtgteq
(State.Block.predecessor_n new_head
(Int32.to_int (Int32.sub head_level new_level)))
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some new_checkpoint =>
op_gtgteq
(State.Block.read_opt chain_state new_checkpoint)
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some new_checkpoint =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Log.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.log_notice)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.String_literal
"Update to checkpoint " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (running in mode " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
")." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[Update to checkpoint %a (running in mode %a).@]"
% string) Block_hash.pp
(State.Block.hash new_checkpoint)
History_mode.pp history_mode in
let new_checkpoint :=
State.Block.header new_checkpoint in
match history_mode with
| Tezos_shell_services.History_mode.Archive =>
op_gtgteq
(State.Chain.set_checkpoint chain_state
new_checkpoint)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Tezos_shell_services.History_mode.Full =>
State.Chain.set_checkpoint_then_purge_full
chain_state new_checkpoint
| Tezos_shell_services.History_mode.Rolling =>
State.Chain.set_checkpoint_then_purge_rolling
chain_state new_checkpoint
end
end)
end)))).
Definition may_switch_test_chain {A B : Type}
(w : Worker.t A) (active_chains : Tezos_base__TzPervasives.Chain_id.Table.t B)
(spawn_child :
Tezos_base__TzPervasives.Chain_id.t ->
Tezos_shell.Peer_validator.limits ->
Tezos_shell.Prevalidator.limits ->
Tezos_shell.Block_validator.t ->
(Tezos_base__TzPervasives.Lwt_watcher.input
Tezos_shell.State.Block.t) ->
(Tezos_base__TzPervasives.Lwt_watcher.input
(Tezos_base__TzPervasives.Chain_id.t * bool)) ->
Tezos_shell.Distributed_db.t ->
Tezos_shell.State.Chain.chain_state ->
limits ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Types.state * (unit -> Lwt.t unit))))
(block : Tezos_shell.State.Block.t) : Lwt.t unit :=
let nv := Worker.state w in
let create_child
(block : Tezos_shell.State.Block.t) (protocol :
Tezos_base__TzPervasives.Protocol_hash.t) (expiration :
Tezos_base.Time.Protocol.t) (forking_block : Tezos_shell.State.Block.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let block_header := State.Block.header block in
let genesis :=
Context.compute_testchain_genesis (State.Block.hash forking_block) in
let chain_id := Context.compute_testchain_chain_id genesis in
let activated :=
match child nv with
| None => false
| Some (child, _) =>
Block_hash.equal
(block (State.Chain.genesis (chain_state (parameters child)))) genesis
end in
let expired := OCaml.Stdlib.lt expiration (timestamp (shell block_header))
in
if andb expired activated then
op_gtgteq (shutdown_child nv active_chains)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
else
if
orb activated
(orb expired
(negb (State.Chain.allow_forked_chain (chain_state (parameters nv)))))
then
return_unit
else
op_gtgteqquestion
(op_gtgteq
(State.Chain.get_opt
(State.Chain.global_state (chain_state (parameters nv))) chain_id)
(fun function_parameter =>
match function_parameter with
| Some chain_state =>
op_gtgteq (State.update_testchain block chain_state)
(fun function_parameter =>
let 'tt := function_parameter in
_return chain_state)
| None =>
let try_init_test_chain
(cont :
unit ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_shell.State.Chain.t))
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_shell.State.Chain.t) :=
let bvp := block_validator_process (parameters nv) in
op_gtgteq
(Block_validator_process.init_test_chain bvp forking_block)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok genesis_header =>
op_gtgteqquestion
(State.fork_testchain block chain_id genesis
genesis_header protocol expiration)
(fun chain_state =>
op_gtgteq (Chain.head chain_state)
(fun new_genesis_block =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_watcher.notify
(global_valid_block_input (parameters nv))
new_genesis_block in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_watcher.notify (valid_block_input nv)
new_genesis_block in
_return chain_state))
|
Stdlib.Error
(cons
(Tezos_base__TzPervasives.Missing_test_protocol
missing_protocol) _) =>
op_gtgteqquestion
(Block_validator.fetch_and_compile_protocol
(block_validator (parameters nv)) None None
missing_protocol)
(fun function_parameter =>
let '_ := function_parameter in
cont tt)
| (Stdlib.Error _) as error => Lwt._return error
end) in
apply try_init_test_chain
(fun function_parameter =>
let 'tt := function_parameter in
apply try_init_test_chain
(fun function_parameter =>
let 'tt := function_parameter in
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Could not retrieve test protocol" % string
CamlinternalFormatBasics.End_of_format)
"Could not retrieve test protocol" % string)))
end))
(fun chain_state =>
op_gtgteqquestion
(spawn_child (State.Chain.id chain_state)
(peer_validator_limits (parameters nv))
(prevalidator_limits (parameters nv))
(block_validator (parameters nv))
(global_valid_block_input (parameters nv))
(global_chains_input (parameters nv)) (db (parameters nv))
chain_state (limits (parameters nv)))
(fun child =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field nv "child" % string (Some child) in
return_unit)) in
op_gtgteq
(op_gtgteq (State.Block.test_chain block)
(fun function_parameter =>
match function_parameter with
| (Tezos_base__TzPervasives.Test_chain_status.Not_running, _) =>
op_gtgteq (shutdown_child nv active_chains)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
|
(Tezos_base__TzPervasives.Test_chain_status.Forking _ |
Tezos_base__TzPervasives.Test_chain_status.Running _, None) =>
return_unit
|
(Tezos_base__TzPervasives.Test_chain_status.Forking {|
protocol := protocol; expiration := expiration |} |
Tezos_base__TzPervasives.Test_chain_status.Running {|
protocol := protocol; expiration := expiration |},
Some forking_block) =>
create_child block protocol expiration forking_block
end))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Worker.record_event w
(Tezos_shell_services.Chain_validator_worker_state.Event.Could_not_switch_testchain
err) in
Lwt.return_unit
end).
Definition broadcast_head {A : Type}
(w : Worker.t A) (previous : Tezos_shell.State.Block.t)
(block : Tezos_shell.State.Block.t) : Lwt.t unit :=
let nv := Worker.state w in
if negb (bootstrapped nv) then
Lwt.return_unit
else
op_gtgteq
(op_gtgteq (State.Block.predecessor block)
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_true
| Some predecessor =>
Lwt._return (State.Block.equal predecessor previous)
end))
(fun successor =>
if successor then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Distributed_db.Advertise.current_head (chain_db (parameters nv))
None None block in
Lwt.return_unit
else
Distributed_db.Advertise.current_branch None
(chain_db (parameters nv))).
Definition safe_get_protocol (hash : Tezos_base__TzPervasives.Protocol_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_updater.Registered_protocol.t) :=
match Registered_protocol.get hash with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"chain_validator: missing protocol '" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"' for the current block." % string
CamlinternalFormatBasics.End_of_format)))
"chain_validator: missing protocol '%a' for the current block." % string)
Protocol_hash.pp_short hash
| Some protocol => _return protocol
end.
Definition on_request {A B C : Type}
(w : Worker.t A) (start_testchain : bool)
(active_chains : Tezos_base__TzPervasives.Chain_id.Table.t B)
(spawn_child :
Tezos_base__TzPervasives.Chain_id.t ->
Tezos_shell.Peer_validator.limits ->
Tezos_shell.Prevalidator.limits ->
Tezos_shell.Block_validator.t ->
(Tezos_base__TzPervasives.Lwt_watcher.input
Tezos_shell.State.Block.t) ->
(Tezos_base__TzPervasives.Lwt_watcher.input
(Tezos_base__TzPervasives.Chain_id.t * bool)) ->
Tezos_shell.Distributed_db.t ->
Tezos_shell.State.Chain.chain_state ->
limits ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Types.state * (unit -> Lwt.t unit))))
(req : Request.t C) : Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
let 'Request.Validated block := req in
let nv := Worker.state w in
op_gtgteq (Chain.head (chain_state (parameters nv)))
(fun head =>
let head_header : Tezos_base__TzPervasives.Block_header.t :=
State.Block.header head
with head_hash : Tezos_base__TzPervasives.Block_hash.t :=
State.Block.hash head
with block_header : Tezos_base__TzPervasives.Block_header.t :=
State.Block.header block
with block_hash : Tezos_base__TzPervasives.Block_hash.t :=
State.Block.hash block in
op_gtgteq
match prevalidator nv with
| None => Lwt._return (fitness (shell head_header))
| Some pv => Prevalidator.fitness pv
end
(fun context_fitness =>
let head_fitness := fitness (shell head_header) in
let new_fitness := fitness (shell block_header) in
let accepted_head :=
if op_eq context_fitness head_fitness then
op_gt new_fitness head_fitness
else
op_gteq new_fitness context_fitness in
if negb accepted_head then
_return
Tezos_shell_services.Chain_validator_worker_state.Event.Ignored_head
else
op_gtgteqquestion
(Chain.set_head (chain_state (parameters nv)) block)
(fun previous =>
op_gtgteqquestion
(may_update_checkpoint (chain_state (parameters nv)) block)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (broadcast_head w previous block)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
match prevalidator nv with
| Some old_prevalidator =>
op_gtgteqquestion (State.Block.protocol_hash block)
(fun new_protocol =>
let old_protocol :=
Prevalidator.protocol_hash old_prevalidator in
if
negb
(Protocol_hash.equal old_protocol
new_protocol) then
op_gtgteqquestion
(safe_get_protocol new_protocol)
(fun Proto =>
let Proto := projT2 Proto in
let '(limits, chain_db) :=
Prevalidator.parameters old_prevalidator
in
op_gtgteq
(Prevalidator.create limits Proto
chain_db)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error errs =>
op_gtgteq
(Log.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_error)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.String_literal
"Failed to reinstantiate prevalidator:"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Failed to reinstantiate prevalidator:@ %a@]"
% string) pp_print_error
errs)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field nv
"prevalidator" % string None
in
op_gtgteq
(Prevalidator.shutdown
old_prevalidator)
(fun function_parameter =>
let 'tt :=
function_parameter in
return_unit))
| Stdlib.Ok prevalidator =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field nv
"prevalidator" % string
(Some prevalidator) in
op_gtgteq
(Prevalidator.shutdown
old_prevalidator)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end))
else
Prevalidator.flush old_prevalidator block_hash)
| None => return_unit
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(if start_testchain then
may_switch_test_chain w active_chains
spawn_child block
else
Lwt.return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_watcher.notify (new_head_input nv) block
in
if
Block_hash.equal head_hash
(predecessor (shell block_header)) then
_return
Tezos_shell_services.Chain_validator_worker_state.Event.Head_increment
else
_return
Tezos_shell_services.Chain_validator_worker_state.Event.Branch_switch))))))).
Definition on_completion {A B : Type}
(w : Worker.t A) (req : Request.t B) (update : B)
(request_status : Tezos_shell_services.Worker_types.request_status)
: Lwt.t unit :=
let 'Request.Validated block := req in
let fitness := State.Block.fitness block in
let request := State.Block.hash block in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Worker.record_event w
(Tezos_shell_services.Chain_validator_worker_state.Event.Processed_block
{| request := request; request_status := request_status;
update := update; fitness := fitness |}) in
Lwt.return_unit.
Definition on_close {A : Type} (w : Worker.t A) : Lwt.t unit :=
let nv := Worker.state w in
op_gtgteq (Distributed_db.deactivate (chain_db (parameters nv)))
(fun function_parameter =>
let 'tt := function_parameter in
let pvs :=
P2p_peer.Error_table.fold_promises
(fun function_parameter =>
let '_ := function_parameter in
fun pv =>
fun acc =>
cons
(op_gtgteq pv
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ => Lwt.return_unit
| Stdlib.Ok pv => Peer_validator.shutdown pv
end)) acc) (active_peers nv) [] in
Lwt.join
(cons
match prevalidator nv with
| Some prevalidator => Prevalidator.shutdown prevalidator
| None => Lwt.return_unit
end
(cons
(Lwt_utils.may
(fun function_parameter =>
let '(_, shutdown) := function_parameter in
shutdown tt) (child nv)) pvs))).
Definition on_launch {A : Type}
(start_prevalidator : bool) (w : Worker.t (Worker.queue Worker.infinite))
(function_parameter : A)
: Types.parameters -> Lwt.t (Tezos_base__TzPervasives.tzresult Types.state) :=
let '_ := function_parameter in
fun parameters =>
op_gtgteqquestion
(if start_prevalidator then
op_gtgteq
(State.read_chain_data (chain_state parameters)
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '{| State.current_head := current_head |} :=
function_parameter in
Lwt._return current_head))
(fun head =>
op_gtgteqquestion (State.Block.protocol_hash head)
(fun head_hash =>
op_gtgteq (safe_get_protocol head_hash)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok Proto =>
let Proto := projT2 Proto in
op_gtgteq
(Prevalidator.create (prevalidator_limits parameters)
Proto (chain_db parameters))
(fun function_parameter =>
match function_parameter with
| Stdlib.Error err =>
op_gtgteq
(Log.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_error)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.String_literal
"Failed to instantiate prevalidator:" %
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Failed to instantiate prevalidator:@ %a@]"
% string) pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
return_none)
| Stdlib.Ok prevalidator => return_some prevalidator
end)
| Stdlib.Error err =>
op_gtgteq
(Log.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_error)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.String_literal
"Failed to instantiate prevalidator:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string
1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Failed to instantiate prevalidator:@ %a@]" %
string) pp_print_error err)
(fun function_parameter =>
let 'tt := function_parameter in
return_none)
end)))
else
return_none)
(fun prevalidator =>
let valid_block_input := Lwt_watcher.create_input tt in
let new_head_input := Lwt_watcher.create_input tt in
let '(bootstrapped_waiter, bootstrapped_wakener) := Lwt.wait tt in
let nv :=
{| parameters := parameters;
bootstrapped :=
OCaml.Stdlib.le (bootstrap_threshold (limits parameters)) 0;
bootstrapped_waiter := bootstrapped_waiter;
bootstrapped_wakener := bootstrapped_wakener;
valid_block_input := valid_block_input;
new_head_input := new_head_input; child := None;
prevalidator := prevalidator;
active_peers := P2p_peer.Error_table.create 50;
bootstrapped_peers := P2p_peer.Table.create 50 |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if bootstrapped nv then
Lwt.wakeup_later bootstrapped_wakener tt
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Distributed_db.set_callback (chain_db parameters)
{|
notify_branch :=
fun peer_id =>
fun locator =>
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
apply (with_activated_peer_validator w peer_id)
(fun pv =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Peer_validator.notify_branch pv locator in
return_unit));
notify_head :=
fun peer_id =>
fun block =>
fun ops =>
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(with_activated_peer_validator w peer_id
(fun pv =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Peer_validator.notify_head pv block in
return_unit))
(fun function_parameter =>
let 'tt := function_parameter in
match prevalidator nv with
| Some prevalidator =>
op_gtgteq
(Prevalidator.notify_operations prevalidator
peer_id ops)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| None => return_unit
end));
disconnection :=
fun peer_id =>
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
let nv := Worker.state w in
match
P2p_peer.Error_table.find_opt (active_peers nv) peer_id
with
| None => return_unit
| Some pv =>
op_gtgteqquestion pv
(fun pv =>
op_gtgteq (Peer_validator.shutdown pv)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))
end) |} in
_return nv).
Fixpoint create
(start_prevalidator : bool) (start_testchain : bool)
(active_chains :
Tezos_base__TzPervasives.Chain_id.Table.t
(Worker.t (Worker.queue Worker.infinite)))
(parent : option Tezos_base__TzPervasives.Chain_id.t)
(block_validator_process : Tezos_shell.Block_validator_process.t)
(peer_validator_limits : Tezos_shell.Peer_validator.limits)
(prevalidator_limits : Tezos_shell.Prevalidator.limits)
(block_validator : Tezos_shell.Block_validator.t)
(global_valid_block_input :
Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t)
(global_chains_input :
Tezos_base__TzPervasives.Lwt_watcher.input
(Tezos_base__TzPervasives.Chain_id.t * bool))
(db : Tezos_shell.Distributed_db.t)
(chain_state : Tezos_shell.State.Chain.chain_state) (limits : limits)
: Lwt.t
(Tezos_base__TzPervasives.tzresult (Worker.t (Worker.queue Worker.infinite))) :=
let spawn_child
(parent : Tezos_base__TzPervasives.Chain_id.t) (pvl :
Tezos_shell.Peer_validator.limits) (pl : Tezos_shell.Prevalidator.limits)
(bl : Tezos_shell.Block_validator.t) (gvbi :
Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t) (gci :
Tezos_base__TzPervasives.Lwt_watcher.input
(Tezos_base__TzPervasives.Chain_id.t * bool)) (db :
Tezos_shell.Distributed_db.t) (n : Tezos_shell.State.Chain.chain_state) (l :
limits)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Worker.Types.state * (unit -> Lwt.t unit))) :=
op_gtgteqquestion
(create start_prevalidator start_testchain active_chains (Some parent)
block_validator_process pvl pl bl gvbi gci db n l)
(fun w =>
_return
((Worker.state w),
(fun function_parameter =>
let 'tt := function_parameter in
Worker.shutdown w))) in
let Handlers :=
existT _ unit
{|
Worker.HANDLERS.on_launch := on_launch start_prevalidator;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_request := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_close := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_error := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_completion := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_no_request := unhandled
|} in
let parameters :=
{| parent := parent; db := db; chain_state := chain_state;
chain_db := Distributed_db.activate db chain_state;
block_validator := block_validator;
block_validator_process := block_validator_process;
global_valid_block_input := global_valid_block_input;
global_chains_input := global_chains_input;
prevalidator_limits := prevalidator_limits;
peer_validator_limits := peer_validator_limits; limits := limits |} in
op_gtgteqquestion (Chain.init_head chain_state)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Worker.launch table None (worker_limits prevalidator_limits)
(State.Chain.id chain_state) parameters Handlers)
(fun w =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Chain_id.Table.add active_chains (State.Chain.id chain_state) w in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_watcher.notify global_chains_input
((State.Chain.id chain_state), true) in
_return w)).
Definition create
(start_prevalidator : bool) (start_testchain : bool)
(active_chains :
Tezos_base__TzPervasives.Chain_id.Table.t
(Worker.t (Worker.queue Worker.infinite)))
(block_validator_process : Tezos_shell.Block_validator_process.t)
(peer_validator_limits : Tezos_shell.Peer_validator.limits)
(prevalidator_limits : Tezos_shell.Prevalidator.limits)
(block_validator : Tezos_shell.Block_validator.t)
(global_valid_block_input :
Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t)
(global_chains_input :
Tezos_base__TzPervasives.Lwt_watcher.input
(Tezos_base__TzPervasives.Chain_id.t * bool))
(global_db : Tezos_shell.Distributed_db.t)
(state : Tezos_shell.State.Chain.chain_state) (limits : limits)
: Lwt.t
(Tezos_base__TzPervasives.tzresult (Worker.t (Worker.queue Worker.infinite))) :=
create start_prevalidator start_testchain active_chains None
block_validator_process peer_validator_limits prevalidator_limits
block_validator global_valid_block_input global_chains_input global_db state
limits.
Definition chain_id {A : Type} (w : Worker.t A)
: Tezos_base__TzPervasives.Chain_id.t :=
let '{| parameters := {| chain_state := chain_state |} |} := Worker.state w in
State.Chain.id chain_state.
Definition chain_state {A : Type} (w : Worker.t A)
: Tezos_shell.State.Chain.t :=
let '{| parameters := {| chain_state := chain_state |} |} := Worker.state w in
chain_state.
Definition prevalidator {A : Type} (w : Worker.t A)
: option Tezos_shell.Prevalidator.t :=
let '{| prevalidator := prevalidator |} := Worker.state w in
prevalidator.
Definition chain_db {A : Type} (w : Worker.t A)
: Tezos_shell.Distributed_db.chain_db :=
let '{| parameters := {| chain_db := chain_db |} |} := Worker.state w in
chain_db.
Definition child {A : Type} (w : Worker.t A)
: option (Worker.t (Worker.queue Worker.infinite)) :=
match child (Worker.state w) with
| None => None
| Some ({| parameters := {| chain_state := chain_state |} |}, _) =>
(* ❌ Try-with are not handled *)
try (Some (List.assoc (State.Chain.id chain_state) (Worker.list table)))
end.
Definition assert_fitness_increases {A : Type} (op_staroptstar : option bool)
: (Worker.t A) ->
Tezos_base__TzPervasives.Block_header.t ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let force :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun w =>
fun distant_header =>
let pv := Worker.state w in
let chain_state := Distributed_db.chain_state (chain_db (parameters pv))
in
op_gtgteq (Chain.head chain_state)
(fun local_header =>
fail_when
(andb (negb force)
(OCaml.Stdlib.le
(Fitness.compare (fitness (Block_header.shell distant_header))
(State.Block.fitness local_header)) 0))
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Fitness too low" % string
CamlinternalFormatBasics.End_of_format)
"Fitness too low" % string))).
Definition assert_checkpoint {A : Type}
(w : Worker.t A) (header : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let pv := Worker.state w in
let chain_state := Distributed_db.chain_state (chain_db (parameters pv)) in
op_gtgteq (State.Chain.acceptable_block chain_state header)
(fun acceptable =>
fail_unless acceptable
(Tezos_base__TzPervasives.Checkpoint_error (Block_header.hash header)
None)).
Definition validate_block
(w : Worker.t (Worker.queue Worker.infinite)) (force : option bool)
(hash : Tezos_base__TzPervasives.Block_hash.t)
(block : Tezos_base__TzPervasives.Block_header.t)
(operations : list (list Tezos_base__TzPervasives.Operation.t))
: Lwt.t (Tezos_base__TzPervasives.tzresult (option Tezos_shell.State.Block.t)) :=
let nv := Worker.state w in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (Block_hash.equal hash (Block_header.hash block)) in
op_gtgteqquestion (assert_fitness_increases force w block)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (assert_checkpoint w block)
(fun function_parameter =>
let 'tt := function_parameter in
Block_validator.validate (block_validator (parameters nv))
(Some (Worker.canceler w)) None (Some (notify_new_block w))
(chain_db (parameters nv)) hash block operations)).
Definition bootstrapped {A : Type} (w : Worker.t A) : Lwt.t unit :=
let '{| bootstrapped_waiter := bootstrapped_waiter |} := Worker.state w in
Lwt.protected bootstrapped_waiter.
Definition valid_block_watcher {A : Type} (w : Worker.t A)
: (Lwt_stream.t Tezos_shell.State.Block.t) *
Tezos_base__TzPervasives.Lwt_watcher.stopper :=
let '{| valid_block_input := valid_block_input |} := Worker.state w in
Lwt_watcher.create_stream valid_block_input.
Definition new_head_watcher {A : Type} (w : Worker.t A)
: (Lwt_stream.t Tezos_shell.State.Block.t) *
Tezos_base__TzPervasives.Lwt_watcher.stopper :=
let '{| new_head_input := new_head_input |} := Worker.state w in
Lwt_watcher.create_stream new_head_input.
Definition status {A : Type}
: (Worker.t A) -> Tezos_shell_services.Worker_types.worker_status :=
Worker.status.
Definition information {A : Type}
: (Worker.t A) -> Tezos_shell_services.Worker_types.worker_information :=
Worker.information.
Definition running_workers (function_parameter : unit)
: list (Worker.Name.t * (Worker.t (Worker.queue Worker.infinite))) :=
let 'tt := function_parameter in
Worker.list table.
Definition pending_requests {A : Type} (t : Worker.t (Worker.queue A))
: list (Tezos_base__TzPervasives.Time.System.t * Worker.Request.view) :=
Worker.Queue.pending_requests t.
Definition pending_requests_length {A : Type} (t : Worker.t (Worker.queue A))
: Z := Worker.Queue.pending_requests_length t.
Definition current_request {A : Type} (t : Worker.t A)
: option
(Tezos_base__TzPervasives.Time.System.t *
Tezos_base__TzPervasives.Time.System.t * Worker.Request.view) :=
Worker.current_request t.
Definition last_events {A : Type}
: (Worker.t A) ->
list (Tezos_base__TzPervasives.Internal_event.level * (list Worker.Event.t)) :=
Worker.last_events.
Definition ddb_information {A : Type} (t : Worker.t A)
: Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view :=
let state := Worker.state t in
let ddb := chain_db (parameters state) in
Distributed_db.information ddb.
src/lib_shell/distributed_db.ml 208 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Message = Distributed_db_message
module Logging = Internal_event.Legacy_logging.Make (struct
let name = "node.distributed_db"
end)
type p2p = (Message.t, Peer_metadata.t, Connection_metadata.t) P2p.net
type connection =
(Message.t, Peer_metadata.t, Connection_metadata.t) P2p.connection
type 'a request_param = {
p2p : (Message.t, Peer_metadata.t, Connection_metadata.t) P2p.t;
data : 'a;
active : unit -> P2p_peer.Set.t;
send : P2p_peer.Id.t -> Message.t -> unit;
}
module Make_raw (Hash : sig
type t
val name : string
val encoding : t Data_encoding.t
val pp : Format.formatter -> t -> unit
module Logging : sig
val tag : t Tag.def
end
end)
(Disk_table : Distributed_db_functors.DISK_TABLE with type key := Hash.t)
(Memory_table : Distributed_db_functors.MEMORY_TABLE with type key := Hash.t)
(Request_message : sig
type param
val max_length : int
val initial_delay : Time.System.Span.t
val forge : param -> Hash.t list -> Message.t
end)
(Precheck : Distributed_db_functors.PRECHECK
with type key := Hash.t
and type value := Disk_table.value) =
struct
module Request = struct
type param = Request_message.param request_param
let active {active; _} = active ()
let initial_delay = Request_message.initial_delay
let rec send state gid keys =
let (first_keys, keys) = List.split_n Request_message.max_length keys in
let msg = Request_message.forge state.data first_keys in
state.send gid msg ;
let open Peer_metadata in
let (req : requests_kind) =
match msg with
| Get_current_branch _ ->
Branch
| Get_current_head _ ->
Head
| Get_block_headers _ ->
Block_header
| Get_operations _ ->
Operations
| Get_protocols _ ->
Protocols
| Get_operation_hashes_for_blocks _ ->
Operation_hashes_for_block
| Get_operations_for_blocks _ ->
Operations_for_block
| _ ->
Other
in
let meta = P2p.get_peer_metadata state.p2p gid in
Peer_metadata.incr meta @@ Scheduled_request req ;
if keys <> [] then send state gid keys
end
module Scheduler =
Distributed_db_functors.Make_request_scheduler (Hash) (Memory_table)
(Request)
module Table =
Distributed_db_functors.Make_table (Hash) (Disk_table) (Memory_table)
(Scheduler)
(Precheck)
type t = {scheduler : Scheduler.t; table : Table.t}
let state_of_t {scheduler; table} =
let table_length = Table.memory_table_length table in
let scheduler_length = Scheduler.memory_table_length scheduler in
{
Chain_validator_worker_state.Distributed_db_state.table_length;
scheduler_length;
}
let create ?global_input request_param param =
let scheduler = Scheduler.create request_param in
let table = Table.create ?global_input scheduler param in
{scheduler; table}
let shutdown {scheduler; _} =
Logging.lwt_log_notice
"Shutting down the distributed data-base scheduler..."
>>= fun () -> Scheduler.shutdown scheduler
end
module Fake_operation_storage = struct
type store = State.Chain.t
type value = Operation.t
let known _ _ = Lwt.return_false
let read _ _ = Lwt.return (Error_monad.error_exn Not_found)
let read_opt _ _ = Lwt.return_none
end
module Raw_operation =
Make_raw (Operation_hash) (Fake_operation_storage) (Operation_hash.Table)
(struct
type param = unit
let max_length = 10
let initial_delay = Time.System.Span.of_seconds_exn 0.5
let forge () keys = Message.Get_operations keys
end)
(struct
type param = unit
type notified_value = Operation.t
let precheck _ _ v = Some v
end)
module Block_header_storage = struct
type store = State.Chain.t
type value = Block_header.t
let known = State.Block.known_valid
let read chain_state h =
State.Block.read chain_state h >>=? fun b -> return (State.Block.header b)
let read_opt chain_state h =
State.Block.read_opt chain_state h
>>= fun b -> Lwt.return (Option.map ~f:State.Block.header b)
end
module Raw_block_header =
Make_raw (Block_hash) (Block_header_storage) (Block_hash.Table)
(struct
type param = unit
let max_length = 10
let initial_delay = Time.System.Span.of_seconds_exn 0.5
let forge () keys = Message.Get_block_headers keys
end)
(struct
type param = unit
type notified_value = Block_header.t
let precheck _ _ v = Some v
end)
module Operation_hashes_storage = struct
type store = State.Chain.t
type value = Operation_hash.t list
let known chain_state (h, _) = State.Block.known_valid chain_state h
let read chain_state (h, i) =
State.Block.read chain_state h
>>=? fun b ->
State.Block.operation_hashes b i >>= fun (ops, _) -> return ops
let read_opt chain_state (h, i) =
State.Block.read_opt chain_state h
>>= function
| None ->
Lwt.return_none
| Some b ->
State.Block.operation_hashes b i
>>= fun (ops, _) -> Lwt.return_some ops
end
module Operations_table = Hashtbl.Make (struct
type t = Block_hash.t * int
let hash = Hashtbl.hash
let equal (b1, i1) (b2, i2) = Block_hash.equal b1 b2 && i1 = i2
end)
module Raw_operation_hashes = struct
include Make_raw
(struct
type t = Block_hash.t * int
let name = "operation_hashes"
let pp ppf (h, n) = Format.fprintf ppf "%a:%d" Block_hash.pp h n
let encoding =
let open Data_encoding in
obj2 (req "block" Block_hash.encoding) (req "index" uint16)
module Logging = struct
let tag = Tag.def ~doc:"Operation hashes" "operation_hashes" pp
end
end)
(Operation_hashes_storage)
(Operations_table)
(struct
type param = unit
let max_length = 10
let initial_delay = Time.System.Span.of_seconds_exn 1.
let forge () keys = Message.Get_operation_hashes_for_blocks keys
end)
(struct
type param = Operation_list_list_hash.t
type notified_value =
Operation_hash.t list * Operation_list_list_hash.path
let precheck (_block, expected_ofs) expected_hash (ops, path) =
let (received_hash, received_ofs) =
Operation_list_list_hash.check_path
path
(Operation_list_hash.compute ops)
in
if
received_ofs = expected_ofs
&& Operation_list_list_hash.compare
expected_hash
received_hash
= 0
then Some ops
else None
end)
let clear_all table hash n =
List.iter (fun i -> Table.clear_or_cancel table (hash, i)) (0 -- (n - 1))
end
module Operations_storage = struct
type store = State.Chain.t
type value = Operation.t list
let known chain_state (h, _) = State.Block.known_valid chain_state h
let read chain_state (h, i) =
State.Block.read chain_state h
>>=? fun b -> State.Block.operations b i >>= fun (ops, _) -> return ops
let read_opt chain_state (h, i) =
State.Block.read_opt chain_state h
>>= function
| None ->
Lwt.return_none
| Some b ->
State.Block.operations b i >>= fun (ops, _) -> Lwt.return_some ops
end
module Raw_operations = struct
include Make_raw
(struct
type t = Block_hash.t * int
let name = "operations"
let pp ppf (h, n) = Format.fprintf ppf "%a:%d" Block_hash.pp h n
let encoding =
let open Data_encoding in
obj2 (req "block" Block_hash.encoding) (req "index" uint16)
module Logging = struct
let tag = Tag.def ~doc:"Operations" "operations" pp
end
end)
(Operations_storage)
(Operations_table)
(struct
type param = unit
let max_length = 10
let initial_delay = Time.System.Span.of_seconds_exn 1.
let forge () keys = Message.Get_operations_for_blocks keys
end)
(struct
type param = Operation_list_list_hash.t
type notified_value =
Operation.t list * Operation_list_list_hash.path
let precheck (_block, expected_ofs) expected_hash (ops, path) =
let (received_hash, received_ofs) =
Operation_list_list_hash.check_path
path
(Operation_list_hash.compute (List.map Operation.hash ops))
in
if
received_ofs = expected_ofs
&& Operation_list_list_hash.compare
expected_hash
received_hash
= 0
then Some ops
else None
end)
let clear_all table hash n =
List.iter (fun i -> Table.clear_or_cancel table (hash, i)) (0 -- (n - 1))
end
module Protocol_storage = struct
type store = State.t
type value = Protocol.t
let known = State.Protocol.known
let read = State.Protocol.read
let read_opt = State.Protocol.read_opt
end
module Raw_protocol =
Make_raw (Protocol_hash) (Protocol_storage) (Protocol_hash.Table)
(struct
type param = unit
let initial_delay = Time.System.Span.of_seconds_exn 10.
let max_length = 10
let forge () keys = Message.Get_protocols keys
end)
(struct
type param = unit
type notified_value = Protocol.t
let precheck _ _ v = Some v
end)
type callback = {
notify_branch : P2p_peer.Id.t -> Block_locator.t -> unit;
notify_head : P2p_peer.Id.t -> Block_header.t -> Mempool.t -> unit;
disconnection : P2p_peer.Id.t -> unit;
}
type db = {
p2p : p2p;
p2p_readers : p2p_reader P2p_peer.Table.t;
disk : State.t;
active_chains : chain_db Chain_id.Table.t;
protocol_db : Raw_protocol.t;
block_input : (Block_hash.t * Block_header.t) Lwt_watcher.input;
operation_input : (Operation_hash.t * Operation.t) Lwt_watcher.input;
}
and chain_db = {
chain_state : State.Chain.t;
global_db : db;
operation_db : Raw_operation.t;
block_header_db : Raw_block_header.t;
operation_hashes_db : Raw_operation_hashes.t;
operations_db : Raw_operations.t;
mutable callback : callback;
active_peers : P2p_peer.Set.t ref;
active_connections : p2p_reader P2p_peer.Table.t;
}
and p2p_reader = {
gid : P2p_peer.Id.t;
conn : connection;
peer_active_chains : chain_db Chain_id.Table.t;
canceler : Lwt_canceler.t;
mutable worker : unit Lwt.t;
}
let noop_callback =
{
notify_branch = (fun _gid _locator -> ());
notify_head = (fun _gid _block _ops -> ());
disconnection = (fun _gid -> ());
}
type t = db
let state {disk; _} = disk
let chain_state {chain_state; _} = chain_state
let db {global_db; _} = global_db
let information
({ global_db = {p2p_readers; active_chains; _};
operation_db;
operations_db;
block_header_db;
operation_hashes_db;
active_connections;
active_peers;
_ } :
chain_db) =
{
Chain_validator_worker_state.Distributed_db_state.p2p_readers_length =
P2p_peer.Table.length p2p_readers;
active_chains_length = Chain_id.Table.length active_chains;
operation_db = Raw_operation.state_of_t operation_db;
operations_db = Raw_operations.state_of_t operations_db;
block_header_db = Raw_block_header.state_of_t block_header_db;
operations_hashed_db = Raw_operation_hashes.state_of_t operation_hashes_db;
active_connections_length = P2p_peer.Table.length active_connections;
active_peers_length = P2p_peer.Set.cardinal !active_peers;
}
let my_peer_id chain_db = P2p.peer_id chain_db.global_db.p2p
let get_peer_metadata chain_db = P2p.get_peer_metadata chain_db.global_db.p2p
let read_block_header {disk; _} h =
State.read_block disk h
>>= function
| Some b ->
Lwt.return_some (State.Block.chain_id b, State.Block.header b)
| None ->
Lwt.return_none
let find_pending_block_header {peer_active_chains; _} h =
Chain_id.Table.fold
(fun _chain_id chain_db acc ->
match acc with
| Some _ ->
acc
| None
when Raw_block_header.Table.pending chain_db.block_header_db.table h ->
Some chain_db
| None ->
None)
peer_active_chains
None
let find_pending_operations {peer_active_chains; _} h i =
Chain_id.Table.fold
(fun _chain_id chain_db acc ->
match acc with
| Some _ ->
acc
| None
when Raw_operations.Table.pending chain_db.operations_db.table (h, i)
->
Some chain_db
| None ->
None)
peer_active_chains
None
let find_pending_operation_hashes {peer_active_chains; _} h i =
Chain_id.Table.fold
(fun _chain_id chain_db acc ->
match acc with
| Some _ ->
acc
| None
when Raw_operation_hashes.Table.pending
chain_db.operation_hashes_db.table
(h, i) ->
Some chain_db
| None ->
None)
peer_active_chains
None
let find_pending_operation {peer_active_chains; _} h =
Chain_id.Table.fold
(fun _chain_id chain_db acc ->
match acc with
| Some _ ->
acc
| None when Raw_operation.Table.pending chain_db.operation_db.table h ->
Some chain_db
| None ->
None)
peer_active_chains
None
let read_operation {active_chains; _} h =
Chain_id.Table.fold
(fun chain_id chain_db acc ->
acc
>>= function
| Some _ ->
acc
| None -> (
Raw_operation.Table.read_opt chain_db.operation_db.table h
>>= function
| None -> Lwt.return_none | Some bh -> Lwt.return_some (chain_id, bh)
))
active_chains
Lwt.return_none
module P2p_reader = struct
let may_activate global_db state chain_id f =
match Chain_id.Table.find_opt state.peer_active_chains chain_id with
| Some chain_db ->
f chain_db
| None -> (
match Chain_id.Table.find_opt global_db.active_chains chain_id with
| Some chain_db ->
chain_db.active_peers :=
P2p_peer.Set.add state.gid !(chain_db.active_peers) ;
P2p_peer.Table.add chain_db.active_connections state.gid state ;
Chain_id.Table.add state.peer_active_chains chain_id chain_db ;
f chain_db
| None ->
let meta = P2p.get_peer_metadata global_db.p2p state.gid in
Peer_metadata.incr meta Unactivated_chain ;
Lwt.return_unit )
let deactivate state chain_db =
chain_db.callback.disconnection state.gid ;
chain_db.active_peers :=
P2p_peer.Set.remove state.gid !(chain_db.active_peers) ;
P2p_peer.Table.remove chain_db.active_connections state.gid
(* check if the chain advertized by a peer is (still) active *)
let may_handle global_db state chain_id f =
match Chain_id.Table.find_opt state.peer_active_chains chain_id with
| None ->
let meta = P2p.get_peer_metadata global_db.p2p state.gid in
Peer_metadata.incr meta Inactive_chain ;
Lwt.return_unit
| Some chain_db ->
f chain_db
let may_handle_global global_db chain_id f =
match Chain_id.Table.find_opt global_db.active_chains chain_id with
| None ->
Lwt.return_unit
| Some chain_db ->
f chain_db
module Handle_msg_Logging =
Internal_event.Legacy_logging.Make_semantic (struct
let name = "node.distributed_db.p2p_reader"
end)
let soon () =
let now = Systime_os.now () in
match Ptime.add_span now (Ptime.Span.of_int_s 15) with
| Some s ->
s
| None ->
invalid_arg "Distributed_db.handle_msg: end of time"
let handle_msg global_db state msg =
let open Message in
let open Handle_msg_Logging in
let meta = P2p.get_peer_metadata global_db.p2p state.gid in
lwt_debug
Tag.DSL.(
fun f ->
f "Read message from %a: %a"
-% t event "read_message"
-% a P2p_peer.Id.Logging.tag state.gid
-% a Message.Logging.tag msg)
>>= fun () ->
match msg with
| Get_current_branch chain_id ->
Peer_metadata.incr meta @@ Received_request Branch ;
may_handle_global global_db chain_id
@@ fun chain_db ->
if not (Chain_id.Table.mem state.peer_active_chains chain_id) then
Peer_metadata.update_requests meta Branch
@@ P2p.try_send global_db.p2p state.conn
@@ Get_current_branch chain_id ;
let seed =
{
Block_locator.receiver_id = state.gid;
sender_id = my_peer_id chain_db;
}
in
Chain.locator chain_db.chain_state seed
>>= fun locator ->
Peer_metadata.update_responses meta Branch
@@ P2p.try_send global_db.p2p state.conn
@@ Current_branch (chain_id, locator) ;
Lwt.return_unit
| Current_branch (chain_id, locator) ->
may_activate global_db state chain_id
@@ fun chain_db ->
let (head, hist) = (locator :> Block_header.t * Block_hash.t list) in
Lwt_list.exists_p
(State.Block.known_invalid chain_db.chain_state)
(Block_header.hash head :: hist)
>>= fun known_invalid ->
if known_invalid then (
P2p.disconnect global_db.p2p state.conn
>>= fun () ->
P2p.greylist_peer global_db.p2p state.gid ;
Lwt.return_unit )
else if Time.System.(soon () < of_protocol_exn head.shell.timestamp)
then (
Peer_metadata.incr meta Future_block ;
lwt_log_notice
Tag.DSL.(
fun f ->
f "Received future block %a from peer %a."
-% t event "received_future_block"
-% a Block_hash.Logging.tag (Block_header.hash head)
-% a P2p_peer.Id.Logging.tag state.gid) )
else (
chain_db.callback.notify_branch state.gid locator ;
(* TODO discriminate between received advertisements
and responses? *)
Peer_metadata.incr meta @@ Received_advertisement Branch ;
Lwt.return_unit )
| Deactivate chain_id ->
may_handle global_db state chain_id
@@ fun chain_db ->
deactivate state chain_db ;
Chain_id.Table.remove state.peer_active_chains chain_id ;
Lwt.return_unit
| Get_current_head chain_id ->
may_handle global_db state chain_id
@@ fun chain_db ->
Peer_metadata.incr meta @@ Received_request Head ;
let {Connection_metadata.disable_mempool; _} =
P2p.connection_remote_metadata chain_db.global_db.p2p state.conn
in
( if disable_mempool then
Chain.head chain_db.chain_state
>>= fun head -> Lwt.return (State.Block.header head, Mempool.empty)
else State.Current_mempool.get chain_db.chain_state )
>>= fun (head, mempool) ->
(* TODO bound the sent mempool size *)
Peer_metadata.update_responses meta Head
@@ P2p.try_send global_db.p2p state.conn
@@ Current_head (chain_id, head, mempool) ;
Lwt.return_unit
| Current_head (chain_id, header, mempool) ->
may_handle global_db state chain_id
@@ fun chain_db ->
let head = Block_header.hash header in
State.Block.known_invalid chain_db.chain_state head
>>= fun known_invalid ->
let {Connection_metadata.disable_mempool; _} =
P2p.connection_local_metadata chain_db.global_db.p2p state.conn
in
let known_invalid =
known_invalid || (disable_mempool && mempool <> Mempool.empty)
(* A non-empty mempool was received while mempool is desactivated,
so the message is ignored.
This should probably warrant a reduction of the sender's score. *)
in
if known_invalid then (
P2p.disconnect global_db.p2p state.conn
>>= fun () ->
P2p.greylist_peer global_db.p2p state.gid ;
Lwt.return_unit )
else if Time.System.(soon () < of_protocol_exn header.shell.timestamp)
then (
Peer_metadata.incr meta Future_block ;
lwt_log_notice
Tag.DSL.(
fun f ->
f "Received future block %a from peer %a."
-% t event "received_future_block"
-% a Block_hash.Logging.tag head
-% a P2p_peer.Id.Logging.tag state.gid) )
else (
chain_db.callback.notify_head state.gid header mempool ;
(* TODO discriminate between received advertisements
and responses? *)
Peer_metadata.incr meta @@ Received_advertisement Head ;
Lwt.return_unit )
| Get_block_headers hashes ->
Peer_metadata.incr meta @@ Received_request Block_header ;
Lwt_list.iter_p
(fun hash ->
read_block_header global_db hash
>>= function
| None ->
Peer_metadata.incr meta @@ Unadvertised Block ;
Lwt.return_unit
| Some (_chain_id, header) ->
Peer_metadata.update_responses meta Block_header
@@ P2p.try_send global_db.p2p state.conn
@@ Block_header header ;
Lwt.return_unit)
hashes
| Block_header block -> (
let hash = Block_header.hash block in
match find_pending_block_header state hash with
| None ->
Peer_metadata.incr meta Unexpected_response ;
Lwt.return_unit
| Some chain_db ->
Raw_block_header.Table.notify
chain_db.block_header_db.table
state.gid
hash
block
>>= fun () ->
Peer_metadata.incr meta @@ Received_response Block_header ;
Lwt.return_unit )
| Get_operations hashes ->
Peer_metadata.incr meta @@ Received_request Operations ;
Lwt_list.iter_p
(fun hash ->
read_operation global_db hash
>>= function
| None ->
Peer_metadata.incr meta @@ Unadvertised Operations ;
Lwt.return_unit
| Some (_chain_id, op) ->
Peer_metadata.update_responses meta Operations
@@ P2p.try_send global_db.p2p state.conn
@@ Operation op ;
Lwt.return_unit)
hashes
| Operation operation -> (
let hash = Operation.hash operation in
match find_pending_operation state hash with
| None ->
Peer_metadata.incr meta Unexpected_response ;
Lwt.return_unit
| Some chain_db ->
Raw_operation.Table.notify
chain_db.operation_db.table
state.gid
hash
operation
>>= fun () ->
Peer_metadata.incr meta @@ Received_response Operations ;
Lwt.return_unit )
| Get_protocols hashes ->
Peer_metadata.incr meta @@ Received_request Protocols ;
Lwt_list.iter_p
(fun hash ->
State.Protocol.read_opt global_db.disk hash
>>= function
| None ->
Peer_metadata.incr meta @@ Unadvertised Protocol ;
Lwt.return_unit
| Some p ->
Peer_metadata.update_responses meta Protocols
@@ P2p.try_send global_db.p2p state.conn
@@ Protocol p ;
Lwt.return_unit)
hashes
| Protocol protocol ->
let hash = Protocol.hash protocol in
Raw_protocol.Table.notify
global_db.protocol_db.table
state.gid
hash
protocol
>>= fun () ->
Peer_metadata.incr meta @@ Received_response Protocols ;
Lwt.return_unit
| Get_operation_hashes_for_blocks blocks ->
Peer_metadata.incr meta @@ Received_request Operation_hashes_for_block ;
Lwt_list.iter_p
(fun (hash, ofs) ->
State.read_block global_db.disk hash
>>= function
| None ->
Lwt.return_unit
| Some block ->
State.Block.operation_hashes block ofs
>>= fun (hashes, path) ->
Peer_metadata.update_responses meta Operation_hashes_for_block
@@ P2p.try_send global_db.p2p state.conn
@@ Operation_hashes_for_block (hash, ofs, hashes, path) ;
Lwt.return_unit)
blocks
| Operation_hashes_for_block (block, ofs, ops, path) -> (
match find_pending_operation_hashes state block ofs with
| None ->
Peer_metadata.incr meta Unexpected_response ;
Lwt.return_unit
| Some chain_db ->
Raw_operation_hashes.Table.notify
chain_db.operation_hashes_db.table
state.gid
(block, ofs)
(ops, path)
>>= fun () ->
Peer_metadata.incr meta
@@ Received_response Operation_hashes_for_block ;
Lwt.return_unit )
| Get_operations_for_blocks blocks ->
Peer_metadata.incr meta @@ Received_request Operations_for_block ;
Lwt_list.iter_p
(fun (hash, ofs) ->
State.read_block global_db.disk hash
>>= function
| None ->
Lwt.return_unit
| Some block ->
State.Block.operations block ofs
>>= fun (ops, path) ->
Peer_metadata.update_responses meta Operations_for_block
@@ P2p.try_send global_db.p2p state.conn
@@ Operations_for_block (hash, ofs, ops, path) ;
Lwt.return_unit)
blocks
| Operations_for_block (block, ofs, ops, path) -> (
match find_pending_operations state block ofs with
| None ->
Peer_metadata.incr meta Unexpected_response ;
Lwt.return_unit
| Some chain_db ->
Raw_operations.Table.notify
chain_db.operations_db.table
state.gid
(block, ofs)
(ops, path)
>>= fun () ->
Peer_metadata.incr meta @@ Received_response Operations_for_block ;
Lwt.return_unit )
let rec worker_loop global_db state =
protect ~canceler:state.canceler (fun () ->
P2p.recv global_db.p2p state.conn)
>>= function
| Ok msg ->
handle_msg global_db state msg
>>= fun () -> worker_loop global_db state
| Error _ ->
Chain_id.Table.iter
(fun _ -> deactivate state)
state.peer_active_chains ;
P2p_peer.Table.remove global_db.p2p_readers state.gid ;
Lwt.return_unit
let run db gid conn =
let canceler = Lwt_canceler.create () in
let state =
{
conn;
gid;
canceler;
peer_active_chains = Chain_id.Table.create 17;
worker = Lwt.return_unit;
}
in
Chain_id.Table.iter
(fun chain_id _chain_db ->
Lwt.async (fun () ->
let meta = P2p.get_peer_metadata db.p2p gid in
Peer_metadata.incr meta (Sent_request Branch) ;
P2p.send db.p2p conn (Get_current_branch chain_id)))
db.active_chains ;
state.worker <-
Lwt_utils.worker
(Format.asprintf "db_network_reader.%a" P2p_peer.Id.pp_short gid)
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> worker_loop db state)
~cancel:(fun () -> Lwt_canceler.cancel canceler) ;
P2p_peer.Table.add db.p2p_readers gid state
let shutdown s = Lwt_canceler.cancel s.canceler >>= fun () -> s.worker
end
let active_peer_ids p2p () =
List.fold_left
(fun acc conn ->
let {P2p_connection.Info.peer_id; _} = P2p.connection_info p2p conn in
P2p_peer.Set.add peer_id acc)
P2p_peer.Set.empty
(P2p.connections p2p)
let raw_try_send p2p peer_id msg =
match P2p.find_connection p2p peer_id with
| None ->
()
| Some conn ->
ignore (P2p.try_send p2p conn msg : bool)
let create disk p2p =
let global_request =
{p2p; data = (); active = active_peer_ids p2p; send = raw_try_send p2p}
in
let protocol_db = Raw_protocol.create global_request disk in
let active_chains = Chain_id.Table.create 17 in
let p2p_readers = P2p_peer.Table.create 17 in
let block_input = Lwt_watcher.create_input () in
let operation_input = Lwt_watcher.create_input () in
let db =
{
p2p;
p2p_readers;
disk;
active_chains;
protocol_db;
block_input;
operation_input;
}
in
db
let activate ({p2p; active_chains; _} as global_db) chain_state =
P2p.on_new_connection p2p (P2p_reader.run global_db) ;
P2p.iter_connections p2p (P2p_reader.run global_db) ;
P2p.activate p2p ;
let chain_id = State.Chain.id chain_state in
match Chain_id.Table.find_opt active_chains chain_id with
| None ->
let active_peers = ref P2p_peer.Set.empty in
let p2p_request =
{
p2p;
data = ();
active = (fun () -> !active_peers);
send = raw_try_send p2p;
}
in
let operation_db =
Raw_operation.create
~global_input:global_db.operation_input
p2p_request
chain_state
in
let block_header_db =
Raw_block_header.create
~global_input:global_db.block_input
p2p_request
chain_state
in
let operation_hashes_db =
Raw_operation_hashes.create p2p_request chain_state
in
let operations_db = Raw_operations.create p2p_request chain_state in
let chain =
{
global_db;
operation_db;
block_header_db;
operation_hashes_db;
operations_db;
chain_state;
callback = noop_callback;
active_peers;
active_connections = P2p_peer.Table.create 53;
}
in
P2p.iter_connections p2p (fun _peer_id conn ->
Lwt.async (fun () -> P2p.send p2p conn (Get_current_branch chain_id))) ;
Chain_id.Table.add active_chains chain_id chain ;
chain
| Some chain ->
chain
let set_callback chain_db callback = chain_db.callback <- callback
let deactivate chain_db =
let {active_chains; p2p; _} = chain_db.global_db in
let chain_id = State.Chain.id chain_db.chain_state in
Chain_id.Table.remove active_chains chain_id ;
P2p_peer.Table.iter
(fun _peer_id reader ->
P2p_reader.deactivate reader chain_db ;
Lwt.async (fun () -> P2p.send p2p reader.conn (Deactivate chain_id)))
chain_db.active_connections ;
Raw_operation.shutdown chain_db.operation_db
>>= fun () -> Raw_block_header.shutdown chain_db.block_header_db
let get_chain {active_chains; _} chain_id =
Chain_id.Table.find_opt active_chains chain_id
let greylist {global_db = {p2p; _}; _} peer_id =
Lwt.return (P2p.greylist_peer p2p peer_id)
let disconnect {global_db = {p2p; _}; _} peer_id =
match P2p.find_connection p2p peer_id with
| None ->
Lwt.return_unit
| Some conn ->
P2p.disconnect p2p conn
let shutdown {p2p_readers; active_chains; _} =
P2p_peer.Table.fold
(fun _peer_id reader acc -> P2p_reader.shutdown reader >>= fun () -> acc)
p2p_readers
Lwt.return_unit
>>= fun () ->
Chain_id.Table.fold
(fun _ chain_db acc ->
Raw_operation.shutdown chain_db.operation_db
>>= fun () ->
Raw_block_header.shutdown chain_db.block_header_db >>= fun () -> acc)
active_chains
Lwt.return_unit
let clear_block chain_db hash n =
Raw_operations.clear_all chain_db.operations_db.table hash n ;
Raw_operation_hashes.clear_all chain_db.operation_hashes_db.table hash n ;
Raw_block_header.Table.clear_or_cancel chain_db.block_header_db.table hash
let commit_block chain_db hash header header_data operations operations_data
result ~forking_testchain =
assert (Block_hash.equal hash (Block_header.hash header)) ;
assert (List.length operations = header.shell.validation_passes) ;
State.Block.store
chain_db.chain_state
header
header_data
operations
operations_data
result
~forking_testchain
>>=? fun res ->
clear_block chain_db hash header.shell.validation_passes ;
return res
let commit_invalid_block chain_db hash header errors =
assert (Block_hash.equal hash (Block_header.hash header)) ;
State.Block.store_invalid chain_db.chain_state header errors
>>=? fun res ->
clear_block chain_db hash header.shell.validation_passes ;
return res
let inject_operation chain_db h op =
assert (Operation_hash.equal h (Operation.hash op)) ;
Raw_operation.Table.inject chain_db.operation_db.table h op
let commit_protocol db h p =
State.Protocol.store db.disk p
>>= fun res ->
Raw_protocol.Table.clear_or_cancel db.protocol_db.table h ;
return (res <> None)
let watch_block_header {block_input; _} = Lwt_watcher.create_stream block_input
let watch_operation {operation_input; _} =
Lwt_watcher.create_stream operation_input
module Raw = struct
let encoding = P2p_message.encoding Message.cfg.encoding
let chain_name = Message.cfg.chain_name
let distributed_db_versions = Message.cfg.distributed_db_versions
end
module Make
(Table : Distributed_db_functors.DISTRIBUTED_DB) (Kind : sig
type t
val proj : t -> Table.t
end) =
struct
type key = Table.key
type value = Table.value
let known t k = Table.known (Kind.proj t) k
type error += Missing_data = Table.Missing_data
type error += Canceled = Table.Canceled
type error += Timeout = Table.Timeout
let read t k = Table.read (Kind.proj t) k
let read_opt t k = Table.read_opt (Kind.proj t) k
let prefetch t ?peer ?timeout k p =
Table.prefetch (Kind.proj t) ?peer ?timeout k p
let fetch t ?peer ?timeout k p = Table.fetch (Kind.proj t) ?peer ?timeout k p
let clear_or_cancel t k = Table.clear_or_cancel (Kind.proj t) k
let inject t k v = Table.inject (Kind.proj t) k v
let pending t k = Table.pending (Kind.proj t) k
let watch t = Table.watch (Kind.proj t)
let resolve_pending t k v = Table.resolve_pending (Kind.proj t) k v
end
module Block_header = struct
type t = Block_header.t
include (
Make
(Raw_block_header.Table)
(struct
type t = chain_db
let proj chain = chain.block_header_db.table
end) :
Distributed_db_functors.DISTRIBUTED_DB
with type t := chain_db
and type key := Block_hash.t
and type value := Block_header.t
and type param := unit )
end
module Operation_hashes =
Make
(Raw_operation_hashes.Table)
(struct
type t = chain_db
let proj chain = chain.operation_hashes_db.table
end)
module Operations =
Make
(Raw_operations.Table)
(struct
type t = chain_db
let proj chain = chain.operations_db.table
end)
module Operation = struct
include Operation
include (
Make
(Raw_operation.Table)
(struct
type t = chain_db
let proj chain = chain.operation_db.table
end) :
Distributed_db_functors.DISTRIBUTED_DB
with type t := chain_db
and type key := Operation_hash.t
and type value := Operation.t
and type param := unit )
end
module Protocol = struct
type t = Protocol.t
include (
Make
(Raw_protocol.Table)
(struct
type t = db
let proj db = db.protocol_db.table
end) :
Distributed_db_functors.DISTRIBUTED_DB
with type t := db
and type key := Protocol_hash.t
and type value := Protocol.t
and type param := unit )
end
let broadcast chain_db msg =
P2p_peer.Table.iter
(fun _peer_id state ->
ignore (P2p.try_send chain_db.global_db.p2p state.conn msg))
chain_db.active_connections
let try_send chain_db peer_id msg =
match P2p_peer.Table.find_opt chain_db.active_connections peer_id with
| None ->
()
| Some conn ->
ignore (P2p.try_send chain_db.global_db.p2p conn.conn msg : bool)
let send chain_db ?peer msg =
match peer with
| Some peer ->
try_send chain_db peer msg
| None ->
broadcast chain_db msg
module Request = struct
let current_head chain_db ?peer () =
let chain_id = State.Chain.id chain_db.chain_state in
( match peer with
| Some peer ->
let meta = P2p.get_peer_metadata chain_db.global_db.p2p peer in
Peer_metadata.incr meta (Sent_request Head)
| None ->
() ) ;
send chain_db ?peer @@ Get_current_head chain_id
let current_branch chain_db ?peer () =
let chain_id = State.Chain.id chain_db.chain_state in
( match peer with
| Some peer ->
let meta = P2p.get_peer_metadata chain_db.global_db.p2p peer in
Peer_metadata.incr meta (Sent_request Head)
| None ->
() ) ;
send chain_db ?peer @@ Get_current_branch chain_id
end
module Advertise = struct
let current_head chain_db ?peer ?(mempool = Mempool.empty) head =
let chain_id = State.Chain.id chain_db.chain_state in
assert (Chain_id.equal chain_id (State.Block.chain_id head)) ;
( match peer with
| Some peer ->
let meta = P2p.get_peer_metadata chain_db.global_db.p2p peer in
Peer_metadata.incr meta (Sent_advertisement Head)
| None ->
() ) ;
let msg_mempool =
Message.Current_head (chain_id, State.Block.header head, mempool)
in
if mempool = Mempool.empty then send chain_db ?peer msg_mempool
else
let msg_disable_mempool =
Message.Current_head (chain_id, State.Block.header head, Mempool.empty)
in
let send_mempool state =
let {Connection_metadata.disable_mempool; _} =
P2p.connection_remote_metadata chain_db.global_db.p2p state.conn
in
let msg =
if disable_mempool then msg_disable_mempool else msg_mempool
in
ignore @@ P2p.try_send chain_db.global_db.p2p state.conn msg
in
match peer with
| Some receiver_id ->
let state =
P2p_peer.Table.find chain_db.active_connections receiver_id
in
send_mempool state
| None ->
List.iter
(fun (_receiver_id, state) -> send_mempool state)
(P2p_peer.Table.fold
(fun k v acc -> (k, v) :: acc)
chain_db.active_connections
[])
let current_branch ?peer chain_db =
let chain_id = State.Chain.id chain_db.chain_state in
let chain_state = chain_state chain_db in
let sender_id = my_peer_id chain_db in
( match peer with
| Some peer ->
let meta = P2p.get_peer_metadata chain_db.global_db.p2p peer in
Peer_metadata.incr meta (Sent_advertisement Branch)
| None ->
() ) ;
match peer with
| Some receiver_id ->
let seed = {Block_locator.receiver_id; sender_id} in
Chain.locator chain_state seed
>>= fun locator ->
let msg = Message.Current_branch (chain_id, locator) in
try_send chain_db receiver_id msg ;
Lwt.return_unit
| None ->
Lwt_list.iter_p
(fun (receiver_id, state) ->
let seed = {Block_locator.receiver_id; sender_id} in
Chain.locator chain_state seed
>>= fun locator ->
let msg = Message.Current_branch (chain_id, locator) in
ignore (P2p.try_send chain_db.global_db.p2p state.conn msg) ;
Lwt.return_unit)
(P2p_peer.Table.fold
(fun k v acc -> (k, v) :: acc)
chain_db.active_connections
[])
end
src/lib_shell/distributed_db.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ Applications of functors are not handled. *)
functor_application
Definition p2p :=
Tezos_p2p.P2p.net Message.t Tezos_shell_services.Peer_metadata.t
Tezos_shell_services.Connection_metadata.t.
Definition connection :=
Tezos_p2p.P2p.connection Message.t Tezos_shell_services.Peer_metadata.t
Tezos_shell_services.Connection_metadata.t.
Record request_param {a : Type} := {
p2p :
Tezos_p2p.P2p.t Message.t Tezos_shell_services.Peer_metadata.t
Tezos_shell_services.Connection_metadata.t;
data : a;
active : unit -> Tezos_base__TzPervasives.P2p_peer.Set.t;
send : Tezos_base__TzPervasives.P2p_peer.Id.t -> Message.t -> unit }.
Arguments request_param : clear implicits.
(* ❌ Functors are not handled. *)
functor
Module Fake_operation_storage.
Definition store := Tezos_shell.State.Chain.t.
Definition value := Tezos_base__TzPervasives.Operation.t.
Definition known {A B : Type} (function_parameter : A) : B -> Lwt.t bool :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
Lwt.return_false.
Definition read {A B C : Type} (function_parameter : A)
: B -> Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult C) :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
Lwt._return (Error_monad.error_exn OCaml.Not_found).
Definition read_opt {A B C : Type} (function_parameter : A)
: B -> Lwt.t (option C) :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
Lwt.return_none.
End Fake_operation_storage.
(* ❌ Applications of functors are not handled. *)
functor_application
Module Block_header_storage.
Definition store := Tezos_shell.State.Chain.t.
Definition value := Tezos_base__TzPervasives.Block_header.t.
Definition known
: Tezos_shell__State.Chain.t ->
Tezos_base__TzPervasives.Block_hash.t -> Lwt.t bool :=
State.Block.known_valid.
Definition read
(chain_state : Tezos_shell__State.Chain.t)
(h : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_header.t) :=
op_gtgteqquestion (State.Block.read chain_state h)
(fun b => _return (State.Block.header b)).
Definition read_opt
(chain_state : Tezos_shell__State.Chain.t)
(h : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t (option Tezos_base__TzPervasives.Block_header.t) :=
op_gtgteq (State.Block.read_opt chain_state h)
(fun b => Lwt._return (Option.map State.Block.header b)).
End Block_header_storage.
(* ❌ Applications of functors are not handled. *)
functor_application
Module Operation_hashes_storage.
Definition store := Tezos_shell.State.Chain.t.
Definition value := list Tezos_base__TzPervasives.Operation_hash.t.
Definition known {A : Type}
(chain_state : Tezos_shell__State.Chain.t)
(function_parameter : Tezos_base__TzPervasives.Block_hash.t * A)
: Lwt.t bool :=
let '(h, _) := function_parameter in
State.Block.known_valid chain_state h.
Definition read
(chain_state : Tezos_shell__State.Chain.t)
(function_parameter : Tezos_base__TzPervasives.Block_hash.t * Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list Tezos_base__TzPervasives.Operation_hash.t)) :=
let '(h, i) := function_parameter in
op_gtgteqquestion (State.Block.read chain_state h)
(fun b =>
op_gtgteq (State.Block.operation_hashes b i)
(fun function_parameter =>
let '(ops, _) := function_parameter in
_return ops)).
Definition read_opt
(chain_state : Tezos_shell__State.Chain.t)
(function_parameter : Tezos_base__TzPervasives.Block_hash.t * Z)
: Lwt.t (option (list Tezos_base__TzPervasives.Operation_hash.t)) :=
let '(h, i) := function_parameter in
op_gtgteq (State.Block.read_opt chain_state h)
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_none
| Some b =>
op_gtgteq (State.Block.operation_hashes b i)
(fun function_parameter =>
let '(ops, _) := function_parameter in
Lwt.return_some ops)
end).
End Operation_hashes_storage.
(* ❌ Applications of functors are not handled. *)
functor_application
Module Raw_operation_hashes.
(* ❌ Structure item `include` not handled. *)
include
Definition clear_all
(table : Table.t) (hash : Tezos_base__TzPervasives.Block_hash.t) (n : Z)
: unit :=
List.iter (fun i => Table.clear_or_cancel table (hash, i))
(op_minusminus 0 (Z.sub n 1)).
End Raw_operation_hashes.
Module Operations_storage.
Definition store := Tezos_shell.State.Chain.t.
Definition value := list Tezos_base__TzPervasives.Operation.t.
Definition known {A : Type}
(chain_state : Tezos_shell__State.Chain.t)
(function_parameter : Tezos_base__TzPervasives.Block_hash.t * A)
: Lwt.t bool :=
let '(h, _) := function_parameter in
State.Block.known_valid chain_state h.
Definition read
(chain_state : Tezos_shell__State.Chain.t)
(function_parameter : Tezos_base__TzPervasives.Block_hash.t * Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list Tezos_base__TzPervasives.Operation.t)) :=
let '(h, i) := function_parameter in
op_gtgteqquestion (State.Block.read chain_state h)
(fun b =>
op_gtgteq (State.Block.operations b i)
(fun function_parameter =>
let '(ops, _) := function_parameter in
_return ops)).
Definition read_opt
(chain_state : Tezos_shell__State.Chain.t)
(function_parameter : Tezos_base__TzPervasives.Block_hash.t * Z)
: Lwt.t (option (list Tezos_base__TzPervasives.Operation.t)) :=
let '(h, i) := function_parameter in
op_gtgteq (State.Block.read_opt chain_state h)
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_none
| Some b =>
op_gtgteq (State.Block.operations b i)
(fun function_parameter =>
let '(ops, _) := function_parameter in
Lwt.return_some ops)
end).
End Operations_storage.
Module Raw_operations.
(* ❌ Structure item `include` not handled. *)
include
Definition clear_all
(table : Table.t) (hash : Tezos_base__TzPervasives.Block_hash.t) (n : Z)
: unit :=
List.iter (fun i => Table.clear_or_cancel table (hash, i))
(op_minusminus 0 (Z.sub n 1)).
End Raw_operations.
Module Protocol_storage.
Definition store := Tezos_shell.State.t.
Definition value := Tezos_base__TzPervasives.Protocol.t.
Definition known
: Tezos_shell__State.global_state ->
Tezos_base__TzPervasives.Protocol_hash.t -> Lwt.t bool :=
State.Protocol.known.
Definition read
: Tezos_shell__State.global_state ->
Tezos_base__TzPervasives.Protocol_hash.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Protocol.t) :=
State.Protocol.read.
Definition read_opt
: Tezos_shell__State.global_state ->
Tezos_base__TzPervasives.Protocol_hash.t ->
Lwt.t (option Tezos_base__TzPervasives.Protocol.t) :=
State.Protocol.read_opt.
End Protocol_storage.
(* ❌ Applications of functors are not handled. *)
functor_application
Record callback := {
notify_branch :
Tezos_base__TzPervasives.P2p_peer.Id.t ->
Tezos_base__TzPervasives.Block_locator.t -> unit;
notify_head :
Tezos_base__TzPervasives.P2p_peer.Id.t ->
Tezos_base__TzPervasives.Block_header.t ->
Tezos_base__TzPervasives.Mempool.t -> unit;
disconnection : Tezos_base__TzPervasives.P2p_peer.Id.t -> unit }.
.
Definition noop_callback : callback :=
{| notify_branch := fun _gid => fun _locator => tt;
notify_head := fun _gid => fun _block => fun _ops => tt;
disconnection := fun _gid => tt |}.
Definition t := db.
Definition state (function_parameter : db) : Tezos_shell.State.t :=
let '{| disk := disk |} := function_parameter in
disk.
Definition chain_state (function_parameter : chain_db)
: Tezos_shell.State.Chain.t :=
let '{| chain_state := chain_state |} := function_parameter in
chain_state.
Definition db (function_parameter : chain_db) : db :=
let '{| global_db := global_db |} := function_parameter in
global_db.
Definition information (function_parameter : chain_db)
: Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view :=
let '{|
global_db := {| p2p_readers := p2p_readers; active_chains := active_chains |};
operation_db := operation_db;
block_header_db := block_header_db;
operation_hashes_db := operation_hashes_db;
operations_db := operations_db;
active_peers := active_peers;
active_connections := active_connections
|} := function_parameter in
{|
Chain_validator_worker_state.Distributed_db_state.p2p_readers_length :=
P2p_peer.Table.length p2p_readers;
Chain_validator_worker_state.Distributed_db_state.active_chains_length :=
Chain_id.Table.length active_chains;
Chain_validator_worker_state.Distributed_db_state.operation_db :=
Raw_operation.state_of_t operation_db;
Chain_validator_worker_state.Distributed_db_state.operations_db :=
Raw_operations.state_of_t operations_db;
Chain_validator_worker_state.Distributed_db_state.block_header_db :=
Raw_block_header.state_of_t block_header_db;
Chain_validator_worker_state.Distributed_db_state.operations_hashed_db :=
Raw_operation_hashes.state_of_t operation_hashes_db;
Chain_validator_worker_state.Distributed_db_state.active_connections_length :=
P2p_peer.Table.length active_connections;
Chain_validator_worker_state.Distributed_db_state.active_peers_length :=
P2p_peer.Set.cardinal (Stdlib.op_exclamation active_peers) |}.
Definition my_peer_id (chain_db : chain_db)
: Tezos_base__TzPervasives.P2p_peer.Id.t :=
P2p.peer_id (p2p (global_db chain_db)).
Definition get_peer_metadata (chain_db : chain_db)
: Tezos_base__TzPervasives.P2p_peer.Id.t ->
Tezos_shell_services.Peer_metadata.t :=
P2p.get_peer_metadata (p2p (global_db chain_db)).
Definition read_block_header (function_parameter : db)
: Tezos_base__TzPervasives.Block_hash.t ->
Lwt.t
(option
(Tezos_base__TzPervasives.Chain_id.t *
Tezos_base__TzPervasives.Block_header.t)) :=
let '{| disk := disk |} := function_parameter in
fun h =>
op_gtgteq (State.read_block disk h)
(fun function_parameter =>
match function_parameter with
| Some b =>
Lwt.return_some ((State.Block.chain_id b), (State.Block.header b))
| None => Lwt.return_none
end).
Definition find_pending_block_header (function_parameter : p2p_reader)
: Raw_block_header.Table.key -> option chain_db :=
let '{| peer_active_chains := peer_active_chains |} := function_parameter in
fun h =>
Chain_id.Table.fold
(fun _chain_id =>
fun chain_db =>
fun acc =>
match acc with
| Some _ => acc
| None => Some chain_db
| None => None
end) peer_active_chains None.
Definition find_pending_operations (function_parameter : p2p_reader)
: Tezos_base__TzPervasives.Block_hash.t -> Z -> option chain_db :=
let '{| peer_active_chains := peer_active_chains |} := function_parameter in
fun h =>
fun i =>
Chain_id.Table.fold
(fun _chain_id =>
fun chain_db =>
fun acc =>
match acc with
| Some _ => acc
| None => Some chain_db
| None => None
end) peer_active_chains None.
Definition find_pending_operation_hashes (function_parameter : p2p_reader)
: Tezos_base__TzPervasives.Block_hash.t -> Z -> option chain_db :=
let '{| peer_active_chains := peer_active_chains |} := function_parameter in
fun h =>
fun i =>
Chain_id.Table.fold
(fun _chain_id =>
fun chain_db =>
fun acc =>
match acc with
| Some _ => acc
| None => Some chain_db
| None => None
end) peer_active_chains None.
Definition find_pending_operation (function_parameter : p2p_reader)
: Raw_operation.Table.key -> option chain_db :=
let '{| peer_active_chains := peer_active_chains |} := function_parameter in
fun h =>
Chain_id.Table.fold
(fun _chain_id =>
fun chain_db =>
fun acc =>
match acc with
| Some _ => acc
| None => Some chain_db
| None => None
end) peer_active_chains None.
Definition read_operation (function_parameter : db)
: Raw_operation.Table.key ->
Lwt.t
(option
(Tezos_base__TzPervasives.Chain_id.Table.key * Raw_operation.Table.value)) :=
let '{| active_chains := active_chains |} := function_parameter in
fun h =>
Chain_id.Table.fold
(fun chain_id =>
fun chain_db =>
fun acc =>
op_gtgteq acc
(fun function_parameter =>
match function_parameter with
| Some _ => acc
| None =>
op_gtgteq
(Raw_operation.Table.read_opt
(table (operation_db chain_db)) h)
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_none
| Some bh => Lwt.return_some (chain_id, bh)
end)
end)) active_chains Lwt.return_none.
Module P2p_reader.
Definition may_activate
(global_db : db) (state : p2p_reader)
(chain_id : Tezos_base__TzPervasives.Chain_id.Table.key)
(f : chain_db -> Lwt.t unit) : Lwt.t unit :=
match Chain_id.Table.find_opt (peer_active_chains state) chain_id with
| Some chain_db => f chain_db
| None =>
match Chain_id.Table.find_opt (active_chains global_db) chain_id with
| Some chain_db =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq (active_peers chain_db)
(P2p_peer.Set.add (gid state)
(Stdlib.op_exclamation (active_peers chain_db))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
P2p_peer.Table.add (active_connections chain_db) (gid state) state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Chain_id.Table.add (peer_active_chains state) chain_id chain_db
in
f chain_db
| None =>
let meta := P2p.get_peer_metadata (p2p global_db) (gid state) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Peer_metadata.incr meta
Tezos_shell_services.Peer_metadata.Unactivated_chain in
Lwt.return_unit
end
end.
Definition deactivate (state : p2p_reader) (chain_db : chain_db) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := (disconnection (callback chain_db)) (gid state) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq (active_peers chain_db)
(P2p_peer.Set.remove (gid state)
(Stdlib.op_exclamation (active_peers chain_db))) in
P2p_peer.Table.remove (active_connections chain_db) (gid state).
Definition may_handle
(global_db : db) (state : p2p_reader)
(chain_id : Tezos_base__TzPervasives.Chain_id.Table.key)
(f : chain_db -> Lwt.t unit) : Lwt.t unit :=
match Chain_id.Table.find_opt (peer_active_chains state) chain_id with
| None =>
let meta := P2p.get_peer_metadata (p2p global_db) (gid state) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Peer_metadata.incr meta
Tezos_shell_services.Peer_metadata.Inactive_chain in
Lwt.return_unit
| Some chain_db => f chain_db
end.
Definition may_handle_global
(global_db : db) (chain_id : Tezos_base__TzPervasives.Chain_id.Table.key)
(f : chain_db -> Lwt.t unit) : Lwt.t unit :=
match Chain_id.Table.find_opt (active_chains global_db) chain_id with
| None => Lwt.return_unit
| Some chain_db => f chain_db
end.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition soon (function_parameter : unit) : Ptime.t :=
let 'tt := function_parameter in
let now := Systime_os.now tt in
match Ptime.add_span now (Ptime.Span.of_int_s 15) with
| Some s => s
| None =>
OCaml.Stdlib.invalid_arg "Distributed_db.handle_msg: end of time" % string
end.
Definition handle_msg
(global_db : db) (state : p2p_reader)
(msg : Tezos_shell__Distributed_db_message.t) : Lwt.t unit :=
let meta := P2p.get_peer_metadata (p2p global_db) (gid state) in
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Read message from " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Read message from %a: %a" % string))
(t event "read_message" % string))
(a P2p_peer.Id.Logging.tag (gid state)))
(a Message.Logging.tag msg)))
(fun function_parameter =>
let 'tt := function_parameter in
match msg with
| Message.Get_current_branch chain_id =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Received_request
Tezos_shell_services.Peer_metadata.Branch) in
apply (may_handle_global global_db chain_id)
(fun chain_db =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if negb (Chain_id.Table.mem (peer_active_chains state) chain_id)
then
apply
(Peer_metadata.update_requests meta
Tezos_shell_services.Peer_metadata.Branch)
(apply (P2p.try_send (p2p global_db) (conn state))
(Message.Get_current_branch chain_id))
else
tt in
let seed :=
{| Block_locator.sender_id := my_peer_id chain_db;
Block_locator.receiver_id := gid state |} in
op_gtgteq (Chain.locator (chain_state chain_db) seed)
(fun locator =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply
(Peer_metadata.update_responses meta
Tezos_shell_services.Peer_metadata.Branch)
(apply (P2p.try_send (p2p global_db) (conn state))
(Message.Current_branch chain_id locator)) in
Lwt.return_unit))
| Message.Current_branch chain_id locator =>
apply (may_activate global_db state chain_id)
(fun chain_db =>
let '(head, hist) := locator in
op_gtgteq
(Lwt_list.exists_p
(State.Block.known_invalid (chain_state chain_db))
(cons (Block_header.hash head) hist))
(fun known_invalid =>
if known_invalid then
op_gtgteq (P2p.disconnect (p2p global_db) None (conn state))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p.greylist_peer (p2p global_db) (gid state)
in
Lwt.return_unit)
else
if
op_lt (soon tt) (of_protocol_exn (timestamp (shell head)))
then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Peer_metadata.incr meta
Tezos_shell_services.Peer_metadata.Future_block in
lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Received future block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format)))))
"Received future block %a from peer %a." %
string))
(t event "received_future_block" % string))
(a Block_hash.Logging.tag (Block_header.hash head)))
(a P2p_peer.Id.Logging.tag (gid state)))
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(notify_branch (callback chain_db)) (gid state) locator
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Received_advertisement
Tezos_shell_services.Peer_metadata.Branch) in
Lwt.return_unit))
| Message.Deactivate chain_id =>
apply (may_handle global_db state chain_id)
(fun chain_db =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := deactivate state chain_db in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Chain_id.Table.remove (peer_active_chains state) chain_id
in
Lwt.return_unit)
| Message.Get_current_head chain_id =>
apply (may_handle global_db state chain_id)
(fun chain_db =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Received_request
Tezos_shell_services.Peer_metadata.Head) in
let '{|
Connection_metadata.disable_mempool := disable_mempool |} :=
P2p.connection_remote_metadata (p2p (global_db chain_db))
(conn state) in
op_gtgteq
(if disable_mempool then
op_gtgteq (Chain.head (chain_state chain_db))
(fun head =>
Lwt._return ((State.Block.header head), Mempool.empty))
else
State.Current_mempool.get (chain_state chain_db))
(fun function_parameter =>
let '(head, mempool) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply
(Peer_metadata.update_responses meta
Tezos_shell_services.Peer_metadata.Head)
(apply (P2p.try_send (p2p global_db) (conn state))
(Message.Current_head chain_id head mempool)) in
Lwt.return_unit))
| Message.Current_head chain_id header mempool =>
apply (may_handle global_db state chain_id)
(fun chain_db =>
let head := Block_header.hash header in
op_gtgteq (State.Block.known_invalid (chain_state chain_db) head)
(fun known_invalid =>
let '{|
Connection_metadata.disable_mempool := disable_mempool
|} :=
P2p.connection_local_metadata (p2p (global_db chain_db))
(conn state) in
let known_invalid :=
orb known_invalid
(andb disable_mempool (nequiv_decb mempool Mempool.empty))
in
if known_invalid then
op_gtgteq (P2p.disconnect (p2p global_db) None (conn state))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p.greylist_peer (p2p global_db) (gid state)
in
Lwt.return_unit)
else
if
op_lt (soon tt)
(of_protocol_exn (timestamp (shell header))) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Peer_metadata.incr meta
Tezos_shell_services.Peer_metadata.Future_block in
lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Received future block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format)))))
"Received future block %a from peer %a." %
string))
(t event "received_future_block" % string))
(a Block_hash.Logging.tag head))
(a P2p_peer.Id.Logging.tag (gid state)))
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(notify_head (callback chain_db)) (gid state) header
mempool in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Received_advertisement
Tezos_shell_services.Peer_metadata.Head) in
Lwt.return_unit))
| Message.Get_block_headers hashes =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Received_request
Tezos_shell_services.Peer_metadata.Block_header) in
Lwt_list.iter_p
(fun hash =>
op_gtgteq (read_block_header global_db hash)
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Unadvertised
Tezos_shell_services.Peer_metadata.Block) in
Lwt.return_unit
| Some (_chain_id, header) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply
(Peer_metadata.update_responses meta
Tezos_shell_services.Peer_metadata.Block_header)
(apply (P2p.try_send (p2p global_db) (conn state))
(Message.Block_header header)) in
Lwt.return_unit
end)) hashes
| Message.Block_header block =>
let hash := Block_header.hash block in
match find_pending_block_header state hash with
| None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Peer_metadata.incr meta
Tezos_shell_services.Peer_metadata.Unexpected_response in
Lwt.return_unit
| Some chain_db =>
op_gtgteq
(Raw_block_header.Table.notify (table (block_header_db chain_db))
(gid state) hash block)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Received_response
Tezos_shell_services.Peer_metadata.Block_header) in
Lwt.return_unit)
end
| Message.Get_operations hashes =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Received_request
Tezos_shell_services.Peer_metadata.Operations) in
Lwt_list.iter_p
(fun hash =>
op_gtgteq (read_operation global_db hash)
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Unadvertised
Tezos_shell_services.Peer_metadata.Operations) in
Lwt.return_unit
| Some (_chain_id, op) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply
(Peer_metadata.update_responses meta
Tezos_shell_services.Peer_metadata.Operations)
(apply (P2p.try_send (p2p global_db) (conn state))
(Message.Operation op)) in
Lwt.return_unit
end)) hashes
| Message.Operation operation =>
let hash := Operation.hash operation in
match find_pending_operation state hash with
| None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Peer_metadata.incr meta
Tezos_shell_services.Peer_metadata.Unexpected_response in
Lwt.return_unit
| Some chain_db =>
op_gtgteq
(Raw_operation.Table.notify (table (operation_db chain_db))
(gid state) hash operation)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Received_response
Tezos_shell_services.Peer_metadata.Operations) in
Lwt.return_unit)
end
| Message.Get_protocols hashes =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Received_request
Tezos_shell_services.Peer_metadata.Protocols) in
Lwt_list.iter_p
(fun hash =>
op_gtgteq (State.Protocol.read_opt (disk global_db) hash)
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Unadvertised
Tezos_shell_services.Peer_metadata.Protocol) in
Lwt.return_unit
| Some p =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply
(Peer_metadata.update_responses meta
Tezos_shell_services.Peer_metadata.Protocols)
(apply (P2p.try_send (p2p global_db) (conn state))
(Message.Protocol p)) in
Lwt.return_unit
end)) hashes
| Message.Protocol protocol =>
let hash := Protocol.hash protocol in
op_gtgteq
(Raw_protocol.Table.notify (table (protocol_db global_db))
(gid state) hash protocol)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Received_response
Tezos_shell_services.Peer_metadata.Protocols) in
Lwt.return_unit)
| Message.Get_operation_hashes_for_blocks blocks =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Received_request
Tezos_shell_services.Peer_metadata.Operation_hashes_for_block)
in
Lwt_list.iter_p
(fun function_parameter =>
let '(hash, ofs) := function_parameter in
op_gtgteq (State.read_block (disk global_db) hash)
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_unit
| Some block =>
op_gtgteq (State.Block.operation_hashes block ofs)
(fun function_parameter =>
let '(hashes, path) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply
(Peer_metadata.update_responses meta
Tezos_shell_services.Peer_metadata.Operation_hashes_for_block)
(apply (P2p.try_send (p2p global_db) (conn state))
(Message.Operation_hashes_for_block hash ofs
hashes path)) in
Lwt.return_unit)
end)) blocks
| Message.Operation_hashes_for_block block ofs ops path =>
match find_pending_operation_hashes state block ofs with
| None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Peer_metadata.incr meta
Tezos_shell_services.Peer_metadata.Unexpected_response in
Lwt.return_unit
| Some chain_db =>
op_gtgteq
(Raw_operation_hashes.Table.notify
(table (operation_hashes_db chain_db)) (gid state) (block, ofs)
(ops, path))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Received_response
Tezos_shell_services.Peer_metadata.Operation_hashes_for_block)
in
Lwt.return_unit)
end
| Message.Get_operations_for_blocks blocks =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Received_request
Tezos_shell_services.Peer_metadata.Operations_for_block) in
Lwt_list.iter_p
(fun function_parameter =>
let '(hash, ofs) := function_parameter in
op_gtgteq (State.read_block (disk global_db) hash)
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_unit
| Some block =>
op_gtgteq (State.Block.operations block ofs)
(fun function_parameter =>
let '(ops, path) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply
(Peer_metadata.update_responses meta
Tezos_shell_services.Peer_metadata.Operations_for_block)
(apply (P2p.try_send (p2p global_db) (conn state))
(Message.Operations_for_block hash ofs ops path))
in
Lwt.return_unit)
end)) blocks
| Message.Operations_for_block block ofs ops path =>
match find_pending_operations state block ofs with
| None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Peer_metadata.incr meta
Tezos_shell_services.Peer_metadata.Unexpected_response in
Lwt.return_unit
| Some chain_db =>
op_gtgteq
(Raw_operations.Table.notify (table (operations_db chain_db))
(gid state) (block, ofs) (ops, path))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
apply (Peer_metadata.incr meta)
(Tezos_shell_services.Peer_metadata.Received_response
Tezos_shell_services.Peer_metadata.Operations_for_block)
in
Lwt.return_unit)
end
end).
Fixpoint worker_loop (global_db : db) (state : p2p_reader) : Lwt.t unit :=
op_gtgteq
(protect None (Some (canceler state))
(fun function_parameter =>
let 'tt := function_parameter in
P2p.recv (p2p global_db) (conn state)))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok msg =>
op_gtgteq (handle_msg global_db state msg)
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop global_db state)
| Stdlib.Error _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Chain_id.Table.iter
(fun function_parameter =>
let '_ := function_parameter in
deactivate state) (peer_active_chains state) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_peer.Table.remove (p2p_readers global_db) (gid state) in
Lwt.return_unit
end).
Definition run
(db : db) (gid : Tezos_base__TzPervasives.P2p_peer.Id.t) (conn : connection)
: unit :=
let canceler := Lwt_canceler.create tt in
let state :=
{| gid := gid; conn := conn;
peer_active_chains := Chain_id.Table.create 17; canceler := canceler;
worker := Lwt.return_unit |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Chain_id.Table.iter
(fun chain_id =>
fun _chain_db =>
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
let meta := P2p.get_peer_metadata (p2p db) gid in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Peer_metadata.incr meta
(Tezos_shell_services.Peer_metadata.Sent_request
Tezos_shell_services.Peer_metadata.Branch) in
P2p.send (p2p db) conn (Message.Get_current_branch chain_id)))
(active_chains db) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "worker" % string
(Lwt_utils.worker
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"db_network_reader." % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"db_network_reader.%a" % string) P2p_peer.Id.pp_short gid)
Internal_event.Lwt_worker_event.on_event
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop db state)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel canceler)) in
P2p_peer.Table.add (p2p_readers db) gid state.
Definition shutdown (s : p2p_reader) : Lwt.t unit :=
op_gtgteq (Lwt_canceler.cancel (canceler s))
(fun function_parameter =>
let 'tt := function_parameter in
worker s).
End P2p_reader.
Definition active_peer_ids {A B C : Type}
(p2p : Tezos_p2p.P2p.net A B C) (function_parameter : unit)
: Tezos_base__TzPervasives.P2p_peer.Set.t :=
let 'tt := function_parameter in
List.fold_left
(fun acc =>
fun conn =>
let '{| P2p_connection.Info.peer_id := peer_id |} :=
P2p.connection_info p2p conn in
P2p_peer.Set.add peer_id acc) P2p_peer.Set.empty (P2p.connections p2p).
Definition raw_try_send {A B C : Type}
(p2p : Tezos_p2p.P2p.net A B C)
(peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t) (msg : A) : unit :=
match P2p.find_connection p2p peer_id with
| None => tt
| Some conn => OCaml.Stdlib.ignore (P2p.try_send p2p conn msg)
end.
Definition create
(disk : Protocol_storage.store)
(p2p :
Tezos_p2p.P2p.t Message.t Tezos_shell_services.Peer_metadata.t
Tezos_shell_services.Connection_metadata.t) : db :=
let global_request :=
{| p2p := p2p; data := tt; active := active_peer_ids p2p;
send := raw_try_send p2p |} in
let protocol_db := Raw_protocol.create None global_request disk in
let active_chains := Chain_id.Table.create 17 in
let p2p_readers := P2p_peer.Table.create 17 in
let block_input := Lwt_watcher.create_input tt in
let operation_input := Lwt_watcher.create_input tt in
let db :=
{| p2p := p2p; p2p_readers := p2p_readers; disk := disk;
active_chains := active_chains; protocol_db := protocol_db;
block_input := block_input; operation_input := operation_input |} in
db.
Definition activate (function_parameter : db)
: Tezos_shell.State.Chain.chain_state -> chain_db :=
let '{| p2p := p2p; active_chains := active_chains |} as global_db :=
function_parameter in
fun chain_state =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p.on_new_connection p2p (P2p_reader.run global_db) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p.iter_connections p2p (P2p_reader.run global_db) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p.activate p2p in
let chain_id := State.Chain.id chain_state in
match Chain_id.Table.find_opt active_chains chain_id with
| None =>
let active_peers := Stdlib.ref P2p_peer.Set.empty in
let p2p_request :=
{| p2p := p2p; data := tt;
active :=
fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_exclamation active_peers; send := raw_try_send p2p |} in
let operation_db :=
Raw_operation.create (Some (operation_input global_db)) p2p_request
chain_state in
let block_header_db :=
Raw_block_header.create (Some (block_input global_db)) p2p_request
chain_state in
let operation_hashes_db :=
Raw_operation_hashes.create None p2p_request chain_state in
let operations_db := Raw_operations.create None p2p_request chain_state in
let chain :=
{| chain_state := chain_state; global_db := global_db;
operation_db := operation_db; block_header_db := block_header_db;
operation_hashes_db := operation_hashes_db;
operations_db := operations_db; callback := noop_callback;
active_peers := active_peers;
active_connections := P2p_peer.Table.create 53 |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
P2p.iter_connections p2p
(fun _peer_id =>
fun conn =>
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
P2p.send p2p conn (Message.Get_current_branch chain_id))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Chain_id.Table.add active_chains chain_id chain in
chain
| Some chain => chain
end.
Definition set_callback (chain_db : chain_db) (callback : callback) : unit :=
(* ❌ Set record field not handled. *)
set_record_field chain_db "callback" % string callback.
Definition deactivate (chain_db : chain_db) : Lwt.t unit :=
let '{| p2p := p2p; active_chains := active_chains |} := global_db chain_db in
let chain_id := State.Chain.id (chain_state chain_db) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Chain_id.Table.remove active_chains chain_id in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
P2p_peer.Table.iter
(fun _peer_id =>
fun reader =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_reader.deactivate reader chain_db in
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
P2p.send p2p (conn reader) (Message.Deactivate chain_id)))
(active_connections chain_db) in
op_gtgteq (Raw_operation.shutdown (operation_db chain_db))
(fun function_parameter =>
let 'tt := function_parameter in
Raw_block_header.shutdown (block_header_db chain_db)).
Definition get_chain (function_parameter : db)
: Tezos_base__TzPervasives.Chain_id.Table.key -> option chain_db :=
let '{| active_chains := active_chains |} := function_parameter in
fun chain_id => Chain_id.Table.find_opt active_chains chain_id.
Definition greylist (function_parameter : chain_db)
: Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit :=
let '{| global_db := {| p2p := p2p |} |} := function_parameter in
fun peer_id => Lwt._return (P2p.greylist_peer p2p peer_id).
Definition disconnect (function_parameter : chain_db)
: Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit :=
let '{| global_db := {| p2p := p2p |} |} := function_parameter in
fun peer_id =>
match P2p.find_connection p2p peer_id with
| None => Lwt.return_unit
| Some conn => P2p.disconnect p2p None conn
end.
Definition shutdown (function_parameter : db) : Lwt.t unit :=
let '{| p2p_readers := p2p_readers; active_chains := active_chains |} :=
function_parameter in
op_gtgteq
(P2p_peer.Table.fold
(fun _peer_id =>
fun reader =>
fun acc =>
op_gtgteq (P2p_reader.shutdown reader)
(fun function_parameter =>
let 'tt := function_parameter in
acc)) p2p_readers Lwt.return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
Chain_id.Table.fold
(fun function_parameter =>
let '_ := function_parameter in
fun chain_db =>
fun acc =>
op_gtgteq (Raw_operation.shutdown (operation_db chain_db))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Raw_block_header.shutdown (block_header_db chain_db))
(fun function_parameter =>
let 'tt := function_parameter in
acc))) active_chains Lwt.return_unit).
Definition clear_block
(chain_db : chain_db) (hash : Tezos_base__TzPervasives.Block_hash.t) (n : Z)
: unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Raw_operations.clear_all (table (operations_db chain_db)) hash n in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Raw_operation_hashes.clear_all (table (operation_hashes_db chain_db)) hash n
in
Raw_block_header.Table.clear_or_cancel (table (block_header_db chain_db)) hash.
Definition commit_block
(chain_db : chain_db) (hash : Tezos_base__TzPervasives.Block_hash.t)
(header : Tezos_base__TzPervasives.Block_header.t)
(header_data : Stdlib.Bytes.t)
(operations : list (list Tezos_base__TzPervasives.Operation.t))
(operations_data : list (list Stdlib.Bytes.t))
(result : Tezos_validation.Block_validation.validation_store)
(forking_testchain : bool)
: Lwt.t
(Tezos_base__TzPervasives.tzresult (option Tezos_shell.State.Block.block)) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (Block_hash.equal hash (Block_header.hash header)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(equiv_decb (List.length operations) (validation_passes (shell header)))
in
op_gtgteqquestion
(State.Block.store None (chain_state chain_db) header header_data operations
operations_data result forking_testchain)
(fun res =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := clear_block chain_db hash (validation_passes (shell header)) in
_return res).
Definition commit_invalid_block
(chain_db : chain_db) (hash : Tezos_base__TzPervasives.Block_hash.t)
(header : Tezos_base__TzPervasives.Block_header.t)
(errors : list Tezos_base__TzPervasives.error)
: Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (Block_hash.equal hash (Block_header.hash header)) in
op_gtgteqquestion
(State.Block.store_invalid (chain_state chain_db) header errors)
(fun res =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := clear_block chain_db hash (validation_passes (shell header)) in
_return res).
Definition inject_operation
(chain_db : chain_db) (h : Tezos_base__TzPervasives.Operation_hash.t)
(op : Tezos_base__TzPervasives.Operation.t) : Lwt.t bool :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (Operation_hash.equal h (Operation.hash op)) in
Raw_operation.Table.inject (table (operation_db chain_db)) h op.
Definition commit_protocol
(db : db) (h : Raw_protocol.Table.key)
(p : Tezos_base__TzPervasives.Protocol.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
op_gtgteq (State.Protocol.store (disk db) p)
(fun res =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Raw_protocol.Table.clear_or_cancel (table (protocol_db db)) h in
_return (nequiv_decb res None)).
Definition watch_block_header (function_parameter : db)
: (Lwt_stream.t
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t)) *
Tezos_base__TzPervasives.Lwt_watcher.stopper :=
let '{| block_input := block_input |} := function_parameter in
Lwt_watcher.create_stream block_input.
Definition watch_operation (function_parameter : db)
: (Lwt_stream.t
(Tezos_base__TzPervasives.Operation_hash.t *
Tezos_base__TzPervasives.Operation.t)) *
Tezos_base__TzPervasives.Lwt_watcher.stopper :=
let '{| operation_input := operation_input |} := function_parameter in
Lwt_watcher.create_stream operation_input.
Module Raw.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.t
(Tezos_p2p.P2p_message.t Message.t) :=
P2p_message.encoding (encoding Message.cfg).
Definition chain_name
: Tezos_base__TzPervasives.Distributed_db_version.name :=
chain_name Message.cfg.
Definition distributed_db_versions
: list Tezos_base__TzPervasives.Distributed_db_version.t :=
distributed_db_versions Message.cfg.
End Raw.
(* ❌ Functors are not handled. *)
functor
Module Block_header.
Definition t := Tezos_base__TzPervasives.Block_header.t.
(* ❌ Structure item `include` not handled. *)
include
End Block_header.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Module Operation.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
End Operation.
Module Protocol.
Definition t := Tezos_base__TzPervasives.Protocol.t.
(* ❌ Structure item `include` not handled. *)
include
End Protocol.
Definition broadcast (chain_db : chain_db) (msg : Message.t) : unit :=
P2p_peer.Table.iter
(fun _peer_id =>
fun state =>
OCaml.Stdlib.ignore
(P2p.try_send (p2p (global_db chain_db)) (conn state) msg))
(active_connections chain_db).
Definition try_send
(chain_db : chain_db) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
(msg : Message.t) : unit :=
match P2p_peer.Table.find_opt (active_connections chain_db) peer_id with
| None => tt
| Some conn =>
OCaml.Stdlib.ignore
(P2p.try_send (p2p (global_db chain_db)) (conn conn) msg)
end.
Definition send
(chain_db : chain_db)
(peer : option Tezos_base__TzPervasives.P2p_peer.Table.key) (msg : Message.t)
: unit :=
match peer with
| Some peer => try_send chain_db peer msg
| None => broadcast chain_db msg
end.
Module Request.
Definition current_head
(chain_db : chain_db) (peer : option Tezos_base__TzPervasives.P2p_peer.Id.t)
(function_parameter : unit) : unit :=
let 'tt := function_parameter in
let chain_id := State.Chain.id (chain_state chain_db) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match peer with
| Some peer =>
let meta := P2p.get_peer_metadata (p2p (global_db chain_db)) peer in
Peer_metadata.incr meta
(Tezos_shell_services.Peer_metadata.Sent_request
Tezos_shell_services.Peer_metadata.Head)
| None => tt
end in
apply (send chain_db peer) (Message.Get_current_head chain_id).
Definition current_branch
(chain_db : chain_db) (peer : option Tezos_base__TzPervasives.P2p_peer.Id.t)
(function_parameter : unit) : unit :=
let 'tt := function_parameter in
let chain_id := State.Chain.id (chain_state chain_db) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match peer with
| Some peer =>
let meta := P2p.get_peer_metadata (p2p (global_db chain_db)) peer in
Peer_metadata.incr meta
(Tezos_shell_services.Peer_metadata.Sent_request
Tezos_shell_services.Peer_metadata.Head)
| None => tt
end in
apply (send chain_db peer) (Message.Get_current_branch chain_id).
End Request.
Module Advertise.
Definition current_head
(chain_db : chain_db) (peer : option Tezos_base__TzPervasives.P2p_peer.Id.t)
(op_staroptstar : option Tezos_base__TzPervasives.Mempool.mempool)
: Tezos_shell.State.Block.t -> unit :=
let mempool :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Mempool.empty
end in
fun head =>
let chain_id := State.Chain.id (chain_state chain_db) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (Chain_id.equal chain_id (State.Block.chain_id head)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match peer with
| Some peer =>
let meta := P2p.get_peer_metadata (p2p (global_db chain_db)) peer in
Peer_metadata.incr meta
(Tezos_shell_services.Peer_metadata.Sent_advertisement
Tezos_shell_services.Peer_metadata.Head)
| None => tt
end in
let msg_mempool :=
Message.Current_head chain_id (State.Block.header head) mempool in
if equiv_decb mempool Mempool.empty then
send chain_db peer msg_mempool
else
let msg_disable_mempool :=
Message.Current_head chain_id (State.Block.header head) Mempool.empty
in
let send_mempool (state : p2p_reader) : unit :=
let '{| Connection_metadata.disable_mempool := disable_mempool |} :=
P2p.connection_remote_metadata (p2p (global_db chain_db))
(conn state) in
let msg :=
if disable_mempool then
msg_disable_mempool
else
msg_mempool in
apply OCaml.Stdlib.ignore
(P2p.try_send (p2p (global_db chain_db)) (conn state) msg) in
match peer with
| Some receiver_id =>
let state :=
P2p_peer.Table.find (active_connections chain_db) receiver_id in
send_mempool state
| None =>
List.iter
(fun function_parameter =>
let '(_receiver_id, state) := function_parameter in
send_mempool state)
(P2p_peer.Table.fold (fun k => fun v => fun acc => cons (k, v) acc)
(active_connections chain_db) [])
end.
Definition current_branch
(peer : option Tezos_base__TzPervasives.P2p_peer.Id.t) (chain_db : chain_db)
: Lwt.t unit :=
let chain_id := State.Chain.id (chain_state chain_db) in
let chain_state := chain_state chain_db in
let sender_id := my_peer_id chain_db in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match peer with
| Some peer =>
let meta := P2p.get_peer_metadata (p2p (global_db chain_db)) peer in
Peer_metadata.incr meta
(Tezos_shell_services.Peer_metadata.Sent_advertisement
Tezos_shell_services.Peer_metadata.Branch)
| None => tt
end in
match peer with
| Some receiver_id =>
let seed :=
{| Block_locator.sender_id := sender_id;
Block_locator.receiver_id := receiver_id |} in
op_gtgteq (Chain.locator chain_state seed)
(fun locator =>
let msg := Message.Current_branch chain_id locator in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := try_send chain_db receiver_id msg in
Lwt.return_unit)
| None =>
Lwt_list.iter_p
(fun function_parameter =>
let '(receiver_id, state) := function_parameter in
let seed :=
{| Block_locator.sender_id := sender_id;
Block_locator.receiver_id := receiver_id |} in
op_gtgteq (Chain.locator chain_state seed)
(fun locator =>
let msg := Message.Current_branch chain_id locator in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
OCaml.Stdlib.ignore
(P2p.try_send (p2p (global_db chain_db)) (conn state) msg) in
Lwt.return_unit))
(P2p_peer.Table.fold (fun k => fun v => fun acc => cons (k, v) acc)
(active_connections chain_db) [])
end.
End Advertise.
src/lib_shell/distributed_db_functors.ml 15 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type DISTRIBUTED_DB = sig
type t
type key
type value
type param
val known : t -> key -> bool Lwt.t
type error += Missing_data of key
type error += Canceled of key
type error += Timeout of key
val read : t -> key -> value tzresult Lwt.t
val read_opt : t -> key -> value option Lwt.t
val prefetch :
t ->
?peer:P2p_peer.Id.t ->
?timeout:Time.System.Span.t ->
key ->
param ->
unit
val fetch :
t ->
?peer:P2p_peer.Id.t ->
?timeout:Time.System.Span.t ->
key ->
param ->
value tzresult Lwt.t
val clear_or_cancel : t -> key -> unit
val resolve_pending : t -> key -> value -> unit
val inject : t -> key -> value -> bool Lwt.t
val watch : t -> (key * value) Lwt_stream.t * Lwt_watcher.stopper
val pending : t -> key -> bool
end
module type DISK_TABLE = sig
type store
type key
type value
val known : store -> key -> bool Lwt.t
val read : store -> key -> value tzresult Lwt.t
val read_opt : store -> key -> value option Lwt.t
end
module type MEMORY_TABLE = sig
type 'a t
type key
val create : int -> 'a t
val find : 'a t -> key -> 'a
val find_opt : 'a t -> key -> 'a option
val add : 'a t -> key -> 'a -> unit
val replace : 'a t -> key -> 'a -> unit
val remove : 'a t -> key -> unit
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val length : 'a t -> int
end
module type SCHEDULER_EVENTS = sig
type t
type key
val request : t -> P2p_peer.Id.t option -> key -> unit
val notify : t -> P2p_peer.Id.t -> key -> unit
val notify_cancellation : t -> key -> unit
val notify_unrequested : t -> P2p_peer.Id.t -> key -> unit
val notify_duplicate : t -> P2p_peer.Id.t -> key -> unit
val notify_invalid : t -> P2p_peer.Id.t -> key -> unit
val memory_table_length : t -> int
end
module type PRECHECK = sig
type key
type param
type notified_value
type value
val precheck : key -> param -> notified_value -> value option
end
module Make_table (Hash : sig
type t
val name : string
val encoding : t Data_encoding.t
val pp : Format.formatter -> t -> unit
end)
(Disk_table : DISK_TABLE with type key := Hash.t)
(Memory_table : MEMORY_TABLE with type key := Hash.t)
(Scheduler : SCHEDULER_EVENTS with type key := Hash.t)
(Precheck : PRECHECK with type key := Hash.t and type value := Disk_table.value) : sig
include
DISTRIBUTED_DB
with type key = Hash.t
and type value = Disk_table.value
and type param = Precheck.param
val create :
?global_input:(key * value) Lwt_watcher.input ->
Scheduler.t ->
Disk_table.store ->
t
val notify :
t -> P2p_peer.Id.t -> key -> Precheck.notified_value -> unit Lwt.t
val memory_table_length : t -> int
end = struct
type key = Hash.t
type value = Disk_table.value
type param = Precheck.param
type t = {
scheduler : Scheduler.t;
disk : Disk_table.store;
memory : status Memory_table.t;
global_input : (key * value) Lwt_watcher.input option;
input : (key * value) Lwt_watcher.input;
}
and status =
| Pending of {
waiter : value tzresult Lwt.t;
wakener : value tzresult Lwt.u;
mutable waiters : int;
param : param;
}
| Found of value
let known s k =
match Memory_table.find_opt s.memory k with
| None ->
Disk_table.known s.disk k
| Some (Pending _) ->
Lwt.return_false
| Some (Found _) ->
Lwt.return_true
let read_opt s k =
match Memory_table.find_opt s.memory k with
| None ->
Disk_table.read_opt s.disk k
| Some (Found v) ->
Lwt.return_some v
| Some (Pending _) ->
Lwt.return_none
type error += Missing_data of key
type error += Canceled of key
type error += Timeout of key
let () =
(* Missing data key *)
register_error_kind
`Permanent
~id:("distributed_db." ^ Hash.name ^ ".missing")
~title:("Missing " ^ Hash.name)
~description:("Some " ^ Hash.name ^ " is missing from the distributed db")
~pp:(fun ppf key ->
Format.fprintf ppf "Missing %s %a" Hash.name Hash.pp key)
(Data_encoding.obj1 (Data_encoding.req "key" Hash.encoding))
(function Missing_data key -> Some key | _ -> None)
(fun key -> Missing_data key) ;
(* Canceled key *)
register_error_kind
`Permanent
~title:("Canceled fetch of a " ^ Hash.name)
~description:("The fetch of a " ^ Hash.name ^ " has been canceled")
~id:("distributed_db." ^ Hash.name ^ ".fetch_canceled")
~pp:(fun ppf key ->
Format.fprintf ppf "Fetch of %s %a canceled" Hash.name Hash.pp key)
Data_encoding.(obj1 (req "key" Hash.encoding))
(function Canceled key -> Some key | _ -> None)
(fun key -> Canceled key) ;
(* Timeout key *)
register_error_kind
`Permanent
~title:("Timed out fetch of a " ^ Hash.name)
~description:("The fetch of a " ^ Hash.name ^ " has timed out")
~id:("distributed_db." ^ Hash.name ^ ".fetch_timeout")
~pp:(fun ppf key ->
Format.fprintf ppf "Fetch of %s %a timed out" Hash.name Hash.pp key)
Data_encoding.(obj1 (req "key" Hash.encoding))
(function Timeout key -> Some key | _ -> None)
(fun key -> Timeout key)
let read s k =
match Memory_table.find_opt s.memory k with
| None ->
trace (Missing_data k) @@ Disk_table.read s.disk k
| Some (Found v) ->
return v
| Some (Pending _) ->
fail (Missing_data k)
let wrap s k ?timeout t =
let t = Lwt.protected t in
Lwt.on_cancel t (fun () ->
match Memory_table.find_opt s.memory k with
| None ->
()
| Some (Found _) ->
()
| Some (Pending data) ->
data.waiters <- data.waiters - 1 ;
if data.waiters = 0 then (
Memory_table.remove s.memory k ;
Scheduler.notify_cancellation s.scheduler k )) ;
match timeout with
| None ->
t
| Some delay ->
let timeout = Systime_os.sleep delay >>= fun () -> fail (Timeout k) in
Lwt.pick [t; timeout]
let fetch s ?peer ?timeout k param =
match Memory_table.find_opt s.memory k with
| None -> (
Disk_table.read_opt s.disk k
>>= function
| Some v ->
return v
| None -> (
match Memory_table.find_opt s.memory k with
| None ->
let (waiter, wakener) = Lwt.wait () in
Memory_table.add
s.memory
k
(Pending {waiter; wakener; waiters = 1; param}) ;
Scheduler.request s.scheduler peer k ;
wrap s k ?timeout waiter
| Some (Pending data) ->
Scheduler.request s.scheduler peer k ;
data.waiters <- data.waiters + 1 ;
wrap s k ?timeout data.waiter
| Some (Found v) ->
return v ) )
| Some (Pending data) ->
Scheduler.request s.scheduler peer k ;
data.waiters <- data.waiters + 1 ;
wrap s k ?timeout data.waiter
| Some (Found v) ->
return v
let prefetch s ?peer ?timeout k param =
try ignore (fetch s ?peer ?timeout k param) with _ -> ()
let notify s p k v =
match Memory_table.find_opt s.memory k with
| None -> (
Disk_table.known s.disk k
>>= function
| true ->
Scheduler.notify_duplicate s.scheduler p k ;
Lwt.return_unit
| false ->
Scheduler.notify_unrequested s.scheduler p k ;
Lwt.return_unit )
| Some (Pending {wakener = w; param; _}) -> (
match Precheck.precheck k param v with
| None ->
Scheduler.notify_invalid s.scheduler p k ;
Lwt.return_unit
| Some v ->
Scheduler.notify s.scheduler p k ;
Memory_table.replace s.memory k (Found v) ;
Lwt.wakeup_later w (Ok v) ;
Option.iter s.global_input ~f:(fun input ->
Lwt_watcher.notify input (k, v)) ;
Lwt_watcher.notify s.input (k, v) ;
Lwt.return_unit )
| Some (Found _) ->
Scheduler.notify_duplicate s.scheduler p k ;
Lwt.return_unit
let inject s k v =
match Memory_table.find_opt s.memory k with
| None -> (
Disk_table.known s.disk k
>>= function
| true ->
Lwt.return_false
| false ->
Memory_table.add s.memory k (Found v) ;
Lwt.return_true )
| Some (Pending _) | Some (Found _) ->
Lwt.return_false
let resolve_pending s k v =
match Memory_table.find_opt s.memory k with
| Some (Pending {wakener; _}) ->
Scheduler.notify_cancellation s.scheduler k ;
Memory_table.replace s.memory k (Found v) ;
Lwt.wakeup_later wakener (Ok v) ;
Option.iter s.global_input ~f:(fun input ->
Lwt_watcher.notify input (k, v)) ;
Lwt_watcher.notify s.input (k, v)
| _ ->
()
let clear_or_cancel s k =
match Memory_table.find_opt s.memory k with
| None ->
()
| Some (Pending {wakener = w; _}) ->
Scheduler.notify_cancellation s.scheduler k ;
Memory_table.remove s.memory k ;
Lwt.wakeup_later w (error (Canceled k))
| Some (Found _) ->
Memory_table.remove s.memory k
let watch s = Lwt_watcher.create_stream s.input
let create ?global_input scheduler disk =
let memory = Memory_table.create 17 in
let input = Lwt_watcher.create_input () in
{scheduler; disk; memory; input; global_input}
let pending s k =
match Memory_table.find_opt s.memory k with
| None ->
false
| Some (Found _) ->
false
| Some (Pending _) ->
true
let memory_table_length s = Memory_table.length s.memory
end
module type REQUEST = sig
type key
type param
val initial_delay : Time.System.Span.t
val active : param -> P2p_peer.Set.t
val send : param -> P2p_peer.Id.t -> key list -> unit
end
module Make_request_scheduler (Hash : sig
type t
val name : string
module Logging : sig
val tag : t Tag.def
end
end)
(Table : MEMORY_TABLE with type key := Hash.t)
(Request : REQUEST with type key := Hash.t) : sig
type t
val create : Request.param -> t
val shutdown : t -> unit Lwt.t
include SCHEDULER_EVENTS with type t := t and type key := Hash.t
val memory_table_length : t -> int
end = struct
include Internal_event.Legacy_logging.Make_semantic (struct
let name = "node.distributed_db.scheduler." ^ Hash.name
end)
type key = Hash.t
type t = {
param : Request.param;
pending : status Table.t;
queue : event Lwt_pipe.t;
mutable events : event list Lwt.t;
canceler : Lwt_canceler.t;
mutable worker : unit Lwt.t;
}
and status = {
peers : P2p_peer.Set.t;
next_request : Time.System.t;
delay : Time.System.Span.t;
}
and event =
| Request of P2p_peer.Id.t option * key
| Notify of P2p_peer.Id.t * key
| Notify_cancellation of key
| Notify_invalid of P2p_peer.Id.t * key
| Notify_duplicate of P2p_peer.Id.t * key
| Notify_unrequested of P2p_peer.Id.t * key
let request t p k = assert (Lwt_pipe.push_now t.queue (Request (p, k)))
let notify t p k =
debug
Tag.DSL.(
fun f ->
f "push received %a from %a"
-% t event "push_received" -% a Hash.Logging.tag k
-% a P2p_peer.Id.Logging.tag p) ;
assert (Lwt_pipe.push_now t.queue (Notify (p, k)))
let notify_cancellation t k =
debug
Tag.DSL.(
fun f ->
f "push cancellation %a"
-% t event "push_cancellation"
-% a Hash.Logging.tag k) ;
assert (Lwt_pipe.push_now t.queue (Notify_cancellation k))
let notify_invalid t p k =
debug
Tag.DSL.(
fun f ->
f "push received invalid %a from %a"
-% t event "push_received_invalid"
-% a Hash.Logging.tag k
-% a P2p_peer.Id.Logging.tag p) ;
assert (Lwt_pipe.push_now t.queue (Notify_invalid (p, k)))
let notify_duplicate t p k =
debug
Tag.DSL.(
fun f ->
f "push received duplicate %a from %a"
-% t event "push_received_duplicate"
-% a Hash.Logging.tag k
-% a P2p_peer.Id.Logging.tag p) ;
assert (Lwt_pipe.push_now t.queue (Notify_duplicate (p, k)))
let notify_unrequested t p k =
debug
Tag.DSL.(
fun f ->
f "push received unrequested %a from %a"
-% t event "push_received_unrequested"
-% a Hash.Logging.tag k
-% a P2p_peer.Id.Logging.tag p) ;
assert (Lwt_pipe.push_now t.queue (Notify_unrequested (p, k)))
let compute_timeout state =
let next =
Table.fold
(fun _ {next_request; _} acc ->
match acc with
| None ->
Some next_request
| Some x ->
Some (Time.System.min x next_request))
state.pending
None
in
match next with
| None ->
fst @@ Lwt.task ()
| Some next ->
let now = Systime_os.now () in
let delay = Ptime.diff next now in
if Ptime.Span.compare delay Ptime.Span.zero <= 0 then Lwt.return_unit
else Systime_os.sleep delay
let process_event state now = function
| Request (peer, key) -> (
lwt_debug
Tag.DSL.(
fun f ->
f "registering request %a from %a"
-% t event "registering_request"
-% a Hash.Logging.tag key
-% a P2p_peer.Id.Logging.tag_opt peer)
>>= fun () ->
try
let data = Table.find state.pending key in
let peers =
match peer with
| None ->
data.peers
| Some peer ->
P2p_peer.Set.add peer data.peers
in
let next_request = now in
Table.replace
state.pending
key
{delay = Request.initial_delay; next_request; peers} ;
lwt_debug
Tag.DSL.(
fun f ->
f "registering request %a from %a -> replaced"
-% t event "registering_request_replaced"
-% a Hash.Logging.tag key
-% a P2p_peer.Id.Logging.tag_opt peer)
with Not_found ->
let peers =
match peer with
| None ->
P2p_peer.Set.empty
| Some peer ->
P2p_peer.Set.singleton peer
in
Table.add
state.pending
key
{peers; next_request = now; delay = Request.initial_delay} ;
lwt_debug
Tag.DSL.(
fun f ->
f "registering request %a from %a -> added"
-% t event "registering_request_added"
-% a Hash.Logging.tag key
-% a P2p_peer.Id.Logging.tag_opt peer) )
| Notify (peer, key) ->
Table.remove state.pending key ;
lwt_debug
Tag.DSL.(
fun f ->
f "received %a from %a" -% t event "received"
-% a Hash.Logging.tag key
-% a P2p_peer.Id.Logging.tag peer)
| Notify_cancellation key ->
Table.remove state.pending key ;
lwt_debug
Tag.DSL.(
fun f ->
f "canceled %a" -% t event "canceled" -% a Hash.Logging.tag key)
| Notify_invalid (peer, key) ->
(* TODO *)
lwt_debug
Tag.DSL.(
fun f ->
f "received invalid %a from %a"
-% t event "received_invalid" -% a Hash.Logging.tag key
-% a P2p_peer.Id.Logging.tag peer)
| Notify_unrequested (peer, key) ->
(* TODO *)
lwt_debug
Tag.DSL.(
fun f ->
f "received unrequested %a from %a"
-% t event "received_unrequested"
-% a Hash.Logging.tag key
-% a P2p_peer.Id.Logging.tag peer)
| Notify_duplicate (peer, key) ->
(* TODO *)
lwt_debug
Tag.DSL.(
fun f ->
f "received duplicate %a from %a"
-% t event "received_duplicate"
-% a Hash.Logging.tag key
-% a P2p_peer.Id.Logging.tag peer)
let worker_loop state =
let shutdown = Lwt_canceler.cancellation state.canceler in
let rec loop state =
let timeout = compute_timeout state in
Lwt.choose [(state.events >|= fun _ -> ()); timeout; shutdown]
>>= fun () ->
if Lwt.state shutdown <> Lwt.Sleep then
lwt_debug Tag.DSL.(fun f -> f "terminating" -% t event "terminating")
else if Lwt.state state.events <> Lwt.Sleep then (
let now = Systime_os.now () in
state.events
>>= fun events ->
state.events <- Lwt_pipe.pop_all state.queue ;
Lwt_list.iter_s (process_event state now) events
>>= fun () -> loop state )
else
lwt_debug Tag.DSL.(fun f -> f "timeout" -% t event "timeout")
>>= fun () ->
let now = Systime_os.now () in
let active_peers = Request.active state.param in
let requests =
Table.fold
(fun key {peers; next_request; delay} acc ->
if Ptime.is_later next_request ~than:now then acc
else
let remaining_peers = P2p_peer.Set.inter peers active_peers in
if
P2p_peer.Set.is_empty remaining_peers
&& not (P2p_peer.Set.is_empty peers)
then (
Table.remove state.pending key ;
acc )
else
let requested_peer =
P2p_peer.Id.Set.random_elt
( if P2p_peer.Set.is_empty remaining_peers then
active_peers
else remaining_peers )
in
let next_request =
Option.unopt ~default:Ptime.max (Ptime.add_span now delay)
in
let next =
{
peers = remaining_peers;
next_request;
delay = Time.System.Span.multiply_exn 1.5 delay;
}
in
Table.replace state.pending key next ;
let requests =
try key :: P2p_peer.Map.find requested_peer acc
with Not_found -> [key]
in
P2p_peer.Map.add requested_peer requests acc)
state.pending
P2p_peer.Map.empty
in
P2p_peer.Map.iter (Request.send state.param) requests ;
P2p_peer.Map.fold
(fun peer request acc ->
acc
>>= fun () ->
Lwt_list.iter_s
(fun key ->
lwt_debug
Tag.DSL.(
fun f ->
f "requested %a from %a" -% t event "requested"
-% a Hash.Logging.tag key
-% a P2p_peer.Id.Logging.tag peer))
request)
requests
Lwt.return_unit
>>= fun () -> loop state
in
loop state
let create param =
let state =
{
param;
queue = Lwt_pipe.create ();
pending = Table.create 17;
events = Lwt.return_nil;
canceler = Lwt_canceler.create ();
worker = Lwt.return_unit;
}
in
state.worker <-
Lwt_utils.worker
"db_request_scheduler"
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> worker_loop state)
~cancel:(fun () -> Lwt_canceler.cancel state.canceler) ;
state
let shutdown s = Lwt_canceler.cancel s.canceler >>= fun () -> s.worker
let memory_table_length s = Table.length s.pending
end
src/lib_shell/distributed_db_functors.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module DISTRIBUTED_DB.
Record signature {t key value param : Type} := {
t := t;
key := key;
value := value;
param := param;
known : t -> key -> Lwt.t bool;
extensible_type;
extensible_type;
extensible_type;
read : t -> key -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
read_opt : t -> key -> Lwt.t (option value);
prefetch : t ->
(option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
(option Tezos_base__TzPervasives.Time.System.Span.t) ->
key -> param -> unit;
fetch : t ->
(option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
(option Tezos_base__TzPervasives.Time.System.Span.t) ->
key -> param -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
clear_or_cancel : t -> key -> unit;
resolve_pending : t -> key -> value -> unit;
inject : t -> key -> value -> Lwt.t bool;
watch : t ->
(Lwt_stream.t (key * value)) *
Tezos_base__TzPervasives.Lwt_watcher.stopper;
pending : t -> key -> bool;
}.
Arguments signature : clear implicits.
End DISTRIBUTED_DB.
Module DISK_TABLE.
Record signature {store key value : Type} := {
store := store;
key := key;
value := value;
known : store -> key -> Lwt.t bool;
read : store -> key -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
read_opt : store -> key -> Lwt.t (option value);
}.
Arguments signature : clear implicits.
End DISK_TABLE.
Module MEMORY_TABLE.
Record signature {t key : Type} := {
polymorphic_abstract_type;
key := key;
create : forall {a : Type}, Z -> t a;
find : forall {a : Type}, (t a) -> key -> a;
find_opt : forall {a : Type}, (t a) -> key -> option a;
add : forall {a : Type}, (t a) -> key -> a -> unit;
replace : forall {a : Type}, (t a) -> key -> a -> unit;
remove : forall {a : Type}, (t a) -> key -> unit;
fold : forall {a b : Type}, (key -> a -> b -> b) -> (t a) -> b -> b;
length : forall {a : Type}, (t a) -> Z;
}.
Arguments signature : clear implicits.
End MEMORY_TABLE.
Module SCHEDULER_EVENTS.
Record signature {t key : Type} := {
t := t;
key := key;
request : t ->
(option Tezos_base__TzPervasives.P2p_peer.Id.t) -> key -> unit;
notify : t -> Tezos_base__TzPervasives.P2p_peer.Id.t -> key -> unit;
notify_cancellation : t -> key -> unit;
notify_unrequested : t ->
Tezos_base__TzPervasives.P2p_peer.Id.t -> key -> unit;
notify_duplicate : t ->
Tezos_base__TzPervasives.P2p_peer.Id.t -> key -> unit;
notify_invalid : t -> Tezos_base__TzPervasives.P2p_peer.Id.t -> key -> unit;
memory_table_length : t -> Z;
}.
Arguments signature : clear implicits.
End SCHEDULER_EVENTS.
Module PRECHECK.
Record signature {key param notified_value value : Type} := {
key := key;
param := param;
notified_value := notified_value;
value := value;
precheck : key -> param -> notified_value -> option value;
}.
Arguments signature : clear implicits.
End PRECHECK.
(* ❌ Functors are not handled. *)
functor
Module REQUEST.
Record signature {key param : Type} := {
key := key;
param := param;
initial_delay : Tezos_base__TzPervasives.Time.System.Span.t;
active : param -> Tezos_base__TzPervasives.P2p_peer.Set.t;
send : param -> Tezos_base__TzPervasives.P2p_peer.Id.t -> (list key) -> unit;
}.
Arguments signature : clear implicits.
End REQUEST.
(* ❌ Functors are not handled. *)
functor
src/lib_shell/distributed_db_message.ml 11 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Bounded_encoding = struct
open Data_encoding
let block_header_max_size = ref (Some (8 * 1024 * 1024))
(* FIXME: arbitrary *)
let block_header_cache =
ref (Block_header.bounded_encoding ?max_size:!block_header_max_size ())
let block_locator_cache =
ref
(Block_locator.bounded_encoding
?max_header_size:!block_header_max_size
())
let update_block_header_encoding () =
block_header_cache :=
Block_header.bounded_encoding ?max_size:!block_header_max_size () ;
block_locator_cache :=
Block_locator.bounded_encoding ?max_header_size:!block_header_max_size ()
let set_block_header_max_size max =
block_header_max_size := max ;
update_block_header_encoding ()
let block_header = delayed (fun () -> !block_header_cache)
let block_locator = delayed (fun () -> !block_locator_cache)
(* FIXME: all constants below are arbitrary high bounds until we
have the mechanism to update them properly *)
let operation_max_size = ref (Some (128 * 1024)) (* FIXME: arbitrary *)
let operation_list_max_size = ref (Some (1024 * 1024)) (* FIXME: arbitrary *)
let operation_list_max_length = ref None (* FIXME: arbitrary *)
let operation_max_pass = ref (Some 8) (* FIXME: arbitrary *)
let operation_cache =
ref (Operation.bounded_encoding ?max_size:!operation_max_size ())
let operation_list_cache =
ref
(Operation.bounded_list_encoding
?max_length:!operation_list_max_length
?max_size:!operation_list_max_size
?max_operation_size:!operation_max_size
?max_pass:!operation_max_pass
())
let operation_hash_list_cache =
ref
(Operation.bounded_hash_list_encoding
?max_length:!operation_list_max_length
?max_pass:!operation_max_pass
())
let update_operation_list_encoding () =
operation_list_cache :=
Operation.bounded_list_encoding
?max_length:!operation_list_max_length
?max_size:!operation_list_max_size
?max_operation_size:!operation_max_size
?max_pass:!operation_max_pass
()
let update_operation_hash_list_encoding () =
operation_list_cache :=
Operation.bounded_list_encoding
?max_length:!operation_list_max_length
?max_pass:!operation_max_pass
()
let update_operation_encoding () =
operation_cache :=
Operation.bounded_encoding ?max_size:!operation_max_size ()
let set_operation_max_size max =
operation_max_size := max ;
update_operation_encoding () ;
update_operation_list_encoding ()
let set_operation_list_max_size max =
operation_list_max_size := max ;
update_operation_list_encoding ()
let set_operation_list_max_length max =
operation_list_max_length := max ;
update_operation_list_encoding () ;
update_operation_hash_list_encoding ()
let set_operation_max_pass max =
operation_max_pass := max ;
update_operation_list_encoding () ;
update_operation_hash_list_encoding ()
let operation = delayed (fun () -> !operation_cache)
let operation_list = delayed (fun () -> !operation_list_cache)
let operation_hash_list = delayed (fun () -> !operation_hash_list_cache)
let protocol_max_size = ref (Some (2 * 1024 * 1024)) (* FIXME: arbitrary *)
let protocol_cache =
ref (Protocol.bounded_encoding ?max_size:!protocol_max_size ())
let set_protocol_max_size max = protocol_max_size := max
let protocol = delayed (fun () -> !protocol_cache)
let mempool_max_operations = ref None
let mempool_cache =
ref (Mempool.bounded_encoding ?max_operations:!mempool_max_operations ())
let set_mempool_max_operations max = mempool_max_operations := max
let mempool = delayed (fun () -> !mempool_cache)
end
type t =
| Get_current_branch of Chain_id.t
| Current_branch of Chain_id.t * Block_locator.t
| Deactivate of Chain_id.t
| Get_current_head of Chain_id.t
| Current_head of Chain_id.t * Block_header.t * Mempool.t
| Get_block_headers of Block_hash.t list
| Block_header of Block_header.t
| Get_operations of Operation_hash.t list
| Operation of Operation.t
| Get_protocols of Protocol_hash.t list
| Protocol of Protocol.t
| Get_operation_hashes_for_blocks of (Block_hash.t * int) list
| Operation_hashes_for_block of
Block_hash.t
* int
* Operation_hash.t list
* Operation_list_list_hash.path
| Get_operations_for_blocks of (Block_hash.t * int) list
| Operations_for_block of
Block_hash.t * int * Operation.t list * Operation_list_list_hash.path
let encoding =
let open Data_encoding in
let case ?max_length ~tag ~title encoding unwrap wrap =
P2p_message.Encoding {tag; title; encoding; wrap; unwrap; max_length}
in
[ case
~tag:0x10
~title:"Get_current_branch"
(obj1 (req "get_current_branch" Chain_id.encoding))
(function Get_current_branch chain_id -> Some chain_id | _ -> None)
(fun chain_id -> Get_current_branch chain_id);
case
~tag:0x11
~title:"Current_branch"
(obj2
(req "chain_id" Chain_id.encoding)
(req "current_branch" Bounded_encoding.block_locator))
(function
| Current_branch (chain_id, locator) ->
Some (chain_id, locator)
| _ ->
None)
(fun (chain_id, locator) -> Current_branch (chain_id, locator));
case
~tag:0x12
~title:"Deactivate"
(obj1 (req "deactivate" Chain_id.encoding))
(function Deactivate chain_id -> Some chain_id | _ -> None)
(fun chain_id -> Deactivate chain_id);
case
~tag:0x13
~title:"Get_current_head"
(obj1 (req "get_current_head" Chain_id.encoding))
(function Get_current_head chain_id -> Some chain_id | _ -> None)
(fun chain_id -> Get_current_head chain_id);
case
~tag:0x14
~title:"Current_head"
(obj3
(req "chain_id" Chain_id.encoding)
(req
"current_block_header"
(dynamic_size Bounded_encoding.block_header))
(req "current_mempool" Bounded_encoding.mempool))
(function
| Current_head (chain_id, bh, mempool) ->
Some (chain_id, bh, mempool)
| _ ->
None)
(fun (chain_id, bh, mempool) -> Current_head (chain_id, bh, mempool));
case
~tag:0x20
~title:"Get_block_headers"
(obj1 (req "get_block_headers" (list ~max_length:10 Block_hash.encoding)))
(function Get_block_headers bhs -> Some bhs | _ -> None)
(fun bhs -> Get_block_headers bhs);
case
~tag:0x21
~title:"Block_header"
(obj1 (req "block_header" Bounded_encoding.block_header))
(function Block_header bh -> Some bh | _ -> None)
(fun bh -> Block_header bh);
case
~tag:0x30
~title:"Get_operations"
(obj1
(req "get_operations" (list ~max_length:10 Operation_hash.encoding)))
(function Get_operations bhs -> Some bhs | _ -> None)
(fun bhs -> Get_operations bhs);
case
~tag:0x31
~title:"Operation"
(obj1 (req "operation" Bounded_encoding.operation))
(function Operation o -> Some o | _ -> None)
(fun o -> Operation o);
case
~tag:0x40
~title:"Get_protocols"
(obj1 (req "get_protocols" (list ~max_length:10 Protocol_hash.encoding)))
(function Get_protocols protos -> Some protos | _ -> None)
(fun protos -> Get_protocols protos);
case
~tag:0x41
~title:"Protocol"
(obj1 (req "protocol" Bounded_encoding.protocol))
(function Protocol proto -> Some proto | _ -> None)
(fun proto -> Protocol proto);
case
~tag:0x50
~title:"Get_operation_hashes_for_blocks"
(obj1
(req
"get_operation_hashes_for_blocks"
(list ~max_length:10 (tup2 Block_hash.encoding int8))))
(function
| Get_operation_hashes_for_blocks keys -> Some keys | _ -> None)
(fun keys -> Get_operation_hashes_for_blocks keys);
case
~tag:0x51
~title:"Operation_hashes_for_blocks"
(merge_objs
(obj1
(req
"operation_hashes_for_block"
(obj2
(req "hash" Block_hash.encoding)
(req "validation_pass" int8))))
Bounded_encoding.operation_hash_list)
(function
| Operation_hashes_for_block (block, ofs, ops, path) ->
Some ((block, ofs), (path, ops))
| _ ->
None)
(fun ((block, ofs), (path, ops)) ->
Operation_hashes_for_block (block, ofs, ops, path));
case
~tag:0x60
~title:"Get_operations_for_blocks"
(obj1
(req
"get_operations_for_blocks"
(list
~max_length:10
(obj2
(req "hash" Block_hash.encoding)
(req "validation_pass" int8)))))
(function Get_operations_for_blocks keys -> Some keys | _ -> None)
(fun keys -> Get_operations_for_blocks keys);
case
~tag:0x61
~title:"Operations_for_blocks"
(merge_objs
(obj1
(req
"operations_for_block"
(obj2
(req "hash" Block_hash.encoding)
(req "validation_pass" int8))))
Bounded_encoding.operation_list)
(function
| Operations_for_block (block, ofs, ops, path) ->
Some ((block, ofs), (path, ops))
| _ ->
None)
(fun ((block, ofs), (path, ops)) ->
Operations_for_block (block, ofs, ops, path)) ]
let cfg : _ P2p.message_config =
{
encoding;
chain_name = Distributed_db_version.chain_name;
distributed_db_versions = [Distributed_db_version.zero];
}
let raw_encoding = P2p_message.encoding encoding
let pp_json ppf msg =
Data_encoding.Json.pp
ppf
(Data_encoding.Json.construct raw_encoding (Message msg))
module Logging = struct
let tag = Tag.def ~doc:"Message" "message" pp_json
end
src/lib_shell/distributed_db_message.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Bounded_encoding.
Import Data_encoding.
Definition block_header_max_size : Stdlib.ref (option Z) :=
Stdlib.ref (Some (Z.mul (Z.mul 8 1024) 1024)).
Definition block_header_cache
: Stdlib.ref
(Tezos_data_encoding.Data_encoding.t
Tezos_base__TzPervasives.Block_header.t) :=
Stdlib.ref
(Block_header.bounded_encoding
(Stdlib.op_exclamation block_header_max_size) tt).
Definition block_locator_cache
: Stdlib.ref
(Tezos_data_encoding.Data_encoding.t
Tezos_base__TzPervasives.Block_locator.t) :=
Stdlib.ref
(Block_locator.bounded_encoding
(Stdlib.op_exclamation block_header_max_size) None tt).
Definition update_block_header_encoding (function_parameter : unit) : unit :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq block_header_cache
(Block_header.bounded_encoding
(Stdlib.op_exclamation block_header_max_size) tt) in
Stdlib.op_coloneq block_locator_cache
(Block_locator.bounded_encoding
(Stdlib.op_exclamation block_header_max_size) None tt).
Definition set_block_header_max_size (max : option Z) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq block_header_max_size max in
update_block_header_encoding tt.
Definition block_header
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_base__TzPervasives.Block_header.t :=
delayed
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_exclamation block_header_cache).
Definition block_locator
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_base__TzPervasives.Block_locator.t :=
delayed
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_exclamation block_locator_cache).
Definition operation_max_size : Stdlib.ref (option Z) :=
Stdlib.ref (Some (Z.mul 128 1024)).
Definition operation_list_max_size : Stdlib.ref (option Z) :=
Stdlib.ref (Some (Z.mul 1024 1024)).
Definition operation_list_max_length : Stdlib.ref (option Z) :=
Stdlib.ref None.
Definition operation_max_pass : Stdlib.ref (option Z) := Stdlib.ref (Some 8).
Definition operation_cache
: Stdlib.ref
(Tezos_data_encoding.Data_encoding.t Tezos_base__TzPervasives.Operation.t) :=
Stdlib.ref
(Operation.bounded_encoding (Stdlib.op_exclamation operation_max_size) tt).
Definition operation_list_cache
: Stdlib.ref
(Tezos_data_encoding.Data_encoding.t
(Tezos_crypto.Operation_list_list_hash.path *
(list Tezos_base__TzPervasives.Operation.t))) :=
Stdlib.ref
(Operation.bounded_list_encoding
(Stdlib.op_exclamation operation_list_max_length)
(Stdlib.op_exclamation operation_list_max_size)
(Stdlib.op_exclamation operation_max_size)
(Stdlib.op_exclamation operation_max_pass) tt).
Definition operation_hash_list_cache
: Stdlib.ref
(Tezos_data_encoding.Data_encoding.t
(Tezos_crypto.Operation_list_list_hash.path *
(list Tezos_crypto.Operation_hash.t))) :=
Stdlib.ref
(Operation.bounded_hash_list_encoding
(Stdlib.op_exclamation operation_list_max_length)
(Stdlib.op_exclamation operation_max_pass) tt).
Definition update_operation_list_encoding (function_parameter : unit)
: unit :=
let 'tt := function_parameter in
Stdlib.op_coloneq operation_list_cache
(Operation.bounded_list_encoding
(Stdlib.op_exclamation operation_list_max_length)
(Stdlib.op_exclamation operation_list_max_size)
(Stdlib.op_exclamation operation_max_size)
(Stdlib.op_exclamation operation_max_pass) tt).
Definition update_operation_hash_list_encoding (function_parameter : unit)
: unit :=
let 'tt := function_parameter in
Stdlib.op_coloneq operation_list_cache
(Operation.bounded_list_encoding
(Stdlib.op_exclamation operation_list_max_length) None None
(Stdlib.op_exclamation operation_max_pass) tt).
Definition update_operation_encoding (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Stdlib.op_coloneq operation_cache
(Operation.bounded_encoding (Stdlib.op_exclamation operation_max_size) tt).
Definition set_operation_max_size (max : option Z) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq operation_max_size max in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := update_operation_encoding tt in
update_operation_list_encoding tt.
Definition set_operation_list_max_size (max : option Z) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq operation_list_max_size max in
update_operation_list_encoding tt.
Definition set_operation_list_max_length (max : option Z) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq operation_list_max_length max in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := update_operation_list_encoding tt in
update_operation_hash_list_encoding tt.
Definition set_operation_max_pass (max : option Z) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq operation_max_pass max in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := update_operation_list_encoding tt in
update_operation_hash_list_encoding tt.
Definition operation
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_base__TzPervasives.Operation.t :=
delayed
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_exclamation operation_cache).
Definition operation_list
: Tezos_base__TzPervasives.Data_encoding.encoding
(Tezos_crypto.Operation_list_list_hash.path *
(list Tezos_base__TzPervasives.Operation.t)) :=
delayed
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_exclamation operation_list_cache).
Definition operation_hash_list
: Tezos_base__TzPervasives.Data_encoding.encoding
(Tezos_crypto.Operation_list_list_hash.path *
(list Tezos_crypto.Operation_hash.t)) :=
delayed
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_exclamation operation_hash_list_cache).
Definition protocol_max_size : Stdlib.ref (option Z) :=
Stdlib.ref (Some (Z.mul (Z.mul 2 1024) 1024)).
Definition protocol_cache
: Stdlib.ref
(Tezos_data_encoding.Data_encoding.t Tezos_base__TzPervasives.Protocol.t) :=
Stdlib.ref
(Protocol.bounded_encoding (Stdlib.op_exclamation protocol_max_size) tt).
Definition set_protocol_max_size (max : option Z) : unit :=
Stdlib.op_coloneq protocol_max_size max.
Definition protocol
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_base__TzPervasives.Protocol.t :=
delayed
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_exclamation protocol_cache).
Definition mempool_max_operations : Stdlib.ref (option Z) := Stdlib.ref None.
Definition mempool_cache
: Stdlib.ref
(Tezos_data_encoding.Data_encoding.t
Tezos_base__TzPervasives.Mempool.mempool) :=
Stdlib.ref
(Mempool.bounded_encoding (Stdlib.op_exclamation mempool_max_operations)
tt).
Definition set_mempool_max_operations (max : option Z) : unit :=
Stdlib.op_coloneq mempool_max_operations max.
Definition mempool
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_base__TzPervasives.Mempool.mempool :=
delayed
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_exclamation mempool_cache).
End Bounded_encoding.
Inductive t : Type :=
| Get_current_branch : Tezos_base__TzPervasives.Chain_id.t -> t
| Current_branch : Tezos_base__TzPervasives.Chain_id.t ->
Tezos_base__TzPervasives.Block_locator.t -> t
| Deactivate : Tezos_base__TzPervasives.Chain_id.t -> t
| Get_current_head : Tezos_base__TzPervasives.Chain_id.t -> t
| Current_head : Tezos_base__TzPervasives.Chain_id.t ->
Tezos_base__TzPervasives.Block_header.t -> Tezos_base__TzPervasives.Mempool.t
-> t
| Get_block_headers : (list Tezos_base__TzPervasives.Block_hash.t) -> t
| Block_header : Tezos_base__TzPervasives.Block_header.t -> t
| Get_operations : (list Tezos_base__TzPervasives.Operation_hash.t) -> t
| Operation : Tezos_base__TzPervasives.Operation.t -> t
| Get_protocols : (list Tezos_base__TzPervasives.Protocol_hash.t) -> t
| Protocol : Tezos_base__TzPervasives.Protocol.t -> t
| Get_operation_hashes_for_blocks :
(list (Tezos_base__TzPervasives.Block_hash.t * Z)) -> t
| Operation_hashes_for_block : Tezos_base__TzPervasives.Block_hash.t -> Z ->
(list Tezos_base__TzPervasives.Operation_hash.t) ->
Tezos_base__TzPervasives.Operation_list_list_hash.path -> t
| Get_operations_for_blocks : (list (Tezos_base__TzPervasives.Block_hash.t * Z))
-> t
| Operations_for_block : Tezos_base__TzPervasives.Block_hash.t -> Z ->
(list Tezos_base__TzPervasives.Operation.t) ->
Tezos_base__TzPervasives.Operation_list_list_hash.path -> t.
Definition encoding : list (Tezos_p2p.P2p_message.encoding t) :=
let case {A B : Type}
(max_length : option Z) (tag : Z) (title : string) (encoding :
Tezos_base__TzPervasives.Data_encoding.t A) (unwrap : B -> option A) (wrap :
A -> B) : Tezos_p2p.P2p_message.encoding B :=
Tezos_p2p.P2p_message.Encoding
{| tag := tag; title := title; encoding := encoding; wrap := wrap;
unwrap := unwrap; max_length := max_length |} in
cons
(case None 16 "Get_current_branch" % string
(obj1 (req None None "get_current_branch" % string Chain_id.encoding))
(fun function_parameter =>
match function_parameter with
| Get_current_branch chain_id => Some chain_id
| _ => None
end) (fun chain_id => Get_current_branch chain_id))
(cons
(case None 17 "Current_branch" % string
(obj2 (req None None "chain_id" % string Chain_id.encoding)
(req None None "current_branch" % string
Bounded_encoding.block_locator))
(fun function_parameter =>
match function_parameter with
| Current_branch chain_id locator => Some (chain_id, locator)
| _ => None
end)
(fun function_parameter =>
let '(chain_id, locator) := function_parameter in
Current_branch chain_id locator))
(cons
(case None 18 "Deactivate" % string
(obj1 (req None None "deactivate" % string Chain_id.encoding))
(fun function_parameter =>
match function_parameter with
| Deactivate chain_id => Some chain_id
| _ => None
end) (fun chain_id => Deactivate chain_id))
(cons
(case None 19 "Get_current_head" % string
(obj1 (req None None "get_current_head" % string Chain_id.encoding))
(fun function_parameter =>
match function_parameter with
| Get_current_head chain_id => Some chain_id
| _ => None
end) (fun chain_id => Get_current_head chain_id))
(cons
(case None 20 "Current_head" % string
(obj3 (req None None "chain_id" % string Chain_id.encoding)
(req None None "current_block_header" % string
(dynamic_size None Bounded_encoding.block_header))
(req None None "current_mempool" % string
Bounded_encoding.mempool))
(fun function_parameter =>
match function_parameter with
| Current_head chain_id bh mempool =>
Some (chain_id, bh, mempool)
| _ => None
end)
(fun function_parameter =>
let '(chain_id, bh, mempool) := function_parameter in
Current_head chain_id bh mempool))
(cons
(case None 32 "Get_block_headers" % string
(obj1
(req None None "get_block_headers" % string
(list (Some 10) Block_hash.encoding)))
(fun function_parameter =>
match function_parameter with
| Get_block_headers bhs => Some bhs
| _ => None
end) (fun bhs => Get_block_headers bhs))
(cons
(case None 33 "Block_header" % string
(obj1
(req None None "block_header" % string
Bounded_encoding.block_header))
(fun function_parameter =>
match function_parameter with
| Block_header bh => Some bh
| _ => None
end) (fun bh => Block_header bh))
(cons
(case None 48 "Get_operations" % string
(obj1
(req None None "get_operations" % string
(list (Some 10) Operation_hash.encoding)))
(fun function_parameter =>
match function_parameter with
| Get_operations bhs => Some bhs
| _ => None
end) (fun bhs => Get_operations bhs))
(cons
(case None 49 "Operation" % string
(obj1
(req None None "operation" % string
Bounded_encoding.operation))
(fun function_parameter =>
match function_parameter with
| Operation o => Some o
| _ => None
end) (fun o => Operation o))
(cons
(case None 64 "Get_protocols" % string
(obj1
(req None None "get_protocols" % string
(list (Some 10) Protocol_hash.encoding)))
(fun function_parameter =>
match function_parameter with
| Get_protocols protos => Some protos
| _ => None
end) (fun protos => Get_protocols protos))
(cons
(case None 65 "Protocol" % string
(obj1
(req None None "protocol" % string
Bounded_encoding.protocol))
(fun function_parameter =>
match function_parameter with
| Protocol proto => Some proto
| _ => None
end) (fun proto => Protocol proto))
(cons
(case None 80
"Get_operation_hashes_for_blocks" % string
(obj1
(req None None
"get_operation_hashes_for_blocks" % string
(list (Some 10) (tup2 Block_hash.encoding int8))))
(fun function_parameter =>
match function_parameter with
| Get_operation_hashes_for_blocks keys =>
Some keys
| _ => None
end)
(fun keys => Get_operation_hashes_for_blocks keys))
(cons
(case None 81 "Operation_hashes_for_blocks" % string
(merge_objs
(obj1
(req None None
"operation_hashes_for_block" % string
(obj2
(req None None "hash" % string
Block_hash.encoding)
(req None None "validation_pass" % string
int8))))
Bounded_encoding.operation_hash_list)
(fun function_parameter =>
match function_parameter with
| Operation_hashes_for_block block ofs ops path
=> Some ((block, ofs), (path, ops))
| _ => None
end)
(fun function_parameter =>
let '((block, ofs), (path, ops)) :=
function_parameter in
Operation_hashes_for_block block ofs ops path))
(cons
(case None 96 "Get_operations_for_blocks" % string
(obj1
(req None None
"get_operations_for_blocks" % string
(list (Some 10)
(obj2
(req None None "hash" % string
Block_hash.encoding)
(req None None
"validation_pass" % string int8)))))
(fun function_parameter =>
match function_parameter with
| Get_operations_for_blocks keys => Some keys
| _ => None
end)
(fun keys => Get_operations_for_blocks keys))
(cons
(case None 97 "Operations_for_blocks" % string
(merge_objs
(obj1
(req None None
"operations_for_block" % string
(obj2
(req None None "hash" % string
Block_hash.encoding)
(req None None
"validation_pass" % string int8))))
Bounded_encoding.operation_list)
(fun function_parameter =>
match function_parameter with
| Operations_for_block block ofs ops path =>
Some ((block, ofs), (path, ops))
| _ => None
end)
(fun function_parameter =>
let '((block, ofs), (path, ops)) :=
function_parameter in
Operations_for_block block ofs ops path)) [])))))))))))))).
Definition cfg : Tezos_p2p.P2p.message_config t :=
{| encoding := encoding; chain_name := Distributed_db_version.chain_name;
distributed_db_versions := cons Distributed_db_version.zero [] |}.
Definition raw_encoding
: Tezos_base__TzPervasives.Data_encoding.t (Tezos_p2p.P2p_message.t t) :=
P2p_message.encoding encoding.
Definition pp_json (ppf : Stdlib.Format.formatter) (msg : t) : unit :=
Data_encoding.Json.pp ppf
(Data_encoding.Json.construct raw_encoding
(Tezos_p2p.P2p_message.Message msg)).
Module Logging.
Definition tag : Tezos_base__TzPervasives.Tag.def t :=
Tag.def (Some "Message" % string) "message" % string pp_json.
End Logging.
src/lib_shell/injection_directory.ml 16 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let read_chain_id validator chain =
let distributed_db = Validator.distributed_db validator in
let state = Distributed_db.state distributed_db in
match chain with
| None ->
Lwt.return_none
| Some chain ->
Chain_directory.get_chain_id state chain >>= Lwt.return_some
let inject_block validator ?force ?chain bytes operations =
read_chain_id validator chain
>>= fun chain_id ->
Validator.validate_block validator ?force ?chain_id bytes operations
>>=? fun (hash, block) -> return (hash, block >>=? fun _ -> return_unit)
let inject_operation validator ?chain bytes =
read_chain_id validator chain
>>= fun chain_id ->
let t =
match Data_encoding.Binary.of_bytes Operation.encoding bytes with
| None ->
failwith "Can't parse the operation"
| Some op ->
Validator.inject_operation validator ?chain_id op
in
let hash = Operation_hash.hash_bytes [bytes] in
Lwt.return (hash, t)
let inject_protocol state proto =
let proto_bytes =
Data_encoding.Binary.to_bytes_exn Protocol.encoding proto
in
let hash = Protocol_hash.hash_bytes [proto_bytes] in
let validation =
Updater.compile hash proto
>>= function
| false ->
failwith "Compilation failed (%a)" Protocol_hash.pp_short hash
| true -> (
State.Protocol.store state proto
>>= function
| None ->
failwith
"Previously registered protocol (%a)"
Protocol_hash.pp_short
hash
| Some _ ->
return_unit )
in
Lwt.return (hash, validation)
let build_rpc_directory validator =
let distributed_db = Validator.distributed_db validator in
let state = Distributed_db.state distributed_db in
let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
let register0 s f =
dir := RPC_directory.register !dir s (fun () p q -> f p q)
in
register0 Injection_services.S.block (fun q (raw, operations) ->
inject_block validator ?chain:q#chain ~force:q#force raw operations
>>=? fun (hash, wait) ->
(if q#async then return_unit else wait) >>=? fun () -> return hash) ;
register0 Injection_services.S.operation (fun q contents ->
inject_operation validator ?chain:q#chain contents
>>= fun (hash, wait) ->
(if q#async then return_unit else wait) >>=? fun () -> return hash) ;
register0 Injection_services.S.protocol (fun q protocol ->
inject_protocol state protocol
>>= fun (hash, wait) ->
(if q#async then return_unit else wait) >>=? fun () -> return hash) ;
!dir
src/lib_shell/injection_directory.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition read_chain_id
(validator : Tezos_shell.Validator.t)
(chain : option Tezos_shell_services.Chain_services.chain)
: Lwt.t (option Tezos_base__TzPervasives.Chain_id.t) :=
let distributed_db := Validator.distributed_db validator in
let state := Distributed_db.state distributed_db in
match chain with
| None => Lwt.return_none
| Some chain =>
op_gtgteq (Chain_directory.get_chain_id state chain) Lwt.return_some
end.
Definition inject_block
(validator : Tezos_shell.Validator.t) (force : option bool)
(chain : option Tezos_shell_services.Chain_services.chain)
(bytes : Stdlib.Bytes.t)
(operations : list (list Tezos_base__TzPervasives.Operation.t))
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Block_hash.t *
(Lwt.t (Tezos_base__TzPervasives.tzresult unit)))) :=
op_gtgteq (read_chain_id validator chain)
(fun chain_id =>
op_gtgteqquestion
(Validator.validate_block validator force chain_id string operations)
(fun function_parameter =>
let '(hash, block) := function_parameter in
_return
(hash,
(op_gtgteqquestion block
(fun function_parameter =>
let '_ := function_parameter in
return_unit))))).
Definition inject_operation
(validator : Tezos_shell.Validator.t)
(chain : option Tezos_shell_services.Chain_services.chain)
(bytes : Stdlib.Bytes.t)
: Lwt.t
(Tezos_base__TzPervasives.Operation_hash.t *
(Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
op_gtgteq (read_chain_id validator chain)
(fun chain_id =>
let t :=
match Data_encoding.Binary.of_bytes Operation.encoding string with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Can't parse the operation" % string
CamlinternalFormatBasics.End_of_format)
"Can't parse the operation" % string)
| Some op => Validator.inject_operation validator chain_id op
end in
let hash := Operation_hash.hash_bytes None (cons string []) in
Lwt._return (hash, t)).
Definition inject_protocol
(state : Tezos_shell__State.global_state)
(proto : Tezos_base__TzPervasives.Protocol.t)
: Lwt.t
(Tezos_base__TzPervasives.Protocol_hash.t *
(Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
let proto_bytes := Data_encoding.Binary.to_bytes_exn Protocol.encoding proto
in
let hash := Protocol_hash.hash_bytes None (cons proto_bytes []) in
let validation :=
op_gtgteq (Updater.compile hash proto)
(fun function_parameter =>
match function_parameter with
| false =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Compilation failed (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"Compilation failed (%a)" % string) Protocol_hash.pp_short hash
| true =>
op_gtgteq (State.Protocol.store state proto)
(fun function_parameter =>
match function_parameter with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Previously registered protocol (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"Previously registered protocol (%a)" % string)
Protocol_hash.pp_short hash
| Some _ => return_unit
end)
end) in
Lwt._return (hash, validation).
Definition build_rpc_directory (validator : Tezos_shell.Validator.t)
: Tezos_base__TzPervasives.RPC_directory.t unit :=
let distributed_db := Validator.distributed_db validator in
let state := Distributed_db.state distributed_db in
let dir := Stdlib.ref RPC_directory.empty in
let register0 {A B C : Type}
(s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
A -> B -> Lwt.t (Tezos_error_monad.Error_monad.tzresult C)) : unit :=
Stdlib.op_coloneq dir
(RPC_directory.register (Stdlib.op_exclamation dir) s
(fun function_parameter =>
let 'tt := function_parameter in
fun p => fun q => f p q)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 Injection_services.S.block
(fun q =>
fun function_parameter =>
let '(raw, operations) := function_parameter in
op_gtgteqquestion
(inject_block validator
(Some
(* ❌ Sending method message is not handled *)
send)
(* ❌ Sending method message is not handled *)
send raw operations)
(fun function_parameter =>
let '(hash, wait) := function_parameter in
op_gtgteqquestion
(if
(* ❌ Sending method message is not handled *)
send then
return_unit
else
wait)
(fun function_parameter =>
let 'tt := function_parameter in
_return hash))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 Injection_services.S.operation
(fun q =>
fun contents =>
op_gtgteq
(inject_operation validator
(* ❌ Sending method message is not handled *)
send contents)
(fun function_parameter =>
let '(hash, wait) := function_parameter in
op_gtgteqquestion
(if
(* ❌ Sending method message is not handled *)
send then
return_unit
else
wait)
(fun function_parameter =>
let 'tt := function_parameter in
_return hash))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 Injection_services.S.protocol
(fun q =>
fun protocol =>
op_gtgteq (inject_protocol state protocol)
(fun function_parameter =>
let '(hash, wait) := function_parameter in
op_gtgteqquestion
(if
(* ❌ Sending method message is not handled *)
send then
return_unit
else
wait)
(fun function_parameter =>
let 'tt := function_parameter in
_return hash))) in
Stdlib.op_exclamation dir.
src/lib_shell/mempool_peer_worker.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Validating batches of operations with some peer-based
* compartimentatilsation. *)
type limits = {
max_promises_per_request : int;
worker_limits : Worker_types.limits;
}
module type T = sig
module Mempool_worker : Mempool_worker.T
type t
type input = Operation_hash.t list
val create : limits -> P2p_peer.Id.t -> Mempool_worker.t -> t tzresult Lwt.t
val shutdown : t -> input Lwt.t
val validate : t -> input -> unit tzresult Lwt.t
end
module type STATIC = sig
val max_pending_requests : int
end
module Make (Static : STATIC) (Mempool_worker : Mempool_worker.T) :
T with module Mempool_worker = Mempool_worker = struct
(* 0. Prelude: set up base modules and types *)
(* See interface file for info if needed. *)
module Proto = Mempool_worker.Proto
module Mempool_worker = Mempool_worker
type input = Operation_hash.t list
type result =
| Cannot_download of error list
| Cannot_parse of error list
| Cannot_validate of error list
| Mempool_result of Mempool_worker.result
type output = result Operation_hash.Map.t
let pp_input ppf input =
Format.fprintf
ppf
"@[<v 0>%a@]"
(Format.pp_print_list Operation_hash.pp)
input
let result_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Cannot download"
(obj1 (req "download_errors" (list Error_monad.error_encoding)))
(function Cannot_download errs -> Some errs | _ -> None)
(fun errs -> Cannot_download errs);
case
(Tag 1)
~title:"Cannot parse"
(obj1 (req "parse_errors" (list Error_monad.error_encoding)))
(function Cannot_parse errs -> Some errs | _ -> None)
(fun errs -> Cannot_parse errs);
case
(Tag 2)
~title:"Cannot validate"
(obj1 (req "validation_errors" (list Error_monad.error_encoding)))
(function Cannot_validate errs -> Some errs | _ -> None)
(fun errs -> Cannot_validate errs);
case
(Tag 3)
~title:"Validation result"
(obj1 (req "validation_result" Mempool_worker.result_encoding))
(function Mempool_result result -> Some result | _ -> None)
(fun result -> Mempool_result result) ]
module Log = Internal_event.Legacy_logging.Make (struct
let name = "node.mempool.peer_worker"
end)
(* 1. Core: the carefully scheduled work performed by the worker *)
module Work : sig
val process_batch : Mempool_worker.t -> int -> input -> output Lwt.t
end = struct
type t = {
pool : unit Lwt_pool.t;
received : Operation_hash.t Queue.t;
downloading : (Operation_hash.t * Operation.t tzresult Lwt.t) Queue.t;
applying :
(Mempool_worker.operation * Mempool_worker.result tzresult Lwt.t)
Queue.t;
mutable results : result Operation_hash.Map.t;
}
(* Primitives *)
let is_empty t =
Queue.is_empty t.received
&& Queue.is_empty t.downloading
&& Queue.is_empty t.applying
let has_resolved t =
match Lwt.state t with
| Lwt.Return _ | Lwt.Fail _ ->
true
| Lwt.Sleep ->
false
let head_is_resolved q =
(not (Queue.is_empty q)) && has_resolved (snd (Queue.peek q))
let select t =
(* A `select`-like function to wait on any of the pipeline's buffers'
* heads to resolve *)
assert (not (Queue.is_empty t.downloading && Queue.is_empty t.applying)) ;
let first_task_or_never q =
if Queue.is_empty q then Lwt_utils.never_ending ()
else snd (Queue.peek q) >>= fun _ -> Lwt.return_unit
in
Lwt.choose
[first_task_or_never t.downloading; first_task_or_never t.applying]
let record_result pipeline op_hash result =
pipeline.results <-
Operation_hash.Map.add op_hash result pipeline.results
let q_of_list l =
let q = Queue.create () in
List.iter (fun x -> Queue.add x q) l ;
q
let create pool_size op_hashes =
{
pool = Lwt_pool.create pool_size Lwt.return;
received = q_of_list op_hashes;
downloading = Queue.create ();
applying = Queue.create ();
results = Operation_hash.Map.empty;
}
let cancel pipeline =
let cancel_snd (_, p) = Lwt.cancel p in
Queue.iter cancel_snd pipeline.downloading ;
Queue.iter cancel_snd pipeline.applying
(* Exported interactions *)
let step mempool_worker pipeline =
(* Going through each buffer one by one. *)
(* op_hash: Opertation_hash.t
* op: Operation.t
* mop: Mempool_worker.operation *)
if head_is_resolved pipeline.applying then (
let (op, p) = Queue.pop pipeline.applying in
p
>>= function
| Error errs ->
record_result pipeline op.hash (Cannot_validate errs) ;
Lwt.return_unit
| Ok mempool_result ->
record_result pipeline op.hash (Mempool_result mempool_result) ;
Lwt.return_unit )
else if head_is_resolved pipeline.downloading then
let (op_hash, p) = Queue.pop pipeline.downloading in
p
>>= function
| Error errs ->
record_result pipeline op_hash (Cannot_download errs) ;
Lwt.return_unit
| Ok op -> (
match Mempool_worker.parse op with
| Error errs ->
record_result pipeline op_hash (Cannot_parse errs) ;
Lwt.return_unit
| Ok mop ->
let p =
Lwt_pool.use pipeline.pool (fun () ->
Mempool_worker.validate mempool_worker mop)
in
Queue.push (mop, p) pipeline.applying ;
Lwt.return_unit )
else if not (Queue.is_empty pipeline.received) then (
let op_hash = Queue.pop pipeline.received in
(* TODO[?] should we specify the current peer for fetching? *)
let chain_db = Mempool_worker.chain_db mempool_worker in
let p =
Lwt_pool.use pipeline.pool (fun () ->
Distributed_db.Operation.fetch chain_db op_hash ())
in
Queue.push (op_hash, p) pipeline.downloading ;
Lwt.return_unit )
else
(* There are some pending operations, we need to wait on them *)
select pipeline
let process_batch mempool_worker pool_size input =
let pipeline = create pool_size input in
let rec loop () =
if is_empty pipeline then Lwt.return pipeline.results
else step mempool_worker pipeline >>= fun () -> loop ()
in
let work = loop () in
Lwt.on_cancel work (fun () -> cancel pipeline) ;
work
end
(* 2. Boilerplate: the set up for the worker architecture *)
module Name = struct
type t = P2p_peer.Id.t
let encoding = P2p_peer.Id.encoding
let base =
let proto_hash =
let (_ : string) = Format.flush_str_formatter () in
Format.fprintf Format.str_formatter "%a" Protocol_hash.pp Proto.hash ;
Format.flush_str_formatter ()
in
["node"; "mempool"; "peer_worker"; proto_hash]
let pp = P2p_peer.Id.pp
end
module Request = struct
type 'a t = Batch : input -> output t
type view = input
let view : type a. a t -> view = fun (Batch os) -> os
let encoding =
let open Data_encoding in
list Operation_hash.encoding
let pp ppf = function
| [] ->
Format.fprintf ppf "@[<v 2>Request:@, Empty List of Operations@]"
| os ->
Format.fprintf
ppf
"@[<v 2>Request:@,%a@]"
(Format.pp_print_list Operation_hash.pp)
os
end
module Event = struct
type t =
| Start of input
| End_ok of (Request.view * Worker_types.request_status * output)
| End_error of (Request.view * Worker_types.request_status * error list)
let level req =
let open Internal_event in
match req with
| Start _ ->
Info
| End_ok _ ->
Info
| End_error _ ->
Error
let encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Start"
(obj1 (req "input" (list Operation_hash.encoding)))
(function Start input -> Some input | _ -> None)
(fun input -> Start input);
case
(Tag 1)
~title:"End_ok"
(obj3
(req "request" Request.encoding)
(req "status" Worker_types.request_status_encoding)
(req "output" (Operation_hash.Map.encoding result_encoding)))
(function
| End_ok (view, status, result) ->
Some (view, status, result)
| _ ->
None)
(fun (view, status, result) -> End_ok (view, status, result));
case
(Tag 2)
~title:"End_error"
(obj3
(req "failed_request" Request.encoding)
(req "status" Worker_types.request_status_encoding)
(req "error" RPC_error.encoding))
(function
| End_error (view, status, errs) ->
Some (view, status, errs)
| _ ->
None)
(fun (view, status, errs) -> End_error (view, status, errs)) ]
let pp ppf = function
| Start input ->
Format.fprintf ppf "@[<v 0>Starting: %a@]" pp_input input
| End_ok (view, _, _) ->
Format.fprintf ppf "@[<v 0>Finished: %a@]" Request.pp view
| End_error (view, _, errs) ->
Format.fprintf
ppf
"@[<v 0>Errors: %a, Operations: %a@]"
(Format.pp_print_list Error_monad.pp)
errs
Request.pp
view
end
module Types = struct
type parameters = Mempool_worker.t * int
type state = {mempool_worker : Mempool_worker.t; pool_size : int}
type view = unit
let view _ _ = ()
let encoding = Data_encoding.unit
let pp _ _ = ()
end
module Logger = Worker_logger.Make (Event) (Request)
module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)
type t = Worker.bounded Worker.queue Worker.t
let table =
let open Worker in
create_table (Bounded {size = Static.max_pending_requests})
(* 3. Workers' work: setting workers' callbacks to perform core work *)
module Handlers = struct
type self = t
let on_launch _ _ (mempool_worker, pool_size) =
return Types.{mempool_worker; pool_size}
let on_request : type a. self -> a Request.t -> a tzresult Lwt.t =
fun t (Request.Batch os) ->
let st = Worker.state t in
Worker.record_event t (Event.Start os) ;
Work.process_batch st.mempool_worker st.pool_size os
>>= fun r -> return r
let on_no_request _ = return_unit
let on_close _ = Lwt.return_unit
let on_error t view st errs =
Worker.record_event t (Event.End_error (view, st, errs)) ;
Lwt.return_error errs
let on_completion :
type a.
self -> a Request.t -> a -> Worker_types.request_status -> unit Lwt.t =
fun t req output st ->
match req with
| Request.Batch _ ->
Worker.record_event t (Event.End_ok (Request.view req, st, output)) ;
Lwt.return_unit
end
(* 4. Public interface: exporting a thin wrapper around workers and work. *)
(* See interface file for documentation *)
let validate t os =
Worker.Queue.push_request_and_wait t (Request.Batch os)
>>=? fun (_ : output) -> return_unit
let create limits peer_id mempool_worker =
Worker.launch
table
limits.worker_limits
peer_id
(mempool_worker, limits.max_promises_per_request)
(module Handlers)
let shutdown w =
let recycled = Operation_hash.Set.empty in
let recycled =
List.fold_left
(fun recycled (_, input) ->
List.fold_left
(fun recycled op_h -> Operation_hash.Set.add op_h recycled)
recycled
input)
recycled
(Worker.Queue.pending_requests w)
in
let recycled =
match Worker.current_request w with
| Some (_, _, input) ->
List.fold_left
(fun recycled op_h -> Operation_hash.Set.add op_h recycled)
recycled
input
| None ->
recycled
in
let input = Operation_hash.Set.elements recycled in
Worker.shutdown w >>= fun () -> Lwt.return input
end
src/lib_shell/mempool_peer_worker.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record limits := {
max_promises_per_request : Z;
worker_limits : Tezos_shell_services.Worker_types.limits }.
Module T.
Record signature {Mempool_worker_Proto_P_block_header_data
Mempool_worker_Proto_P_block_header
Mempool_worker_Proto_P_block_header_metadata
Mempool_worker_Proto_P_operation_data
Mempool_worker_Proto_P_operation_receipt Mempool_worker_Proto_P_operation
Mempool_worker_Proto_P_validation_state Mempool_worker_t
Mempool_worker_operation Mempool_worker_result t : Type} := {
Mempool_worker : Mempool_worker.T.signature Mempool_worker_Proto_P_block_header_data Mempool_worker_Proto_P_block_header Mempool_worker_Proto_P_block_header_metadata Mempool_worker_Proto_P_operation_data Mempool_worker_Proto_P_operation_receipt Mempool_worker_Proto_P_operation Mempool_worker_Proto_P_validation_state Mempool_worker_t Mempool_worker_operation Mempool_worker_result;
t := t;
input := list Tezos_base__TzPervasives.Operation_hash.t;
create : limits ->
Tezos_base__TzPervasives.P2p_peer.Id.t ->
Mempool_worker.(Tezos_shell__Mempool_worker.T.t) ->
Lwt.t (Tezos_base__TzPervasives.tzresult t);
shutdown : t -> Lwt.t input;
validate : t -> input -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
}.
Arguments signature : clear implicits.
End T.
Module STATIC.
Record signature := {
max_pending_requests : Z;
}.
End STATIC.
(* ❌ Functors are not handled. *)
functor
src/lib_shell/mempool_worker.ml 1 error
(*****************************************************************************)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type limits = {worker_limits : Worker_types.limits}
module type T = sig
module Proto : Registered_protocol.T
type t
type operation = private {
hash : Operation_hash.t;
raw : Operation.t;
protocol_data : Proto.operation_data;
}
type result =
| Applied of Proto.operation_receipt
| Branch_delayed of error list
| Branch_refused of error list
| Refused of error list
| Duplicate
| Not_in_branch
val result_encoding : result Data_encoding.t
(** Creates/tear-down a new mempool validator context. *)
val create : limits -> Distributed_db.chain_db -> t tzresult Lwt.t
val shutdown : t -> unit Lwt.t
(** parse a new operation and add it to the mempool context *)
val parse : Operation.t -> operation tzresult
(** validate a new operation and add it to the mempool context *)
val validate : t -> operation -> result tzresult Lwt.t
val chain_db : t -> Distributed_db.chain_db
val rpc_directory : t RPC_directory.t
end
module type STATIC = sig
val max_size_parsed_cache : int
end
module Make (Static : STATIC) (Proto : Registered_protocol.T) :
T with module Proto = Proto = struct
module Proto = Proto
(* used for rpc *)
module Proto_services = Block_services.Make (Proto) (Proto)
type operation = {
hash : Operation_hash.t;
raw : Operation.t;
protocol_data : Proto.operation_data;
}
type result =
| Applied of Proto.operation_receipt
| Branch_delayed of error list
| Branch_refused of error list
| Refused of error list
| Duplicate
| Not_in_branch
let result_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Applied"
(obj1 (req "receipt" Proto.operation_receipt_encoding))
(function Applied receipt -> Some receipt | _ -> None)
(fun receipt -> Applied receipt);
case
(Tag 1)
~title:"Branch Delayed"
(obj1 (req "error" (list Error_monad.error_encoding)))
(function Branch_delayed error -> Some error | _ -> None)
(fun error -> Branch_delayed error);
case
(Tag 2)
~title:"Branch Refused"
(obj1 (req "error" (list Error_monad.error_encoding)))
(function Branch_refused error -> Some error | _ -> None)
(fun error -> Branch_refused error);
case
(Tag 3)
~title:"Refused"
(obj1 (req "error" (list Error_monad.error_encoding)))
(function Refused error -> Some error | _ -> None)
(fun error -> Refused error);
case
(Tag 4)
~title:"Duplicate"
empty
(function Duplicate -> Some () | _ -> None)
(fun () -> Duplicate);
case
(Tag 5)
~title:"Not_in_branch"
empty
(function Not_in_branch -> Some () | _ -> None)
(fun () -> Not_in_branch) ]
let pp_result ppf = function
| Applied _ ->
Format.pp_print_string ppf "applied"
| Branch_delayed _ ->
Format.pp_print_string ppf "branch delayed"
| Branch_refused _ ->
Format.pp_print_string ppf "branch refused"
| Refused _ ->
Format.pp_print_string ppf "refused"
| Duplicate ->
Format.pp_print_string ppf "duplicate"
| Not_in_branch ->
Format.pp_print_string ppf "not in branch"
let operation_encoding =
let open Data_encoding in
conv
(fun {hash; raw; protocol_data} -> (hash, raw, protocol_data))
(fun (hash, raw, protocol_data) -> {hash; raw; protocol_data})
(obj3
(req "hash" Operation_hash.encoding)
(req "raw" Operation.encoding)
(req "protocol_data" Proto.operation_data_encoding))
module Log = Internal_event.Legacy_logging.Make (struct
let name = "node.mempool_validator"
end)
module Name = struct
type t = Chain_id.t
let encoding = Chain_id.encoding
let base =
let proto_hash =
let (_ : string) = Format.flush_str_formatter () in
Format.fprintf Format.str_formatter "%a" Protocol_hash.pp Proto.hash ;
Format.flush_str_formatter ()
in
["node"; "mempool"; "worker"; proto_hash]
let pp = Chain_id.pp_short
end
module Request = struct
type 'a t = Validate : operation -> result t [@@ocaml.unboxed]
type view = View : _ t -> view
let view req = View req
let encoding =
let open Data_encoding in
conv
(fun (View (Validate op)) -> op)
(fun op -> View (Validate op))
operation_encoding
let pp ppf (View (Validate {hash; _})) =
Format.fprintf ppf "Validating new operation %a" Operation_hash.pp hash
end
module Event = struct
type t =
| Request of
(Request.view * Worker_types.request_status * error list option)
| Debug of string
let level req =
match req with
| Debug _ ->
Internal_event.Debug
| Request _ ->
Internal_event.Info
let encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Debug"
(obj1 (req "message" string))
(function Debug msg -> Some msg | _ -> None)
(fun msg -> Debug msg);
case
(Tag 1)
~title:"Request"
(obj2
(req "request" Request.encoding)
(req "status" Worker_types.request_status_encoding))
(function Request (req, t, None) -> Some (req, t) | _ -> None)
(fun (req, t) -> Request (req, t, None));
case
(Tag 2)
~title:"Failed request"
(obj3
(req "error" RPC_error.encoding)
(req "failed_request" Request.encoding)
(req "status" Worker_types.request_status_encoding))
(function
| Request (req, t, Some errs) -> Some (errs, req, t) | _ -> None)
(fun (errs, req, t) -> Request (req, t, Some errs)) ]
let pp ppf = function
| Debug msg ->
Format.fprintf ppf "%s" msg
| Request (view, {pushed; treated; completed}, None) ->
Format.fprintf
ppf
"@[<v 0>%a@, %a@]"
Request.pp
view
Worker_types.pp_status
{pushed; treated; completed}
| Request (view, {pushed; treated; completed}, Some errors) ->
Format.fprintf
ppf
"@[<v 0>%a@, %a, %a@]"
Request.pp
view
Worker_types.pp_status
{pushed; treated; completed}
(Format.pp_print_list Error_monad.pp)
errors
end
(* parsed operations' cache. used for memoization *)
module ParsedCache = struct
type t = {
table : operation tzresult Operation_hash.Table.t;
ring : Operation_hash.t Ring.t;
}
let create () : t =
{
table = Operation_hash.Table.create Static.max_size_parsed_cache;
ring = Ring.create Static.max_size_parsed_cache;
}
let add t raw_op parsed_op =
let hash = Operation.hash raw_op in
Option.iter
~f:(Operation_hash.Table.remove t.table)
(Ring.add_and_return_erased t.ring hash) ;
Operation_hash.Table.replace t.table hash parsed_op
let find_opt t raw_op =
let hash = Operation.hash raw_op in
Operation_hash.Table.find_opt t.table hash
let rem t hash =
(* NOTE: hashes are not removed from the ring. As a result, the cache size
* bound can be lowered. This is a non-issue because it's only a cache. *)
Operation_hash.Table.remove t.table hash
end
(* validated operations' cache. used for memoization *)
module ValidatedCache = struct
type t = (result * Operation.t) Operation_hash.Table.t
let encoding =
let open Data_encoding in
Operation_hash.Table.encoding (tup2 result_encoding Operation.encoding)
let pp break ppf table =
let open Format in
Operation_hash.Table.iter
(fun h (r, _) ->
fprintf ppf "Operation %a: %a" Operation_hash.pp_short h pp_result r ;
break ppf)
table
let create () = Operation_hash.Table.create 1000
let add t parsed_op result =
Operation_hash.Table.replace t parsed_op.hash result
let find_opt t parsed_op = Operation_hash.Table.find_opt t parsed_op.hash
let iter f t = Operation_hash.Table.iter f t
let to_mempool t =
let empty =
{
Proto_services.Mempool.applied = [];
refused = Operation_hash.Map.empty;
branch_refused = Operation_hash.Map.empty;
branch_delayed = Operation_hash.Map.empty;
unprocessed = Operation_hash.Map.empty;
}
in
let map_op op =
let protocol_data =
Data_encoding.Binary.of_bytes_exn
Proto.operation_data_encoding
op.Operation.proto
in
{Proto.shell = op.shell; protocol_data}
in
Operation_hash.Table.fold
(fun hash (result, raw_op) acc ->
let proto_op = map_op raw_op in
match result with
| Applied _ ->
{
acc with
Proto_services.Mempool.applied =
(hash, proto_op) :: acc.Proto_services.Mempool.applied;
}
| Branch_refused err ->
{
acc with
Proto_services.Mempool.branch_refused =
Operation_hash.Map.add
hash
(proto_op, err)
acc.Proto_services.Mempool.branch_refused;
}
| Branch_delayed err ->
{
acc with
Proto_services.Mempool.branch_delayed =
Operation_hash.Map.add
hash
(proto_op, err)
acc.Proto_services.Mempool.branch_delayed;
}
| Refused err ->
{
acc with
Proto_services.Mempool.refused =
Operation_hash.Map.add
hash
(proto_op, err)
acc.Proto_services.Mempool.refused;
}
| _ ->
acc)
t
empty
let clear t = Operation_hash.Table.clear t
end
module Types = struct
type parameters = {
limits : limits;
chain_db : Distributed_db.chain_db;
validation_state : Proto.validation_state;
}
(* internal worker state *)
type state = {
(* state of the validator. this is updated at each apply_operation *)
mutable validation_state : Proto.validation_state;
cache : ValidatedCache.t;
(* live blocks and operations, initialized at worker launch *)
live_blocks : Block_hash.Set.t;
live_operations : Operation_hash.Set.t;
operation_stream :
(result * Operation.shell_header * Proto.operation_data)
Lwt_watcher.input;
parameters : parameters;
}
type view = {cache : ValidatedCache.t}
let view (state : state) _ : view = {cache = state.cache}
let encoding =
let open Data_encoding in
conv
(fun {cache} -> cache)
(fun cache -> {cache})
ValidatedCache.encoding
let pp ppf {cache} =
ValidatedCache.pp
(fun ppf ->
Format.pp_print_string ppf ";" ;
Format.pp_print_space ppf ())
ppf
cache
end
module Logger = Worker_logger.Make (Event) (Request)
module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)
open Types
type t = Worker.infinite Worker.queue Worker.t
let parsed_cache = ParsedCache.create ()
let shutdown w = Worker.shutdown w
(*** prevalidation ****)
open Validation_errors
let create ?protocol_data ~predecessor ~timestamp () =
let { Block_header.shell =
{ fitness = predecessor_fitness;
timestamp = predecessor_timestamp;
level = predecessor_level;
_ };
_ } =
State.Block.header predecessor
in
State.Block.context predecessor
>>=? fun predecessor_context ->
let predecessor_hash = State.Block.hash predecessor in
( match protocol_data with
| None ->
return_none
| Some protocol_data -> (
match
Data_encoding.Binary.of_bytes
Proto.block_header_data_encoding
protocol_data
with
| None ->
failwith "Invalid block header"
| Some protocol_data ->
return_some protocol_data ) )
>>=? fun protocol_data ->
let predecessor_context =
Shell_context.wrap_disk_context predecessor_context
in
Proto.begin_construction
~chain_id:(State.Block.chain_id predecessor)
~predecessor_context
~predecessor_timestamp
~predecessor_fitness
~predecessor_level
~predecessor:predecessor_hash
~timestamp
?protocol_data
()
let apply_operation state op =
if Operation_hash.Set.mem op.hash state.live_operations then
Lwt.return (None, Duplicate)
else if
not (Block_hash.Set.mem op.raw.Operation.shell.branch state.live_blocks)
then Lwt.return (None, Not_in_branch)
else
Proto.apply_operation
state.validation_state
{shell = op.raw.shell; protocol_data = op.protocol_data}
>|= function
| Ok (validation_state, receipt) ->
(Some validation_state, Applied receipt)
| Error errors -> (
( None,
match classify_errors errors with
| `Branch ->
Branch_refused errors
| `Permanent ->
Refused errors
| `Temporary ->
Branch_delayed errors ) )
(*** end prevalidation ***)
let parse_helper raw_op =
let hash = Operation.hash raw_op in
let size = Data_encoding.Binary.length Operation.encoding raw_op in
if size > Proto.max_operation_data_length then
error (Oversized_operation {size; max = Proto.max_operation_data_length})
else
match
Data_encoding.Binary.of_bytes
Proto.operation_data_encoding
raw_op.Operation.proto
with
| None ->
error Parse_error
| Some protocol_data ->
ok {hash; raw = raw_op; protocol_data}
(* this function update the internal state of the worker *)
let validate_helper w parsed_op =
let state = Worker.state w in
apply_operation state parsed_op
>>= fun (validation_state, result) ->
( match validation_state with
| Some validation_state ->
state.validation_state <- validation_state
| None ->
() ) ;
Lwt.return result
let notify_helper w result {Operation.shell; proto} =
let state = Worker.state w in
(* this function is called by on_validate where we take care of the error *)
let protocol_data =
Data_encoding.Binary.of_bytes_exn Proto.operation_data_encoding proto
in
Lwt_watcher.notify state.operation_stream (result, shell, protocol_data)
(* memoization is done only at on_* level *)
let on_validate w parsed_op =
let state = Worker.state w in
match ValidatedCache.find_opt state.cache parsed_op with
| None | Some (Branch_delayed _, _) ->
validate_helper w parsed_op
>>= fun result ->
ValidatedCache.add state.cache parsed_op (result, parsed_op.raw) ;
(* operations are notified only the first time *)
notify_helper w result parsed_op.raw ;
Lwt.return result
| Some (result, _) ->
Lwt.return result
(* worker's handlers *)
let on_request : type r. t -> r Request.t -> r tzresult Lwt.t =
fun w request ->
match request with
| Request.Validate parsed_op ->
on_validate w parsed_op >>= return
let on_launch (_ : t) (_ : Name.t)
({chain_db; validation_state; _} as parameters) =
let chain_state = Distributed_db.chain_state chain_db in
Chain.data chain_state
>>= fun {current_mempool = _mempool; live_blocks; live_operations; _} ->
(* remove all operations that are already included *)
Operation_hash.Set.iter
(fun hash -> ParsedCache.rem parsed_cache hash)
live_operations ;
return
{
validation_state;
cache = ValidatedCache.create ();
live_blocks;
live_operations;
operation_stream = Lwt_watcher.create_input ();
parameters;
}
let on_close w =
let state = Worker.state w in
Lwt_watcher.shutdown_input state.operation_stream ;
ValidatedCache.iter
(fun hash _ ->
Distributed_db.Operation.clear_or_cancel state.parameters.chain_db hash)
state.cache ;
ValidatedCache.clear state.cache ;
Lwt.return_unit
let on_error w r st errs =
Worker.record_event w (Event.Request (r, st, Some errs)) ;
Lwt.return_error errs
let on_completion w r _ st =
Worker.record_event w (Event.Request (Request.view r, st, None)) ;
Lwt.return_unit
let table = Worker.create_table Queue
let create limits chain_db =
let chain_state = Distributed_db.chain_state chain_db in
let chain_id = State.Chain.id chain_state in
let module Handlers = struct
type self = t
let on_launch = on_launch
let on_close = on_close
let on_error = on_error
let on_completion = on_completion
let on_no_request _ = return_unit
let on_request = on_request
end in
Chain.data chain_state
>>= fun {current_head = predecessor; _} ->
let timestamp = Time.System.to_protocol (Systime_os.now ()) in
create ~predecessor ~timestamp ()
>>=? fun validation_state ->
Worker.launch
table
limits.worker_limits
chain_id
{limits; chain_db; validation_state}
(module Handlers)
(* Exporting functions *)
let validate t parsed_op =
Worker.Queue.push_request_and_wait t (Request.Validate parsed_op)
(* atomic parse + memoization *)
let parse raw_op =
match ParsedCache.find_opt parsed_cache raw_op with
| None ->
let parsed_op = parse_helper raw_op in
ParsedCache.add parsed_cache raw_op parsed_op ;
parsed_op
| Some parsed_op ->
parsed_op
let chain_db t =
let state = Worker.state t in
state.parameters.chain_db
let pending_rpc_directory : t RPC_directory.t =
RPC_directory.gen_register
RPC_directory.empty
(Proto_services.S.Mempool.pending_operations RPC_path.open_root)
(fun w () () ->
let state = Worker.state w in
RPC_answer.return (ValidatedCache.to_mempool state.cache))
let monitor_rpc_directory : t RPC_directory.t =
RPC_directory.gen_register
RPC_directory.empty
(Proto_services.S.Mempool.monitor_operations RPC_path.open_root)
(fun w params () ->
let state = Worker.state w in
let filter_result = function
| Applied _ ->
params#applied
| Refused _ ->
params#refused
| Branch_refused _ ->
params#branch_refused
| Branch_delayed _ ->
params#branch_delayed
| _ ->
false
in
let (op_stream, stopper) =
Lwt_watcher.create_stream state.operation_stream
in
let shutdown () = Lwt_watcher.shutdown stopper in
let next () =
Lwt_stream.get op_stream
>>= function
| Some (kind, shell, protocol_data) when filter_result kind ->
Lwt.return_some [{Proto.shell; protocol_data}]
| _ ->
Lwt.return_none
in
RPC_answer.return_stream {next; shutdown})
(* /mempool/<chain_id>/pending
/mempool/<chain_id>/monitor *)
let rpc_directory =
RPC_directory.merge pending_rpc_directory monitor_rpc_directory
end
src/lib_shell/mempool_worker.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record limits := {
worker_limits : Tezos_shell_services.Worker_types.limits }.
Module T.
Record signature {Proto_P_block_header_data Proto_P_block_header
Proto_P_block_header_metadata Proto_P_operation_data
Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state t
operation result : Type} := {
Proto : Registered_protocol.T.signature Proto_P_block_header_data Proto_P_block_header Proto_P_block_header_metadata Proto_P_operation_data Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state;
t := t;
operation := operation;
result := result;
result_encoding : Tezos_base__TzPervasives.Data_encoding.t result;
create : limits ->
Tezos_shell.Distributed_db.chain_db ->
Lwt.t (Tezos_base__TzPervasives.tzresult t);
shutdown : t -> Lwt.t unit;
parse : Tezos_base__TzPervasives.Operation.t ->
Tezos_base__TzPervasives.tzresult operation;
validate : t ->
operation -> Lwt.t (Tezos_base__TzPervasives.tzresult result);
chain_db : t -> Tezos_shell.Distributed_db.chain_db;
rpc_directory : Tezos_base__TzPervasives.RPC_directory.t t;
}.
Arguments signature : clear implicits.
End T.
Module STATIC.
Record signature := {
max_size_parsed_cache : Z;
}.
End STATIC.
(* ❌ Functors are not handled. *)
functor
src/lib_shell/monitor_directory.ml 50 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let build_rpc_directory validator mainchain_validator =
let distributed_db = Validator.distributed_db validator in
let state = Distributed_db.state distributed_db in
let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
let gen_register0 s f =
dir := RPC_directory.gen_register !dir s (fun () p q -> f p q)
in
let gen_register1 s f =
dir := RPC_directory.gen_register !dir s (fun ((), a) p q -> f a p q)
in
gen_register0 Monitor_services.S.bootstrapped (fun () () ->
let (block_stream, stopper) =
Chain_validator.new_head_watcher mainchain_validator
in
let first_run = ref true in
let next () =
if !first_run then (
first_run := false ;
let chain_state = Chain_validator.chain_state mainchain_validator in
Chain.head chain_state
>>= fun head ->
let head_hash = State.Block.hash head in
let head_header = State.Block.header head in
Lwt.return_some (head_hash, head_header.shell.timestamp) )
else
Lwt.pick
[ Lwt_stream.get block_stream
>|= Option.map ~f:(fun b ->
( State.Block.hash b,
(State.Block.header b).shell.timestamp ));
( Chain_validator.bootstrapped mainchain_validator
>|= fun () -> None ) ]
in
let shutdown () = Lwt_watcher.shutdown stopper in
RPC_answer.return_stream {next; shutdown}) ;
gen_register0 Monitor_services.S.valid_blocks (fun q () ->
let (block_stream, stopper) = State.watcher state in
let shutdown () = Lwt_watcher.shutdown stopper in
let in_chains block =
match q#chains with
| [] ->
Lwt.return_true
| chains ->
let chain_id = State.Block.chain_id block in
Lwt_list.filter_map_p
(Chain_directory.get_chain_id_opt state)
chains
>>= fun chains ->
Lwt.return (List.exists (Chain_id.equal chain_id) chains)
in
let in_protocols block =
match q#protocols with
| [] ->
Lwt.return_true
| protocols -> (
State.Block.predecessor block
>>= function
| None ->
Lwt.return_false (* won't happen *)
| Some pred ->
State.Block.context_exn pred
>>= fun context ->
Context.get_protocol context
>>= fun protocol ->
Lwt.return
(List.exists (Protocol_hash.equal protocol) protocols) )
in
let in_next_protocols block =
match q#next_protocols with
| [] ->
Lwt.return_true
| protocols ->
State.Block.context_exn block
>>= fun context ->
Context.get_protocol context
>>= fun next_protocol ->
Lwt.return
(List.exists (Protocol_hash.equal next_protocol) protocols)
in
let stream =
Lwt_stream.filter_map_s
(fun block ->
in_chains block
>>= fun in_chains ->
in_next_protocols block
>>= fun in_next_protocols ->
in_protocols block
>>= fun in_protocols ->
if in_chains && in_protocols && in_next_protocols then
Lwt.return_some
( (State.Block.chain_id block, State.Block.hash block),
State.Block.header block )
else Lwt.return_none)
block_stream
in
let next () = Lwt_stream.get stream in
RPC_answer.return_stream {next; shutdown}) ;
gen_register1 Monitor_services.S.heads (fun chain q () ->
(* TODO: when `chain = `Test`, should we reset then stream when
the `testnet` change, or dias we currently do ?? *)
Chain_directory.get_chain state chain
>>= fun chain ->
match Validator.get validator (State.Chain.id chain) with
| Error _ ->
Lwt.fail Not_found
| Ok chain_validator ->
let (block_stream, stopper) =
Chain_validator.new_head_watcher chain_validator
in
Chain.head chain
>>= fun head ->
let shutdown () = Lwt_watcher.shutdown stopper in
let in_next_protocols block =
match q#next_protocols with
| [] ->
Lwt.return_true
| protocols ->
State.Block.context_exn block
>>= fun context ->
Context.get_protocol context
>>= fun next_protocol ->
Lwt.return
(List.exists (Protocol_hash.equal next_protocol) protocols)
in
let stream =
Lwt_stream.filter_map_s
(fun block ->
in_next_protocols block
>>= fun in_next_protocols ->
if in_next_protocols then
Lwt.return_some
(State.Block.hash block, State.Block.header block)
else Lwt.return_none)
block_stream
in
in_next_protocols head
>>= fun first_block_is_among_next_protocols ->
let first_call =
(* Skip the first block if this is false *)
ref first_block_is_among_next_protocols
in
let next () =
if !first_call then (
first_call := false ;
Lwt.return_some (State.Block.hash head, State.Block.header head)
)
else Lwt_stream.get stream
in
RPC_answer.return_stream {next; shutdown}) ;
gen_register0 Monitor_services.S.protocols (fun () () ->
let (stream, stopper) = State.Protocol.watcher state in
let shutdown () = Lwt_watcher.shutdown stopper in
let next () = Lwt_stream.get stream in
RPC_answer.return_stream {next; shutdown}) ;
gen_register0 Monitor_services.S.commit_hash (fun () () ->
RPC_answer.return Tezos_version.Current_git_info.commit_hash) ;
gen_register0 Monitor_services.S.active_chains (fun () () ->
let (stream, stopper) = Validator.chains_watcher validator in
let shutdown () = Lwt_watcher.shutdown stopper in
let first_call =
(* Only notify the newly created chains if this is false *)
ref true
in
let next () =
let convert (chain_id, b) =
if not b then Lwt.return (Monitor_services.Stopping chain_id)
else if Chain_id.equal (State.Chain.main state) chain_id then
Lwt.return (Monitor_services.Active_main chain_id)
else
State.Chain.get_exn state chain_id
>>= fun chain_state ->
let {State.Chain.protocol; _} = State.Chain.genesis chain_state in
let expiration_date =
Option.unopt_exn
(Invalid_argument
(Format.asprintf
"Monitor.active_chains: no expiration date for the \
chain %a"
Chain_id.pp
chain_id))
(State.Chain.expiration chain_state)
in
Lwt.return
(Monitor_services.Active_test
{chain = chain_id; protocol; expiration_date})
in
if !first_call then (
first_call := false ;
Lwt_list.map_p
(fun c -> convert (c, true))
(Validator.get_active_chains validator)
>>= fun l -> Lwt.return_some l )
else
Lwt_stream.get stream
>>= function
| None ->
Lwt.return_none
| Some c ->
convert c >>= fun status -> Lwt.return_some [status]
in
RPC_answer.return_stream {next; shutdown}) ;
!dir
src/lib_shell/monitor_directory.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition build_rpc_directory
(validator : Tezos_shell.Validator.t)
(mainchain_validator : Tezos_shell.Chain_validator.t)
: Tezos_base__TzPervasives.RPC_directory.t unit :=
let distributed_db := Validator.distributed_db validator in
let state := Distributed_db.state distributed_db in
let dir := Stdlib.ref RPC_directory.empty in
let gen_register0 {A B C : Type}
(s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
A -> B -> Lwt.t variant) : unit :=
Stdlib.op_coloneq dir
(RPC_directory.gen_register (Stdlib.op_exclamation dir) s
(fun function_parameter =>
let 'tt := function_parameter in
fun p => fun q => f p q)) in
let gen_register1 {A B C D : Type}
(s : Tezos_rpc.RPC_service.t variant unit (unit * A) B C D) (f :
A -> B -> C -> Lwt.t variant) : unit :=
Stdlib.op_coloneq dir
(RPC_directory.gen_register (Stdlib.op_exclamation dir) s
(fun function_parameter =>
let '(tt, a) := function_parameter in
fun p => fun q => f a p q)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
gen_register0 Monitor_services.S.bootstrapped
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
let '(block_stream, stopper) :=
Chain_validator.new_head_watcher mainchain_validator in
let first_run := Stdlib.ref true in
let next (function_parameter : unit)
: Lwt.t
(option
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base.Time.Protocol.t)) :=
let 'tt := function_parameter in
if Stdlib.op_exclamation first_run then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq first_run false in
let chain_state := Chain_validator.chain_state mainchain_validator
in
op_gtgteq (Chain.head chain_state)
(fun head =>
let head_hash := State.Block.hash head in
let head_header := State.Block.header head in
Lwt.return_some (head_hash, (timestamp (shell head_header))))
else
Lwt.pick
(cons
(op_gtpipeeq (Lwt_stream.get block_stream)
(Option.map
(fun b =>
((State.Block.hash b),
(timestamp (shell (State.Block.header b)))))))
(cons
(op_gtpipeeq
(Chain_validator.bootstrapped mainchain_validator)
(fun function_parameter =>
let 'tt := function_parameter in
None)) [])) in
let shutdown (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Lwt_watcher.shutdown stopper in
RPC_answer.return_stream {| next := next; shutdown := shutdown |}) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
gen_register0 Monitor_services.S.valid_blocks
(fun q =>
fun function_parameter =>
let 'tt := function_parameter in
let '(block_stream, stopper) := State.watcher state in
let shutdown (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Lwt_watcher.shutdown stopper in
let in_chains (block : Tezos_shell.State.Block.t) : Lwt.t bool :=
match
(* ❌ Sending method message is not handled *)
send with
| [] => Lwt.return_true
| chains =>
let chain_id := State.Block.chain_id block in
op_gtgteq
(Lwt_list.filter_map_p (Chain_directory.get_chain_id_opt state)
chains)
(fun chains =>
Lwt._return (List._exists (Chain_id.equal chain_id) chains))
end in
let in_protocols (block : Tezos_shell.State.Block.t) : Lwt.t bool :=
match
(* ❌ Sending method message is not handled *)
send with
| [] => Lwt.return_true
| protocols =>
op_gtgteq (State.Block.predecessor block)
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_false
| Some pred =>
op_gtgteq (State.Block.context_exn pred)
(fun context =>
op_gtgteq (Context.get_protocol context)
(fun protocol =>
Lwt._return
(List._exists (Protocol_hash.equal protocol)
protocols)))
end)
end in
let in_next_protocols (block : Tezos_shell.State.Block.t)
: Lwt.t bool :=
match
(* ❌ Sending method message is not handled *)
send with
| [] => Lwt.return_true
| protocols =>
op_gtgteq (State.Block.context_exn block)
(fun context =>
op_gtgteq (Context.get_protocol context)
(fun next_protocol =>
Lwt._return
(List._exists (Protocol_hash.equal next_protocol)
protocols)))
end in
let stream :=
Lwt_stream.filter_map_s
(fun block =>
op_gtgteq (in_chains block)
(fun in_chains =>
op_gtgteq (in_next_protocols block)
(fun in_next_protocols =>
op_gtgteq (in_protocols block)
(fun in_protocols =>
if
andb in_chains
(andb in_protocols in_next_protocols) then
Lwt.return_some
(((State.Block.chain_id block),
(State.Block.hash block)),
(State.Block.header block))
else
Lwt.return_none)))) block_stream in
let next (function_parameter : unit)
: Lwt.t
(option
((Tezos_base__TzPervasives.Chain_id.t *
Tezos_base__TzPervasives.Block_hash.t) *
Tezos_base__TzPervasives.Block_header.t)) :=
let 'tt := function_parameter in
Lwt_stream.get stream in
RPC_answer.return_stream {| next := next; shutdown := shutdown |}) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
gen_register1 Monitor_services.S.heads
(fun chain =>
fun q =>
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Chain_directory.get_chain state chain)
(fun chain =>
match Validator.get validator (State.Chain.id chain) with
| Stdlib.Error _ => Lwt.fail OCaml.Not_found
| Stdlib.Ok chain_validator =>
let '(block_stream, stopper) :=
Chain_validator.new_head_watcher chain_validator in
op_gtgteq (Chain.head chain)
(fun head =>
let shutdown (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Lwt_watcher.shutdown stopper in
let in_next_protocols (block : Tezos_shell.State.Block.t)
: Lwt.t bool :=
match
(* ❌ Sending method message is not handled *)
send with
| [] => Lwt.return_true
| protocols =>
op_gtgteq (State.Block.context_exn block)
(fun context =>
op_gtgteq (Context.get_protocol context)
(fun next_protocol =>
Lwt._return
(List._exists
(Protocol_hash.equal next_protocol)
protocols)))
end in
let stream :=
Lwt_stream.filter_map_s
(fun block =>
op_gtgteq (in_next_protocols block)
(fun in_next_protocols =>
if in_next_protocols then
Lwt.return_some
((State.Block.hash block),
(State.Block.header block))
else
Lwt.return_none)) block_stream in
op_gtgteq (in_next_protocols head)
(fun first_block_is_among_next_protocols =>
let first_call :=
Stdlib.ref first_block_is_among_next_protocols in
let next (function_parameter : unit)
: Lwt.t
(option
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t)) :=
let 'tt := function_parameter in
if Stdlib.op_exclamation first_call then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq first_call false in
Lwt.return_some
((State.Block.hash head),
(State.Block.header head))
else
Lwt_stream.get stream in
RPC_answer.return_stream
{| next := next; shutdown := shutdown |}))
end)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
gen_register0 Monitor_services.S.protocols
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
let '(stream, stopper) := State.Protocol.watcher state in
let shutdown (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Lwt_watcher.shutdown stopper in
let next (function_parameter : unit)
: Lwt.t (option Tezos_base__TzPervasives.Protocol_hash.t) :=
let 'tt := function_parameter in
Lwt_stream.get stream in
RPC_answer.return_stream {| next := next; shutdown := shutdown |}) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
gen_register0 Monitor_services.S.commit_hash
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
RPC_answer._return Tezos_version.Current_git_info.commit_hash) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
gen_register0 Monitor_services.S.active_chains
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
let '(stream, stopper) := Validator.chains_watcher validator in
let shutdown (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Lwt_watcher.shutdown stopper in
let first_call := Stdlib.ref true in
let next (function_parameter : unit)
: Lwt.t
(option (list Tezos_shell_services.Monitor_services.chain_status)) :=
let 'tt := function_parameter in
let convert
(function_parameter : Tezos_base__TzPervasives.Chain_id.t * bool)
: Lwt.t Tezos_shell_services.Monitor_services.chain_status :=
let '(chain_id, b) := function_parameter in
if negb b then
Lwt._return
(Tezos_shell_services.Monitor_services.Stopping chain_id)
else
if Chain_id.equal (State.Chain.main state) chain_id then
Lwt._return
(Tezos_shell_services.Monitor_services.Active_main chain_id)
else
op_gtgteq (State.Chain.get_exn state chain_id)
(fun chain_state =>
let '{| State.Chain.protocol := protocol |} :=
State.Chain.genesis chain_state in
let expiration_date :=
Option.unopt_exn
(OCaml.Invalid_argument
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Monitor.active_chains: no expiration date for the chain "
% string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Monitor.active_chains: no expiration date for the chain %a"
% string) Chain_id.pp chain_id))
(State.Chain.expiration chain_state) in
Lwt._return
(Tezos_shell_services.Monitor_services.Active_test
{| chain := chain_id; protocol := protocol;
expiration_date := expiration_date |})) in
if Stdlib.op_exclamation first_call then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq first_call false in
op_gtgteq
(Lwt_list.map_p (fun c => convert (c, true))
(Validator.get_active_chains validator))
(fun l => Lwt.return_some l)
else
op_gtgteq (Lwt_stream.get stream)
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_none
| Some c =>
op_gtgteq (convert c)
(fun status => Lwt.return_some (cons status []))
end) in
RPC_answer.return_stream {| next := next; shutdown := shutdown |}) in
Stdlib.op_exclamation dir.
src/lib_shell/node.ml 82 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018-2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
[@@@ocaml.warning "-30"]
open Lwt.Infix
open Tezos_base
module Initialization_event = struct
type t = {
time_stamp : float;
status : [`P2p_layer_disabled | `Bootstrapping | `P2p_maintain_started];
}
let status_names =
[ ("p2p_layer_disabled", `P2p_layer_disabled);
("bootstrapping", `Bootstrapping);
("p2p_maintain_started", `P2p_maintain_started) ]
module Definition = struct
let name = "shell-node"
type nonrec t = t
let encoding =
let open Data_encoding in
let v0_encoding =
conv
(function {time_stamp; status} -> (time_stamp, status))
(fun (time_stamp, status) -> {time_stamp; status})
(obj2
(req "time-stamp" float)
(req "status" (string_enum status_names)))
in
With_version.(encoding ~name (first_version v0_encoding))
let pp ppf {status; _} =
Format.fprintf
ppf
"%s initialization: %s"
name
(List.find (fun (_, s) -> s = status) status_names |> fst)
let doc = "Status of the initialization of the P2P layer."
let level _ = Internal_event.Notice
end
module Event = Internal_event.Make (Definition)
let lwt_emit status =
let time_stamp = Unix.gettimeofday () in
Event.emit (fun () -> {time_stamp; status})
>>= function
| Ok () ->
Lwt.return_unit
| Error el ->
Format.kasprintf
Lwt.fail_with
"Initialization_event.emit: %a"
pp_print_error
el
end
type t = {
state : State.t;
distributed_db : Distributed_db.t;
validator : Validator.t;
mainchain_validator : Chain_validator.t;
p2p : Distributed_db.p2p;
(* For P2P RPCs *)
shutdown : unit -> unit Lwt.t;
}
let peer_metadata_cfg : _ P2p.peer_meta_config =
{
peer_meta_encoding = Peer_metadata.encoding;
peer_meta_initial = Peer_metadata.empty;
score = Peer_metadata.score;
}
let connection_metadata_cfg cfg : _ P2p.conn_meta_config =
{
conn_meta_encoding = Connection_metadata.encoding;
private_node = (fun {private_node; _} -> private_node);
conn_meta_value = (fun _ -> cfg);
}
let init_connection_metadata opt =
let open Connection_metadata in
match opt with
| None ->
{disable_mempool = false; private_node = false}
| Some c ->
{
disable_mempool = c.P2p.disable_mempool;
private_node = c.P2p.private_mode;
}
let init_p2p ?(sandboxed = false) p2p_params =
match p2p_params with
| None ->
let c_meta = init_connection_metadata None in
Initialization_event.lwt_emit `P2p_layer_disabled
>>= fun () ->
return
(P2p.faked_network Distributed_db_message.cfg peer_metadata_cfg c_meta)
| Some (config, limits) ->
let c_meta = init_connection_metadata (Some config) in
let conn_metadata_cfg = connection_metadata_cfg c_meta in
Initialization_event.lwt_emit `Bootstrapping
>>= fun () ->
let message_cfg =
if sandboxed then
{
Distributed_db_message.cfg with
chain_name = Distributed_db_version.sandboxed_chain_name;
}
else Distributed_db_message.cfg
in
P2p.create
~config
~limits
peer_metadata_cfg
conn_metadata_cfg
message_cfg
>>=? fun p2p ->
Initialization_event.lwt_emit `P2p_maintain_started
>>= fun () -> return p2p
type config = {
genesis : State.Chain.genesis;
store_root : string;
context_root : string;
protocol_root : string;
patch_context : (Context.t -> Context.t Lwt.t) option;
p2p : (P2p.config * P2p.limits) option;
checkpoint : Block_header.t option;
}
and peer_validator_limits = Peer_validator.limits = {
new_head_request_timeout : Time.System.Span.t;
block_header_timeout : Time.System.Span.t;
block_operations_timeout : Time.System.Span.t;
protocol_timeout : Time.System.Span.t;
worker_limits : Worker_types.limits;
}
and prevalidator_limits = Prevalidator.limits = {
max_refused_operations : int;
operation_timeout : Time.System.Span.t;
worker_limits : Worker_types.limits;
operations_batch_size : int;
}
and block_validator_limits = Block_validator.limits = {
protocol_timeout : Time.System.Span.t;
worker_limits : Worker_types.limits;
}
and chain_validator_limits = Chain_validator.limits = {
bootstrap_threshold : int;
worker_limits : Worker_types.limits;
}
let default_block_validator_limits =
{
protocol_timeout = Time.System.Span.of_seconds_exn 120.;
worker_limits = {backlog_size = 1000; backlog_level = Internal_event.Debug};
}
let default_prevalidator_limits =
{
operation_timeout = Time.System.Span.of_seconds_exn 10.;
max_refused_operations = 1000;
worker_limits = {backlog_size = 1000; backlog_level = Internal_event.Info};
operations_batch_size = 50;
}
let default_peer_validator_limits =
{
block_header_timeout = Time.System.Span.of_seconds_exn 300.;
block_operations_timeout = Time.System.Span.of_seconds_exn 300.;
protocol_timeout = Time.System.Span.of_seconds_exn 600.;
new_head_request_timeout = Time.System.Span.of_seconds_exn 90.;
worker_limits = {backlog_size = 1000; backlog_level = Internal_event.Info};
}
let default_chain_validator_limits =
{
bootstrap_threshold = 4;
worker_limits = {backlog_size = 1000; backlog_level = Internal_event.Info};
}
let may_update_checkpoint chain_state checkpoint history_mode =
match checkpoint with
| None ->
return_unit
| Some checkpoint -> (
State.best_known_head_for_checkpoint chain_state checkpoint
>>= fun new_head ->
Chain.set_head chain_state new_head
>>= fun _old_head ->
match history_mode with
| History_mode.Archive ->
State.Chain.set_checkpoint chain_state checkpoint
>>= fun () -> return_unit
| Full ->
State.Chain.set_checkpoint_then_purge_full chain_state checkpoint
| Rolling ->
State.Chain.set_checkpoint_then_purge_rolling chain_state checkpoint
)
module Local_logging = Internal_event.Legacy_logging.Make_semantic (struct
let name = "node.worker"
end)
let store_known_protocols state =
let open Local_logging in
let embedded_protocols = Registered_protocol.list_embedded () in
Lwt_list.iter_s
(fun protocol_hash ->
State.Protocol.known state protocol_hash
>>= function
| true ->
lwt_log_info
Tag.DSL.(
fun f ->
f "protocol %a is already in store: nothing to do"
-% a Protocol_hash.Logging.tag protocol_hash
-% t event "embedded_protocol_already_stored")
| false -> (
match Registered_protocol.get_embedded_sources protocol_hash with
| None ->
lwt_log_info
Tag.DSL.(
fun f ->
f "protocol %a won't be stored: missing source files"
-% a Protocol_hash.Logging.tag protocol_hash
-% t event "embedded_protocol_missing_sources")
| Some protocol -> (
let hash = Protocol.hash protocol in
if not (Protocol_hash.equal hash protocol_hash) then
lwt_log_info
Tag.DSL.(
fun f ->
f "protocol %a won't be stored: wrong hash"
-% a Protocol_hash.Logging.tag protocol_hash
-% t event "embedded_protocol_inconsistent_hash")
else
State.Protocol.store state protocol
>>= function
| Some hash' ->
assert (hash = hash') ;
lwt_log_info
Tag.DSL.(
fun f ->
f "protocol %a successfully stored"
-% a Protocol_hash.Logging.tag protocol_hash
-% t event "embedded_protocol_stored")
| None ->
lwt_log_info
Tag.DSL.(
fun f ->
f "protocol %a is already in store: nothing to do"
-% a Protocol_hash.Logging.tag protocol_hash
-% t event "embedded_protocol_already_stored") ) ))
embedded_protocols
let create ?(sandboxed = false) ?sandbox_parameters ~singleprocess
{ genesis;
store_root;
context_root;
protocol_root;
patch_context;
p2p = p2p_params;
checkpoint } peer_validator_limits block_validator_limits
prevalidator_limits chain_validator_limits history_mode =
let (start_prevalidator, start_testchain) =
match p2p_params with
| Some (config, _limits) ->
(not config.P2p.disable_mempool, not config.P2p.disable_testchain)
| None ->
(true, true)
in
init_p2p ~sandboxed p2p_params
>>=? fun p2p ->
(let open Block_validator_process in
if singleprocess then
State.init ~store_root ~context_root ?history_mode ?patch_context genesis
>>=? fun (state, mainchain_state, context_index, history_mode) ->
init (Internal context_index)
>>=? fun validator_process ->
return (validator_process, state, mainchain_state, history_mode)
else
init
(External
{
context_root;
protocol_root;
process_path = Sys.executable_name;
sandbox_parameters;
})
>>=? fun validator_process ->
let commit_genesis =
Block_validator_process.commit_genesis
validator_process
~genesis_hash:genesis.block
in
State.init
~store_root
~context_root
?history_mode
?patch_context
~commit_genesis
genesis
>>=? fun (state, mainchain_state, _context_index, history_mode) ->
return (validator_process, state, mainchain_state, history_mode))
>>=? fun (validator_process, state, mainchain_state, history_mode) ->
may_update_checkpoint mainchain_state checkpoint history_mode
>>=? fun () ->
let distributed_db = Distributed_db.create state p2p in
store_known_protocols state
>>= fun () ->
Validator.create
state
distributed_db
peer_validator_limits
block_validator_limits
validator_process
prevalidator_limits
chain_validator_limits
~start_testchain
>>=? fun validator ->
(* TODO : Check that the testchain is correctly activated after a node restart *)
Validator.activate
validator
~start_prevalidator
~validator_process
mainchain_state
>>=? fun mainchain_validator ->
let shutdown () =
let open Local_logging in
lwt_log_info
Tag.DSL.(
fun f -> f "Shutting down the p2p layer..." -% t event "shutdown")
>>= fun () ->
P2p.shutdown p2p
>>= fun () ->
lwt_log_info
Tag.DSL.(
fun f ->
f "Shutting down the distributed database..." -% t event "shutdown")
>>= fun () ->
Distributed_db.shutdown distributed_db
>>= fun () ->
lwt_log_info
Tag.DSL.(
fun f -> f "Shutting down the validator..." -% t event "shutdown")
>>= fun () ->
Validator.shutdown validator
>>= fun () ->
lwt_log_info
Tag.DSL.(fun f -> f "Closing down the state..." -% t event "shutdown")
>>= fun () -> State.close state
in
return {state; distributed_db; validator; mainchain_validator; p2p; shutdown}
let shutdown node = node.shutdown ()
let build_rpc_directory node =
let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
let merge d = dir := RPC_directory.merge !dir d in
let register0 s f =
dir := RPC_directory.register !dir s (fun () p q -> f p q)
in
merge
(Protocol_directory.build_rpc_directory
(Block_validator.running_worker ())
node.state) ;
merge
(Monitor_directory.build_rpc_directory
node.validator
node.mainchain_validator) ;
merge (Injection_directory.build_rpc_directory node.validator) ;
merge (Chain_directory.build_rpc_directory node.validator) ;
merge (P2p_directory.build_rpc_directory node.p2p) ;
merge (Worker_directory.build_rpc_directory node.state) ;
merge (Stat_directory.rpc_directory ()) ;
register0 RPC_service.error_service (fun () () ->
return (Data_encoding.Json.schema Error_monad.error_encoding)) ;
RPC_directory.register_describe_directory_service
!dir
RPC_service.description_service
src/lib_shell/node.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
Import Tezos_base.
Module Initialization_event.
Record t := {
time_stamp : Z;
status : variant }.
Definition status_names : list (string * variant) :=
cons
("p2p_layer_disabled" % string,
(* ❌ Variants not supported *)
variant)
(cons
("bootstrapping" % string,
(* ❌ Variants not supported *)
variant)
(cons
("p2p_maintain_started" % string,
(* ❌ Variants not supported *)
variant) [])).
Module Definition.
Definition name : string := "shell-node" % string.
Definition t := t.
Definition encoding : Tezos_data_encoding__Data_encoding.encoding t :=
let v0_encoding :=
conv
(fun function_parameter =>
let '{| time_stamp := time_stamp; status := status |} :=
function_parameter in
(time_stamp, status))
(fun function_parameter =>
let '(time_stamp, status) := function_parameter in
{| time_stamp := time_stamp; status := status |}) None
(obj2 (req None None "time-stamp" % string float)
(req None None "status" % string (string_enum status_names))) in
encoding name (first_version v0_encoding).
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
let '{| status := status |} := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" initialization: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"%s initialization: %s" % string) name
(OCaml.Stdlib.reverse_apply
(List.find
(fun function_parameter =>
let '(_, s) := function_parameter in
equiv_decb s status) status_names) fst).
Definition doc : string :=
"Status of the initialization of the P2P layer." % string.
Definition level {A : Type} (function_parameter : A)
: Tezos_base__TzPervasives.Internal_event.level :=
let '_ := function_parameter in
Tezos_base__TzPervasives.Internal_event.Notice.
End Definition.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition lwt_emit (status : variant) : Lwt.t unit :=
let time_stamp := Unix.gettimeofday tt in
op_gtgteq
(Event.emit None
(fun function_parameter =>
let 'tt := function_parameter in
{| time_stamp := time_stamp; status := status |}))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error el =>
Format.kasprintf Lwt.fail_with
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Initialization_event.emit: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Initialization_event.emit: %a" % string) pp_print_error el
end).
End Initialization_event.
Record t := {
state : Tezos_shell.State.t;
distributed_db : Tezos_shell.Distributed_db.t;
validator : Tezos_shell.Validator.t;
mainchain_validator : Tezos_shell.Chain_validator.t;
p2p : Tezos_shell.Distributed_db.p2p;
shutdown : unit -> Lwt.t unit }.
Definition peer_metadata_cfg
: Tezos_p2p.P2p.peer_meta_config Tezos_shell_services.Peer_metadata.t :=
{| peer_meta_encoding := Peer_metadata.encoding;
peer_meta_initial := Peer_metadata.empty; score := Peer_metadata.score |}.
Definition connection_metadata_cfg
(cfg : Tezos_shell_services.Connection_metadata.t)
: Tezos_p2p.P2p.conn_meta_config Tezos_shell_services.Connection_metadata.t :=
{| conn_meta_encoding := Connection_metadata.encoding;
conn_meta_value :=
fun function_parameter =>
let '_ := function_parameter in
cfg;
private_node :=
fun function_parameter =>
let '{| private_node := private_node |} := function_parameter in
private_node |}.
Definition init_connection_metadata (opt : option Tezos_p2p.P2p.config)
: Tezos_shell_services.Connection_metadata.t :=
match opt with
| None => {| disable_mempool := false; private_node := false |}
| Some c =>
{| disable_mempool := P2p.disable_mempool c;
private_node := P2p.private_mode c |}
end.
Definition init_p2p (op_staroptstar : option bool)
: (option (Tezos_p2p.P2p.config * Tezos_p2p.P2p.limits)) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_p2p.P2p.net Tezos_shell.Distributed_db_message.t
Tezos_shell_services.Peer_metadata.t
Tezos_shell_services.Connection_metadata.t)) :=
let sandboxed :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun p2p_params =>
match p2p_params with
| None =>
let c_meta := init_connection_metadata None in
op_gtgteq
(Initialization_event.lwt_emit
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
_return
(P2p.faked_network Distributed_db_message.cfg peer_metadata_cfg
c_meta))
| Some (config, limits) =>
let c_meta := init_connection_metadata (Some config) in
let conn_metadata_cfg := connection_metadata_cfg c_meta in
op_gtgteq
(Initialization_event.lwt_emit
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
let message_cfg :=
if sandboxed then
(* ❌ Record substitution not handled *)
record_substitution
else
Distributed_db_message.cfg in
op_gtgteqquestion
(P2p.create config limits peer_metadata_cfg conn_metadata_cfg
message_cfg)
(fun p2p =>
op_gtgteq
(Initialization_event.lwt_emit
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
_return p2p)))
end.
.
Definition default_block_validator_limits : block_validator_limits :=
{|
protocol_timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 120. is approximated by the integer 120 *)
120;
worker_limits :=
{| backlog_size := 1000;
backlog_level := Tezos_base__TzPervasives.Internal_event.Debug |} |}.
Definition default_prevalidator_limits : prevalidator_limits :=
{| max_refused_operations := 1000;
operation_timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 10. is approximated by the integer 10 *)
10;
worker_limits :=
{| backlog_size := 1000;
backlog_level := Tezos_base__TzPervasives.Internal_event.Info |};
operations_batch_size := 50 |}.
Definition default_peer_validator_limits : peer_validator_limits :=
{|
new_head_request_timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 90. is approximated by the integer 90 *)
90;
block_header_timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 300. is approximated by the integer 300 *)
300;
block_operations_timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 300. is approximated by the integer 300 *)
300;
protocol_timeout :=
Time.System.Span.of_seconds_exn
(* ❌ Float constant 600. is approximated by the integer 600 *)
600;
worker_limits :=
{| backlog_size := 1000;
backlog_level := Tezos_base__TzPervasives.Internal_event.Info |} |}.
Definition default_chain_validator_limits : chain_validator_limits :=
{| bootstrap_threshold := 4;
worker_limits :=
{| backlog_size := 1000;
backlog_level := Tezos_base__TzPervasives.Internal_event.Info |} |}.
Definition may_update_checkpoint
(chain_state : Tezos_shell.State.Chain.t)
(checkpoint : option Tezos_base__TzPervasives.Block_header.t)
(history_mode : Tezos_shell_services.History_mode.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match checkpoint with
| None => return_unit
| Some checkpoint =>
op_gtgteq (State.best_known_head_for_checkpoint chain_state checkpoint)
(fun new_head =>
op_gtgteq (Chain.set_head chain_state new_head)
(fun _old_head =>
match history_mode with
| Tezos_shell_services.History_mode.Archive =>
op_gtgteq (State.Chain.set_checkpoint chain_state checkpoint)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Tezos_shell_services.History_mode.Full =>
State.Chain.set_checkpoint_then_purge_full chain_state checkpoint
| Tezos_shell_services.History_mode.Rolling =>
State.Chain.set_checkpoint_then_purge_rolling chain_state
checkpoint
end))
end.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition store_known_protocols (state : Tezos_shell__State.global_state)
: Lwt.t unit :=
let embedded_protocols := Registered_protocol.list_embedded tt in
Lwt_list.iter_s
(fun protocol_hash =>
op_gtgteq (State.Protocol.known state protocol_hash)
(fun function_parameter =>
match function_parameter with
| true =>
lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"protocol " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is already in store: nothing to do" % string
CamlinternalFormatBasics.End_of_format)))
"protocol %a is already in store: nothing to do" %
string)) (a Protocol_hash.Logging.tag protocol_hash))
(t event "embedded_protocol_already_stored" % string))
| false =>
match Registered_protocol.get_embedded_sources protocol_hash with
| None =>
lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"protocol " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" won't be stored: missing source files" %
string CamlinternalFormatBasics.End_of_format)))
"protocol %a won't be stored: missing source files" %
string)) (a Protocol_hash.Logging.tag protocol_hash))
(t event "embedded_protocol_missing_sources" % string))
| Some protocol =>
let hash := Protocol.hash protocol in
if negb (Protocol_hash.equal hash protocol_hash) then
lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"protocol " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" won't be stored: wrong hash" % string
CamlinternalFormatBasics.End_of_format)))
"protocol %a won't be stored: wrong hash" % string))
(a Protocol_hash.Logging.tag protocol_hash))
(t event "embedded_protocol_inconsistent_hash" % string))
else
op_gtgteq (State.Protocol.store state protocol)
(fun function_parameter =>
match function_parameter with
| Some hash' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb hash hash') in
lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"protocol " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" successfully stored" % string
CamlinternalFormatBasics.End_of_format)))
"protocol %a successfully stored" % string))
(a Protocol_hash.Logging.tag protocol_hash))
(t event "embedded_protocol_stored" % string))
| None =>
lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"protocol " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is already in store: nothing to do" %
string
CamlinternalFormatBasics.End_of_format)))
"protocol %a is already in store: nothing to do"
% string))
(a Protocol_hash.Logging.tag protocol_hash))
(t event "embedded_protocol_already_stored" % string))
end)
end
end)) embedded_protocols.
Definition create (op_staroptstar : option bool)
: (option Tezos_base__TzPervasives.Data_encoding.json) ->
bool ->
config ->
Tezos_shell.Peer_validator.limits ->
Tezos_shell.Block_validator.limits ->
Tezos_shell.Prevalidator.limits ->
Tezos_shell.Chain_validator.limits ->
(option Tezos_shell_services.History_mode.t) ->
Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
let sandboxed :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun sandbox_parameters =>
fun singleprocess =>
fun function_parameter =>
let '{|
genesis := genesis;
store_root := store_root;
context_root := context_root;
protocol_root := protocol_root;
patch_context := patch_context;
p2p := p2p_params;
checkpoint := checkpoint
|} := function_parameter in
fun peer_validator_limits =>
fun block_validator_limits =>
fun prevalidator_limits =>
fun chain_validator_limits =>
fun history_mode =>
let '(start_prevalidator, start_testchain) :=
match p2p_params with
| Some (config, _limits) =>
((negb (P2p.disable_mempool config)),
(negb (P2p.disable_testchain config)))
| None => (true, true)
end in
op_gtgteqquestion (init_p2p (Some sandboxed) p2p_params)
(fun p2p =>
op_gtgteqquestion
(if singleprocess then
op_gtgteqquestion
(State.init patch_context None None None store_root
context_root history_mode genesis)
(fun function_parameter =>
let
'(state, mainchain_state, context_index,
history_mode) := function_parameter in
op_gtgteqquestion
(init
(Tezos_shell.Block_validator_process.Internal
context_index))
(fun validator_process =>
_return
(validator_process, state, mainchain_state,
history_mode)))
else
op_gtgteqquestion
(init
(Tezos_shell.Block_validator_process.External
{| context_root := context_root;
protocol_root := protocol_root;
process_path := Sys.executable_name;
sandbox_parameters := sandbox_parameters |}))
(fun validator_process =>
let commit_genesis :=
Block_validator_process.commit_genesis
validator_process (block genesis) in
op_gtgteqquestion
(State.init patch_context (Some commit_genesis)
None None store_root context_root history_mode
genesis)
(fun function_parameter =>
let
'(state, mainchain_state, _context_index,
history_mode) := function_parameter in
_return
(validator_process, state, mainchain_state,
history_mode))))
(fun function_parameter =>
let
'(validator_process, state, mainchain_state,
history_mode) := function_parameter in
op_gtgteqquestion
(may_update_checkpoint mainchain_state checkpoint
history_mode)
(fun function_parameter =>
let 'tt := function_parameter in
let distributed_db :=
Distributed_db.create state p2p in
op_gtgteq (store_known_protocols state)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Validator.create state distributed_db
peer_validator_limits
block_validator_limits validator_process
prevalidator_limits chain_validator_limits
start_testchain)
(fun validator =>
op_gtgteqquestion
(Validator.activate validator
start_prevalidator validator_process
mainchain_state)
(fun mainchain_validator =>
let shutdown
(function_parameter : unit)
: Lwt.t unit :=
let 'tt := function_parameter in
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down the p2p layer..."
% string
CamlinternalFormatBasics.End_of_format)
"Shutting down the p2p layer..."
% string))
(t event "shutdown" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (P2p.shutdown p2p)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down the distributed database..."
% string
CamlinternalFormatBasics.End_of_format)
"Shutting down the distributed database..."
% string))
(t event
"shutdown" %
string)))
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteq
(Distributed_db.shutdown
distributed_db)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down the validator..."
%
string
CamlinternalFormatBasics.End_of_format)
"Shutting down the validator..."
%
string))
(t event
"shutdown"
% string)))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(Validator.shutdown
validator)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(lwt_log_info
(fun f
=>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Closing down the state..."
%
string
CamlinternalFormatBasics.End_of_format)
"Closing down the state..."
%
string))
(t
event
"shutdown"
%
string)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
State.close
state)))))))
in
_return
{| state := state;
distributed_db := distributed_db;
validator := validator;
mainchain_validator :=
mainchain_validator; p2p := p2p;
shutdown := shutdown |})))))).
Definition shutdown (node : t) : Lwt.t unit := (shutdown node) tt.
Definition build_rpc_directory (node : t)
: Tezos_base__TzPervasives.RPC_directory.directory unit :=
let dir := Stdlib.ref RPC_directory.empty in
let merge (d : Tezos_base__TzPervasives.RPC_directory.directory unit)
: unit :=
Stdlib.op_coloneq dir (RPC_directory.merge (Stdlib.op_exclamation dir) d) in
let register0 {A B C : Type}
(s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
A -> B -> Lwt.t (Tezos_error_monad.Error_monad.tzresult C)) : unit :=
Stdlib.op_coloneq dir
(RPC_directory.register (Stdlib.op_exclamation dir) s
(fun function_parameter =>
let 'tt := function_parameter in
fun p => fun q => f p q)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
merge
(Protocol_directory.build_rpc_directory
(Block_validator.running_worker tt) (state node)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
merge
(Monitor_directory.build_rpc_directory (validator node)
(mainchain_validator node)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := merge (Injection_directory.build_rpc_directory (validator node)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := merge (Chain_directory.build_rpc_directory (validator node)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := merge (P2p_directory.build_rpc_directory (p2p node)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := merge (Worker_directory.build_rpc_directory (state node)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := merge (Stat_directory.rpc_directory tt) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 RPC_service.error_service
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
_return (Data_encoding.Json.schema None Error_monad.error_encoding))
in
RPC_directory.register_describe_directory_service (Stdlib.op_exclamation dir)
RPC_service.description_service.
src/lib_shell/p2p_directory.ml 120 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let info_of_point_info i =
let open P2p_point.Info in
let open P2p_point.State in
let state =
match P2p_point_state.get i with
| Requested _ ->
Requested
| Accepted {current_peer_id; _} ->
Accepted current_peer_id
| Running {current_peer_id; _} ->
Running current_peer_id
| Disconnected ->
Disconnected
in
P2p_point_state.Info.
{
trusted = trusted i;
state;
greylisted_until = greylisted_until i;
last_failed_connection = last_failed_connection i;
last_rejected_connection = last_rejected_connection i;
last_established_connection = last_established_connection i;
last_disconnection = last_disconnection i;
last_seen = last_seen i;
last_miss = last_miss i;
}
let info_of_peer_info pool i =
let open P2p_peer.Info in
let open P2p_peer.State in
let (state, id_point) =
match P2p_peer_state.get i with
| Accepted {current_point; _} ->
(Accepted, Some current_point)
| Running {current_point; _} ->
(Running, Some current_point)
| Disconnected ->
(Disconnected, None)
in
let peer_id = P2p_peer_state.Info.peer_id i in
let score = P2p_pool.Peers.get_score pool peer_id in
let conn_opt = P2p_pool.Connection.find_by_peer_id pool peer_id in
let stat =
match conn_opt with
| None ->
P2p_stat.empty
| Some conn ->
P2p_conn.stat conn
in
let meta_opt =
match conn_opt with
| None ->
None
| Some conn ->
Some (P2p_conn.remote_metadata conn)
in
P2p_peer_state.Info.
{
score;
trusted = trusted i;
conn_metadata = meta_opt;
peer_metadata = peer_metadata i;
state;
id_point;
stat;
last_failed_connection = last_failed_connection i;
last_rejected_connection = last_rejected_connection i;
last_established_connection = last_established_connection i;
last_disconnection = last_disconnection i;
last_seen = last_seen i;
last_miss = last_miss i;
}
let build_rpc_directory net =
let dir = RPC_directory.empty in
(* Network : Global *)
let dir =
RPC_directory.register0 dir P2p_services.S.version (fun () () ->
return (P2p.announced_version net))
in
let dir =
(* DEPRECATED: use [version] instead. *)
RPC_directory.register0 dir P2p_services.S.versions (fun () () ->
return [P2p.announced_version net])
in
let dir =
RPC_directory.register0 dir P2p_services.S.self (fun () () ->
match P2p.pool net with
| None ->
failwith "The P2P layer is disabled."
| Some pool ->
return (P2p_pool.config pool).identity.peer_id)
in
let dir =
RPC_directory.register0 dir P2p_services.S.stat (fun () () ->
match P2p.connect_handler net with
| None ->
return P2p_stat.empty
| Some connect_handler ->
return (P2p_connect_handler.stat connect_handler))
in
let dir =
RPC_directory.gen_register0 dir P2p_services.S.events (fun () () ->
let (stream, stopper) = P2p.watcher net in
let shutdown () = Lwt_watcher.shutdown stopper in
let next () = Lwt_stream.get stream in
RPC_answer.return_stream {next; shutdown})
in
let dir =
RPC_directory.register1 dir P2p_services.S.connect (fun point q () ->
match P2p.connect_handler net with
| None ->
failwith "The P2P layer is disabled."
| Some connect_handler ->
P2p_connect_handler.connect
~timeout:q#timeout
connect_handler
point
>>=? fun _conn -> return_unit)
in
(* Network : Connection *)
let dir =
RPC_directory.opt_register1
dir
P2p_services.Connections.S.info
(fun peer_id () () ->
return
@@ Option.apply (P2p.pool net) ~f:(fun pool ->
Option.map
~f:P2p_conn.info
(P2p_pool.Connection.find_by_peer_id pool peer_id)))
in
let dir =
RPC_directory.lwt_register1
dir
P2p_services.Connections.S.kick
(fun peer_id q () ->
match P2p.pool net with
| None ->
Lwt.return_unit
| Some pool -> (
match P2p_pool.Connection.find_by_peer_id pool peer_id with
| None ->
Lwt.return_unit
| Some conn ->
P2p_conn.disconnect ~wait:q#wait conn ))
in
let dir =
RPC_directory.register0 dir P2p_services.Connections.S.list (fun () () ->
match P2p.pool net with
| None ->
return_nil
| Some pool ->
return
@@ P2p_pool.Connection.fold pool ~init:[] ~f:(fun _peer_id c acc ->
P2p_conn.info c :: acc))
in
(* Network : Peer_id *)
let dir =
RPC_directory.register0 dir P2p_services.Peers.S.list (fun q () ->
match P2p.pool net with
| None ->
return_nil
| Some pool ->
return
@@ P2p_pool.Peers.fold_known pool ~init:[] ~f:(fun peer_id i a ->
let info = info_of_peer_info pool i in
match q#filters with
| [] ->
(peer_id, info) :: a
| filters when P2p_peer.State.filter filters info.state ->
(peer_id, info) :: a
| _ ->
a))
in
let dir =
RPC_directory.opt_register1
dir
P2p_services.Peers.S.info
(fun peer_id () () ->
match P2p.pool net with
| None ->
return_none
| Some pool ->
return
@@ Option.map
~f:(info_of_peer_info pool)
(P2p_pool.Peers.info pool peer_id))
in
let dir =
RPC_directory.gen_register1
dir
P2p_services.Peers.S.events
(fun peer_id q () ->
match P2p.pool net with
| None ->
RPC_answer.not_found
| Some pool -> (
match P2p_pool.Peers.info pool peer_id with
| None ->
RPC_answer.return []
| Some gi ->
let rev = false and max = max_int in
let evts =
P2p_peer_state.Info.fold gi ~init:[] ~f:(fun a e -> e :: a)
in
let evts = (if rev then List.rev_sub else List.sub) evts max in
if not q#monitor then RPC_answer.return evts
else
let (stream, stopper) = P2p_peer_state.Info.watch gi in
let shutdown () = Lwt_watcher.shutdown stopper in
let first_request = ref true in
let next () =
if not !first_request then
Lwt_stream.get stream >|= Option.map ~f:(fun i -> [i])
else (
first_request := false ;
Lwt.return_some evts )
in
RPC_answer.return_stream {next; shutdown} ))
in
let dir =
RPC_directory.gen_register1
dir
P2p_services.Peers.S.ban
(fun peer_id () () ->
match P2p.pool net with
| None ->
RPC_answer.not_found
| Some pool ->
P2p_pool.Peers.untrust pool peer_id ;
P2p_pool.Peers.ban pool peer_id ;
RPC_answer.return_unit)
in
let dir =
RPC_directory.gen_register1
dir
P2p_services.Peers.S.unban
(fun peer_id () () ->
match P2p.pool net with
| None ->
RPC_answer.not_found
| Some pool ->
P2p_pool.Peers.unban pool peer_id ;
RPC_answer.return_unit)
in
let dir =
RPC_directory.gen_register1
dir
P2p_services.Peers.S.trust
(fun peer_id () () ->
match P2p.pool net with
| None ->
RPC_answer.not_found
| Some pool ->
P2p_pool.Peers.trust pool peer_id ;
RPC_answer.return_unit)
in
let dir =
RPC_directory.gen_register1
dir
P2p_services.Peers.S.untrust
(fun peer_id () () ->
match P2p.pool net with
| None ->
RPC_answer.not_found
| Some pool ->
P2p_pool.Peers.untrust pool peer_id ;
RPC_answer.return_unit)
in
let dir =
RPC_directory.register1
dir
P2p_services.Peers.S.banned
(fun peer_id () () ->
match P2p.pool net with
| None ->
return_false
| Some pool when P2p_pool.Peers.get_trusted pool peer_id ->
return_false
| Some pool ->
return (P2p_pool.Peers.banned pool peer_id))
in
(* Network : Point *)
let dir =
RPC_directory.register0 dir P2p_services.Points.S.list (fun q () ->
match P2p.pool net with
| None ->
return_nil
| Some pool ->
return
@@ P2p_pool.Points.fold_known pool ~init:[] ~f:(fun point i a ->
let info = info_of_point_info i in
match q#filters with
| [] ->
(point, info) :: a
| filters when P2p_point.State.filter filters info.state ->
(point, info) :: a
| _ ->
a))
in
let dir =
RPC_directory.opt_register1
dir
P2p_services.Points.S.info
(fun point () () ->
match P2p.pool net with
| None ->
return_none
| Some pool ->
return
@@ Option.map
(P2p_pool.Points.info pool point)
~f:info_of_point_info)
in
let dir =
RPC_directory.gen_register1
dir
P2p_services.Points.S.events
(fun point_id q () ->
match P2p.pool net with
| None ->
RPC_answer.not_found
| Some pool -> (
match P2p_pool.Points.info pool point_id with
| None ->
RPC_answer.return []
| Some gi ->
let rev = false and max = max_int in
let evts =
P2p_point_state.Info.fold gi ~init:[] ~f:(fun a e -> e :: a)
in
let evts = (if rev then List.rev_sub else List.sub) evts max in
if not q#monitor then RPC_answer.return evts
else
let (stream, stopper) = P2p_point_state.Info.watch gi in
let shutdown () = Lwt_watcher.shutdown stopper in
let first_request = ref true in
let next () =
if not !first_request then
Lwt_stream.get stream >|= Option.map ~f:(fun i -> [i])
else (
first_request := false ;
Lwt.return_some evts )
in
RPC_answer.return_stream {next; shutdown} ))
in
let dir =
RPC_directory.gen_register1
dir
P2p_services.Points.S.ban
(fun point () () ->
match P2p.pool net with
| None ->
RPC_answer.not_found
| Some pool ->
P2p_pool.Points.untrust pool point ;
P2p_pool.Points.ban pool point ;
RPC_answer.return_unit)
in
let dir =
RPC_directory.gen_register1
dir
P2p_services.Points.S.unban
(fun point () () ->
match P2p.pool net with
| None ->
RPC_answer.not_found
| Some pool ->
P2p_pool.Points.unban pool point ;
RPC_answer.return_unit)
in
let dir =
RPC_directory.gen_register1
dir
P2p_services.Points.S.trust
(fun point () () ->
match P2p.pool net with
| None ->
RPC_answer.not_found
| Some pool ->
P2p_pool.Points.trust pool point ;
RPC_answer.return_unit)
in
let dir =
RPC_directory.gen_register1
dir
P2p_services.Points.S.untrust
(fun point () () ->
match P2p.pool net with
| None ->
RPC_answer.not_found
| Some pool ->
P2p_pool.Points.untrust pool point ;
RPC_answer.return_unit)
in
let dir =
RPC_directory.gen_register1
dir
P2p_services.Points.S.banned
(fun point () () ->
match P2p.pool net with
| None ->
RPC_answer.not_found
| Some pool when P2p_pool.Points.get_trusted pool point ->
RPC_answer.return false
| Some pool ->
RPC_answer.return (P2p_pool.Points.banned pool point))
in
(* Network : Greylist *)
let dir =
RPC_directory.register dir P2p_services.ACL.S.clear (fun () () () ->
match P2p.pool net with
| None ->
return_unit
| Some pool ->
P2p_pool.acl_clear pool ; return_unit)
in
dir
src/lib_shell/p2p_directory.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition info_of_point_info {A : Type}
(i : Tezos_p2p.P2p_point_state.Info.t A)
: Tezos_base__TzPervasives.P2p_point.Info.t :=
let state :=
match P2p_point_state.get i with
| Tezos_p2p.P2p_point_state.Requested _ =>
Tezos_base__TzPervasives.P2p_point.State.Requested
|
Tezos_p2p.P2p_point_state.Accepted {|
current_peer_id := current_peer_id |} =>
Tezos_base__TzPervasives.P2p_point.State.Accepted current_peer_id
| Tezos_p2p.P2p_point_state.Running {| current_peer_id := current_peer_id |}
=> Tezos_base__TzPervasives.P2p_point.State.Running current_peer_id
| Tezos_p2p.P2p_point_state.Disconnected =>
Tezos_base__TzPervasives.P2p_point.State.Disconnected
end in
{| trusted := trusted i; greylisted_until := greylisted_until i;
state := state; last_failed_connection := last_failed_connection i;
last_rejected_connection := last_rejected_connection i;
last_established_connection := last_established_connection i;
last_disconnection := last_disconnection i; last_seen := last_seen i;
last_miss := last_miss i |}.
Definition info_of_peer_info {A B C D E F : Type}
(pool : Tezos_p2p__P2p_pool.t A B C)
(i : Tezos_p2p.P2p_peer_state.Info.t D E F)
: Tezos_base__TzPervasives.P2p_peer.Info.t E C :=
let '(state, id_point) :=
match P2p_peer_state.get i with
| Tezos_p2p.P2p_peer_state.Accepted {| current_point := current_point |} =>
(Tezos_base__TzPervasives.P2p_peer.State.Accepted, (Some current_point))
| Tezos_p2p.P2p_peer_state.Running {| current_point := current_point |} =>
(Tezos_base__TzPervasives.P2p_peer.State.Running, (Some current_point))
| Tezos_p2p.P2p_peer_state.Disconnected =>
(Tezos_base__TzPervasives.P2p_peer.State.Disconnected, None)
end in
let peer_id := P2p_peer_state.Info.peer_id i in
let score := P2p_pool.Peers.get_score pool peer_id in
let conn_opt := P2p_pool.Connection.find_by_peer_id pool peer_id in
let stat :=
match conn_opt with
| None => P2p_stat.empty
| Some conn => P2p_conn.stat conn
end in
let meta_opt :=
match conn_opt with
| None => None
| Some conn => Some (P2p_conn.remote_metadata conn)
end in
{| score := score; trusted := trusted i; conn_metadata := meta_opt;
peer_metadata := peer_metadata i; state := state; id_point := id_point;
stat := stat; last_failed_connection := last_failed_connection i;
last_rejected_connection := last_rejected_connection i;
last_established_connection := last_established_connection i;
last_disconnection := last_disconnection i; last_seen := last_seen i;
last_miss := last_miss i |}.
Definition build_rpc_directory {A : Type}
(net :
Tezos_p2p.P2p.net A Tezos_shell_services.Peer_metadata.t
Tezos_shell_services.Connection_metadata.t)
: Tezos_base__TzPervasives.RPC_directory.directory unit :=
let dir := RPC_directory.empty in
let dir :=
RPC_directory.register0 dir P2p_services.S.version
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
_return (P2p.announced_version net)) in
let dir :=
RPC_directory.register0 dir P2p_services.S.versions
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
_return (cons (P2p.announced_version net) [])) in
let dir :=
RPC_directory.register0 dir P2p_services.S.self
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The P2P layer is disabled." % string
CamlinternalFormatBasics.End_of_format)
"The P2P layer is disabled." % string)
| Some pool => _return (peer_id (identity (P2p_pool.config pool)))
end) in
let dir :=
RPC_directory.register0 dir P2p_services.S.stat
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.connect_handler net with
| None => _return P2p_stat.empty
| Some connect_handler =>
_return (P2p_connect_handler.stat connect_handler)
end) in
let dir :=
RPC_directory.gen_register0 dir P2p_services.S.events
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
let '(stream, stopper) := P2p.watcher net in
let shutdown (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Lwt_watcher.shutdown stopper in
let next (function_parameter : unit)
: Lwt.t (option Tezos_base__TzPervasives.P2p_connection.P2p_event.t) :=
let 'tt := function_parameter in
Lwt_stream.get stream in
RPC_answer.return_stream {| next := next; shutdown := shutdown |}) in
let dir :=
RPC_directory.register1 dir P2p_services.S.connect
(fun point =>
fun q =>
fun function_parameter =>
let 'tt := function_parameter in
match P2p.connect_handler net with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The P2P layer is disabled." % string
CamlinternalFormatBasics.End_of_format)
"The P2P layer is disabled." % string)
| Some connect_handler =>
op_gtgteqquestion
(P2p_connect_handler.connect
(Some
(* ❌ Sending method message is not handled *)
send) connect_handler point) (fun _conn => return_unit)
end) in
let dir :=
RPC_directory.opt_register1 dir P2p_services.Connections.S.info
(fun peer_id =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
apply _return
(Option.apply
(fun pool =>
Option.map P2p_conn.info
(P2p_pool.Connection.find_by_peer_id pool peer_id))
(P2p.pool net))) in
let dir :=
RPC_directory.lwt_register1 dir P2p_services.Connections.S.kick
(fun peer_id =>
fun q =>
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => Lwt.return_unit
| Some pool =>
match P2p_pool.Connection.find_by_peer_id pool peer_id with
| None => Lwt.return_unit
| Some conn =>
P2p_conn.disconnect
(Some
(* ❌ Sending method message is not handled *)
send) conn
end
end) in
let dir :=
RPC_directory.register0 dir P2p_services.Connections.S.list
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => return_nil
| Some pool =>
apply _return
(P2p_pool.Connection.fold pool []
(fun _peer_id => fun c => fun acc => cons (P2p_conn.info c) acc))
end) in
let dir :=
RPC_directory.register0 dir P2p_services.Peers.S.list
(fun q =>
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => return_nil
| Some pool =>
apply _return
(P2p_pool.Peers.fold_known pool []
(fun peer_id =>
fun i =>
fun a =>
let info := info_of_peer_info pool i in
match
(* ❌ Sending method message is not handled *)
send with
| [] => cons (peer_id, info) a
| filters => cons (peer_id, info) a
| _ => a
end))
end) in
let dir :=
RPC_directory.opt_register1 dir P2p_services.Peers.S.info
(fun peer_id =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => return_none
| Some pool =>
apply _return
(Option.map (info_of_peer_info pool)
(P2p_pool.Peers.info pool peer_id))
end) in
let dir :=
RPC_directory.gen_register1 dir P2p_services.Peers.S.events
(fun peer_id =>
fun q =>
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => RPC_answer.not_found
| Some pool =>
match P2p_pool.Peers.info pool peer_id with
| None => RPC_answer._return []
| Some gi =>
let rev : bool :=
false
with max : Z :=
Stdlib.max_int in
let evts :=
P2p_peer_state.Info.fold gi [] (fun a => fun e => cons e a) in
let evts :=
(if rev then
List.rev_sub
else
List.sub) evts max in
if
negb
(* ❌ Sending method message is not handled *)
send then
RPC_answer._return evts
else
let '(stream, stopper) := P2p_peer_state.Info.watch gi in
let shutdown (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Lwt_watcher.shutdown stopper in
let first_request := Stdlib.ref true in
let next (function_parameter : unit)
: Lwt.t
(option
(list Tezos_base__TzPervasives.P2p_peer.Pool_event.t)) :=
let 'tt := function_parameter in
if negb (Stdlib.op_exclamation first_request) then
op_gtpipeeq (Lwt_stream.get stream)
(Option.map (fun i => cons i []))
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq first_request false in
Lwt.return_some evts in
RPC_answer.return_stream
{| next := next; shutdown := shutdown |}
end
end) in
let dir :=
RPC_directory.gen_register1 dir P2p_services.Peers.S.ban
(fun peer_id =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => RPC_answer.not_found
| Some pool =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_pool.Peers.untrust pool peer_id in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_pool.Peers.ban pool peer_id in
RPC_answer.return_unit
end) in
let dir :=
RPC_directory.gen_register1 dir P2p_services.Peers.S.unban
(fun peer_id =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => RPC_answer.not_found
| Some pool =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_pool.Peers.unban pool peer_id in
RPC_answer.return_unit
end) in
let dir :=
RPC_directory.gen_register1 dir P2p_services.Peers.S.trust
(fun peer_id =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => RPC_answer.not_found
| Some pool =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_pool.Peers.trust pool peer_id in
RPC_answer.return_unit
end) in
let dir :=
RPC_directory.gen_register1 dir P2p_services.Peers.S.untrust
(fun peer_id =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => RPC_answer.not_found
| Some pool =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_pool.Peers.untrust pool peer_id in
RPC_answer.return_unit
end) in
let dir :=
RPC_directory.register1 dir P2p_services.Peers.S.banned
(fun peer_id =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => return_false
| Some pool => return_false
| Some pool => _return (P2p_pool.Peers.banned pool peer_id)
end) in
let dir :=
RPC_directory.register0 dir P2p_services.Points.S.list
(fun q =>
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => return_nil
| Some pool =>
apply _return
(P2p_pool.Points.fold_known pool []
(fun point =>
fun i =>
fun a =>
let info := info_of_point_info i in
match
(* ❌ Sending method message is not handled *)
send with
| [] => cons (point, info) a
| filters => cons (point, info) a
| _ => a
end))
end) in
let dir :=
RPC_directory.opt_register1 dir P2p_services.Points.S.info
(fun point =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => return_none
| Some pool =>
apply _return
(Option.map info_of_point_info (P2p_pool.Points.info pool point))
end) in
let dir :=
RPC_directory.gen_register1 dir P2p_services.Points.S.events
(fun point_id =>
fun q =>
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => RPC_answer.not_found
| Some pool =>
match P2p_pool.Points.info pool point_id with
| None => RPC_answer._return []
| Some gi =>
let rev : bool :=
false
with max : Z :=
Stdlib.max_int in
let evts :=
P2p_point_state.Info.fold gi [] (fun a => fun e => cons e a)
in
let evts :=
(if rev then
List.rev_sub
else
List.sub) evts max in
if
negb
(* ❌ Sending method message is not handled *)
send then
RPC_answer._return evts
else
let '(stream, stopper) := P2p_point_state.Info.watch gi in
let shutdown (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Lwt_watcher.shutdown stopper in
let first_request := Stdlib.ref true in
let next (function_parameter : unit)
: Lwt.t
(option
(list Tezos_base__TzPervasives.P2p_point.Pool_event.t)) :=
let 'tt := function_parameter in
if negb (Stdlib.op_exclamation first_request) then
op_gtpipeeq (Lwt_stream.get stream)
(Option.map (fun i => cons i []))
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq first_request false in
Lwt.return_some evts in
RPC_answer.return_stream
{| next := next; shutdown := shutdown |}
end
end) in
let dir :=
RPC_directory.gen_register1 dir P2p_services.Points.S.ban
(fun point =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => RPC_answer.not_found
| Some pool =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_pool.Points.untrust pool point in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_pool.Points.ban pool point in
RPC_answer.return_unit
end) in
let dir :=
RPC_directory.gen_register1 dir P2p_services.Points.S.unban
(fun point =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => RPC_answer.not_found
| Some pool =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_pool.Points.unban pool point in
RPC_answer.return_unit
end) in
let dir :=
RPC_directory.gen_register1 dir P2p_services.Points.S.trust
(fun point =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => RPC_answer.not_found
| Some pool =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_pool.Points.trust pool point in
RPC_answer.return_unit
end) in
let dir :=
RPC_directory.gen_register1 dir P2p_services.Points.S.untrust
(fun point =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => RPC_answer.not_found
| Some pool =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_pool.Points.untrust pool point in
RPC_answer.return_unit
end) in
let dir :=
RPC_directory.gen_register1 dir P2p_services.Points.S.banned
(fun point =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => RPC_answer.not_found
| Some pool => RPC_answer._return false
| Some pool =>
RPC_answer._return (P2p_pool.Points.banned pool point)
end) in
let dir :=
RPC_directory.register dir P2p_services.ACL.S.clear
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match P2p.pool net with
| None => return_unit
| Some pool =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := P2p_pool.acl_clear pool in
return_unit
end) in
dir.
src/lib_shell/peer_validator.ml 95 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* FIXME ignore/postpone fetching/validating of block in the future... *)
open Peer_validator_worker_state
module Name = struct
type t = Chain_id.t * P2p_peer.Id.t
let encoding = Data_encoding.tup2 Chain_id.encoding P2p_peer.Id.encoding
let base = ["validator"; "peer"]
let pp ppf (chain, peer) =
Format.fprintf
ppf
"%a:%a"
Chain_id.pp_short
chain
P2p_peer.Id.pp_short
peer
end
module Request = struct
include Request
type _ t =
| New_head : Block_hash.t * Block_header.t -> unit t
| New_branch :
Block_hash.t * Block_locator.t * Block_locator.seed
-> unit t
let view (type a) (req : a t) : view =
match req with
| New_head (hash, _) ->
New_head hash
| New_branch (hash, locator, seed) ->
(* the seed is associated to each locator
w.r.t. the peer_id of the sender *)
New_branch (hash, Block_locator.estimated_length seed locator)
end
type limits = {
new_head_request_timeout : Time.System.Span.t;
block_header_timeout : Time.System.Span.t;
block_operations_timeout : Time.System.Span.t;
protocol_timeout : Time.System.Span.t;
worker_limits : Worker_types.limits;
}
module Types = struct
include Worker_state
type parameters = {
chain_db : Distributed_db.chain_db;
block_validator : Block_validator.t;
(* callback to chain_validator *)
notify_new_block : State.Block.t -> unit;
notify_bootstrapped : unit -> unit;
notify_termination : unit -> unit;
limits : limits;
}
type state = {
peer_id : P2p_peer.Id.t;
parameters : parameters;
mutable bootstrapped : bool;
mutable pipeline : Bootstrap_pipeline.t option;
mutable last_validated_head : Block_header.t;
mutable last_advertised_head : Block_header.t;
}
let pipeline_length = function
| None ->
Bootstrap_pipeline.length_zero
| Some p ->
Bootstrap_pipeline.length p
let view (state : state) _ : view =
let {bootstrapped; pipeline; last_validated_head; last_advertised_head; _}
=
state
in
{
bootstrapped;
pipeline_length = pipeline_length pipeline;
last_validated_head = Block_header.hash last_validated_head;
last_advertised_head = Block_header.hash last_advertised_head;
}
end
module Logger = Worker_logger.Make (Event) (Request)
module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)
open Types
type t = Worker.dropbox Worker.t
let debug w = Format.kasprintf (fun msg -> Worker.record_event w (Debug msg))
let set_bootstrapped pv =
if not pv.bootstrapped then (
pv.bootstrapped <- true ;
pv.parameters.notify_bootstrapped () )
let bootstrap_new_branch w _head unknown_prefix =
let pv = Worker.state w in
let sender_id = Distributed_db.my_peer_id pv.parameters.chain_db in
(* sender and receiver are inverted here because they are from
the point of view of the node sending the locator *)
let seed = {Block_locator.sender_id = pv.peer_id; receiver_id = sender_id} in
let len = Block_locator.estimated_length seed unknown_prefix in
debug
w
"validating new branch from peer %a (approx. %d blocks)"
P2p_peer.Id.pp_short
pv.peer_id
len ;
let pipeline =
Bootstrap_pipeline.create
~notify_new_block:pv.parameters.notify_new_block
~block_header_timeout:pv.parameters.limits.block_header_timeout
~block_operations_timeout:pv.parameters.limits.block_operations_timeout
pv.parameters.block_validator
pv.peer_id
pv.parameters.chain_db
unknown_prefix
in
pv.pipeline <- Some pipeline ;
Worker.protect
w
~on_error:(fun error ->
(* if the peer_validator is killed, let's cancel the pipeline *)
pv.pipeline <- None ;
Bootstrap_pipeline.cancel pipeline >>= fun () -> Lwt.return_error error)
(fun () -> Bootstrap_pipeline.wait pipeline)
>>=? fun () ->
pv.pipeline <- None ;
set_bootstrapped pv ;
debug
w
"done validating new branch from peer %a."
P2p_peer.Id.pp_short
pv.peer_id ;
return_unit
let validate_new_head w hash (header : Block_header.t) =
let pv = Worker.state w in
debug
w
"fetching operations for new head %a from peer %a"
Block_hash.pp_short
hash
P2p_peer.Id.pp_short
pv.peer_id ;
map_p
(fun i ->
Worker.protect w (fun () ->
Distributed_db.Operations.fetch
~timeout:pv.parameters.limits.block_operations_timeout
pv.parameters.chain_db
~peer:pv.peer_id
(hash, i)
header.shell.operations_hash))
(0 -- (header.shell.validation_passes - 1))
>>=? fun operations ->
debug
w
"requesting validation for new head %a from peer %a"
Block_hash.pp_short
hash
P2p_peer.Id.pp_short
pv.peer_id ;
Block_validator.validate
~notify_new_block:pv.parameters.notify_new_block
pv.parameters.block_validator
pv.parameters.chain_db
hash
header
operations
>>=? fun _block ->
debug
w
"end of validation for new head %a from peer %a"
Block_hash.pp_short
hash
P2p_peer.Id.pp_short
pv.peer_id ;
set_bootstrapped pv ;
let meta =
Distributed_db.get_peer_metadata pv.parameters.chain_db pv.peer_id
in
Peer_metadata.incr meta Valid_blocks ;
return_unit
let only_if_fitness_increases w distant_header cont =
let pv = Worker.state w in
let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
Chain.head chain_state
>>= fun local_header ->
if
Fitness.compare
distant_header.Block_header.shell.fitness
(State.Block.fitness local_header)
<= 0
then (
set_bootstrapped pv ;
debug
w
"ignoring head %a with non increasing fitness from peer: %a."
Block_hash.pp_short
(Block_header.hash distant_header)
P2p_peer.Id.pp_short
pv.peer_id ;
(* Don't download a branch that cannot beat the current head. *)
let meta =
Distributed_db.get_peer_metadata pv.parameters.chain_db pv.peer_id
in
Peer_metadata.incr meta Old_heads ;
return_unit )
else cont ()
let assert_acceptable_head w hash (header : Block_header.t) =
let pv = Worker.state w in
let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
State.Chain.acceptable_block chain_state header
>>= fun acceptable ->
fail_unless
acceptable
(Validation_errors.Checkpoint_error (hash, Some pv.peer_id))
let may_validate_new_head w hash (header : Block_header.t) =
let pv = Worker.state w in
let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
State.Block.known_valid chain_state hash
>>= fun valid_block ->
State.Block.known_invalid chain_state hash
>>= fun invalid_block ->
State.Block.known_valid chain_state header.shell.predecessor
>>= fun valid_predecessor ->
State.Block.known_invalid chain_state header.shell.predecessor
>>= fun invalid_predecessor ->
if valid_block then (
debug
w
"ignoring previously validated block %a from peer %a"
Block_hash.pp_short
hash
P2p_peer.Id.pp_short
pv.peer_id ;
set_bootstrapped pv ;
pv.last_validated_head <- header ;
return_unit )
else if invalid_block then (
debug
w
"ignoring known invalid block %a from peer %a"
Block_hash.pp_short
hash
P2p_peer.Id.pp_short
pv.peer_id ;
fail Validation_errors.Known_invalid )
else if invalid_predecessor then (
debug
w
"ignoring known invalid block %a from peer %a"
Block_hash.pp_short
hash
P2p_peer.Id.pp_short
pv.peer_id ;
Distributed_db.commit_invalid_block
pv.parameters.chain_db
hash
header
[Validation_errors.Known_invalid]
>>=? fun _ -> fail Validation_errors.Known_invalid )
else if not valid_predecessor then (
debug
w
"missing predecessor for new head %a from peer %a"
Block_hash.pp_short
hash
P2p_peer.Id.pp_short
pv.peer_id ;
Distributed_db.Request.current_branch
pv.parameters.chain_db
~peer:pv.peer_id
() ;
return_unit )
else
only_if_fitness_increases w header
@@ fun () ->
assert_acceptable_head w hash header
>>=? fun () -> validate_new_head w hash header
let may_validate_new_branch w distant_hash locator =
let pv = Worker.state w in
let (distant_header, _) =
(locator : Block_locator.t :> Block_header.t * _)
in
only_if_fitness_increases w distant_header
@@ fun () ->
assert_acceptable_head w (Block_header.hash distant_header) distant_header
>>=? fun () ->
let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
State.Block.known_ancestor chain_state locator
>>= function
| None ->
debug
w
"ignoring branch %a without common ancestor from peer: %a."
Block_hash.pp_short
distant_hash
P2p_peer.Id.pp_short
pv.peer_id ;
fail Validation_errors.Unknown_ancestor
| Some unknown_prefix ->
let (_, history) = Block_locator.raw unknown_prefix in
if history <> [] then
bootstrap_new_branch w distant_header unknown_prefix
else return_unit
let on_no_request w =
let pv = Worker.state w in
debug
w
"no new head from peer %a for %g seconds."
P2p_peer.Id.pp_short
pv.peer_id
(Ptime.Span.to_float_s pv.parameters.limits.new_head_request_timeout) ;
Distributed_db.Request.current_head
pv.parameters.chain_db
~peer:pv.peer_id
() ;
return_unit
let on_request (type a) w (req : a Request.t) : a tzresult Lwt.t =
let pv = Worker.state w in
match req with
| Request.New_head (hash, header) ->
debug
w
"processing new head %a from peer %a."
Block_hash.pp_short
hash
P2p_peer.Id.pp_short
pv.peer_id ;
may_validate_new_head w hash header
| Request.New_branch (hash, locator, _seed) ->
(* TODO penalize empty locator... ?? *)
debug
w
"processing new branch %a from peer %a."
Block_hash.pp_short
hash
P2p_peer.Id.pp_short
pv.peer_id ;
may_validate_new_branch w hash locator
let on_completion w r _ st =
Worker.record_event w (Event.Request (Request.view r, st, None)) ;
Lwt.return_unit
let on_error w r st err =
let pv = Worker.state w in
match err with
| ( Validation_errors.Unknown_ancestor
| Validation_errors.Invalid_locator _
| Block_validator_errors.Invalid_block _ )
:: _ as errors ->
Distributed_db.greylist pv.parameters.chain_db pv.peer_id
>>= fun () ->
debug
w
"Terminating the validation worker for peer %a (kickban)."
P2p_peer.Id.pp_short
pv.peer_id ;
debug w "%a" Error_monad.pp_print_error errors ;
Worker.trigger_shutdown w ;
Worker.record_event w (Event.Request (r, st, Some err)) ;
Lwt.return_error err
| Block_validator_errors.System_error _ :: _ ->
Worker.record_event w (Event.Request (r, st, Some err)) ;
return_unit
| Block_validator_errors.Unavailable_protocol {protocol; _} :: _ -> (
Block_validator.fetch_and_compile_protocol
pv.parameters.block_validator
~peer:pv.peer_id
~timeout:pv.parameters.limits.protocol_timeout
protocol
>>= function
| Ok _ ->
Distributed_db.Request.current_head
pv.parameters.chain_db
~peer:pv.peer_id
() ;
return_unit
| Error _ ->
(* TODO: punish *)
debug
w
"Terminating the validation worker for peer %a (missing protocol \
%a)."
P2p_peer.Id.pp_short
pv.peer_id
Protocol_hash.pp_short
protocol ;
Worker.record_event w (Event.Request (r, st, Some err)) ;
Lwt.return_error err )
| Validation_errors.Too_short_locator _ :: _ ->
debug
w
"Terminating the validation worker for peer %a (kick)."
P2p_peer.Id.pp_short
pv.peer_id ;
Worker.trigger_shutdown w ;
Worker.record_event w (Event.Request (r, st, Some err)) ;
return_unit
| _ ->
Worker.record_event w (Event.Request (r, st, Some err)) ;
Lwt.return_error err
let on_close w =
let pv = Worker.state w in
Distributed_db.disconnect pv.parameters.chain_db pv.peer_id
>>= fun () ->
pv.parameters.notify_termination () ;
Lwt.return_unit
let on_launch _ name parameters =
let chain_state = Distributed_db.chain_state parameters.chain_db in
State.Block.read_opt chain_state (State.Chain.genesis chain_state).block
>|= Option.unopt_assert ~loc:__POS__
>>= fun genesis ->
let rec pv =
{
peer_id = snd name;
parameters = {parameters with notify_new_block};
bootstrapped = false;
pipeline = None;
last_validated_head = State.Block.header genesis;
last_advertised_head = State.Block.header genesis;
}
and notify_new_block block =
pv.last_validated_head <- State.Block.header block ;
parameters.notify_new_block block
in
return pv
let table =
let merge w (Worker.Any_request neu) old =
let pv = Worker.state w in
match neu with
| Request.New_branch (_, locator, _) ->
let (header, _) = (locator : Block_locator.t :> _ * _) in
pv.last_advertised_head <- header ;
Some (Worker.Any_request neu)
| Request.New_head (_, header) -> (
pv.last_advertised_head <- header ;
(* TODO penalize decreasing fitness *)
match old with
| Some (Worker.Any_request (Request.New_branch _) as old) ->
Some old (* ignore *)
| Some (Worker.Any_request (Request.New_head _)) ->
Some (Any_request neu)
| None ->
Some (Any_request neu) )
in
Worker.create_table (Dropbox {merge})
let create ?(notify_new_block = fun _ -> ())
?(notify_bootstrapped = fun () -> ()) ?(notify_termination = fun _ -> ())
limits block_validator chain_db peer_id =
let name = (State.Chain.id (Distributed_db.chain_state chain_db), peer_id) in
let parameters =
{
chain_db;
notify_termination;
block_validator;
notify_new_block;
notify_bootstrapped;
limits;
}
in
let module Handlers = struct
type self = t
let on_launch = on_launch
let on_request = on_request
let on_close = on_close
let on_error = on_error
let on_completion = on_completion
let on_no_request = on_no_request
end in
Worker.launch
table
~timeout:limits.new_head_request_timeout
limits.worker_limits
name
parameters
(module Handlers)
let notify_branch w locator =
let (header, _) = (locator : Block_locator.t :> _ * _) in
let hash = Block_header.hash header in
let pv = Worker.state w in
let sender_id = Distributed_db.my_peer_id pv.parameters.chain_db in
(* sender and receiver are inverted here because they are from
the point of view of the node sending the locator *)
let seed = {Block_locator.sender_id = pv.peer_id; receiver_id = sender_id} in
Worker.Dropbox.put_request w (New_branch (hash, locator, seed))
let notify_head w header =
let hash = Block_header.hash header in
Worker.Dropbox.put_request w (New_head (hash, header))
let shutdown w = Worker.shutdown w
let peer_id w =
let pv = Worker.state w in
pv.peer_id
let bootstrapped w =
let pv = Worker.state w in
pv.bootstrapped
let current_head w =
let pv = Worker.state w in
pv.last_validated_head
let status = Worker.status
let information = Worker.information
let running_workers () = Worker.list table
let current_request t = Worker.current_request t
let last_events = Worker.last_events
let pipeline_length w =
let state = Worker.state w in
Types.pipeline_length state.pipeline
src/lib_shell/peer_validator.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Peer_validator_worker_state.
Module Name.
Definition t :=
Tezos_base__TzPervasives.Chain_id.t * Tezos_base__TzPervasives.P2p_peer.Id.t.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
(Tezos_base__TzPervasives.Chain_id.t *
Tezos_base__TzPervasives.P2p_peer.Id.t) :=
Data_encoding.tup2 Chain_id.encoding P2p_peer.Id.encoding.
Definition base : list string :=
cons "validator" % string (cons "peer" % string []).
Definition pp
(ppf : Stdlib.Format.formatter)
(function_parameter :
Tezos_base__TzPervasives.Chain_id.t *
Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
let '(chain, peer) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))) "%a:%a" % string)
Chain_id.pp_short chain P2p_peer.Id.pp_short peer.
End Name.
Module Request.
(* ❌ Structure item `include` not handled. *)
include
Inductive t : forall (_ : Type), Type :=
| New_head : Tezos_base__TzPervasives.Block_hash.t ->
Tezos_base__TzPervasives.Block_header.t -> t unit
| New_branch : Tezos_base__TzPervasives.Block_hash.t ->
Tezos_base__TzPervasives.Block_locator.t ->
Tezos_base__TzPervasives.Block_locator.seed -> t unit.
Definition view {A : Type} (req : t A) : view :=
match req with
| New_head hash _ => New_head hash
| New_branch hash locator seed =>
New_branch hash (Block_locator.estimated_length seed locator)
end.
End Request.
Record limits := {
new_head_request_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
block_header_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
block_operations_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
protocol_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
worker_limits : Tezos_shell_services.Worker_types.limits }.
Module Types.
(* ❌ Structure item `include` not handled. *)
include
Record parameters := {
chain_db : Tezos_shell.Distributed_db.chain_db;
block_validator : Tezos_shell.Block_validator.t;
notify_new_block : Tezos_shell.State.Block.t -> unit;
notify_bootstrapped : unit -> unit;
notify_termination : unit -> unit;
limits : limits }.
Record state := {
peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
parameters : parameters;
bootstrapped : bool;
pipeline : option Tezos_shell.Bootstrap_pipeline.t;
last_validated_head : Tezos_base__TzPervasives.Block_header.t;
last_advertised_head : Tezos_base__TzPervasives.Block_header.t }.
Definition pipeline_length
(function_parameter : option Tezos_shell.Bootstrap_pipeline.t)
: Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length :=
match function_parameter with
| None => Bootstrap_pipeline.length_zero
| Some p => Bootstrap_pipeline.length p
end.
Definition view {A : Type} (state : state) (function_parameter : A) : view :=
let '_ := function_parameter in
let '{|
bootstrapped := bootstrapped;
pipeline := pipeline;
last_validated_head := last_validated_head;
last_advertised_head := last_advertised_head
|} := state in
{| bootstrapped := bootstrapped;
pipeline_length := pipeline_length pipeline;
last_validated_head := Block_header.hash last_validated_head;
last_advertised_head := Block_header.hash last_advertised_head |}.
End Types.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Import Types.
Definition t := Worker.t Worker.dropbox.
Definition debug {A B : Type} (w : Worker.t A)
: (Stdlib.format4 B Stdlib.Format.formatter unit unit) -> B :=
Format.kasprintf
(fun msg =>
Worker.record_event w
(Tezos_shell_services.Peer_validator_worker_state.Event.Debug msg)).
Definition set_bootstrapped (pv : Types.state) : unit :=
if negb (bootstrapped pv) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pv "bootstrapped" % string true in
(notify_bootstrapped (parameters pv)) tt
else
tt.
Definition bootstrap_new_branch {A B : Type}
(w : Worker.t A) (_head : B)
(unknown_prefix : Tezos_base__TzPervasives.Block_locator.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let pv := Worker.state w in
let sender_id := Distributed_db.my_peer_id (chain_db (parameters pv)) in
let seed :=
{| Block_locator.sender_id := peer_id pv;
Block_locator.receiver_id := sender_id |} in
let len := Block_locator.estimated_length seed unknown_prefix in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"validating new branch from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (approx. " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " blocks)" % string
CamlinternalFormatBasics.End_of_format)))))
"validating new branch from peer %a (approx. %d blocks)" % string)
P2p_peer.Id.pp_short (peer_id pv) len in
let pipeline :=
Bootstrap_pipeline.create (Some (notify_new_block (parameters pv)))
(block_header_timeout (limits (parameters pv)))
(block_operations_timeout (limits (parameters pv)))
(block_validator (parameters pv)) (peer_id pv) (chain_db (parameters pv))
unknown_prefix in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pv "pipeline" % string (Some pipeline) in
op_gtgteqquestion
(Worker.protect w
(Some
(fun error =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pv "pipeline" % string None in
op_gtgteq (Bootstrap_pipeline.cancel pipeline)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_error error)))
(fun function_parameter =>
let 'tt := function_parameter in
Bootstrap_pipeline.wait pipeline))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pv "pipeline" % string None in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := set_bootstrapped pv in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"done validating new branch from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))
"done validating new branch from peer %a." % string)
P2p_peer.Id.pp_short (peer_id pv) in
return_unit).
Definition validate_new_head {A : Type}
(w : Worker.t A) (hash : Tezos_base__TzPervasives.Block_hash.t)
(header : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let pv := Worker.state w in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"fetching operations for new head " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " from peer " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"fetching operations for new head %a from peer %a" % string)
Block_hash.pp_short hash P2p_peer.Id.pp_short (peer_id pv) in
op_gtgteqquestion
(map_p
(fun i =>
Worker.protect w None
(fun function_parameter =>
let 'tt := function_parameter in
Distributed_db.Operations.fetch (chain_db (parameters pv))
(Some (peer_id pv))
(Some (block_operations_timeout (limits (parameters pv))))
(hash, i) (operations_hash (shell header))))
(op_minusminus 0 (Z.sub (validation_passes (shell header)) 1)))
(fun operations =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"requesting validation for new head " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " from peer " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"requesting validation for new head %a from peer %a" % string)
Block_hash.pp_short hash P2p_peer.Id.pp_short (peer_id pv) in
op_gtgteqquestion
(Block_validator.validate (block_validator (parameters pv)) None None
(Some (notify_new_block (parameters pv))) (chain_db (parameters pv))
hash header operations)
(fun _block =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"end of validation for new head " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"end of validation for new head %a from peer %a" % string)
Block_hash.pp_short hash P2p_peer.Id.pp_short (peer_id pv) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := set_bootstrapped pv in
let meta :=
Distributed_db.get_peer_metadata (chain_db (parameters pv))
(peer_id pv) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Peer_metadata.incr meta
Tezos_shell_services.Peer_metadata.Valid_blocks in
return_unit)).
Definition only_if_fitness_increases {A : Type}
(w : Worker.t A) (distant_header : Tezos_base__TzPervasives.Block_header.t)
(cont : unit -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let pv := Worker.state w in
let chain_state := Distributed_db.chain_state (chain_db (parameters pv)) in
op_gtgteq (Chain.head chain_state)
(fun local_header =>
if
OCaml.Stdlib.le
(Fitness.compare (fitness (Block_header.shell distant_header))
(State.Block.fitness local_header)) 0 then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := set_bootstrapped pv in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "ignoring head " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" with non increasing fitness from peer: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))))
"ignoring head %a with non increasing fitness from peer: %a." %
string) Block_hash.pp_short (Block_header.hash distant_header)
P2p_peer.Id.pp_short (peer_id pv) in
let meta :=
Distributed_db.get_peer_metadata (chain_db (parameters pv))
(peer_id pv) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Peer_metadata.incr meta Tezos_shell_services.Peer_metadata.Old_heads
in
return_unit
else
cont tt).
Definition assert_acceptable_head {A : Type}
(w : Worker.t A) (hash : Tezos_base__TzPervasives.Block_hash.t)
(header : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let pv := Worker.state w in
let chain_state := Distributed_db.chain_state (chain_db (parameters pv)) in
op_gtgteq (State.Chain.acceptable_block chain_state header)
(fun acceptable =>
fail_unless acceptable
(Tezos_base__TzPervasives.Checkpoint_error hash (Some (peer_id pv)))).
Definition may_validate_new_head {A : Type}
(w : Worker.t A) (hash : Tezos_base__TzPervasives.Block_hash.t)
(header : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let pv := Worker.state w in
let chain_state := Distributed_db.chain_state (chain_db (parameters pv)) in
op_gtgteq (State.Block.known_valid chain_state hash)
(fun valid_block =>
op_gtgteq (State.Block.known_invalid chain_state hash)
(fun invalid_block =>
op_gtgteq
(State.Block.known_valid chain_state (predecessor (shell header)))
(fun valid_predecessor =>
op_gtgteq
(State.Block.known_invalid chain_state
(predecessor (shell header)))
(fun invalid_predecessor =>
if valid_block then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"ignoring previously validated block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"ignoring previously validated block %a from peer %a"
% string) Block_hash.pp_short hash
P2p_peer.Id.pp_short (peer_id pv) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := set_bootstrapped pv in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pv "last_validated_head" % string header
in
return_unit
else
if invalid_block then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"ignoring known invalid block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"ignoring known invalid block %a from peer %a" %
string) Block_hash.pp_short hash
P2p_peer.Id.pp_short (peer_id pv) in
fail Tezos_base__TzPervasives.Known_invalid
else
if invalid_predecessor then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"ignoring known invalid block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"ignoring known invalid block %a from peer %a" %
string) Block_hash.pp_short hash
P2p_peer.Id.pp_short (peer_id pv) in
op_gtgteqquestion
(Distributed_db.commit_invalid_block
(chain_db (parameters pv)) hash header
(cons Tezos_base__TzPervasives.Known_invalid []))
(fun function_parameter =>
let '_ := function_parameter in
fail Tezos_base__TzPervasives.Known_invalid)
else
if negb valid_predecessor then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"missing predecessor for new head " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from peer " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"missing predecessor for new head %a from peer %a"
% string) Block_hash.pp_short hash
P2p_peer.Id.pp_short (peer_id pv) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Distributed_db.Request.current_branch
(chain_db (parameters pv)) (Some (peer_id pv)) tt
in
return_unit
else
apply (only_if_fitness_increases w header)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(assert_acceptable_head w hash header)
(fun function_parameter =>
let 'tt := function_parameter in
validate_new_head w hash header)))))).
Definition may_validate_new_branch {A : Type}
(w : Worker.t A) (distant_hash : Tezos_base__TzPervasives.Block_hash.t)
(locator : Tezos_base__TzPervasives.Block_locator.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let pv := Worker.state w in
let '(distant_header, _) := locator in
apply (only_if_fitness_increases w distant_header)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(assert_acceptable_head w (Block_header.hash distant_header)
distant_header)
(fun function_parameter =>
let 'tt := function_parameter in
let chain_state :=
Distributed_db.chain_state (chain_db (parameters pv)) in
op_gtgteq (State.Block.known_ancestor chain_state locator)
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"ignoring branch " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" without common ancestor from peer: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))))
"ignoring branch %a without common ancestor from peer: %a."
% string) Block_hash.pp_short distant_hash
P2p_peer.Id.pp_short (peer_id pv) in
fail Tezos_base__TzPervasives.Unknown_ancestor
| Some unknown_prefix =>
let '(_, history) := Block_locator.raw unknown_prefix in
if nequiv_decb history [] then
bootstrap_new_branch w distant_header unknown_prefix
else
return_unit
end))).
Definition on_no_request {A : Type} (w : Worker.t A)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let pv := Worker.state w in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"no new head from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " for " % string
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_g
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " seconds." % string
CamlinternalFormatBasics.End_of_format)))))
"no new head from peer %a for %g seconds." % string)
P2p_peer.Id.pp_short (peer_id pv)
(Ptime.Span.to_float_s (new_head_request_timeout (limits (parameters pv))))
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Distributed_db.Request.current_head (chain_db (parameters pv))
(Some (peer_id pv)) tt in
return_unit.
Definition on_request {A B : Type}
(w : Worker.t A) (req : Request.(Tezos_shell__Worker.REQUEST.t) B)
: Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
let pv := Worker.state w in
match req with
| Request.New_head hash header =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"processing new head " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))))
"processing new head %a from peer %a." % string) Block_hash.pp_short
hash P2p_peer.Id.pp_short (peer_id pv) in
may_validate_new_head w hash header
| Request.New_branch hash locator _seed =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"processing new branch " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " from peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))))
"processing new branch %a from peer %a." % string) Block_hash.pp_short
hash P2p_peer.Id.pp_short (peer_id pv) in
may_validate_new_branch w hash locator
end.
Definition on_completion {A B C : Type}
(w : Worker.t A) (r : Request.(Tezos_shell__Worker.REQUEST.t) B)
(function_parameter : C)
: Tezos_shell_services.Worker_types.request_status -> Lwt.t unit :=
let '_ := function_parameter in
fun st =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Worker.record_event w
(Tezos_shell_services.Peer_validator_worker_state.Event.Request
((Request.(Tezos_shell__Worker.REQUEST.view) r), st, None)) in
Lwt.return_unit.
Definition on_error {A : Type}
(w : Worker.t A)
(r : Tezos_shell_services__Peer_validator_worker_state.Request.view)
(st : Tezos_shell_services.Worker_types.request_status)
(err : Tezos_base__TzPervasives.trace)
: Lwt.t (Result.result unit Tezos_base__TzPervasives.trace) :=
let pv := Worker.state w in
match err with
|
(cons
(Tezos_base__TzPervasives.Unknown_ancestor |
Tezos_base__TzPervasives.Invalid_locator _ _ |
Tezos_base__TzPervasives.Invalid_block _) _) as errors =>
op_gtgteq (Distributed_db.greylist (chain_db (parameters pv)) (peer_id pv))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Terminating the validation worker for peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (kickban)." % string
CamlinternalFormatBasics.End_of_format)))
"Terminating the validation worker for peer %a (kickban)." %
string) P2p_peer.Id.pp_short (peer_id pv) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Error_monad.pp_print_error errors in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Worker.trigger_shutdown w in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Worker.record_event w
(Tezos_shell_services.Peer_validator_worker_state.Event.Request
(r, st, (Some err))) in
Lwt.return_error err)
| cons (Tezos_base__TzPervasives.System_error _) _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Worker.record_event w
(Tezos_shell_services.Peer_validator_worker_state.Event.Request
(r, st, (Some err))) in
return_unit
|
cons
(Tezos_base__TzPervasives.Unavailable_protocol {| protocol := protocol |})
_ =>
op_gtgteq
(Block_validator.fetch_and_compile_protocol
(block_validator (parameters pv)) (Some (peer_id pv))
(Some (protocol_timeout (limits (parameters pv)))) protocol)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Distributed_db.Request.current_head (chain_db (parameters pv))
(Some (peer_id pv)) tt in
return_unit
| Stdlib.Error _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Terminating the validation worker for peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (missing protocol " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ")." % string
CamlinternalFormatBasics.End_of_format)))))
"Terminating the validation worker for peer %a (missing protocol %a)."
% string) P2p_peer.Id.pp_short (peer_id pv)
Protocol_hash.pp_short protocol in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Worker.record_event w
(Tezos_shell_services.Peer_validator_worker_state.Event.Request
(r, st, (Some err))) in
Lwt.return_error err
end)
| cons (Tezos_base__TzPervasives.Too_short_locator _ _) _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug w
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Terminating the validation worker for peer " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (kick)." % string
CamlinternalFormatBasics.End_of_format)))
"Terminating the validation worker for peer %a (kick)." % string)
P2p_peer.Id.pp_short (peer_id pv) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Worker.trigger_shutdown w in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Worker.record_event w
(Tezos_shell_services.Peer_validator_worker_state.Event.Request
(r, st, (Some err))) in
return_unit
| _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Worker.record_event w
(Tezos_shell_services.Peer_validator_worker_state.Event.Request
(r, st, (Some err))) in
Lwt.return_error err
end.
Definition on_close {A : Type} (w : Worker.t A) : Lwt.t unit :=
let pv := Worker.state w in
op_gtgteq (Distributed_db.disconnect (chain_db (parameters pv)) (peer_id pv))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := (notify_termination (parameters pv)) tt in
Lwt.return_unit).
Definition on_launch {A B : Type} (function_parameter : A)
: (B * Tezos_base__TzPervasives.P2p_peer.Id.t) ->
Types.parameters -> Lwt.t (Tezos_base__TzPervasives.tzresult Types.state) :=
let '_ := function_parameter in
fun name =>
fun parameters =>
let chain_state := Distributed_db.chain_state (chain_db parameters) in
op_gtgteq
(op_gtpipeeq
(State.Block.read_opt chain_state
(block (State.Chain.genesis chain_state)))
(Option.unopt_assert Stdlib.__POS__))
(fun genesis =>
let fix pv : Types.state :=
{| peer_id := snd name;
parameters :=
(* ❌ Record substitution not handled *)
record_substitution; bootstrapped := false; pipeline := None;
last_validated_head := State.Block.header genesis;
last_advertised_head := State.Block.header genesis |}
with notify_new_block (block : Tezos_shell.State.Block.t) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pv "last_validated_head" % string
(State.Block.header block) in
(notify_new_block parameters) block in
_return pv).
Definition table : Worker.table Worker.dropbox :=
let merge {A : Type}
(w : Worker.t A) (function_parameter : Worker.any_request)
: (option Worker.any_request) -> option Worker.any_request :=
let 'Worker.Any_request neu := function_parameter in
fun old =>
let pv := Worker.state w in
match neu with
| Request.New_branch _ locator _ =>
let '(header, _) := locator in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pv "last_advertised_head" % string header in
Some (Worker.Any_request neu)
| Request.New_head _ header =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field pv "last_advertised_head" % string header in
match old with
| Some ((Worker.Any_request (Request.New_branch _ _ _)) as old) =>
Some old
| Some (Worker.Any_request (Request.New_head _ _)) =>
Some (Worker.Any_request neu)
| None => Some (Worker.Any_request neu)
end
end in
Worker.create_table (Worker.Dropbox {| merge := merge |}).
Definition create (op_staroptstar : option (Tezos_shell.State.Block.t -> unit))
: (option (unit -> unit)) ->
(option (unit -> unit)) ->
limits ->
Tezos_shell.Block_validator.t ->
Tezos_shell.Distributed_db.chain_db ->
Tezos_base__TzPervasives.P2p_peer.Id.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult (Worker.t Worker.dropbox)) :=
let notify_new_block :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
fun function_parameter =>
let '_ := function_parameter in
tt
end in
fun op_staroptstar =>
let notify_bootstrapped :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
fun function_parameter =>
let 'tt := function_parameter in
tt
end in
fun op_staroptstar =>
let notify_termination :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
fun function_parameter =>
let '_ := function_parameter in
tt
end in
fun limits =>
fun block_validator =>
fun chain_db =>
fun peer_id =>
let name :=
((State.Chain.id (Distributed_db.chain_state chain_db)), peer_id)
in
let parameters :=
{| chain_db := chain_db; block_validator := block_validator;
notify_new_block := notify_new_block;
notify_bootstrapped := notify_bootstrapped;
notify_termination := notify_termination; limits := limits |}
in
let Handlers :=
existT _ unit
{|
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_launch := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_request := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_close := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_error := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_completion := unhandled;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Worker.HANDLERS.on_no_request := unhandled
|} in
Worker.launch table (Some (new_head_request_timeout limits))
(worker_limits limits) name parameters Handlers.
Definition notify_branch
(w : Worker.t Worker.dropbox)
(locator : Tezos_base__TzPervasives.Block_locator.t) : unit :=
let '(header, _) := locator in
let hash := Block_header.hash header in
let pv := Worker.state w in
let sender_id := Distributed_db.my_peer_id (chain_db (parameters pv)) in
let seed :=
{| Block_locator.sender_id := peer_id pv;
Block_locator.receiver_id := sender_id |} in
Worker.Dropbox.put_request w (Request.New_branch hash locator seed).
Definition notify_head
(w : Worker.t Worker.dropbox)
(header : Tezos_base__TzPervasives.Block_header.t) : unit :=
let hash := Block_header.hash header in
Worker.Dropbox.put_request w (Request.New_head hash header).
Definition shutdown {A : Type} (w : Worker.t A) : Lwt.t unit :=
Worker.shutdown w.
Definition peer_id {A : Type} (w : Worker.t A)
: Tezos_base__TzPervasives.P2p_peer.Id.t :=
let pv := Worker.state w in
peer_id pv.
Definition bootstrapped {A : Type} (w : Worker.t A) : bool :=
let pv := Worker.state w in
bootstrapped pv.
Definition current_head {A : Type} (w : Worker.t A)
: Tezos_base__TzPervasives.Block_header.t :=
let pv := Worker.state w in
last_validated_head pv.
Definition status {A : Type}
: (Worker.t A) -> Tezos_shell_services.Worker_types.worker_status :=
Worker.status.
Definition information {A : Type}
: (Worker.t A) -> Tezos_shell_services.Worker_types.worker_information :=
Worker.information.
Definition running_workers (function_parameter : unit)
: list (Worker.Name.(Tezos_shell__Worker.NAME.t) * (Worker.t Worker.dropbox)) :=
let 'tt := function_parameter in
Worker.list table.
Definition current_request {A : Type} (t : Worker.t A)
: option
(Tezos_base__TzPervasives.Time.System.t *
Tezos_base__TzPervasives.Time.System.t *
Worker.Request.(Tezos_shell__Worker.REQUEST.view)) :=
Worker.current_request t.
Definition last_events {A : Type}
: (Worker.t A) ->
list
(Tezos_base__TzPervasives.Internal_event.level *
(list Worker.Event.(Tezos_shell__Worker.EVENT.t))) := Worker.last_events.
Definition pipeline_length {A : Type} (w : Worker.t A)
: Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length :=
let state := Worker.state w in
Types.pipeline_length (pipeline state).
src/lib_shell/prevalidation.ml 20 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Validation_errors
module type T = sig
module Proto : Registered_protocol.T
type t
type operation = private {
hash : Operation_hash.t;
raw : Operation.t;
protocol_data : Proto.operation_data;
}
val compare : operation -> operation -> int
val parse : Operation.t -> operation tzresult
(** Creates a new prevalidation context w.r.t. the protocol associate to the
predecessor block . When ?protocol_data is passed to this function, it will
be used to create the new block *)
val create :
?protocol_data:Bytes.t ->
predecessor:State.Block.t ->
timestamp:Time.Protocol.t ->
unit ->
t tzresult Lwt.t
type result =
| Applied of t * Proto.operation_receipt
| Branch_delayed of error list
| Branch_refused of error list
| Refused of error list
| Duplicate
| Outdated
val apply_operation : t -> operation -> result Lwt.t
type status = {
applied_operations : (operation * Proto.operation_receipt) list;
block_result : Tezos_protocol_environment.validation_result;
block_metadata : Proto.block_header_metadata;
}
val status : t -> status tzresult Lwt.t
val pp_result : Format.formatter -> result -> unit
end
module Make (Proto : Registered_protocol.T) : T with module Proto = Proto =
struct
module Proto = Proto
type operation = {
hash : Operation_hash.t;
raw : Operation.t;
protocol_data : Proto.operation_data;
}
type t = {
state : Proto.validation_state;
applied : (operation * Proto.operation_receipt) list;
live_blocks : Block_hash.Set.t;
live_operations : Operation_hash.Set.t;
}
type result =
| Applied of t * Proto.operation_receipt
| Branch_delayed of error list
| Branch_refused of error list
| Refused of error list
| Duplicate
| Outdated
let parse (raw : Operation.t) =
let hash = Operation.hash raw in
let size = Data_encoding.Binary.length Operation.encoding raw in
if size > Proto.max_operation_data_length then
error (Oversized_operation {size; max = Proto.max_operation_data_length})
else
match
Data_encoding.Binary.of_bytes
Proto.operation_data_encoding
raw.Operation.proto
with
| None ->
error Parse_error
| Some protocol_data ->
ok {hash; raw; protocol_data}
let compare op1 op2 =
Proto.compare_operations
{shell = op1.raw.shell; protocol_data = op1.protocol_data}
{shell = op2.raw.shell; protocol_data = op2.protocol_data}
let create ?protocol_data ~predecessor ~timestamp () =
(* The prevalidation module receives input from the system byt handles
protocol values. It translates timestamps here. *)
let { Block_header.shell =
{ fitness = predecessor_fitness;
timestamp = predecessor_timestamp;
level = predecessor_level;
_ };
_ } =
State.Block.header predecessor
in
State.Block.context predecessor
>>=? fun predecessor_context ->
let predecessor_header = State.Block.header predecessor in
let predecessor_hash = State.Block.hash predecessor in
State.Block.max_operations_ttl predecessor
>>=? fun max_op_ttl ->
Chain_traversal.live_blocks predecessor max_op_ttl
>>=? fun (live_blocks, live_operations) ->
Block_validation.update_testchain_status
predecessor_context
predecessor_header
timestamp
>>=? fun predecessor_context ->
( match protocol_data with
| None ->
return_none
| Some protocol_data -> (
match
Data_encoding.Binary.of_bytes
Proto.block_header_data_encoding
protocol_data
with
| None ->
failwith "Invalid block header"
| Some protocol_data ->
return_some protocol_data ) )
>>=? fun protocol_data ->
let predecessor_context =
Shell_context.wrap_disk_context predecessor_context
in
Proto.begin_construction
~chain_id:(State.Block.chain_id predecessor)
~predecessor_context
~predecessor_timestamp
~predecessor_fitness
~predecessor_level
~predecessor:predecessor_hash
~timestamp
?protocol_data
()
>>=? fun state ->
(* FIXME arbitrary value, to be customisable *)
return {state; applied = []; live_blocks; live_operations}
let apply_operation pv op =
if Operation_hash.Set.mem op.hash pv.live_operations then
Lwt.return Outdated
else
Proto.apply_operation
pv.state
{shell = op.raw.shell; protocol_data = op.protocol_data}
>|= function
| Ok (state, receipt) ->
let pv =
{
state;
applied = (op, receipt) :: pv.applied;
live_blocks = pv.live_blocks;
live_operations =
Operation_hash.Set.add op.hash pv.live_operations;
}
in
Applied (pv, receipt)
| Error errors -> (
match classify_errors errors with
| `Branch ->
Branch_refused errors
| `Permanent ->
Refused errors
| `Temporary ->
Branch_delayed errors )
type status = {
applied_operations : (operation * Proto.operation_receipt) list;
block_result : Tezos_protocol_environment.validation_result;
block_metadata : Proto.block_header_metadata;
}
let status pv =
Proto.finalize_block pv.state
>>=? fun (block_result, block_metadata) ->
return {block_metadata; block_result; applied_operations = pv.applied}
let pp_result ppf =
let open Format in
function
| Applied _ ->
pp_print_string ppf "applied"
| Branch_delayed err ->
fprintf ppf "branch delayed (%a)" pp_print_error err
| Branch_refused err ->
fprintf ppf "branch refused (%a)" pp_print_error err
| Refused err ->
fprintf ppf "refused (%a)" pp_print_error err
| Duplicate ->
pp_print_string ppf "duplicate"
| Outdated ->
pp_print_string ppf "outdated"
end
let preapply ~predecessor ~timestamp ~protocol_data operations =
State.Block.context predecessor
>>=? fun predecessor_context ->
Context.get_protocol predecessor_context
>>= fun protocol ->
( match Registered_protocol.get protocol with
| None ->
(* FIXME. *)
(* This should not happen: it should be handled in the validator. *)
failwith
"Prevalidation: missing protocol '%a' for the current block."
Protocol_hash.pp_short
protocol
| Some protocol ->
return protocol )
>>=? fun (module Proto) ->
let module Prevalidation = Make (Proto) in
let apply_operation_with_preapply_result preapp t op =
let open Preapply_result in
Prevalidation.apply_operation t op
>>= function
| Applied (t, _) ->
let applied = (op.hash, op.raw) :: preapp.applied in
Lwt.return ({preapp with applied}, t)
| Branch_delayed errors ->
let branch_delayed =
Operation_hash.Map.add op.hash (op.raw, errors) preapp.branch_delayed
in
Lwt.return ({preapp with branch_delayed}, t)
| Branch_refused errors ->
let branch_refused =
Operation_hash.Map.add op.hash (op.raw, errors) preapp.branch_refused
in
Lwt.return ({preapp with branch_refused}, t)
| Refused errors ->
let refused =
Operation_hash.Map.add op.hash (op.raw, errors) preapp.refused
in
Lwt.return ({preapp with refused}, t)
| Duplicate | Outdated ->
Lwt.return (preapp, t)
in
Prevalidation.create ~protocol_data ~predecessor ~timestamp ()
>>=? fun validation_state ->
Lwt_list.fold_left_s
(fun (acc_validation_result, acc_validation_state) operations ->
Lwt_list.fold_left_s
(fun (acc_validation_result, acc_validation_state) op ->
match Prevalidation.parse op with
| Error _ ->
(* FIXME *)
Lwt.return (acc_validation_result, acc_validation_state)
| Ok op ->
apply_operation_with_preapply_result
acc_validation_result
acc_validation_state
op)
(Preapply_result.empty, acc_validation_state)
operations
>>= fun (new_validation_result, new_validation_state) ->
(* Applied operations are reverted ; revert to the initial ordering *)
let new_validation_result =
{
new_validation_result with
applied = List.rev new_validation_result.applied;
}
in
Lwt.return
(acc_validation_result @ [new_validation_result], new_validation_state))
([], validation_state)
operations
>>= fun (validation_result_list, validation_state) ->
let operations_hash =
Operation_list_list_hash.compute
(List.map
(fun r ->
Operation_list_hash.compute (List.map fst r.Preapply_result.applied))
validation_result_list)
in
Prevalidation.status validation_state
>>=? fun {block_result; _} ->
let pred_shell_header = State.Block.shell_header predecessor in
let level = Int32.succ pred_shell_header.level in
Block_validation.may_patch_protocol ~level block_result
>>= fun {fitness; context; message; _} ->
State.Block.protocol_hash predecessor
>>=? fun pred_protocol ->
let context = Shell_context.unwrap_disk_context context in
Context.get_protocol context
>>= fun protocol ->
let proto_level =
if Protocol_hash.equal protocol pred_protocol then
pred_shell_header.proto_level
else (pred_shell_header.proto_level + 1) mod 256
in
let shell_header : Block_header.shell_header =
{
level;
proto_level;
predecessor = State.Block.hash predecessor;
timestamp;
validation_passes = List.length validation_result_list;
operations_hash;
fitness;
context = Context_hash.zero (* place holder *);
}
in
( if Protocol_hash.equal protocol pred_protocol then return (context, message)
else
match Registered_protocol.get protocol with
| None ->
fail
(Block_validator_errors.Unavailable_protocol
{block = State.Block.hash predecessor; protocol})
| Some (module NewProto) ->
let context = Shell_context.wrap_disk_context context in
NewProto.init context shell_header
>>=? fun {context; message; _} ->
let context = Shell_context.unwrap_disk_context context in
return (context, message) )
>>=? fun (context, message) ->
let context = Context.hash ?message ~time:timestamp context in
return ({shell_header with context}, validation_result_list)
src/lib_shell/prevalidation.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Validation_errors.
Module T.
Record signature {Proto_P_block_header_data Proto_P_block_header
Proto_P_block_header_metadata Proto_P_operation_data
Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state t
operation result status : Type} := {
Proto : Registered_protocol.T.signature Proto_P_block_header_data Proto_P_block_header Proto_P_block_header_metadata Proto_P_operation_data Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state;
t := t;
operation := operation;
compare : operation -> operation -> Z;
parse : Tezos_base__TzPervasives.Operation.t ->
Tezos_base__TzPervasives.tzresult operation;
create : (option Stdlib.Bytes.t) ->
Tezos_shell.State.Block.t ->
Tezos_base__TzPervasives.Time.Protocol.t ->
unit -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
result := result;
apply_operation : t -> operation -> Lwt.t result;
status := status;
status : t -> Lwt.t (Tezos_base__TzPervasives.tzresult status);
pp_result : Stdlib.Format.formatter -> result -> unit;
}.
Arguments signature : clear implicits.
End T.
(* ❌ Functors are not handled. *)
functor
Definition preapply
(predecessor : Tezos_shell.State.Block.t)
(timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
(protocol_data : Stdlib.Bytes.t)
(operations : list (list Tezos_base__TzPervasives.Operation.t))
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Block_header.shell_header *
(list
(Tezos_base__TzPervasives.Preapply_result.t
Tezos_base__TzPervasives.error)))) :=
op_gtgteqquestion (State.Block.context predecessor)
(fun predecessor_context =>
op_gtgteq (Context.get_protocol predecessor_context)
(fun protocol =>
op_gtgteqquestion
match Registered_protocol.get protocol with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Prevalidation: missing protocol '" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"' for the current block." % string
CamlinternalFormatBasics.End_of_format)))
"Prevalidation: missing protocol '%a' for the current block."
% string) Protocol_hash.pp_short protocol
| Some protocol => _return protocol
end
(fun Proto =>
let Proto := projT2 Proto in
let Prevalidation :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
let apply_operation_with_preapply_result
(preapp :
Tezos_base__TzPervasives.Preapply_result.t
Tezos_base__TzPervasives.error) (t : Prevalidation.t) (op :
Prevalidation.operation)
: Lwt.t
((Tezos_base__TzPervasives.Preapply_result.t
Tezos_base__TzPervasives.error) * Prevalidation.t) :=
op_gtgteq (Prevalidation.apply_operation t op)
(fun function_parameter =>
match function_parameter with
| Prevalidation.Applied t _ =>
let applied := cons ((hash op), (raw op)) (applied preapp)
in
Lwt._return
((* ❌ Record substitution not handled *)
record_substitution, t)
| Prevalidation.Branch_delayed errors =>
let branch_delayed :=
Operation_hash.Map.add (hash op) ((raw op), errors)
(branch_delayed preapp) in
Lwt._return
((* ❌ Record substitution not handled *)
record_substitution, t)
| Prevalidation.Branch_refused errors =>
let branch_refused :=
Operation_hash.Map.add (hash op) ((raw op), errors)
(branch_refused preapp) in
Lwt._return
((* ❌ Record substitution not handled *)
record_substitution, t)
| Prevalidation.Refused errors =>
let refused :=
Operation_hash.Map.add (hash op) ((raw op), errors)
(refused preapp) in
Lwt._return
((* ❌ Record substitution not handled *)
record_substitution, t)
| Prevalidation.Duplicate | Prevalidation.Outdated =>
Lwt._return (preapp, t)
end) in
op_gtgteqquestion
(Prevalidation.create (Some protocol_data) predecessor timestamp
tt)
(fun validation_state =>
op_gtgteq
(Lwt_list.fold_left_s
(fun function_parameter =>
let '(acc_validation_result, acc_validation_state) :=
function_parameter in
fun operations =>
op_gtgteq
(Lwt_list.fold_left_s
(fun function_parameter =>
let
'(acc_validation_result, acc_validation_state) :=
function_parameter in
fun op =>
match Prevalidation.parse op with
| Stdlib.Error _ =>
Lwt._return
(acc_validation_result,
acc_validation_state)
| Stdlib.Ok op =>
apply_operation_with_preapply_result
acc_validation_result acc_validation_state
op
end)
(Preapply_result.empty, acc_validation_state)
operations)
(fun function_parameter =>
let
'(new_validation_result, new_validation_state) :=
function_parameter in
let new_validation_result :=
(* ❌ Record substitution not handled *)
record_substitution in
Lwt._return
((OCaml.Stdlib.app acc_validation_result
(cons new_validation_result [])),
new_validation_state))) ([], validation_state)
operations)
(fun function_parameter =>
let '(validation_result_list, validation_state) :=
function_parameter in
let operations_hash :=
Operation_list_list_hash.compute
(List.map
(fun r =>
Operation_list_hash.compute
(List.map fst (Preapply_result.applied r)))
validation_result_list) in
op_gtgteqquestion (Prevalidation.status validation_state)
(fun function_parameter =>
let '{| block_result := block_result |} :=
function_parameter in
let pred_shell_header :=
State.Block.shell_header predecessor in
let level := Int32.succ (level pred_shell_header) in
op_gtgteq
(Block_validation.may_patch_protocol level
block_result)
(fun function_parameter =>
let '{|
context := context;
fitness := fitness;
message := message
|} := function_parameter in
op_gtgteqquestion
(State.Block.protocol_hash predecessor)
(fun pred_protocol =>
let context :=
Shell_context.unwrap_disk_context context in
op_gtgteq (Context.get_protocol context)
(fun protocol =>
let proto_level :=
if
Protocol_hash.equal protocol
pred_protocol then
proto_level pred_shell_header
else
Z.modulo
(Z.add
(proto_level pred_shell_header) 1)
256 in
let shell_header :=
{| level := level;
proto_level := proto_level;
predecessor :=
State.Block.hash predecessor;
timestamp := timestamp;
validation_passes :=
List.length validation_result_list;
operations_hash := operations_hash;
fitness := fitness;
context := Context_hash.zero |} in
op_gtgteqquestion
(if
Protocol_hash.equal protocol
pred_protocol then
_return (context, message)
else
match Registered_protocol.get protocol
with
| None =>
fail
(Tezos_base__TzPervasives.Unavailable_protocol
{|
block :=
State.Block.hash predecessor;
protocol := protocol |})
| Some NewProto =>
let NewProto := projT2 NewProto in
let context :=
Shell_context.wrap_disk_context
context in
op_gtgteqquestion
(NewProto.(Tezos_protocol_updater__Registered_protocol.T.init)
context shell_header)
(fun function_parameter =>
let '{|
context := context;
message := message
|} := function_parameter in
let context :=
Shell_context.unwrap_disk_context
context in
_return (context, message))
end)
(fun function_parameter =>
let '(context, message) :=
function_parameter in
let context :=
Context.hash timestamp message
context in
_return
((* ❌ Record substitution not handled *)
record_substitution,
validation_result_list))))))))))).
src/lib_shell/prevalidator.ml 46 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Prevalidator_worker_state
type limits = {
max_refused_operations : int;
operation_timeout : Time.System.Span.t;
worker_limits : Worker_types.limits;
operations_batch_size : int;
}
type name_t = Chain_id.t * Protocol_hash.t
module type T = sig
module Proto : Registered_protocol.T
val name : name_t
val parameters : limits * Distributed_db.chain_db
module Prevalidation : Prevalidation.T with module Proto = Proto
type types_state = {
chain_db : Distributed_db.chain_db;
limits : limits;
mutable predecessor : State.Block.t;
mutable timestamp : Time.System.t;
mutable live_blocks : Block_hash.Set.t;
mutable live_operations : Operation_hash.Set.t;
refused : Operation_hash.t Ring.t;
mutable refusals : (Operation.t * error list) Operation_hash.Map.t;
branch_refused : Operation_hash.t Ring.t;
mutable branch_refusals : (Operation.t * error list) Operation_hash.Map.t;
branch_delayed : Operation_hash.t Ring.t;
mutable branch_delays : (Operation.t * error list) Operation_hash.Map.t;
mutable fetching : Operation_hash.Set.t;
mutable pending : Operation.t Operation_hash.Map.t;
mutable mempool : Mempool.t;
mutable in_mempool : Operation_hash.Set.t;
mutable applied : (Operation_hash.t * Operation.t) list;
mutable applied_count : int;
mutable validation_state : Prevalidation.t tzresult;
mutable operation_stream :
( [`Applied | `Refused | `Branch_refused | `Branch_delayed]
* Operation.shell_header
* Proto.operation_data )
Lwt_watcher.input;
mutable advertisement : [`Pending of Mempool.t | `None];
mutable rpc_directory : types_state RPC_directory.t lazy_t;
}
module Name : Worker.NAME with type t = name_t
module Types : Worker.TYPES with type state = types_state
module Worker :
Worker.T
with type Event.t = Event.t
and type 'a Request.t = 'a Request.t
and type Request.view = Request.view
and type Types.state = types_state
type worker = Worker.infinite Worker.queue Worker.t
val list_pendings :
Distributed_db.chain_db ->
from_block:State.Block.t ->
to_block:State.Block.t ->
live_blocks:Block_hash.Set.t ->
Operation.t Operation_hash.Map.t ->
Operation.t Operation_hash.Map.t Lwt.t
val validation_result : types_state -> error Preapply_result.t
val fitness : unit -> Fitness.t Lwt.t
val initialization_errors : unit tzresult Lwt.t
val worker : worker Lazy.t
end
module type ARG = sig
val limits : limits
val chain_db : Distributed_db.chain_db
val chain_id : Chain_id.t
end
type t = (module T)
module Make (Proto : Registered_protocol.T) (Arg : ARG) : T = struct
module Proto = Proto
let name = (Arg.chain_id, Proto.hash)
let parameters = (Arg.limits, Arg.chain_db)
module Prevalidation = Prevalidation.Make (Proto)
type types_state = {
chain_db : Distributed_db.chain_db;
limits : limits;
mutable predecessor : State.Block.t;
mutable timestamp : Time.System.t;
mutable live_blocks : Block_hash.Set.t;
(* just a cache *)
mutable live_operations : Operation_hash.Set.t;
(* just a cache *)
refused : Operation_hash.t Ring.t;
mutable refusals : (Operation.t * error list) Operation_hash.Map.t;
branch_refused : Operation_hash.t Ring.t;
mutable branch_refusals : (Operation.t * error list) Operation_hash.Map.t;
branch_delayed : Operation_hash.t Ring.t;
mutable branch_delays : (Operation.t * error list) Operation_hash.Map.t;
mutable fetching : Operation_hash.Set.t;
mutable pending : Operation.t Operation_hash.Map.t;
mutable mempool : Mempool.t;
mutable in_mempool : Operation_hash.Set.t;
mutable applied : (Operation_hash.t * Operation.t) list;
mutable applied_count : int;
mutable validation_state : Prevalidation.t tzresult;
mutable operation_stream :
( [`Applied | `Refused | `Branch_refused | `Branch_delayed]
* Operation.shell_header
* Proto.operation_data )
Lwt_watcher.input;
mutable advertisement : [`Pending of Mempool.t | `None];
mutable rpc_directory : types_state RPC_directory.t lazy_t;
}
module Name = struct
type t = name_t
let encoding = Data_encoding.tup2 Chain_id.encoding Protocol_hash.encoding
let chain_id_string =
let (_ : string) = Format.flush_str_formatter () in
Chain_id.pp_short Format.str_formatter Arg.chain_id ;
Format.flush_str_formatter ()
let proto_hash_string =
let (_ : string) = Format.flush_str_formatter () in
Protocol_hash.pp_short Format.str_formatter Proto.hash ;
Format.flush_str_formatter ()
let base = ["prevalidator"; chain_id_string; proto_hash_string]
let pp fmt (chain_id, proto_hash) =
Chain_id.pp_short fmt chain_id ;
Format.pp_print_string fmt "." ;
Protocol_hash.pp_short fmt proto_hash
end
module Types = struct
(* Invariants:
- an operation is in only one of these sets (map domains):
pv.refusals pv.pending pv.fetching pv.live_operations pv.in_mempool
- pv.in_mempool is the domain of all fields of pv.prevalidation_result
- pv.prevalidation_result.refused = Ã, refused ops are in pv.refused
- the 'applied' operations in pv.validation_result are in reverse order. *)
type state = types_state
type parameters = limits * Distributed_db.chain_db
include Worker_state
let view (state : state) _ : view =
let domain map =
Operation_hash.Map.fold
(fun elt _ acc -> Operation_hash.Set.add elt acc)
map
Operation_hash.Set.empty
in
{
head = State.Block.hash state.predecessor;
timestamp = state.timestamp;
fetching = state.fetching;
pending = domain state.pending;
applied = List.rev (List.map (fun (h, _) -> h) state.applied);
delayed =
Operation_hash.Set.union
(domain state.branch_delays)
(domain state.branch_refusals);
}
end
module Logger = Worker_logger.Make (Event) (Request)
module Worker :
Worker.T
with type Name.t = Name.t
and type Event.t = Event.t
and type 'a Request.t = 'a Request.t
and type Request.view = Request.view
and type Types.state = Types.state
and type Types.parameters = Types.parameters =
Worker.Make (Name) (Prevalidator_worker_state.Event)
(Prevalidator_worker_state.Request)
(Types)
(Logger)
(** Centralised operation stream for the RPCs *)
let notify_operation {operation_stream; _} result {Operation.shell; proto} =
let protocol_data =
Data_encoding.Binary.of_bytes Proto.operation_data_encoding proto
in
match protocol_data with
| Some protocol_data ->
Lwt_watcher.notify operation_stream (result, shell, protocol_data)
| None ->
()
open Types
type worker = Worker.infinite Worker.queue Worker.t
let debug w = Format.kasprintf (fun msg -> Worker.record_event w (Debug msg))
let list_pendings chain_db ~from_block ~to_block ~live_blocks old_mempool =
let rec pop_blocks ancestor block mempool =
let hash = State.Block.hash block in
if Block_hash.equal hash ancestor then Lwt.return mempool
else
State.Block.all_operations block
>>= fun operations ->
Lwt_list.fold_left_s
(Lwt_list.fold_left_s (fun mempool op ->
let h = Operation.hash op in
Distributed_db.inject_operation chain_db h op
>>= fun (_ : bool) ->
Lwt.return (Operation_hash.Map.add h op mempool)))
mempool
operations
>>= fun mempool ->
State.Block.predecessor block
>>= function
| None ->
assert false
| Some predecessor ->
pop_blocks ancestor predecessor mempool
in
let push_block mempool block =
State.Block.all_operation_hashes block
>|= fun operations ->
List.iter
(List.iter (Distributed_db.Operation.clear_or_cancel chain_db))
operations ;
List.fold_left
(List.fold_left (fun mempool h -> Operation_hash.Map.remove h mempool))
mempool
operations
in
Chain_traversal.new_blocks ~from_block ~to_block
>>= fun (ancestor, path) ->
pop_blocks (State.Block.hash ancestor) from_block old_mempool
>>= fun mempool ->
Lwt_list.fold_left_s push_block mempool path
>>= fun new_mempool ->
let (new_mempool, outdated) =
Operation_hash.Map.partition
(fun _oph op ->
Block_hash.Set.mem op.Operation.shell.branch live_blocks)
new_mempool
in
Operation_hash.Map.iter
(fun oph _op -> Distributed_db.Operation.clear_or_cancel chain_db oph)
outdated ;
Lwt.return new_mempool
let already_handled pv oph =
Operation_hash.Map.mem oph pv.refusals
|| Operation_hash.Map.mem oph pv.pending
|| Operation_hash.Set.mem oph pv.fetching
|| Operation_hash.Set.mem oph pv.live_operations
|| Operation_hash.Set.mem oph pv.in_mempool
let validation_result (state : types_state) =
{
Preapply_result.applied = List.rev state.applied;
branch_delayed = state.branch_delays;
branch_refused = state.branch_refusals;
refused = Operation_hash.Map.empty;
}
let advertise (w : worker) pv mempool =
match pv.advertisement with
| `Pending {Mempool.known_valid; pending} ->
pv.advertisement <-
`Pending
{
known_valid = known_valid @ mempool.Mempool.known_valid;
pending = Operation_hash.Set.union pending mempool.pending;
}
| `None ->
pv.advertisement <- `Pending mempool ;
Lwt.async (fun () ->
Lwt_unix.sleep 0.01
>>= fun () ->
Worker.Queue.push_request_now w Advertise ;
Lwt.return_unit)
let is_endorsement (op : Prevalidation.operation) =
Proto.acceptable_passes
{shell = op.raw.shell; protocol_data = op.protocol_data}
= [0]
let is_endorsement_raw op =
match Prevalidation.parse op with
| Ok op ->
is_endorsement op
| Error _ ->
false
let handle_unprocessed w pv =
( match pv.validation_state with
| Error err ->
Operation_hash.Map.iter
(fun h op ->
Option.iter
(Ring.add_and_return_erased pv.branch_delayed h)
~f:(fun e ->
pv.branch_delays <-
Operation_hash.Map.remove e pv.branch_delays ;
pv.in_mempool <- Operation_hash.Set.remove e pv.in_mempool) ;
pv.in_mempool <- Operation_hash.Set.add h pv.in_mempool ;
pv.branch_delays <-
Operation_hash.Map.add h (op, err) pv.branch_delays)
pv.pending ;
pv.pending <- Operation_hash.Map.empty ;
Lwt.return_unit
| Ok state -> (
match Operation_hash.Map.cardinal pv.pending with
| 0 ->
Lwt.return_unit
| n ->
debug w "processing %d operations" n ;
let operations =
List.map snd (Operation_hash.Map.bindings pv.pending)
in
Lwt_utils.fold_left_s_n
~n:pv.limits.operations_batch_size
(fun (acc_validation_state, acc_mempool) op ->
let refused hash raw errors =
notify_operation pv `Refused raw ;
let new_mempool =
Mempool.
{
acc_mempool with
pending = Operation_hash.Set.add hash acc_mempool.pending;
}
in
Option.iter
(Ring.add_and_return_erased pv.refused hash)
~f:(fun e ->
pv.refusals <- Operation_hash.Map.remove e pv.refusals) ;
pv.refusals <-
Operation_hash.Map.add hash (raw, errors) pv.refusals ;
Distributed_db.Operation.clear_or_cancel pv.chain_db hash ;
Lwt.return (acc_validation_state, new_mempool)
in
match Prevalidation.parse op with
| Error errors ->
refused (Operation.hash op) op errors
| Ok op -> (
Prevalidation.apply_operation state op
>>= function
| Applied (new_acc_validation_state, _) ->
if
pv.applied_count <= 2000
(* this test is a quick fix while we wait for the new mempool *)
|| is_endorsement op
then (
notify_operation pv `Applied op.raw ;
let new_mempool =
Mempool.
{
acc_mempool with
known_valid = op.hash :: acc_mempool.known_valid;
}
in
pv.applied <- (op.hash, op.raw) :: pv.applied ;
pv.in_mempool <-
Operation_hash.Set.add op.hash pv.in_mempool ;
Lwt.return (new_acc_validation_state, new_mempool) )
else Lwt.return (acc_validation_state, acc_mempool)
| Branch_delayed errors ->
notify_operation pv `Branch_delayed op.raw ;
let new_mempool =
if is_endorsement op then
Mempool.
{
acc_mempool with
pending =
Operation_hash.Set.add
op.hash
acc_mempool.pending;
}
else acc_mempool
in
Option.iter
(Ring.add_and_return_erased pv.branch_delayed op.hash)
~f:(fun e ->
pv.branch_delays <-
Operation_hash.Map.remove e pv.branch_delays ;
pv.in_mempool <-
Operation_hash.Set.remove e pv.in_mempool) ;
pv.in_mempool <-
Operation_hash.Set.add op.hash pv.in_mempool ;
pv.branch_delays <-
Operation_hash.Map.add
op.hash
(op.raw, errors)
pv.branch_delays ;
Lwt.return (acc_validation_state, new_mempool)
| Branch_refused errors ->
notify_operation pv `Branch_refused op.raw ;
let new_mempool =
if is_endorsement op then
Mempool.
{
acc_mempool with
pending =
Operation_hash.Set.add
op.hash
acc_mempool.pending;
}
else acc_mempool
in
Option.iter
(Ring.add_and_return_erased pv.branch_refused op.hash)
~f:(fun e ->
pv.branch_refusals <-
Operation_hash.Map.remove e pv.branch_refusals ;
pv.in_mempool <-
Operation_hash.Set.remove e pv.in_mempool) ;
pv.in_mempool <-
Operation_hash.Set.add op.hash pv.in_mempool ;
pv.branch_refusals <-
Operation_hash.Map.add
op.hash
(op.raw, errors)
pv.branch_refusals ;
Lwt.return (acc_validation_state, new_mempool)
| Refused errors ->
refused op.hash op.raw errors
| Duplicate | Outdated ->
Lwt.return (acc_validation_state, acc_mempool) ))
(state, Mempool.empty)
operations
>>= fun ((state, advertised_mempool), remaining_op) ->
( if remaining_op != [] then
Worker.Queue.push_request w Request.Leftover
else Lwt.return_unit )
>>= fun () ->
pv.validation_state <- Ok state ;
pv.pending <- Operation_hash.Map.empty ;
advertise
w
pv
{
advertised_mempool with
known_valid = List.rev advertised_mempool.known_valid;
} ;
Lwt.return_unit ) )
>>= fun () ->
pv.mempool <-
{
Mempool.known_valid = List.rev_map fst pv.applied;
pending =
Operation_hash.Map.fold
(fun k (op, _) s ->
if is_endorsement_raw op then Operation_hash.Set.add k s else s)
pv.branch_delays
@@ Operation_hash.Map.fold
(fun k (op, _) s ->
if is_endorsement_raw op then Operation_hash.Set.add k s
else s)
pv.branch_refusals
@@ Operation_hash.Set.empty;
} ;
State.Current_mempool.set
(Distributed_db.chain_state pv.chain_db)
~head:(State.Block.hash pv.predecessor)
pv.mempool
>>= fun () -> Lwt_main.yield ()
let fetch_operation w pv ?peer oph =
debug w "fetching operation %a" Operation_hash.pp_short oph ;
Distributed_db.Operation.fetch
~timeout:pv.limits.operation_timeout
pv.chain_db
?peer
oph
()
>>= function
| Ok op ->
Worker.Queue.push_request_now w (Arrived (oph, op)) ;
Lwt.return_unit
| Error (Distributed_db.Operation.Canceled _ :: _) ->
debug
w
"operation %a included before being prevalidated"
Operation_hash.pp_short
oph ;
Lwt.return_unit
| Error _ ->
(* should not happen *)
Lwt.return_unit
let rpc_directory =
lazy
(let dir : state RPC_directory.t ref = ref RPC_directory.empty in
let module Proto_services = Block_services.Make (Proto) (Proto) in
(* TODO
refused => Operation_hash.Set.t ;
kick le peer
*)
dir :=
RPC_directory.register
!dir
(Proto_services.S.Mempool.pending_operations RPC_path.open_root)
(fun pv () () ->
let map_op op =
let protocol_data_opt =
Data_encoding.Binary.of_bytes
Proto.operation_data_encoding
op.Operation.proto
in
match protocol_data_opt with
| Some protocol_data ->
Some {Proto.shell = op.shell; protocol_data}
| None ->
None
in
let map_op_error oph (op, error) acc =
match map_op op with
| None ->
acc
| Some res ->
Operation_hash.Map.add oph (res, error) acc
in
let applied =
List.filter_map
(fun (hash, op) ->
match map_op op with
| Some op ->
Some (hash, op)
| None ->
None)
(List.rev pv.applied)
in
let filter f map =
Operation_hash.Map.fold f map Operation_hash.Map.empty
in
let refused = filter map_op_error pv.refusals in
let branch_refused = filter map_op_error pv.branch_refusals in
let branch_delayed = filter map_op_error pv.branch_delays in
let unprocessed =
Operation_hash.Map.fold
(fun oph op acc ->
match map_op op with
| Some op ->
Operation_hash.Map.add oph op acc
| None ->
acc)
pv.pending
Operation_hash.Map.empty
in
return
{
Proto_services.Mempool.applied;
refused;
branch_refused;
branch_delayed;
unprocessed;
}) ;
dir :=
RPC_directory.register
!dir
(Proto_services.S.Mempool.request_operations RPC_path.open_root)
(fun pv () () ->
Distributed_db.Request.current_head pv.chain_db () ;
return_unit) ;
dir :=
RPC_directory.gen_register
!dir
(Proto_services.S.Mempool.monitor_operations RPC_path.open_root)
(fun { applied;
refusals = refused;
branch_refusals = branch_refused;
branch_delays = branch_delayed;
operation_stream;
_ }
params
()
->
let (op_stream, stopper) =
Lwt_watcher.create_stream operation_stream
in
(* Convert ops *)
let map_op op =
let protocol_data =
Data_encoding.Binary.of_bytes_exn
Proto.operation_data_encoding
op.Operation.proto
in
Proto.{shell = op.shell; protocol_data}
in
let fold_op _k (op, _error) acc = map_op op :: acc in
(* First call : retrieve the current set of op from the mempool *)
let applied =
if params#applied then List.map map_op (List.map snd applied)
else []
in
let refused =
if params#refused then
Operation_hash.Map.fold fold_op refused []
else []
in
let branch_refused =
if params#branch_refused then
Operation_hash.Map.fold fold_op branch_refused []
else []
in
let branch_delayed =
if params#branch_delayed then
Operation_hash.Map.fold fold_op branch_delayed []
else []
in
let current_mempool =
List.concat [applied; refused; branch_refused; branch_delayed]
in
let current_mempool = ref (Some current_mempool) in
let filter_result = function
| `Applied ->
params#applied
| `Refused ->
params#refused
| `Branch_refused ->
params#branch_refused
| `Branch_delayed ->
params#branch_delayed
in
let rec next () =
match !current_mempool with
| Some mempool ->
current_mempool := None ;
Lwt.return_some mempool
| None -> (
Lwt_stream.get op_stream
>>= function
| Some (kind, shell, protocol_data) when filter_result kind
->
(* NOTE: Should the protocol change, a new Prevalidation
* context would be created. Thus, we use the same Proto. *)
let bytes =
Data_encoding.Binary.to_bytes_exn
Proto.operation_data_encoding
protocol_data
in
let protocol_data =
Data_encoding.Binary.of_bytes_exn
Proto.operation_data_encoding
bytes
in
Lwt.return_some [{Proto.shell; protocol_data}]
| Some _ ->
next ()
| None ->
Lwt.return_none )
in
let shutdown () = Lwt_watcher.shutdown stopper in
RPC_answer.return_stream {next; shutdown}) ;
!dir)
module Handlers = struct
type self = worker
let on_operation_arrived (pv : state) oph op =
pv.fetching <- Operation_hash.Set.remove oph pv.fetching ;
if not (Block_hash.Set.mem op.Operation.shell.branch pv.live_blocks) then
Distributed_db.Operation.clear_or_cancel pv.chain_db oph
(* TODO: put in a specific delayed map ? *)
else if
not (already_handled pv oph) (* prevent double inclusion on flush *)
then pv.pending <- Operation_hash.Map.add oph op pv.pending
let on_inject pv op =
let oph = Operation.hash op in
if already_handled pv oph then return_unit
(* FIXME : is this an error ? *)
else
Lwt.return pv.validation_state
>>=? fun validation_state ->
Lwt.return (Prevalidation.parse op)
>>=? fun parsed_op ->
Prevalidation.apply_operation validation_state parsed_op
>>= function
| Applied (_, _result) ->
Distributed_db.inject_operation pv.chain_db oph op
>>= fun (_ : bool) ->
pv.pending <- Operation_hash.Map.add parsed_op.hash op pv.pending ;
return_unit
| res ->
failwith
"Error while applying operation %a:@ %a"
Operation_hash.pp
oph
Prevalidation.pp_result
res
let on_notify w pv peer mempool =
let all_ophs =
List.fold_left
(fun s oph -> Operation_hash.Set.add oph s)
mempool.Mempool.pending
mempool.known_valid
in
let to_fetch =
Operation_hash.Set.filter
(fun oph -> not (already_handled pv oph))
all_ophs
in
pv.fetching <- Operation_hash.Set.union to_fetch pv.fetching ;
Operation_hash.Set.iter
(fun oph -> Lwt.ignore_result (fetch_operation w pv ~peer oph))
to_fetch
let on_flush w pv predecessor =
Lwt_watcher.shutdown_input pv.operation_stream ;
State.Block.max_operations_ttl predecessor
>>=? fun max_op_ttl ->
Chain_traversal.live_blocks predecessor max_op_ttl
>>=? fun (new_live_blocks, new_live_operations) ->
list_pendings
pv.chain_db
~from_block:pv.predecessor
~to_block:predecessor
~live_blocks:new_live_blocks
(Preapply_result.operations (validation_result pv))
>>= fun pending ->
let timestamp_system = Tezos_stdlib_unix.Systime_os.now () in
let timestamp = Time.System.to_protocol timestamp_system in
Prevalidation.create ~predecessor ~timestamp ()
>>= fun validation_state ->
debug
w
"%d operations were not washed by the flush"
(Operation_hash.Map.cardinal pending) ;
pv.predecessor <- predecessor ;
pv.live_blocks <- new_live_blocks ;
pv.live_operations <- new_live_operations ;
pv.timestamp <- timestamp_system ;
pv.mempool <- {known_valid = []; pending = Operation_hash.Set.empty} ;
pv.pending <- pending ;
pv.in_mempool <- Operation_hash.Set.empty ;
Ring.clear pv.branch_delayed ;
pv.branch_delays <- Operation_hash.Map.empty ;
Ring.clear pv.branch_refused ;
pv.branch_refusals <- Operation_hash.Map.empty ;
pv.applied <- [] ;
pv.applied_count <- 0 ;
pv.validation_state <- validation_state ;
pv.operation_stream <- Lwt_watcher.create_input () ;
return_unit
let on_advertise pv =
match pv.advertisement with
| `None ->
() (* should not happen *)
| `Pending mempool ->
pv.advertisement <- `None ;
Distributed_db.Advertise.current_head
pv.chain_db
~mempool
pv.predecessor
let on_request : type r. worker -> r Request.t -> r tzresult Lwt.t =
fun w request ->
let pv = Worker.state w in
( match request with
| Request.Flush hash ->
on_advertise pv ;
(* TODO: rebase the advertisement instead *)
let chain_state = Distributed_db.chain_state pv.chain_db in
State.Block.read chain_state hash
>>=? fun block -> on_flush w pv block >>=? fun () -> return (() : r)
| Request.Notify (peer, mempool) ->
on_notify w pv peer mempool ;
return_unit
| Request.Leftover ->
(* unprocessed ops are handled just below *)
return_unit
| Request.Inject op ->
on_inject pv op
| Request.Arrived (oph, op) ->
on_operation_arrived pv oph op ;
return_unit
| Request.Advertise ->
on_advertise pv ; return_unit )
>>=? fun r -> handle_unprocessed w pv >>= fun () -> return r
let on_close w =
let pv = Worker.state w in
Operation_hash.Set.iter
(Distributed_db.Operation.clear_or_cancel pv.chain_db)
pv.fetching ;
Lwt.return_unit
let on_launch w _ (limits, chain_db) =
let chain_state = Distributed_db.chain_state chain_db in
Chain.data chain_state
>>= fun { current_head = predecessor;
current_mempool = mempool;
live_blocks;
live_operations;
_ } ->
let timestamp_system = Tezos_stdlib_unix.Systime_os.now () in
let timestamp = Time.System.to_protocol timestamp_system in
Prevalidation.create ~predecessor ~timestamp ()
>>= fun validation_state ->
let fetching =
List.fold_left
(fun s h -> Operation_hash.Set.add h s)
Operation_hash.Set.empty
mempool.known_valid
in
let pv =
{
limits;
chain_db;
predecessor;
timestamp = timestamp_system;
live_blocks;
live_operations;
mempool = {known_valid = []; pending = Operation_hash.Set.empty};
refused = Ring.create limits.max_refused_operations;
refusals = Operation_hash.Map.empty;
fetching;
pending = Operation_hash.Map.empty;
in_mempool = Operation_hash.Set.empty;
applied = [];
applied_count = 0;
branch_refused = Ring.create limits.max_refused_operations;
branch_refusals = Operation_hash.Map.empty;
branch_delayed = Ring.create limits.max_refused_operations;
branch_delays = Operation_hash.Map.empty;
validation_state;
operation_stream = Lwt_watcher.create_input ();
advertisement = `None;
rpc_directory;
}
in
List.iter
(fun oph -> Lwt.ignore_result (fetch_operation w pv oph))
mempool.known_valid ;
return pv
let on_error w r st errs =
Worker.record_event w (Event.Request (r, st, Some errs)) ;
match r with
| Request.(View (Inject _)) ->
return_unit
| _ ->
Lwt.return_error errs
let on_completion w r _ st =
Worker.record_event w (Event.Request (Request.view r, st, None)) ;
Lwt.return_unit
let on_no_request _ = return_unit
end
let table = Worker.create_table Queue
(* NOTE: we register a single worker for each instantiation of this Make
* functor (and thus a single worker for the single instantiaion of Worker).
* Whislt this is somewhat abusing the intended purpose of worker, it is part
* of a transition plan to a one-worker-per-peer architecture. *)
let worker_promise =
Worker.launch
table
Arg.limits.worker_limits
name
(Arg.limits, Arg.chain_db)
(module Handlers)
let initialization_errors = worker_promise >>=? fun _ -> return_unit
let worker =
lazy
( match Lwt.state worker_promise with
| Lwt.Return (Ok worker) ->
worker
| Lwt.Return (Error _) | Lwt.Fail _ | Lwt.Sleep ->
assert false )
let fitness () =
let w = Lazy.force worker in
let pv = Worker.state w in
Lwt.return pv.validation_state
>>=? (fun state ->
Prevalidation.status state
>>=? fun status -> return status.block_result.fitness)
>>= function
| Ok fitness ->
Lwt.return fitness
| Error _ ->
Lwt.return (State.Block.fitness pv.predecessor)
end
module ChainProto_registry = Registry.Make (struct
type v = t
type t = Chain_id.t * Protocol_hash.t
let compare (c1, p1) (c2, p2) =
let pc = Protocol_hash.compare p1 p2 in
if pc = 0 then Chain_id.compare c1 c2 else pc
end)
let create limits (module Proto : Registered_protocol.T) chain_db =
let chain_state = Distributed_db.chain_state chain_db in
let chain_id = State.Chain.id chain_state in
match ChainProto_registry.query (chain_id, Proto.hash) with
| None ->
let module Prevalidator =
Make
(Proto)
(struct
let limits = limits
let chain_db = chain_db
let chain_id = chain_id
end)
in
(* Checking initialization errors before giving a reference to dnagerous
* `worker` value to caller. *)
Prevalidator.initialization_errors
>>=? fun () ->
ChainProto_registry.register Prevalidator.name (module Prevalidator : T) ;
return (module Prevalidator : T)
| Some p ->
return p
let shutdown (t : t) =
let module Prevalidator : T = (val t) in
let w = Lazy.force Prevalidator.worker in
ChainProto_registry.remove Prevalidator.name ;
Prevalidator.Worker.shutdown w
let flush (t : t) head =
let module Prevalidator : T = (val t) in
let w = Lazy.force Prevalidator.worker in
Prevalidator.Worker.Queue.push_request_and_wait w (Request.Flush head)
let notify_operations (t : t) peer mempool =
let module Prevalidator : T = (val t) in
let w = Lazy.force Prevalidator.worker in
Prevalidator.Worker.Queue.push_request w (Request.Notify (peer, mempool))
let operations (t : t) =
let module Prevalidator : T = (val t) in
let w = Lazy.force Prevalidator.worker in
let pv = Prevalidator.Worker.state w in
( {(Prevalidator.validation_result pv) with applied = List.rev pv.applied},
pv.pending )
let pending (t : t) =
let module Prevalidator : T = (val t) in
let w = Lazy.force Prevalidator.worker in
let pv = Prevalidator.Worker.state w in
let ops = Preapply_result.operations (Prevalidator.validation_result pv) in
Lwt.return ops
let timestamp (t : t) =
let module Prevalidator : T = (val t) in
let w = Lazy.force Prevalidator.worker in
let pv = Prevalidator.Worker.state w in
pv.timestamp
let fitness (t : t) =
let module Prevalidator : T = (val t) in
Prevalidator.fitness ()
let inject_operation (t : t) op =
let module Prevalidator : T = (val t) in
let w = Lazy.force Prevalidator.worker in
Prevalidator.Worker.Queue.push_request_and_wait w (Inject op)
let status (t : t) =
let module Prevalidator : T = (val t) in
let w = Lazy.force Prevalidator.worker in
Prevalidator.Worker.status w
let running_workers () =
ChainProto_registry.fold (fun (id, proto) t acc -> (id, proto, t) :: acc) []
let pending_requests (t : t) =
let module Prevalidator : T = (val t) in
let w = Lazy.force Prevalidator.worker in
Prevalidator.Worker.Queue.pending_requests w
let current_request (t : t) =
let module Prevalidator : T = (val t) in
let w = Lazy.force Prevalidator.worker in
Prevalidator.Worker.current_request w
let last_events (t : t) =
let module Prevalidator : T = (val t) in
let w = Lazy.force Prevalidator.worker in
Prevalidator.Worker.last_events w
let protocol_hash (t : t) =
let module Prevalidator : T = (val t) in
Prevalidator.Proto.hash
let parameters (t : t) =
let module Prevalidator : T = (val t) in
Prevalidator.parameters
let information (t : t) =
let module Prevalidator : T = (val t) in
let w = Lazy.force Prevalidator.worker in
Prevalidator.Worker.information w
let pipeline_length (t : t) =
let module Prevalidator : T = (val t) in
let w = Lazy.force Prevalidator.worker in
Prevalidator.Worker.Queue.pending_requests_length w
let empty_rpc_directory : unit RPC_directory.t =
RPC_directory.register
RPC_directory.empty
(Block_services.Empty.S.Mempool.pending_operations RPC_path.open_root)
(fun _pv () () ->
return
{
Block_services.Empty.Mempool.applied = [];
refused = Operation_hash.Map.empty;
branch_refused = Operation_hash.Map.empty;
branch_delayed = Operation_hash.Map.empty;
unprocessed = Operation_hash.Map.empty;
})
let rpc_directory : t option RPC_directory.t =
RPC_directory.register_dynamic_directory
RPC_directory.empty
(Block_services.mempool_path RPC_path.open_root)
(function
| None ->
Lwt.return
(RPC_directory.map (fun _ -> Lwt.return_unit) empty_rpc_directory)
| Some t -> (
let module Prevalidator : T = (val t : T) in
Prevalidator.initialization_errors
>>= function
| Error _ ->
Lwt.return
(RPC_directory.map
(fun _ -> Lwt.return_unit)
empty_rpc_directory)
| Ok () ->
let w = Lazy.force Prevalidator.worker in
let pv = Prevalidator.Worker.state w in
let pv_rpc_dir = Lazy.force pv.rpc_directory in
Lwt.return
(RPC_directory.map (fun _ -> Lwt.return pv) pv_rpc_dir) ))
src/lib_shell/prevalidator.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Prevalidator_worker_state.
Record limits := {
max_refused_operations : Z;
operation_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
worker_limits : Tezos_shell_services.Worker_types.limits;
operations_batch_size : Z }.
Definition name_t :=
Tezos_base__TzPervasives.Chain_id.t * Tezos_base__TzPervasives.Protocol_hash.t.
Module T.
Record signature {Proto_P_block_header_data Proto_P_block_header
Proto_P_block_header_metadata Proto_P_operation_data
Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state
Prevalidation_t Prevalidation_operation Prevalidation_result
Prevalidation_status types_state Types_parameters Types_view Worker_Name_t
Worker_Types_parameters Worker_Types_view Worker_t Worker_table Worker_queue
Worker_bounded Worker_infinite Worker_dropbox Worker_buffer_kind
Worker_any_request : Type} := {
Proto : Registered_protocol.T.signature Proto_P_block_header_data Proto_P_block_header Proto_P_block_header_metadata Proto_P_operation_data Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state;
name : name_t;
parameters : limits * Tezos_shell.Distributed_db.chain_db;
Prevalidation : Prevalidation.T.signature Prevalidation_Proto_P_block_header_data Prevalidation_Proto_P_block_header Prevalidation_Proto_P_block_header_metadata Prevalidation_Proto_P_operation_data Prevalidation_Proto_P_operation_receipt Prevalidation_Proto_P_operation Prevalidation_Proto_P_validation_state Prevalidation_t Prevalidation_operation Prevalidation_result Prevalidation_status;
types_state := types_state;
Name : Worker.NAME.signature name_t;
Types : Worker.TYPES.signature types_state Types_parameters Types_view;
Worker : Worker.T.signature (Tezos_shell_services.Prevalidator_worker_state.Request.t
a) (Tezos_shell_services.Prevalidator_worker_state.Request.t a) (Tezos_shell_services.Prevalidator_worker_state.Request.t
a) Tezos_shell_services.Prevalidator_worker_state.Request.view types_state Worker_Types_parameters Tezos_shell_services.Prevalidator_worker_state.Request.view Worker_t Worker_table Worker_queue Worker_bounded Worker_infinite Worker_dropbox Worker_buffer_kind Worker_any_request;
worker := Worker.t (Worker.queue Worker.infinite);
list_pendings : Tezos_shell.Distributed_db.chain_db ->
Tezos_shell.State.Block.t ->
Tezos_shell.State.Block.t ->
Tezos_base__TzPervasives.Block_hash.Set.t ->
(Tezos_base__TzPervasives.Operation_hash.Map.t
Tezos_base__TzPervasives.Operation.t) ->
Lwt.t
(Tezos_base__TzPervasives.Operation_hash.Map.t
Tezos_base__TzPervasives.Operation.t);
validation_result : types_state ->
Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error;
fitness : unit -> Lwt.t Tezos_base__TzPervasives.Fitness.t;
initialization_errors : Lwt.t (Tezos_base__TzPervasives.tzresult unit);
worker : Stdlib.Lazy.t worker;
}.
Arguments signature : clear implicits.
End T.
Module ARG.
Record signature := {
limits : limits;
chain_db : Tezos_shell.Distributed_db.chain_db;
chain_id : Tezos_base__TzPervasives.Chain_id.t;
}.
End ARG.
Definition t :=
{'(Proto_P_block_header_data, Proto_P_block_header,
Proto_P_block_header_metadata, Proto_P_operation_data,
Proto_P_operation_receipt, Proto_P_operation, Proto_P_validation_state,
Prevalidation_t, Prevalidation_operation, Prevalidation_result,
Prevalidation_status, types_state, Types_parameters, Types_view,
Worker_Name_t, Worker_Types_parameters, Worker_Types_view, Worker_t,
Worker_table, Worker_queue, Worker_bounded, Worker_infinite, Worker_dropbox,
Worker_buffer_kind, Worker_any_request) : _ &
T.signature Proto_P_block_header_data Proto_P_block_header
Proto_P_block_header_metadata Proto_P_operation_data
Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state
Prevalidation_t Prevalidation_operation Prevalidation_result
Prevalidation_status types_state Types_parameters Types_view Worker_Name_t
Worker_Types_parameters Worker_Types_view Worker_t Worker_table
Worker_queue Worker_bounded Worker_infinite Worker_dropbox
Worker_buffer_kind Worker_any_request}.
(* ❌ Functors are not handled. *)
functor
(* ❌ Applications of functors are not handled. *)
functor_application
Definition create
(limits : limits)
(Proto :
{'(P_block_header_data, P_block_header, P_block_header_metadata,
P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
_ &
Tezos_protocol_updater.Registered_protocol.T.signature P_block_header_data
P_block_header P_block_header_metadata P_operation_data
P_operation_receipt P_operation P_validation_state})
: Tezos_shell.Distributed_db.chain_db ->
Lwt.t (Tezos_base__TzPervasives.tzresult ChainProto_registry.v) :=
let Proto := projT2 Proto in
fun chain_db =>
let chain_state := Distributed_db.chain_state chain_db in
let chain_id := State.Chain.id chain_state in
match
ChainProto_registry.query
(chain_id, Proto.(Tezos_protocol_updater__Registered_protocol.T.hash))
with
| None =>
let Prevalidator :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
op_gtgteqquestion Prevalidator.(T.initialization_errors)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
ChainProto_registry.register Prevalidator.(T.name) Prevalidator in
_return Prevalidator)
| Some p => _return p
end.
Definition shutdown (t : t) : Lwt.t unit :=
let Prevalidator := projT2 t in
let w := Lazy.force Prevalidator.(T.worker) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := ChainProto_registry.remove Prevalidator.(T.name) in
Prevalidator.Worker.shutdown w.
Definition flush (t : t) (head : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let Prevalidator := projT2 t in
let w := Lazy.force Prevalidator.(T.worker) in
Prevalidator.Worker.Queue.push_request_and_wait w
(Tezos_shell_services.Prevalidator_worker_state.Request.Flush head).
Definition notify_operations
(t : t) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t)
(mempool : Tezos_base__TzPervasives.Mempool.t) : Lwt.t unit :=
let Prevalidator := projT2 t in
let w := Lazy.force Prevalidator.(T.worker) in
Prevalidator.Worker.Queue.push_request w
(Tezos_shell_services.Prevalidator_worker_state.Request.Notify peer mempool).
Definition operations (t : t)
: (Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error)
*
(Tezos_base__TzPervasives.Operation_hash.Map.t
Tezos_base__TzPervasives.Operation.t) :=
let Prevalidator := projT2 t in
let w := Lazy.force Prevalidator.(T.worker) in
let pv := Prevalidator.Worker.state w in
((* ❌ Record substitution not handled *)
record_substitution, (pending pv)).
Definition pending (t : t)
: Lwt.t (Tezos_crypto.Operation_hash.Map.t Tezos_base.Operation.t) :=
let Prevalidator := projT2 t in
let w := Lazy.force Prevalidator.(T.worker) in
let pv := Prevalidator.Worker.state w in
let ops := Preapply_result.operations (Prevalidator.(T.validation_result) pv)
in
Lwt._return ops.
Definition timestamp (t : t) : Tezos_base__TzPervasives.Time.System.t :=
let Prevalidator := projT2 t in
let w := Lazy.force Prevalidator.(T.worker) in
let pv := Prevalidator.Worker.state w in
timestamp pv.
Definition fitness (t : t) : Lwt.t Tezos_base__TzPervasives.Fitness.t :=
let Prevalidator := projT2 t in
Prevalidator.(T.fitness) tt.
Definition inject_operation (t : t) (op : Tezos_base__TzPervasives.Operation.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let Prevalidator := projT2 t in
let w := Lazy.force Prevalidator.(T.worker) in
Prevalidator.Worker.Queue.push_request_and_wait w
(Tezos_shell_services.Prevalidator_worker_state.Request.Inject op).
Definition status (t : t) : Tezos_shell_services.Worker_types.worker_status :=
let Prevalidator := projT2 t in
let w := Lazy.force Prevalidator.(T.worker) in
Prevalidator.Worker.status w.
Definition running_workers (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Chain_id.t *
Tezos_base__TzPervasives.Protocol_hash.t * ChainProto_registry.v) :=
let 'tt := function_parameter in
ChainProto_registry.fold
(fun function_parameter =>
let '(id, proto) := function_parameter in
fun t => fun acc => cons (id, proto, t) acc) [].
Definition pending_requests (t : t)
: list
(Tezos_base__TzPervasives.Time.System.t *
Tezos_shell_services.Prevalidator_worker_state.Request.view) :=
let Prevalidator := projT2 t in
let w := Lazy.force Prevalidator.(T.worker) in
Prevalidator.Worker.Queue.pending_requests w.
Definition current_request (t : t)
: option
(Tezos_base__TzPervasives.Time.System.t *
Tezos_base__TzPervasives.Time.System.t *
Tezos_shell_services.Prevalidator_worker_state.Request.view) :=
let Prevalidator := projT2 t in
let w := Lazy.force Prevalidator.(T.worker) in
Prevalidator.Worker.current_request w.
Definition last_events (t : t)
: list
(Tezos_base__TzPervasives.Internal_event.level *
(list Tezos_shell_services.Prevalidator_worker_state.Event.t)) :=
let Prevalidator := projT2 t in
let w := Lazy.force Prevalidator.(T.worker) in
Prevalidator.Worker.last_events w.
Definition protocol_hash (t : t) : Tezos_base__TzPervasives.Protocol_hash.t :=
let Prevalidator := projT2 t in
Prevalidator.(T.Proto).(Tezos_protocol_updater__Registered_protocol.T.hash).
Definition parameters (t : t) : limits * Tezos_shell.Distributed_db.chain_db :=
let Prevalidator := projT2 t in
Prevalidator.(T.parameters).
Definition information (t : t)
: Tezos_shell_services.Worker_types.worker_information :=
let Prevalidator := projT2 t in
let w := Lazy.force Prevalidator.(T.worker) in
Prevalidator.Worker.information w.
Definition pipeline_length (t : t) : Z :=
let Prevalidator := projT2 t in
let w := Lazy.force Prevalidator.(T.worker) in
Prevalidator.Worker.Queue.pending_requests_length w.
Definition empty_rpc_directory
: Tezos_base__TzPervasives.RPC_directory.t unit :=
RPC_directory.register RPC_directory.empty
(Block_services.Empty.S.Mempool.pending_operations RPC_path.open_root)
(fun _pv =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
_return
{| Block_services.Empty.Mempool.applied := [];
Block_services.Empty.Mempool.refused := Operation_hash.Map.empty;
Block_services.Empty.Mempool.branch_refused :=
Operation_hash.Map.empty;
Block_services.Empty.Mempool.branch_delayed :=
Operation_hash.Map.empty;
Block_services.Empty.Mempool.unprocessed :=
Operation_hash.Map.empty |}).
Definition rpc_directory
: Tezos_base__TzPervasives.RPC_directory.t (option t) :=
RPC_directory.register_dynamic_directory None RPC_directory.empty
(Block_services.mempool_path RPC_path.open_root)
(fun function_parameter =>
match function_parameter with
| None =>
Lwt._return
(RPC_directory.map
(fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit) empty_rpc_directory)
| Some t =>
let Prevalidator := projT2 t in
op_gtgteq Prevalidator.(T.initialization_errors)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ =>
Lwt._return
(RPC_directory.map
(fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit) empty_rpc_directory)
| Stdlib.Ok tt =>
let w := Lazy.force Prevalidator.(T.worker) in
let pv := Prevalidator.Worker.state w in
let pv_rpc_dir := Lazy.force (rpc_directory pv) in
Lwt._return
(RPC_directory.map
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return pv) pv_rpc_dir)
end)
end).
src/lib_shell/protocol_directory.ml 13 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let build_rpc_directory block_validator state =
let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
let gen_register0 s f =
dir := RPC_directory.gen_register !dir s (fun () p q -> f p q)
in
let register1 s f =
dir := RPC_directory.register !dir s (fun ((), a) p q -> f a p q)
in
gen_register0 Protocol_services.S.list (fun () () ->
State.Protocol.list state
>>= fun set ->
let protocols =
List.fold_left
(fun acc x -> Protocol_hash.Set.add x acc)
set
(Registered_protocol.list_embedded ())
in
RPC_answer.return (Protocol_hash.Set.elements protocols)) ;
register1 Protocol_services.S.contents (fun hash () () ->
match Registered_protocol.get_embedded_sources hash with
| Some p ->
return p
| None ->
State.Protocol.read state hash) ;
register1 Protocol_services.S.fetch (fun hash () () ->
Block_validator.fetch_and_compile_protocol block_validator hash
>>=? fun _proto -> return_unit) ;
!dir
src/lib_shell/protocol_directory.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition build_rpc_directory
(block_validator : Tezos_shell.Block_validator.t)
(state : Tezos_shell__State.global_state)
: Tezos_base__TzPervasives.RPC_directory.t unit :=
let dir := Stdlib.ref RPC_directory.empty in
let gen_register0 {A B C : Type}
(s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
A -> B -> Lwt.t variant) : unit :=
Stdlib.op_coloneq dir
(RPC_directory.gen_register (Stdlib.op_exclamation dir) s
(fun function_parameter =>
let 'tt := function_parameter in
fun p => fun q => f p q)) in
let register1 {A B C D : Type}
(s : Tezos_rpc.RPC_service.t variant unit (unit * A) B C D) (f :
A -> B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
Stdlib.op_coloneq dir
(RPC_directory.register (Stdlib.op_exclamation dir) s
(fun function_parameter =>
let '(tt, a) := function_parameter in
fun p => fun q => f a p q)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
gen_register0 Protocol_services.S.list
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Protocol.list state)
(fun set =>
let protocols :=
List.fold_left (fun acc => fun x => Protocol_hash.Set.add x acc)
set (Registered_protocol.list_embedded tt) in
RPC_answer._return (Protocol_hash.Set.elements protocols))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 Protocol_services.S.contents
(fun hash =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match Registered_protocol.get_embedded_sources hash with
| Some p => _return p
| None => State.Protocol.read state hash
end) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 Protocol_services.S.fetch
(fun hash =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Block_validator.fetch_and_compile_protocol block_validator None
None hash) (fun _proto => return_unit)) in
Stdlib.op_exclamation dir.
src/lib_shell/protocol_validator.ml 65 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Validation_errors
include Internal_event.Legacy_logging.Make_semantic (struct
let name = "node.validator.block"
end)
type t = {
db : Distributed_db.t;
mutable worker : unit Lwt.t;
request : unit Lwt_condition.t;
mutable pending :
( Protocol.t
* Registered_protocol.t tzresult Lwt.t
* Registered_protocol.t tzresult Lwt.u )
Protocol_hash.Map.t;
canceler : Lwt_canceler.t;
}
(** Block validation *)
let rec worker_loop bv =
( if Protocol_hash.Map.cardinal bv.pending = 0 then
Lwt_condition.wait bv.request >>= return
else
let (hash, (protocol, _, wakener)) = Protocol_hash.Map.choose bv.pending in
bv.pending <- Protocol_hash.Map.remove hash bv.pending ;
Updater.compile hash protocol
>>= fun valid ->
( if valid then Distributed_db.commit_protocol bv.db hash protocol
else
(* no need to tag 'invalid' protocol on disk,
the economic protocol prevents us from
being spammed with protocol validation. *)
return_true )
>>=? fun _ ->
if valid then
match Registered_protocol.get hash with
| Some protocol ->
Lwt.wakeup_later wakener (Ok protocol)
| None ->
Lwt.wakeup_later
wakener
(error (Invalid_protocol {hash; error = Dynlinking_failed}))
else
Lwt.wakeup_later
wakener
(error (Invalid_protocol {hash; error = Compilation_failed})) ;
return_unit )
>>= function
| Ok () ->
worker_loop bv
| Error (Canceled :: _) | Error (Exn Lwt_pipe.Closed :: _) ->
lwt_log_notice
Tag.DSL.(fun f -> f "terminating" -% t event "terminating")
| Error err ->
lwt_log_error
Tag.DSL.(
fun f ->
f "@[Unexpected error (worker):@ %a@]"
-% t event "unexpected_error" -% a errs_tag err)
>>= fun () -> Lwt_canceler.cancel bv.canceler
let create db =
let canceler = Lwt_canceler.create () in
let pending = Protocol_hash.Map.empty in
let request = Lwt_condition.create () in
let bv = {canceler; pending; request; db; worker = Lwt.return_unit} in
Lwt_canceler.on_cancel bv.canceler (fun () ->
Protocol_hash.Map.iter (fun _ (_, r, _) -> Lwt.cancel r) bv.pending ;
Lwt.return_unit) ;
bv.worker <-
Lwt_utils.worker
"block_validator"
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> worker_loop bv)
~cancel:(fun () -> Lwt_canceler.cancel bv.canceler) ;
bv
let shutdown {canceler; worker; _} =
Lwt_canceler.cancel canceler >>= fun () -> worker
let validate state hash protocol =
match Registered_protocol.get hash with
| Some protocol ->
lwt_debug
Tag.DSL.(
fun f ->
f "previously validated protocol %a (before pipe)"
-% t event "previously_validated_protocol"
-% a Protocol_hash.Logging.tag hash)
>>= fun () -> return protocol
| None -> (
lwt_debug
Tag.DSL.(
fun f ->
f "pushing validation request for protocol %a"
-% t event "pushing_validation_request"
-% a Protocol_hash.Logging.tag hash)
>>= fun () ->
match Protocol_hash.Map.find_opt hash state.pending with
| None ->
let (res, wakener) = Lwt.task () in
let broadcast = Protocol_hash.Map.cardinal state.pending = 0 in
state.pending <-
Protocol_hash.Map.add hash (protocol, res, wakener) state.pending ;
if broadcast then Lwt_condition.broadcast state.request () ;
res
| Some (_, res, _) ->
res )
let fetch_and_compile_protocol pv ?peer ?timeout hash =
match Registered_protocol.get hash with
| Some proto ->
return proto
| None ->
Distributed_db.Protocol.read_opt pv.db hash
>>= (function
| Some protocol ->
return protocol
| None ->
lwt_log_notice
Tag.DSL.(
fun f ->
f "Fetching protocol %a%a"
-% t event "fetching_protocol"
-% a Protocol_hash.Logging.tag hash
-% a P2p_peer.Id.Logging.tag_source peer)
>>= fun () ->
Distributed_db.Protocol.fetch pv.db ?peer ?timeout hash ())
>>=? fun protocol ->
validate pv hash protocol >>=? fun proto -> return proto
let fetch_and_compile_protocols pv ?peer ?timeout (block : State.Block.t) =
let protocol_level = State.Block.protocol_level block in
let chain_state = State.Block.chain_state block in
State.Block.context block
>>=? fun context ->
let protocol =
Context.get_protocol context
>>= fun protocol_hash ->
fetch_and_compile_protocol pv ?peer ?timeout protocol_hash
>>=? fun _p ->
let chain_id = State.Chain.id chain_state in
State.Chain.update_level_indexed_protocol_store
chain_state
chain_id
protocol_level
protocol_hash
(State.Block.header block)
>>= fun () -> return_unit
and test_protocol =
Context.get_test_chain context
>>= function
| Not_running ->
return_unit
| Forking {protocol; _} | Running {protocol; _} ->
fetch_and_compile_protocol pv ?peer ?timeout protocol
>>=? fun _ ->
State.Chain.test chain_state
>>= (function
| None ->
Lwt.return_unit
| Some chain_id ->
State.Chain.update_level_indexed_protocol_store
chain_state
chain_id
protocol_level
protocol
(State.Block.header block))
>>= fun () -> return_unit
in
protocol >>=? fun () -> test_protocol
let prefetch_and_compile_protocols pv ?peer ?timeout block =
try ignore (fetch_and_compile_protocols pv ?peer ?timeout block)
with _ -> ()
src/lib_shell/protocol_validator.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Validation_errors.
(* ❌ Structure item `include` not handled. *)
include
Record t := {
db : Tezos_shell.Distributed_db.t;
worker : Lwt.t unit;
request : Lwt_condition.t unit;
pending :
Tezos_base__TzPervasives.Protocol_hash.Map.t
(Tezos_base__TzPervasives.Protocol.t *
(Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_updater.Registered_protocol.t)) *
(Lwt.u
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_updater.Registered_protocol.t)));
canceler : Tezos_base__TzPervasives.Lwt_canceler.t }.
Fixpoint worker_loop (bv : t) : Lwt.t unit :=
op_gtgteq
(if equiv_decb (Protocol_hash.Map.cardinal (pending bv)) 0 then
op_gtgteq (Lwt_condition.wait None (request bv)) _return
else
let '(hash, (protocol, _, wakener)) :=
Protocol_hash.Map.choose (pending bv) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field bv "pending" % string
(Protocol_hash.Map.remove hash (pending bv)) in
op_gtgteq (Updater.compile hash protocol)
(fun valid =>
op_gtgteqquestion
(if valid then
Distributed_db.commit_protocol (db bv) hash protocol
else
return_true)
(fun function_parameter =>
let '_ := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if valid then
match Registered_protocol.get hash with
| Some protocol =>
Lwt.wakeup_later wakener (Stdlib.Ok protocol)
| None =>
Lwt.wakeup_later wakener
(error
(Tezos_base__TzPervasives.Invalid_protocol
{| hash := hash;
error :=
Tezos_shell_services.Validation_errors.Dynlinking_failed
|}))
end
else
Lwt.wakeup_later wakener
(error
(Tezos_base__TzPervasives.Invalid_protocol
{| hash := hash;
error :=
Tezos_shell_services.Validation_errors.Compilation_failed
|})) in
return_unit)))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => worker_loop bv
|
Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) |
Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Closed) _) =>
lwt_log_notice
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"terminating" % string
CamlinternalFormatBasics.End_of_format)
"terminating" % string)) (t event "terminating" % string))
| Stdlib.Error err =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Unexpected error (worker):" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Unexpected error (worker):@ %a@]" % string))
(t event "unexpected_error" % string)) (a errs_tag err)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler bv))
end).
Definition create (db : Tezos_shell.Distributed_db.t) : t :=
let canceler := Lwt_canceler.create tt in
let pending := Protocol_hash.Map.empty in
let request := Lwt_condition.create tt in
let bv :=
{| db := db; worker := Lwt.return_unit; request := request;
pending := pending; canceler := canceler |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_canceler.on_cancel (canceler bv)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Protocol_hash.Map.iter
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '(_, r, _) := function_parameter in
Lwt.cancel r) (pending bv) in
Lwt.return_unit) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field bv "worker" % string
(Lwt_utils.worker "block_validator" % string
Internal_event.Lwt_worker_event.on_event
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop bv)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_canceler.cancel (canceler bv))) in
bv.
Definition shutdown (function_parameter : t) : Lwt.t unit :=
let '{| worker := worker; canceler := canceler |} := function_parameter in
op_gtgteq (Lwt_canceler.cancel canceler)
(fun function_parameter =>
let 'tt := function_parameter in
worker).
Definition validate
(state : t) (hash : Tezos_base__TzPervasives.Protocol_hash.t)
(protocol : Tezos_base__TzPervasives.Protocol.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_updater.Registered_protocol.t) :=
match Registered_protocol.get hash with
| Some protocol =>
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"previously validated protocol " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (before pipe)" % string
CamlinternalFormatBasics.End_of_format)))
"previously validated protocol %a (before pipe)" % string))
(t event "previously_validated_protocol" % string))
(a Protocol_hash.Logging.tag hash)))
(fun function_parameter =>
let 'tt := function_parameter in
_return protocol)
| None =>
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"pushing validation request for protocol " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"pushing validation request for protocol %a" % string))
(t event "pushing_validation_request" % string))
(a Protocol_hash.Logging.tag hash)))
(fun function_parameter =>
let 'tt := function_parameter in
match Protocol_hash.Map.find_opt hash (pending state) with
| None =>
let '(res, wakener) := Lwt.task tt in
let broadcast :=
equiv_decb (Protocol_hash.Map.cardinal (pending state)) 0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "pending" % string
(Protocol_hash.Map.add hash (protocol, res, wakener)
(pending state)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if broadcast then
Lwt_condition.broadcast (request state) tt
else
tt in
res
| Some (_, res, _) => res
end)
end.
Definition fetch_and_compile_protocol
(pv : t) (peer : option Tezos_base__P2p_peer_id.t)
(timeout : option Tezos_base__TzPervasives.Time.System.Span.t)
(hash : Tezos_base__TzPervasives.Protocol_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_updater.Registered_protocol.t) :=
match Registered_protocol.get hash with
| Some proto => _return proto
| None =>
op_gtgteqquestion
(op_gtgteq (Distributed_db.Protocol.read_opt (db pv) hash)
(fun function_parameter =>
match function_parameter with
| Some protocol => _return protocol
| None =>
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Fetching protocol " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))
"Fetching protocol %a%a" % string))
(t event "fetching_protocol" % string))
(a Protocol_hash.Logging.tag hash))
(a P2p_peer.Id.Logging.tag_source peer)))
(fun function_parameter =>
let 'tt := function_parameter in
Distributed_db.Protocol.fetch (db pv) peer timeout hash tt)
end))
(fun protocol =>
op_gtgteqquestion (validate pv hash protocol)
(fun proto => _return proto))
end.
Definition fetch_and_compile_protocols
(pv : t) (peer : option Tezos_base__P2p_peer_id.t)
(timeout : option Tezos_base__TzPervasives.Time.System.Span.t)
(block : Tezos_shell.State.Block.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let protocol_level := State.Block.protocol_level block in
let chain_state := State.Block.chain_state block in
op_gtgteqquestion (State.Block.context block)
(fun context =>
let protocol : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (Context.get_protocol context)
(fun protocol_hash =>
op_gtgteqquestion
(fetch_and_compile_protocol pv peer timeout protocol_hash)
(fun _p =>
let chain_id := State.Chain.id chain_state in
op_gtgteq
(State.Chain.update_level_indexed_protocol_store chain_state
chain_id protocol_level protocol_hash
(State.Block.header block))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
with test_protocol : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (Context.get_test_chain context)
(fun function_parameter =>
match function_parameter with
| Tezos_base__TzPervasives.Test_chain_status.Not_running =>
return_unit
|
Tezos_base__TzPervasives.Test_chain_status.Forking {|
protocol := protocol |} |
Tezos_base__TzPervasives.Test_chain_status.Running {|
protocol := protocol |} =>
op_gtgteqquestion
(fetch_and_compile_protocol pv peer timeout protocol)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(op_gtgteq (State.Chain.test chain_state)
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_unit
| Some chain_id =>
State.Chain.update_level_indexed_protocol_store
chain_state chain_id protocol_level protocol
(State.Block.header block)
end))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))
end) in
op_gtgteqquestion protocol
(fun function_parameter =>
let 'tt := function_parameter in
test_protocol)).
Definition prefetch_and_compile_protocols
(pv : t) (peer : option Tezos_base__P2p_peer_id.t)
(timeout : option Tezos_base__TzPervasives.Time.System.Span.t)
(block : Tezos_shell.State.Block.t) : unit :=
(* ❌ Try-with are not handled *)
try (OCaml.Stdlib.ignore (fetch_and_compile_protocols pv peer timeout block)).
src/lib_shell/snapshots.ml 101 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs. <nomadic@tezcore.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type status =
| Export_unspecified_hash of Block_hash.t
| Export_info of History_mode.t * Block_hash.t * Int32.t
| Export_success of string
| Set_history_mode of History_mode.t
| Import_info of string
| Import_unspecified_hash
| Import_loading
| Set_head of Block_hash.t
| Import_success of string
let status_pp ppf = function
| Export_unspecified_hash h ->
Format.fprintf
ppf
"There is no block hash specified with the `--block` option. Using %a \
(last checkpoint)"
Block_hash.pp
h
| Export_info (hm, h, l) ->
Format.fprintf
ppf
"Exporting a snapshot in %a mode, targeting block hash %a at level %a"
History_mode.pp
hm
Block_hash.pp
h
Format.pp_print_int
(Int32.to_int l)
| Export_success filename ->
Format.fprintf ppf "@[Successful export: %s@]" filename
| Set_history_mode hm ->
Format.fprintf ppf "Setting history-mode to %a" History_mode.pp hm
| Import_info filename ->
Format.fprintf ppf "Importing data from snapshot file %s" filename
| Import_unspecified_hash ->
Format.fprintf
ppf
"You may consider using the --block <block_hash> argument to verify \
that the block imported is the one you expect"
| Import_loading ->
Format.fprintf
ppf
"Retrieving and validating data. This can take a while, please bear \
with us"
| Set_head h ->
Format.fprintf ppf "Setting current head to block %a" Block_hash.pp h
| Import_success filename ->
Format.fprintf ppf "@[Successful import from file %s@]" filename
type t = status Time.System.stamped
module Definition = struct
let name = "snapshot"
type nonrec t = t
let encoding =
let open Data_encoding in
Time.System.stamped_encoding
@@ union
[ case
(Tag 0)
~title:"Export_unspecified_hash"
Block_hash.encoding
(function Export_unspecified_hash h -> Some h | _ -> None)
(fun h -> Export_unspecified_hash h);
case
(Tag 1)
~title:"Export_info"
(obj3
(req "history_mode" History_mode.encoding)
(req "block_hash" Block_hash.encoding)
(req "level" int32))
(function Export_info (hm, h, l) -> Some (hm, h, l) | _ -> None)
(fun (hm, h, l) -> Export_info (hm, h, l));
case
(Tag 2)
~title:"Export_success"
string
(function Export_success s -> Some s | _ -> None)
(fun s -> Export_success s);
case
(Tag 3)
~title:"Set_history_mode"
History_mode.encoding
(function Set_history_mode hm -> Some hm | _ -> None)
(fun hm -> Set_history_mode hm);
case
(Tag 4)
~title:"Import_info"
string
(function Import_info s -> Some s | _ -> None)
(fun s -> Import_info s);
case
(Tag 5)
~title:"Import_unspecified_hash"
empty
(function Import_unspecified_hash -> Some () | _ -> None)
(fun () -> Import_unspecified_hash);
case
(Tag 6)
~title:"Import_loading"
empty
(function Import_loading -> Some () | _ -> None)
(fun () -> Import_loading);
case
(Tag 7)
~title:"Set_head"
Block_hash.encoding
(function Set_head h -> Some h | _ -> None)
(fun h -> Set_head h);
case
(Tag 8)
~title:"Import_success"
string
(function Import_success s -> Some s | _ -> None)
(fun s -> Import_success s) ]
let pp ppf (status : t) = Format.fprintf ppf "%a" status_pp status.data
let doc = "Snapshots status."
let level (status : t) =
match status.data with
| Export_unspecified_hash _
| Export_info _
| Export_success _
| Set_history_mode _
| Import_info _
| Import_unspecified_hash
| Import_loading
| Set_head _
| Import_success _ ->
Internal_event.Notice
end
module Event_snapshot = Internal_event.Make (Definition)
let lwt_emit (status : status) =
let time = Systime_os.now () in
Event_snapshot.emit
~section:(Internal_event.Section.make_sanitized [Definition.name])
(fun () -> Time.System.stamp ~time status)
>>= function
| Ok () ->
Lwt.return_unit
| Error el ->
Format.kasprintf
Lwt.fail_with
"Snapshot_event.emit: %a"
pp_print_error
el
type error += Wrong_snapshot_export of History_mode.t * History_mode.t
type error +=
| Wrong_block_export of
Block_hash.t * [`Pruned | `Too_few_predecessors | `Cannot_be_found]
type error += Inconsistent_imported_block of Block_hash.t * Block_hash.t
type error += Snapshot_import_failure of string
type error += Wrong_protocol_hash of Protocol_hash.t
type error +=
| Inconsistent_operation_hashes of
(Operation_list_list_hash.t * Operation_list_list_hash.t)
let () =
let open Data_encoding in
register_error_kind
`Permanent
~id:"WrongSnapshotExport"
~title:"Wrong snapshot export"
~description:
"Snapshot exports is not compatible with the current configuration."
~pp:(fun ppf (src, dst) ->
Format.fprintf
ppf
"Cannot export a %a snapshot from a %a node."
History_mode.pp
dst
History_mode.pp
src)
(obj2 (req "src" History_mode.encoding) (req "dst" History_mode.encoding))
(function
| Wrong_snapshot_export (src, dst) -> Some (src, dst) | _ -> None)
(fun (src, dst) -> Wrong_snapshot_export (src, dst)) ;
let pp_wrong_block_export_error ppf kind =
let str =
match kind with
| `Pruned ->
"is pruned"
| `Too_few_predecessors ->
"has not enough predecessors"
| `Cannot_be_found ->
"cannot be found"
in
Format.fprintf ppf "%s" str
in
let error_kind_encoding =
string_enum
[ ("pruned", `Pruned);
("too_few_predecessors", `Too_few_predecessors);
("cannot_be_found", `Cannot_be_found) ]
in
register_error_kind
`Permanent
~id:"WrongBlockExport"
~title:"Wrong block export"
~description:"The block to export in the snapshot is not valid."
~pp:(fun ppf (bh, kind) ->
Format.fprintf
ppf
"Fails to export snapshot as the block with block hash %a %a."
Block_hash.pp
bh
pp_wrong_block_export_error
kind)
(obj2
(req "block_hash" Block_hash.encoding)
(req "kind" error_kind_encoding))
(function Wrong_block_export (bh, kind) -> Some (bh, kind) | _ -> None)
(fun (bh, kind) -> Wrong_block_export (bh, kind)) ;
register_error_kind
`Permanent
~id:"InconsistentImportedBlock"
~title:"Inconsistent imported block"
~description:"The imported block is not the expected one."
~pp:(fun ppf (got, exp) ->
Format.fprintf
ppf
"The block contained in the file is %a instead of %a."
Block_hash.pp
got
Block_hash.pp
exp)
(obj2
(req "block_hash" Block_hash.encoding)
(req "block_hash_expected" Block_hash.encoding))
(function
| Inconsistent_imported_block (got, exp) -> Some (got, exp) | _ -> None)
(fun (got, exp) -> Inconsistent_imported_block (got, exp)) ;
register_error_kind
`Permanent
~id:"SnapshotImportFailure"
~title:"Snapshot import failure"
~description:"The imported snapshot is malformed."
~pp:(fun ppf msg ->
Format.fprintf
ppf
"The data contained in the snapshot is not valid. The import \
mechanism failed to validate the file: %s."
msg)
(obj1 (req "message" string))
(function Snapshot_import_failure str -> Some str | _ -> None)
(fun str -> Snapshot_import_failure str) ;
register_error_kind
`Permanent
~id:"WrongProtocolHash"
~title:"Wrong protocol hash"
~description:"Wrong protocol hash"
~pp:(fun ppf p ->
Format.fprintf
ppf
"Wrong protocol hash (%a) found in snapshot. Snapshot is corrupted."
Protocol_hash.pp
p)
(obj1 (req "protocol_hash" Protocol_hash.encoding))
(function Wrong_protocol_hash p -> Some p | _ -> None)
(fun p -> Wrong_protocol_hash p) ;
register_error_kind
`Permanent
~id:"InconsistentOperationHashes"
~title:"Inconsistent operation hashes"
~description:"The operations given do not match their hashes."
~pp:(fun ppf (oph, oph') ->
Format.fprintf
ppf
"Inconsistent operation hashes. Expected: %a, got: %a."
Operation_list_list_hash.pp
oph
Operation_list_list_hash.pp
oph')
(obj2
(req "expected_operation_hashes" Operation_list_list_hash.encoding)
(req "received_operation_hashes" Operation_list_list_hash.encoding))
(function
| Inconsistent_operation_hashes (oph, oph') ->
Some (oph, oph')
| _ ->
None)
(fun (oph, oph') -> Inconsistent_operation_hashes (oph, oph'))
let ( // ) = Filename.concat
let context_dir data_dir = data_dir // "context"
let store_dir data_dir = data_dir // "store"
let compute_export_limit block_store chain_data_store block_header
export_rolling =
let block_hash = Block_header.hash block_header in
Store.Block.Contents.read_opt (block_store, block_hash)
>>= (function
| Some contents ->
return contents
| None ->
fail (Wrong_block_export (block_hash, `Pruned)))
>>=? fun {max_operations_ttl; _} ->
if not export_rolling then
Store.Chain_data.Caboose.read chain_data_store
>>=? fun (caboose_level, _) -> return (max 1l caboose_level)
else
let limit =
Int32.(
sub block_header.Block_header.shell.level (of_int max_operations_ttl))
in
(* fails when the limit exceeds the genesis or the genesis is
included in the export limit *)
fail_when
(limit <= 0l)
(Wrong_block_export (block_hash, `Too_few_predecessors))
>>=? fun () -> return limit
(** When called with a block, returns its predecessor if it exists and
its protocol_data if the block is a transition block (i.e. protocol
level changing block) or when there is no more predecessor. *)
let pruned_block_iterator index block_store limit header =
if header.Block_header.shell.level <= limit then
Context.get_protocol_data_from_header index header
>>= fun protocol_data -> return (None, Some protocol_data)
else
let pred_hash = header.Block_header.shell.predecessor in
State.Block.Header.read (block_store, pred_hash)
>>=? fun pred_header ->
Store.Block.Operations.bindings (block_store, pred_hash)
>>= fun pred_operations ->
Store.Block.Operation_hashes.bindings (block_store, pred_hash)
>>= fun pred_operation_hashes ->
let pruned_block =
{
Context.Pruned_block.block_header = pred_header;
operations = pred_operations;
operation_hashes = pred_operation_hashes;
}
in
let header_proto_level = header.Block_header.shell.proto_level in
let pred_header_proto_level = pred_header.Block_header.shell.proto_level in
if header_proto_level <> pred_header_proto_level then
Context.get_protocol_data_from_header index header
>>= fun proto_data -> return (Some pruned_block, Some proto_data)
else return (Some pruned_block, None)
let export ?(export_rolling = false) ~context_index ~store ~genesis filename
block =
let chain_id = Chain_id.of_block_hash genesis in
let chain_store = Store.Chain.get store chain_id in
let chain_data_store = Store.Chain_data.get chain_store in
let block_store = Store.Block.get chain_store in
Store.Configuration.History_mode.read_opt store
>>= (function
| Some (Archive | Full) | None ->
return_unit
| Some (Rolling as history_mode) ->
if export_rolling then return_unit
else fail (Wrong_snapshot_export (history_mode, History_mode.Full)))
>>=? fun () ->
( match block with
| Some block_hash ->
Lwt.return (Block_hash.of_b58check block_hash)
| None ->
Store.Chain_data.Checkpoint.read_opt chain_data_store
>|= Option.unopt_assert ~loc:__POS__
>>= fun last_checkpoint ->
if last_checkpoint.shell.level = 0l then
fail (Wrong_block_export (genesis, `Too_few_predecessors))
else
let last_checkpoint_hash = Block_header.hash last_checkpoint in
lwt_emit (Export_unspecified_hash last_checkpoint_hash)
>>= fun () -> return last_checkpoint_hash )
>>=? fun checkpoint_block_hash ->
State.Block.Header.read_opt (block_store, checkpoint_block_hash)
>>= (function
| None ->
fail (Wrong_block_export (checkpoint_block_hash, `Cannot_be_found))
| Some block_header ->
let export_mode =
if export_rolling then History_mode.Rolling else Full
in
lwt_emit
(Export_info
(export_mode, checkpoint_block_hash, block_header.shell.level))
>>= fun () ->
(* Get block precessor's block header *)
Store.Block.Predecessors.read
(block_store, checkpoint_block_hash)
0
>>=? fun pred_block_hash ->
State.Block.Header.read (block_store, pred_block_hash)
>>=? fun pred_block_header ->
(* Get operation list *)
let validations_passes = block_header.shell.validation_passes in
map_s
(fun i ->
Store.Block.Operations.read
(block_store, checkpoint_block_hash)
i)
(0 -- (validations_passes - 1))
>>=? fun operations ->
compute_export_limit
block_store
chain_data_store
block_header
export_rolling
>>=? fun export_limit ->
let iterator =
pruned_block_iterator context_index block_store export_limit
in
let block_data = {Context.Block_data.block_header; operations} in
return (pred_block_header, block_data, export_mode, iterator))
>>=? fun data_to_dump ->
Context.dump_contexts context_index data_to_dump ~filename
>>=? fun () -> lwt_emit (Export_success filename) >>= fun () -> return_unit
let check_operations_consistency block_header operations operation_hashes =
(* Compute operations hashes and compare *)
List.iter2
(fun (_, op) (_, oph) ->
let expected_op_hash = List.map Operation.hash op in
List.iter2
(fun expected found ->
assert (Operation_hash.equal expected found) (* paul:here *))
expected_op_hash
oph)
operations
operation_hashes ;
(* Check header hashes based on merkel tree *)
let hashes =
List.map
(fun (_, opl) -> List.map Operation.hash opl)
(List.rev operations)
in
let computed_hash =
Operation_list_list_hash.compute
(List.map Operation_list_hash.compute hashes)
in
let are_oph_equal =
Operation_list_list_hash.equal
computed_hash
block_header.Block_header.shell.operations_hash
in
fail_unless
are_oph_equal
(Inconsistent_operation_hashes
(computed_hash, block_header.Block_header.shell.operations_hash))
let compute_predecessors ~genesis_hash oldest_level block_hashes i =
let rec step s d acc =
if oldest_level = 1l && i - d = -1 then List.rev ((s, genesis_hash) :: acc)
else if i - d < 0 then List.rev acc
else step (s + 1) (d * 2) ((s, block_hashes.(i - d)) :: acc)
in
step 0 1 []
let check_context_hash_consistency block_validation_result block_header =
fail_unless
(Context_hash.equal
block_validation_result.Tezos_validation.Block_validation.context_hash
block_header.Block_header.shell.context)
(Snapshot_import_failure "resulting context hash does not match")
let set_history_mode store history_mode =
match history_mode with
| History_mode.Full | History_mode.Rolling ->
lwt_emit (Set_history_mode history_mode)
>>= fun () ->
Store.Configuration.History_mode.store store history_mode
>>= fun () -> return_unit
| History_mode.Archive ->
fail (Snapshot_import_failure "cannot import an archive context")
let store_new_head chain_state chain_data ~genesis block_header operations
block_validation_result =
let ({validation_store; block_metadata; ops_metadata; forking_testchain}
: Tezos_validation.Block_validation.result) =
block_validation_result
in
State.Block.store
chain_state
block_header
block_metadata
operations
ops_metadata
~forking_testchain
validation_store
>>=? fun new_head ->
match new_head with
| None ->
(* Should not happen as the data-dir must be empty *)
fail
(Snapshot_import_failure "a chain head is already present in the store")
| Some new_head ->
(* New head is set*)
Store.Chain_data.Known_heads.remove chain_data genesis
>>= fun () ->
Store.Chain_data.Known_heads.store chain_data (State.Block.hash new_head)
>>= fun () ->
Store.Chain_data.Current_head.store
chain_data
(State.Block.hash new_head)
>>= fun () -> return_unit
let update_checkpoint chain_state checkpoint_header =
let block_hash = Block_header.hash checkpoint_header in
(* Imported block is set as the current checkpoint/save_point ⦠*)
let new_checkpoint =
(checkpoint_header.Block_header.shell.level, block_hash)
in
State.Chain.set_checkpoint chain_state checkpoint_header
>>= fun () -> Lwt.return new_checkpoint
let update_savepoint chain_state new_savepoint =
State.update_chain_data chain_state (fun store data ->
let new_data = {data with save_point = new_savepoint} in
Store.Chain_data.Save_point.store store new_savepoint
>>= fun () -> Lwt.return (Some new_data, ()))
let update_caboose chain_data ~genesis block_header oldest_header max_op_ttl =
let oldest_level = oldest_header.Block_header.shell.level in
let caboose_level = if oldest_level = 1l then 0l else oldest_level in
let caboose_hash =
if oldest_level = 1l then genesis else Block_header.hash oldest_header
in
let minimal_caboose_level =
Int32.(sub block_header.Block_header.shell.level (of_int max_op_ttl))
in
fail_unless
Compare.Int32.(caboose_level <= minimal_caboose_level)
(Snapshot_import_failure
(Format.sprintf "caboose level (%ld) is not valid" caboose_level))
>>=? fun () ->
Store.Chain_data.Caboose.store chain_data (caboose_level, caboose_hash)
>>= fun () -> return_unit
let import_protocol_data index store block_hash_arr level_oldest_block
(level, protocol_data) =
(* Retrieve the original context hash of the block. *)
let delta = Int32.(to_int (sub level level_oldest_block)) in
let pruned_block_hash = block_hash_arr.(delta) in
let block_store = Store.Block.get store in
State.Block.Header.read_opt (block_store, pruned_block_hash)
>>= (function
| None -> assert false | Some block_header -> Lwt.return block_header)
>>= fun block_header ->
let expected_context_hash = block_header.Block_header.shell.context in
(* Retrieve the input info. *)
let info = protocol_data.Context.Protocol_data.info in
let test_chain = protocol_data.test_chain_status in
let data_hash = protocol_data.data_key in
let parents = protocol_data.parents in
let protocol_hash = protocol_data.protocol_hash in
(* Validate the context hash consistency, and so the protocol data. *)
Context.validate_context_hash_consistency_and_commit
~author:info.author
~timestamp:info.timestamp
~message:info.message
~data_hash
~parents
~expected_context_hash
~test_chain
~protocol_hash
~index
>>= function
| true ->
let protocol_level = block_header.shell.proto_level in
let block_level = block_header.shell.level in
Store.Chain.Protocol_info.store
store
protocol_level
(protocol_hash, block_level)
>>= fun () -> return_unit
| false ->
fail (Wrong_protocol_hash protocol_hash)
let import_protocol_data_list index store block_hash_arr level_oldest_block
protocol_data =
let rec aux = function
| [] ->
return_unit
| (level, protocol_data) :: xs ->
import_protocol_data
index
store
block_hash_arr
level_oldest_block
(level, protocol_data)
>>=? fun () -> aux xs
in
aux protocol_data
let verify_predecessors header_opt pred_hash =
match header_opt with
| None ->
return_unit
| Some header ->
fail_unless
( header.Block_header.shell.level >= 2l
&& Block_hash.equal header.shell.predecessor pred_hash )
(Snapshot_import_failure "inconsistent predecessors")
let verify_oldest_header oldest_header genesis_hash =
let oldest_level = oldest_header.Block_header.shell.level in
fail_unless
( oldest_level >= 1l
|| Compare.Int32.(oldest_level = 1l)
&& Block_hash.equal
oldest_header.Block_header.shell.predecessor
genesis_hash )
(Snapshot_import_failure "inconsistent oldest level")
let block_validation succ_header_opt header_hash
{Context.Pruned_block.block_header; operations; operation_hashes} =
verify_predecessors succ_header_opt header_hash
>>=? fun () ->
check_operations_consistency block_header operations operation_hashes
>>=? fun () -> return_unit
let import ~data_dir ~dir_cleaner ~patch_context ~genesis filename block =
lwt_emit (Import_info filename)
>>= fun () ->
( match block with
| None ->
lwt_emit Import_unspecified_hash
| Some _ ->
Lwt.return_unit )
>>= fun () ->
lwt_emit Import_loading
>>= fun () ->
let context_root = context_dir data_dir in
let store_root = store_dir data_dir in
let chain_id = Chain_id.of_block_hash genesis.State.Chain.block in
(* FIXME: use config value ? *)
State.init
~context_root
~store_root
genesis
~patch_context:(patch_context None)
>>=? fun (state, chain_state, context_index, _history_mode) ->
Store.init store_root
>>=? fun store ->
let chain_store = Store.Chain.get store chain_id in
let chain_data = Store.Chain_data.get chain_store in
let block_store = Store.Block.get chain_store in
let open Context in
Lwt.try_bind
(fun () ->
let k_store_pruned_blocks data =
Store.with_atomic_rw store (fun () ->
Error_monad.iter_s
(fun (pruned_header_hash, pruned_block) ->
Store.Block.Pruned_contents.store
(block_store, pruned_header_hash)
{header = pruned_block.Context.Pruned_block.block_header}
>>= fun () ->
Lwt_list.iter_s
(fun (i, v) ->
Store.Block.Operations.store
(block_store, pruned_header_hash)
i
v)
pruned_block.operations
>>= fun () ->
Lwt_list.iter_s
(fun (i, v) ->
Store.Block.Operation_hashes.store
(block_store, pruned_header_hash)
i
v)
pruned_block.operation_hashes
>>= fun () -> return_unit)
data)
in
(* Restore context and fetch data *)
restore_contexts
context_index
~filename
k_store_pruned_blocks
block_validation
>>=? fun ( predecessor_block_header,
meta,
history_mode,
oldest_header_opt,
rev_block_hashes,
protocol_data ) ->
let oldest_header = Option.unopt_assert ~loc:__POS__ oldest_header_opt in
let block_hashes_arr = Array.of_list rev_block_hashes in
let write_predecessors_table to_write =
Store.with_atomic_rw store (fun () ->
Lwt_list.iter_s
(fun (current_hash, predecessors_list) ->
Lwt_list.iter_s
(fun (l, h) ->
Store.Block.Predecessors.store
(block_store, current_hash)
l
h)
predecessors_list
>>= fun () ->
match predecessors_list with
| (0, pred_hash) :: _ ->
Store.Chain_data.In_main_branch.store
(chain_data, pred_hash)
current_hash
| [] ->
Lwt.return_unit
| _ :: _ ->
assert false)
to_write)
in
Lwt_list.fold_left_s
(fun (cpt, to_write) current_hash ->
Tezos_stdlib_unix.Utils.display_progress
~refresh_rate:(cpt, 1_000)
"Computing predecessors table %dK elements%!"
(cpt / 1_000) ;
( if (cpt + 1) mod 5_000 = 0 then
write_predecessors_table to_write >>= fun () -> Lwt.return_nil
else Lwt.return to_write )
>>= fun to_write ->
let predecessors_list =
compute_predecessors
~genesis_hash:genesis.block
oldest_header.shell.level
block_hashes_arr
cpt
in
Lwt.return (cpt + 1, (current_hash, predecessors_list) :: to_write))
(0, [])
rev_block_hashes
>>= fun (_, to_write) ->
write_predecessors_table to_write
>>= fun () ->
Tezos_stdlib_unix.Utils.display_progress_end () ;
(* Process data imported from snapshot *)
let {Block_data.block_header; operations} = meta in
let block_hash = Block_header.hash block_header in
(* Checks that the block hash imported by the snapshot is the expected one *)
( match block with
| Some str ->
let bh = Block_hash.of_b58check_exn str in
fail_unless
(Block_hash.equal bh block_hash)
(Inconsistent_imported_block (bh, block_hash))
| None ->
return_unit )
>>=? fun () ->
lwt_emit (Set_head (Block_header.hash block_header))
>>= fun () ->
let pred_context_hash = predecessor_block_header.shell.context in
checkout_exn context_index pred_context_hash
>>= fun predecessor_context ->
(* ... we can now call apply ... *)
Tezos_validation.Block_validation.apply
chain_id
~max_operations_ttl:(Int32.to_int predecessor_block_header.shell.level)
~predecessor_block_header
~predecessor_context
~block_header
operations
>>=? fun block_validation_result ->
check_context_hash_consistency
block_validation_result.validation_store
block_header
>>=? fun () ->
verify_oldest_header oldest_header genesis.block
>>=? fun () ->
(* ... we set the history mode regarding the snapshot version hint ... *)
set_history_mode store history_mode
>>=? fun () ->
(* ... and we import protocol data...*)
import_protocol_data_list
context_index
chain_store
block_hashes_arr
oldest_header.Block_header.shell.level
protocol_data
>>=? fun () ->
(* Everything is ok. We can store the new head *)
store_new_head
chain_state
chain_data
~genesis:genesis.block
block_header
operations
block_validation_result
>>=? fun () ->
(* Update history mode flags *)
update_checkpoint chain_state block_header
>>= fun new_checkpoint ->
update_savepoint chain_state new_checkpoint
>>= fun () ->
update_caboose
chain_data
~genesis:genesis.block
block_header
oldest_header
block_validation_result.validation_store.max_operations_ttl
>>=? fun () ->
Store.close store ;
State.close state >>= fun () -> return_unit)
(function
| Ok () ->
lwt_emit (Import_success filename) >>= fun () -> return_unit
| Error errors ->
dir_cleaner data_dir >>= fun () -> Lwt.return (Error errors))
(fun exn -> dir_cleaner data_dir >>= fun () -> Lwt.fail exn)
src/lib_shell/snapshots.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive status : Type :=
| Export_unspecified_hash : Tezos_base__TzPervasives.Block_hash.t -> status
| Export_info : Tezos_shell_services.History_mode.t ->
Tezos_base__TzPervasives.Block_hash.t -> Stdlib.Int32.t -> status
| Export_success : string -> status
| Set_history_mode : Tezos_shell_services.History_mode.t -> status
| Import_info : string -> status
| Import_unspecified_hash : status
| Import_loading : status
| Set_head : Tezos_base__TzPervasives.Block_hash.t -> status
| Import_success : string -> status.
Definition status_pp
(ppf : Stdlib.Format.formatter) (function_parameter : status) : unit :=
match function_parameter with
| Export_unspecified_hash h =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"There is no block hash specified with the `--block` option. Using " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (last checkpoint)" % string
CamlinternalFormatBasics.End_of_format)))
"There is no block hash specified with the `--block` option. Using %a (last checkpoint)"
% string) Block_hash.pp h
| Export_info hm h l =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Exporting a snapshot in " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" mode, targeting block hash " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " at level " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))))
"Exporting a snapshot in %a mode, targeting block hash %a at level %a" %
string) History_mode.pp hm Block_hash.pp h Format.pp_print_int
(Int32.to_int l)
| Export_success filename =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Successful export: " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))
"@[Successful export: %s@]" % string) filename
| Set_history_mode hm =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Setting history-mode to " % string
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
"Setting history-mode to %a" % string) History_mode.pp hm
| Import_info filename =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Importing data from snapshot file " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Importing data from snapshot file %s" % string) filename
| Import_unspecified_hash =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"You may consider using the --block <block_hash> argument to verify that the block imported is the one you expect"
% string CamlinternalFormatBasics.End_of_format)
"You may consider using the --block <block_hash> argument to verify that the block imported is the one you expect"
% string)
| Import_loading =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Retrieving and validating data. This can take a while, please bear with us"
% string CamlinternalFormatBasics.End_of_format)
"Retrieving and validating data. This can take a while, please bear with us"
% string)
| Set_head h =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Setting current head to block " % string
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
"Setting current head to block %a" % string) Block_hash.pp h
| Import_success filename =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Successful import from file " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))
"@[Successful import from file %s@]" % string) filename
end.
Definition t := Tezos_base__TzPervasives.Time.System.stamped status.
Module Definition.
Definition name : string := "snapshot" % string.
Definition t := t.
Definition encoding
: Tezos_data_encoding.Data_encoding.t
(Tezos_base__TzPervasives.Time.System.stamped status) :=
apply Time.System.stamped_encoding
(union None
(cons
(case "Export_unspecified_hash" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0) Block_hash.encoding
(fun function_parameter =>
match function_parameter with
| Export_unspecified_hash h => Some h
| _ => None
end) (fun h => Export_unspecified_hash h))
(cons
(case "Export_info" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj3
(req None None "history_mode" % string History_mode.encoding)
(req None None "block_hash" % string Block_hash.encoding)
(req None None "level" % string int32))
(fun function_parameter =>
match function_parameter with
| Export_info hm h l => Some (hm, h, l)
| _ => None
end)
(fun function_parameter =>
let '(hm, h, l) := function_parameter in
Export_info hm h l))
(cons
(case "Export_success" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 2) string
(fun function_parameter =>
match function_parameter with
| Export_success s => Some s
| _ => None
end) (fun s => Export_success s))
(cons
(case "Set_history_mode" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 3)
History_mode.encoding
(fun function_parameter =>
match function_parameter with
| Set_history_mode hm => Some hm
| _ => None
end) (fun hm => Set_history_mode hm))
(cons
(case "Import_info" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 4) string
(fun function_parameter =>
match function_parameter with
| Import_info s => Some s
| _ => None
end) (fun s => Import_info s))
(cons
(case "Import_unspecified_hash" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 5) empty
(fun function_parameter =>
match function_parameter with
| Import_unspecified_hash => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Import_unspecified_hash))
(cons
(case "Import_loading" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 6) empty
(fun function_parameter =>
match function_parameter with
| Import_loading => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Import_loading))
(cons
(case "Set_head" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 7)
Block_hash.encoding
(fun function_parameter =>
match function_parameter with
| Set_head h => Some h
| _ => None
end) (fun h => Set_head h))
(cons
(case "Import_success" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 8)
string
(fun function_parameter =>
match function_parameter with
| Import_success s => Some s
| _ => None
end) (fun s => Import_success s)) [])))))))))).
Definition pp (ppf : Stdlib.Format.formatter) (status : t) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) status_pp (data status).
Definition doc : string := "Snapshots status." % string.
Definition level (status : t)
: Tezos_base__TzPervasives.Internal_event.level :=
let
'Export_unspecified_hash _ | Export_info _ _ _ | Export_success _ |
Set_history_mode _ | Import_info _ | Import_unspecified_hash |
Import_loading | Set_head _ | Import_success _ := data status in
Tezos_base__TzPervasives.Internal_event.Notice.
End Definition.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition lwt_emit (status : status) : Lwt.t unit :=
let time := Systime_os.now tt in
op_gtgteq
(Event_snapshot.emit
(Some
(Internal_event.Section.make_sanitized
(cons
Definition.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.name)
[])))
(fun function_parameter =>
let 'tt := function_parameter in
Time.System.stamp time status))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error el =>
Format.kasprintf Lwt.fail_with
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Snapshot_event.emit: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Snapshot_event.emit: %a" % string) pp_print_error el
end).
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition context_dir (data_dir : string) : string :=
op_divdiv data_dir "context" % string.
Definition store_dir (data_dir : string) : string :=
op_divdiv data_dir "store" % string.
Definition compute_export_limit
(block_store : Tezos_shell__Store.Block.store)
(chain_data_store : Tezos_shell__Store.Chain_data.store)
(block_header : Tezos_base__TzPervasives.Block_header.t)
(export_rolling : bool)
: Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Int32.t) :=
let block_hash := Block_header.hash block_header in
op_gtgteqquestion
(op_gtgteq (Store.Block.Contents.read_opt (block_store, block_hash))
(fun function_parameter =>
match function_parameter with
| Some contents => _return contents
| None =>
fail
(Tezos_base__TzPervasives.Wrong_block_export block_hash
(* ❌ Variants not supported *)
variant)
end))
(fun function_parameter =>
let '{| max_operations_ttl := max_operations_ttl |} := function_parameter
in
if negb export_rolling then
op_gtgteqquestion (Store.Chain_data.Caboose.read chain_data_store)
(fun function_parameter =>
let '(caboose_level, _) := function_parameter in
_return
(OCaml.Stdlib.max
(* ❌ Constant of type int32 is converted to int *)
1 caboose_level))
else
let limit :=
sub (level (Block_header.shell block_header))
(of_int max_operations_ttl) in
op_gtgteqquestion
(fail_when
(OCaml.Stdlib.le limit
(* ❌ Constant of type int32 is converted to int *)
0)
(Tezos_base__TzPervasives.Wrong_block_export block_hash
(* ❌ Variants not supported *)
variant))
(fun function_parameter =>
let 'tt := function_parameter in
_return limit)).
Definition pruned_block_iterator
(index : Tezos_storage.Context.index)
(block_store : Tezos_shell.Store.Block.store) (limit : Stdlib.Int32.t)
(header : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
((option Tezos_storage.Context.Pruned_block.t) *
(option Tezos_storage.Context.Protocol_data.t))) :=
if OCaml.Stdlib.le (level (Block_header.shell header)) limit then
op_gtgteq (Context.get_protocol_data_from_header index header)
(fun protocol_data => _return (None, (Some protocol_data)))
else
let pred_hash := predecessor (Block_header.shell header) in
op_gtgteqquestion (State.Block.Header.read (block_store, pred_hash))
(fun pred_header =>
op_gtgteq (Store.Block.Operations.bindings (block_store, pred_hash))
(fun pred_operations =>
op_gtgteq
(Store.Block.Operation_hashes.bindings (block_store, pred_hash))
(fun pred_operation_hashes =>
let pruned_block :=
{| Context.Pruned_block.block_header := pred_header;
Context.Pruned_block.operations := pred_operations;
Context.Pruned_block.operation_hashes :=
pred_operation_hashes |} in
let header_proto_level :=
proto_level (Block_header.shell header) in
let pred_header_proto_level :=
proto_level (Block_header.shell pred_header) in
if nequiv_decb header_proto_level pred_header_proto_level then
op_gtgteq (Context.get_protocol_data_from_header index header)
(fun proto_data =>
_return ((Some pruned_block), (Some proto_data)))
else
_return ((Some pruned_block), None)))).
Definition export (op_staroptstar : option bool)
: Tezos_storage.Context.index ->
Tezos_shell__Store.global_store ->
Tezos_crypto.Block_hash.t ->
string ->
(option string) -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let export_rolling :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun context_index =>
fun store =>
fun genesis =>
fun filename =>
fun block =>
let chain_id := Chain_id.of_block_hash genesis in
let chain_store := Store.Chain.get store chain_id in
let chain_data_store := Store.Chain_data.get chain_store in
let block_store := Store.Block.get chain_store in
op_gtgteqquestion
(op_gtgteq (Store.Configuration.History_mode.read_opt store)
(fun function_parameter =>
match function_parameter with
|
Some
(Tezos_shell_services.History_mode.Archive |
Tezos_shell_services.History_mode.Full) | None =>
return_unit
|
Some
(Tezos_shell_services.History_mode.Rolling as history_mode)
=>
if export_rolling then
return_unit
else
fail
(Tezos_base__TzPervasives.Wrong_snapshot_export
history_mode Tezos_shell_services.History_mode.Full)
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
match block with
| Some block_hash =>
Lwt._return (Block_hash.of_b58check block_hash)
| None =>
op_gtgteq
(op_gtpipeeq
(Store.Chain_data.Checkpoint.read_opt chain_data_store)
(Option.unopt_assert Stdlib.__POS__))
(fun last_checkpoint =>
if
equiv_decb (level (shell last_checkpoint))
(* ❌ Constant of type int32 is converted to int *)
0 then
fail
(Tezos_base__TzPervasives.Wrong_block_export genesis
(* ❌ Variants not supported *)
variant)
else
let last_checkpoint_hash :=
Block_header.hash last_checkpoint in
op_gtgteq
(lwt_emit
(Export_unspecified_hash last_checkpoint_hash))
(fun function_parameter =>
let 'tt := function_parameter in
_return last_checkpoint_hash))
end
(fun checkpoint_block_hash =>
op_gtgteqquestion
(op_gtgteq
(State.Block.Header.read_opt
(block_store, checkpoint_block_hash))
(fun function_parameter =>
match function_parameter with
| None =>
fail
(Tezos_base__TzPervasives.Wrong_block_export
checkpoint_block_hash
(* ❌ Variants not supported *)
variant)
| Some block_header =>
let export_mode :=
if export_rolling then
Tezos_shell_services.History_mode.Rolling
else
Tezos_shell_services.History_mode.Full in
op_gtgteq
(lwt_emit
(Export_info export_mode checkpoint_block_hash
(level (shell block_header))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Store.Block.Predecessors.read
(block_store, checkpoint_block_hash) 0)
(fun pred_block_hash =>
op_gtgteqquestion
(State.Block.Header.read
(block_store, pred_block_hash))
(fun pred_block_header =>
let validations_passes :=
validation_passes (shell block_header)
in
op_gtgteqquestion
(map_s
(fun i =>
Store.Block.Operations.read
(block_store,
checkpoint_block_hash) i)
(op_minusminus 0
(Z.sub validations_passes 1)))
(fun operations =>
op_gtgteqquestion
(compute_export_limit block_store
chain_data_store block_header
export_rolling)
(fun export_limit =>
let iterator :=
pruned_block_iterator
context_index block_store
export_limit in
let block_data :=
{|
Context.Block_data.block_header :=
block_header;
Context.Block_data.operations :=
operations |} in
_return
(pred_block_header,
block_data, export_mode,
iterator))))))
end))
(fun data_to_dump =>
op_gtgteqquestion
(Context.dump_contexts context_index data_to_dump
filename)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (lwt_emit (Export_success filename))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))).
Definition check_operations_consistency {A B : Type}
(block_header : Tezos_base__TzPervasives.Block_header.t)
(operations : list (A * (list Tezos_base__TzPervasives.Operation.t)))
(operation_hashes :
list (B * (list Tezos_base__TzPervasives.Operation_hash.t)))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter2
(fun function_parameter =>
let '(_, op) := function_parameter in
fun function_parameter =>
let '(_, oph) := function_parameter in
let expected_op_hash := List.map Operation.hash op in
List.iter2
(fun expected =>
fun found =>
(* ❌ Assert instruction is not handled. *)
assert (Operation_hash.equal expected found)) expected_op_hash
oph) operations operation_hashes in
let hashes :=
List.map
(fun function_parameter =>
let '(_, opl) := function_parameter in
List.map Operation.hash opl) (List.rev operations) in
let computed_hash :=
Operation_list_list_hash.compute
(List.map Operation_list_hash.compute hashes) in
let are_oph_equal :=
Operation_list_list_hash.equal computed_hash
(operations_hash (Block_header.shell block_header)) in
fail_unless are_oph_equal
(Tezos_base__TzPervasives.Inconsistent_operation_hashes
(computed_hash, (operations_hash (Block_header.shell block_header)))).
Definition compute_predecessors {A : Type}
(genesis_hash : A) (oldest_level : int32) (block_hashes : array A) (i : Z)
: list (Z * A) :=
let fix step (s : Z) (d : Z) (acc : list (Z * A)) : list (Z * A) :=
if
andb
(equiv_decb oldest_level
(* ❌ Constant of type int32 is converted to int *)
1) (equiv_decb (Z.sub i d) (-1)) then
List.rev (cons (s, genesis_hash) acc)
else
if OCaml.Stdlib.lt (Z.sub i d) 0 then
List.rev acc
else
step (Z.add s 1) (Z.mul d 2)
(cons (s, (Array.get block_hashes (Z.sub i d))) acc) in
step 0 1 [].
Definition check_context_hash_consistency
(block_validation_result : Tezos_validation.Block_validation.validation_store)
(block_header : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
fail_unless
(Context_hash.equal
(Tezos_validation.Block_validation.context_hash block_validation_result)
(context (Block_header.shell block_header)))
(Tezos_base__TzPervasives.Snapshot_import_failure
"resulting context hash does not match" % string).
Definition set_history_mode
(store : Tezos_shell__Store.global_store)
(history_mode : Tezos_shell_services.History_mode.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match history_mode with
|
Tezos_shell_services.History_mode.Full |
Tezos_shell_services.History_mode.Rolling =>
op_gtgteq (lwt_emit (Set_history_mode history_mode))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Store.Configuration.History_mode.store store history_mode)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))
| Tezos_shell_services.History_mode.Archive =>
fail
(Tezos_base__TzPervasives.Snapshot_import_failure
"cannot import an archive context" % string)
end.
Definition store_new_head
(chain_state : Tezos_shell__State.Chain.t)
(chain_data : Tezos_shell__Store.Chain_data.store)
(genesis : Tezos_base__TzPervasives.Block_hash.t)
(block_header : Tezos_base__TzPervasives.Block_header.t)
(operations : list (list Tezos_base__TzPervasives.Operation.t))
(block_validation_result : Tezos_validation.Block_validation.result)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{|
validation_store := validation_store;
block_metadata := block_metadata;
ops_metadata := ops_metadata;
forking_testchain := forking_testchain
|} := block_validation_result in
op_gtgteqquestion
(State.Block.store None chain_state block_header block_metadata operations
ops_metadata validation_store forking_testchain)
(fun new_head =>
match new_head with
| None =>
fail
(Tezos_base__TzPervasives.Snapshot_import_failure
"a chain head is already present in the store" % string)
| Some new_head =>
op_gtgteq (Store.Chain_data.Known_heads.remove chain_data genesis)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Chain_data.Known_heads.store chain_data
(State.Block.hash new_head))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Chain_data.Current_head.store chain_data
(State.Block.hash new_head))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
end).
Definition update_checkpoint
(chain_state : Tezos_shell.State.Chain.chain_state)
(checkpoint_header : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t (Stdlib.Int32.t * Tezos_crypto.Block_hash.t) :=
let block_hash := Block_header.hash checkpoint_header in
let new_checkpoint :=
((level (Block_header.shell checkpoint_header)), block_hash) in
op_gtgteq (State.Chain.set_checkpoint chain_state checkpoint_header)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return new_checkpoint).
Definition update_savepoint
(chain_state : Tezos_shell.State.Chain.t)
(new_savepoint : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t unit :=
State.update_chain_data chain_state
(fun store =>
fun data =>
let new_data :=
(* ❌ Record substitution not handled *)
record_substitution in
op_gtgteq (Store.Chain_data.Save_point.store store new_savepoint)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return ((Some new_data), tt))).
Definition update_caboose
(chain_data : Tezos_shell__Store.Chain_data.store)
(genesis : Tezos_crypto.Block_hash.t)
(block_header : Tezos_base__TzPervasives.Block_header.t)
(oldest_header : Tezos_base__TzPervasives.Block_header.t) (max_op_ttl : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let oldest_level := level (Block_header.shell oldest_header) in
let caboose_level :=
if
equiv_decb oldest_level
(* ❌ Constant of type int32 is converted to int *)
1 then
(* ❌ Constant of type int32 is converted to int *)
0
else
oldest_level in
let caboose_hash :=
if
equiv_decb oldest_level
(* ❌ Constant of type int32 is converted to int *)
1 then
genesis
else
Block_header.hash oldest_header in
let minimal_caboose_level :=
sub (level (Block_header.shell block_header)) (of_int max_op_ttl) in
op_gtgteqquestion
(fail_unless (op_lteq caboose_level minimal_caboose_level)
(Tezos_base__TzPervasives.Snapshot_import_failure
(Format.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "caboose level (" % string
(CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
") is not valid" % string
CamlinternalFormatBasics.End_of_format)))
"caboose level (%ld) is not valid" % string) caboose_level)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Chain_data.Caboose.store chain_data (caboose_level, caboose_hash))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)).
Definition import_protocol_data
(index : Tezos_storage.Context.index) (store : Tezos_shell__Store.Chain.store)
(block_hash_arr : array Tezos_base__TzPervasives.Block_hash.t)
(level_oldest_block : int32)
(function_parameter : int32 * Tezos_storage.Context.Protocol_data.data)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '(level, protocol_data) := function_parameter in
let delta := to_int (sub level level_oldest_block) in
let pruned_block_hash := Array.get block_hash_arr delta in
let block_store := Store.Block.get store in
op_gtgteq
(op_gtgteq (State.Block.Header.read_opt (block_store, pruned_block_hash))
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some block_header => Lwt._return block_header
end))
(fun block_header =>
let expected_context_hash := context (Block_header.shell block_header) in
let info := Context.Protocol_data.info protocol_data in
let test_chain := test_chain_status protocol_data in
let data_hash := data_key protocol_data in
let parents := parents protocol_data in
let protocol_hash := protocol_hash protocol_data in
op_gtgteq
(Context.validate_context_hash_consistency_and_commit data_hash
expected_context_hash (timestamp info) test_chain protocol_hash
(message info) (author info) parents index)
(fun function_parameter =>
match function_parameter with
| true =>
let protocol_level := proto_level (shell block_header) in
let block_level := level (shell block_header) in
op_gtgteq
(Store.Chain.Protocol_info.store store protocol_level
(protocol_hash, block_level))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| false =>
fail (Tezos_base__TzPervasives.Wrong_protocol_hash protocol_hash)
end)).
Definition import_protocol_data_list
(index : Tezos_storage.Context.index) (store : Tezos_shell__Store.Chain.store)
(block_hash_arr : array Tezos_base__TzPervasives.Block_hash.t)
(level_oldest_block : int32)
(protocol_data : list (int32 * Tezos_storage.Context.Protocol_data.data))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let fix aux
(function_parameter :
list (int32 * Tezos_storage.Context.Protocol_data.data))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match function_parameter with
| [] => return_unit
| cons (level, protocol_data) xs =>
op_gtgteqquestion
(import_protocol_data index store block_hash_arr level_oldest_block
(level, protocol_data))
(fun function_parameter =>
let 'tt := function_parameter in
aux xs)
end in
aux protocol_data.
Definition verify_predecessors
(header_opt : option Tezos_base__TzPervasives.Block_header.t)
(pred_hash : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match header_opt with
| None => return_unit
| Some header =>
fail_unless
(andb
(OCaml.Stdlib.ge (level (Block_header.shell header))
(* ❌ Constant of type int32 is converted to int *)
2) (Block_hash.equal (predecessor (shell header)) pred_hash))
(Tezos_base__TzPervasives.Snapshot_import_failure
"inconsistent predecessors" % string)
end.
Definition verify_oldest_header
(oldest_header : Tezos_base__TzPervasives.Block_header.t)
(genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let oldest_level := level (Block_header.shell oldest_header) in
fail_unless
(orb
(OCaml.Stdlib.ge oldest_level
(* ❌ Constant of type int32 is converted to int *)
1)
(andb
(op_eq oldest_level
(* ❌ Constant of type int32 is converted to int *)
1)
(Block_hash.equal (predecessor (Block_header.shell oldest_header))
genesis_hash)))
(Tezos_base__TzPervasives.Snapshot_import_failure
"inconsistent oldest level" % string).
Definition block_validation
(succ_header_opt : option Tezos_base__TzPervasives.Block_header.t)
(header_hash : Tezos_base__TzPervasives.Block_hash.t)
(function_parameter : Tezos_storage.Context.Pruned_block.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{|
Context.Pruned_block.block_header := block_header;
Context.Pruned_block.operations := operations;
Context.Pruned_block.operation_hashes := operation_hashes
|} := function_parameter in
op_gtgteqquestion (verify_predecessors succ_header_opt header_hash)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(check_operations_consistency block_header operations operation_hashes)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)).
Definition import {A : Type}
(data_dir : string) (dir_cleaner : string -> Lwt.t unit)
(patch_context :
(option A) -> Tezos_storage.Context.t -> Lwt.t Tezos_storage.Context.t)
(genesis : Tezos_shell.State.Chain.genesis) (filename : string)
(block : option string) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (lwt_emit (Import_info filename))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
match block with
| None => lwt_emit Import_unspecified_hash
| Some _ => Lwt.return_unit
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (lwt_emit Import_loading)
(fun function_parameter =>
let 'tt := function_parameter in
let context_root := context_dir data_dir in
let store_root := store_dir data_dir in
let chain_id := Chain_id.of_block_hash (State.Chain.block genesis)
in
op_gtgteqquestion
(State.init (Some (patch_context None)) None None None
store_root context_root None genesis)
(fun function_parameter =>
let '(state, chain_state, context_index, _history_mode) :=
function_parameter in
op_gtgteqquestion (Store.init None None store_root)
(fun store =>
let chain_store := Store.Chain.get store chain_id in
let chain_data := Store.Chain_data.get chain_store in
let block_store := Store.Block.get chain_store in
Lwt.try_bind
(fun function_parameter =>
let 'tt := function_parameter in
let k_store_pruned_blocks
(data :
list
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_storage.Context.Pruned_block.t))
: Lwt.t
(Tezos_base__TzPervasives.Error_monad.tzresult
unit) :=
Store.with_atomic_rw store
(fun function_parameter =>
let 'tt := function_parameter in
Error_monad.iter_s
(fun function_parameter =>
let '(pruned_header_hash, pruned_block) :=
function_parameter in
op_gtgteq
(Store.Block.Pruned_contents.store
(block_store, pruned_header_hash)
{|
header :=
Context.Pruned_block.block_header
pruned_block |})
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_list.iter_s
(fun function_parameter =>
let '(i, v) := function_parameter
in
Store.Block.Operations.store
(block_store, pruned_header_hash)
i v) (operations pruned_block))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_list.iter_s
(fun function_parameter =>
let '(i, v) :=
function_parameter in
Store.Block.Operation_hashes.store
(block_store,
pruned_header_hash) i v)
(operation_hashes pruned_block))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))) data) in
op_gtgteqquestion
(restore_contexts context_index filename
k_store_pruned_blocks block_validation)
(fun function_parameter =>
let
'(predecessor_block_header, meta, history_mode,
oldest_header_opt, rev_block_hashes,
protocol_data) := function_parameter in
let oldest_header :=
Option.unopt_assert Stdlib.__POS__
oldest_header_opt in
let block_hashes_arr :=
Array.of_list rev_block_hashes in
let write_predecessors_table
(to_write :
list
(Tezos_base__TzPervasives.Block_hash.t *
(list
(Tezos_shell.Store.Block.Predecessors.key
*
Tezos_shell.Store.Block.Predecessors.value))))
: Lwt.t unit :=
Store.with_atomic_rw store
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_list.iter_s
(fun function_parameter =>
let
'(current_hash, predecessors_list) :=
function_parameter in
op_gtgteq
(Lwt_list.iter_s
(fun function_parameter =>
let '(l, h) := function_parameter
in
Store.Block.Predecessors.store
(block_store, current_hash) l h)
predecessors_list)
(fun function_parameter =>
let 'tt := function_parameter in
match predecessors_list with
| cons (0, pred_hash) _ =>
Store.Chain_data.In_main_branch.store
(chain_data, pred_hash)
current_hash
| [] => Lwt.return_unit
| cons _ _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end)) to_write) in
op_gtgteq
(Lwt_list.fold_left_s
(fun function_parameter =>
let '(cpt, to_write) := function_parameter
in
fun current_hash =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Tezos_stdlib_unix.Utils.display_progress
(Some (cpt, 1000))
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Computing predecessors table " %
string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
"K elements" % string
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))))
"Computing predecessors table %dK elements%!"
% string) (Z.div cpt 1000) in
op_gtgteq
(if
equiv_decb
(Z.modulo (Z.add cpt 1) 5000) 0 then
op_gtgteq
(write_predecessors_table to_write)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_nil)
else
Lwt._return to_write)
(fun to_write =>
let predecessors_list :=
compute_predecessors (block genesis)
(level (shell oldest_header))
block_hashes_arr cpt in
Lwt._return
((Z.add cpt 1),
(cons
(current_hash, predecessors_list)
to_write)))) (0, [])
rev_block_hashes)
(fun function_parameter =>
let '(_, to_write) := function_parameter in
op_gtgteq (write_predecessors_table to_write)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Tezos_stdlib_unix.Utils.display_progress_end
tt in
let '{|
Block_data.block_header := block_header;
Block_data.operations := operations
|} := meta in
let block_hash :=
Block_header.hash block_header in
op_gtgteqquestion
match block with
| Some str =>
let bh :=
Block_hash.of_b58check_exn str in
fail_unless
(Block_hash.equal bh block_hash)
(Tezos_base__TzPervasives.Inconsistent_imported_block
bh block_hash)
| None => return_unit
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_emit
(Set_head
(Block_header.hash block_header)))
(fun function_parameter =>
let 'tt := function_parameter in
let pred_context_hash :=
context
(shell
predecessor_block_header) in
op_gtgteq
(checkout_exn context_index
pred_context_hash)
(fun predecessor_context =>
op_gtgteqquestion
(Tezos_validation.Block_validation.apply
chain_id
(Int32.to_int
(level
(shell
predecessor_block_header)))
predecessor_block_header
predecessor_context
block_header operations)
(fun block_validation_result
=>
op_gtgteqquestion
(check_context_hash_consistency
(validation_store
block_validation_result)
block_header)
(fun function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteqquestion
(verify_oldest_header
oldest_header
(block genesis))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteqquestion
(set_history_mode
store
history_mode)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteqquestion
(import_protocol_data_list
context_index
chain_store
block_hashes_arr
(level
(Block_header.shell
oldest_header))
protocol_data)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteqquestion
(store_new_head
chain_state
chain_data
(block
genesis)
block_header
operations
block_validation_result)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(update_checkpoint
chain_state
block_header)
(fun
new_checkpoint
=>
op_gtgteq
(update_savepoint
chain_state
new_checkpoint)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(update_caboose
chain_data
(block
genesis)
block_header
oldest_header
(max_operations_ttl
(validation_store
block_validation_result)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
Store.close
store
in
op_gtgteq
(State.close
state)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
return_unit)))))))))))))))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt =>
op_gtgteq (lwt_emit (Import_success filename))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error errors =>
op_gtgteq (dir_cleaner data_dir)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return (Stdlib.Error errors))
end)
(fun exn =>
op_gtgteq (dir_cleaner data_dir)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.fail exn))))))).
src/lib_shell/stat_directory.ml 2 errors
(*****************************************************************************)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let rpc_directory () =
let dir = RPC_directory.empty in
RPC_directory.gen_register dir Stat_services.S.gc (fun () () () ->
RPC_answer.return @@ Gc.stat ())
|> fun dir ->
RPC_directory.gen_register dir Stat_services.S.memory (fun () () () ->
Sys_info.memory_stats ()
>>= function
| Ok stats -> RPC_answer.return stats | Error err -> RPC_answer.fail [err])
src/lib_shell/stat_directory.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition rpc_directory (function_parameter : unit)
: Tezos_base__TzPervasives.RPC_directory.directory unit :=
let 'tt := function_parameter in
let dir := RPC_directory.empty in
OCaml.Stdlib.reverse_apply
(RPC_directory.gen_register dir Stat_services.S.gc
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
apply RPC_answer._return (Gc.stat tt)))
(fun dir =>
RPC_directory.gen_register dir Stat_services.S.memory
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Sys_info.memory_stats tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok stats => RPC_answer._return stats
| Stdlib.Error err => RPC_answer.fail (cons err [])
end))).
src/lib_shell/state.ml 367 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
[@@@ocaml.warning "-30"]
open State_logging
open Validation_errors
module Shared = struct
type 'a t = {data : 'a; lock : Lwt_mutex.t}
let create data = {data; lock = Lwt_mutex.create ()}
let use {data; lock} f = Lwt_mutex.with_lock lock (fun () -> f data)
end
type genesis = {
time : Time.Protocol.t;
block : Block_hash.t;
protocol : Protocol_hash.t;
}
type global_state = {
global_data : global_data Shared.t;
protocol_store : Store.Protocol.store Shared.t;
main_chain : Chain_id.t;
protocol_watcher : Protocol_hash.t Lwt_watcher.input;
block_watcher : block Lwt_watcher.input;
}
and global_data = {
chains : chain_state Chain_id.Table.t;
global_store : Store.t;
context_index : Context.index;
}
and chain_state = {
(* never take the lock on 'block_store' when holding
the lock on 'chain_data'. *)
global_state : global_state;
chain_id : Chain_id.t;
genesis : genesis;
faked_genesis_hash : Block_hash.t;
expiration : Time.Protocol.t option;
allow_forked_chain : bool;
block_store : Store.Block.store Shared.t;
context_index : Context.index Shared.t;
block_watcher : block Lwt_watcher.input;
chain_data : chain_data_state Shared.t;
block_rpc_directories :
block RPC_directory.t Protocol_hash.Map.t Protocol_hash.Table.t;
header_rpc_directories :
(chain_state * Block_hash.t * Block_header.t) RPC_directory.t
Protocol_hash.Map.t
Protocol_hash.Table.t;
}
and chain_data_state = {
mutable data : chain_data;
mutable checkpoint : Block_header.t;
chain_data_store : Store.Chain_data.store;
}
and chain_data = {
current_head : block;
current_mempool : Mempool.t;
live_blocks : Block_hash.Set.t;
live_operations : Operation_hash.Set.t;
test_chain : Chain_id.t option;
save_point : Int32.t * Block_hash.t;
caboose : Int32.t * Block_hash.t;
}
and block = {
chain_state : chain_state;
hash : Block_hash.t;
header : Block_header.t;
}
(* Errors *)
type error += Block_not_found of Block_hash.t
type error += Block_contents_not_found of Block_hash.t
let () =
register_error_kind
`Permanent
~id:"state.block.not_found"
~title:"Block_not_found"
~description:"Block not found"
~pp:(fun ppf block_hash ->
Format.fprintf ppf "@[Cannot find block %a]" Block_hash.pp block_hash)
Data_encoding.(obj1 (req "block_not_found" @@ Block_hash.encoding))
(function Block_not_found block_hash -> Some block_hash | _ -> None)
(fun block_hash -> Block_not_found block_hash) ;
register_error_kind
`Permanent
~id:"state.block.contents_not_found"
~title:"Block_contents_not_found"
~description:"Block not found"
~pp:(fun ppf block_hash ->
Format.fprintf
ppf
"@[Cannot find block contents %a]"
Block_hash.pp
block_hash)
Data_encoding.(
obj1 (req "block_contents_not_found" @@ Block_hash.encoding))
(function
| Block_contents_not_found block_hash -> Some block_hash | _ -> None)
(fun block_hash -> Block_contents_not_found block_hash)
(* Abstract view over block header storage.
This module aims to abstract over block header's [read], [read_opt] and [known]
functions by calling the adequate function depending on the block being pruned or not.
*)
module Header = struct
let read (store, hash) =
Store.Block.Contents.read (store, hash)
>>= function
| Ok {header; _} ->
return header
| Error _ ->
Store.Block.Pruned_contents.read (store, hash)
>>=? fun {header} -> return header
let read_opt (store, hash) =
read (store, hash)
>>= function
| Ok header -> Lwt.return_some header | Error _ -> Lwt.return_none
let known (store, hash) =
Store.Block.Pruned_contents.known (store, hash)
>>= function
| true ->
Lwt.return_true
| false ->
Store.Block.Contents.known (store, hash)
end
let read_chain_data {chain_data; _} f =
Shared.use chain_data (fun state -> f state.chain_data_store state.data)
let update_chain_data {chain_data; _} f =
Shared.use chain_data (fun state ->
f state.chain_data_store state.data
>>= fun (data, res) ->
Lwt_utils.may data ~f:(fun data ->
state.data <- data ;
Lwt.return_unit)
>>= fun () -> Lwt.return res)
(** The number of predecessors stored per block.
This value chosen to compute efficiently block locators that
can cover a chain of 2 months, at 1 block/min, which is ~86K
blocks at the cost in space of ~72MB.
|locator| = log2(|chain|/10) -1
*)
let stored_predecessors_size = 12
(**
Takes a block and populates its predecessors store, under the
assumption that all its predecessors have their store already
populated. The precedecessors are distributed along the chain, up
to the genesis, at a distance from [b] that grows exponentially.
The store tabulates a function [p] from distances to block_ids such
that if [p(b,d)=b'] then [b'] is at distance 2^d from [b].
Example of how previous predecessors are used:
p(n,0) = n-1
p(n,1) = n-2 = p(n-1,0)
p(n,2) = n-4 = p(n-2,1)
p(n,3) = n-8 = p(n-4,2)
p(n,4) = n-16 = p(n-8,3)
*)
let store_predecessors (store : Store.Block.store) (b : Block_hash.t) :
unit Lwt.t =
let rec loop pred dist =
if dist = stored_predecessors_size then Lwt.return_unit
else
Store.Block.Predecessors.read_opt (store, pred) (dist - 1)
>>= function
| None ->
Lwt.return_unit (* we reached the last known block *)
| Some p ->
Store.Block.Predecessors.store (store, b) dist p
>>= fun () -> loop p (dist + 1)
in
(* the first predecessor is fetched from the header *)
Header.read_opt (store, b)
>|= Option.unopt_assert ~loc:__POS__
>>= fun header ->
let pred = header.shell.predecessor in
if Block_hash.equal b pred then Lwt.return_unit (* genesis *)
else
Store.Block.Predecessors.store (store, b) 0 pred >>= fun () -> loop pred 1
(**
[predecessor_n_raw s b d] returns the hash of the block at distance [d] from [b].
Returns [None] if [d] is greater than the distance of [b] from genesis or
if [b] is genesis.
Works in O(log|chain|) if the chain is shorter than 2^[stored_predecessors_size]
and in O(|chain|) after that.
@raise Invalid_argument "State.predecessors: negative distance"
*)
let predecessor_n_raw store block_hash distance =
(* helper functions *)
(* computes power of 2 w/o floats *)
let power_of_2 n =
if n < 0 then invalid_arg "negative argument"
else
let rec loop cnt res =
if cnt < 1 then res else loop (cnt - 1) (res * 2)
in
loop n 1
in
(* computes the closest power of two smaller than a given
a number and the rest w/o floats *)
let closest_power_two_and_rest n =
if n < 0 then invalid_arg "negative argument"
else
let rec loop cnt n rest =
if n <= 1 then (cnt, rest)
else loop (cnt + 1) (n / 2) (rest + (power_of_2 cnt * (n mod 2)))
in
loop 0 n 0
in
(* actual predecessor function *)
if distance < 0 then
invalid_arg ("State.predecessor: distance < 0 " ^ string_of_int distance)
else if distance = 0 then Lwt.return_some block_hash
else
let rec loop block_hash distance =
if distance = 1 then
Store.Block.Predecessors.read_opt (store, block_hash) 0
else
let (power, rest) = closest_power_two_and_rest distance in
let (power, rest) =
if power < stored_predecessors_size then (power, rest)
else
let power = stored_predecessors_size - 1 in
let rest = distance - power_of_2 power in
(power, rest)
in
Store.Block.Predecessors.read_opt (store, block_hash) power
>>= function
| None ->
Lwt.return_none (* reached genesis *)
| Some pred ->
if rest = 0 then Lwt.return_some pred
(* landed on the requested predecessor *)
else loop pred rest
(* need to jump further back *)
in
loop block_hash distance
let predecessor_n ?(below_save_point = false) block_store block_hash distance =
predecessor_n_raw block_store block_hash distance
>>= function
| None ->
Lwt.return_none
| Some predecessor -> (
( if below_save_point then Header.known (block_store, predecessor)
else Store.Block.Contents.known (block_store, predecessor) )
>>= function
| false -> Lwt.return_none | true -> Lwt.return_some predecessor )
let compute_locator_from_hash chain_state ?(size = 200) head_hash seed =
Shared.use chain_state.chain_data (fun state ->
Lwt.return state.data.caboose)
>>= fun (_lvl, caboose) ->
Shared.use chain_state.block_store (fun block_store ->
Header.read_opt (block_store, head_hash)
>|= Option.unopt_assert ~loc:__POS__
>>= fun header ->
Block_locator.compute
~get_predecessor:(predecessor_n ~below_save_point:true block_store)
~caboose
~size
head_hash
header
seed)
let compute_locator chain ?size head seed =
compute_locator_from_hash chain ?size head.hash seed
type t = global_state
module Locked_block = struct
let store_genesis store genesis context =
let shell : Block_header.shell_header =
{
level = 0l;
proto_level = 0;
predecessor = genesis.block;
(* genesis' predecessor is genesis *)
timestamp = genesis.time;
fitness = [];
validation_passes = 0;
operations_hash = Operation_list_list_hash.empty;
context;
}
in
let header : Block_header.t = {shell; protocol_data = Bytes.create 0} in
Store.Block.Contents.store
(store, genesis.block)
{
header;
Store.Block.message = Some "Genesis";
max_operations_ttl = 0;
context;
metadata = Bytes.create 0;
last_allowed_fork_level = 0l;
}
>>= fun () -> Lwt.return header
(* Will that block is compatible with the current checkpoint. *)
let acceptable chain_data (header : Block_header.t) =
let checkpoint_level = chain_data.checkpoint.shell.level in
if checkpoint_level < header.shell.level then
(* the predecessor is assumed compatible. *)
Lwt.return_true
else if checkpoint_level = header.shell.level then
Lwt.return (Block_header.equal header chain_data.checkpoint)
else
(* header.shell.level < level *)
(* valid only if the current head is lower than the checkpoint. *)
let head_level = chain_data.data.current_head.header.shell.level in
Lwt.return (head_level < checkpoint_level)
(* Is a block still valid for a given checkpoint ? *)
let is_valid_for_checkpoint block_store hash (header : Block_header.t)
(checkpoint : Block_header.t) =
if Compare.Int32.(header.shell.level < checkpoint.shell.level) then
Lwt.return_true
else
predecessor_n
block_store
hash
(Int32.to_int @@ Int32.sub header.shell.level checkpoint.shell.level)
>|= Option.unopt_assert ~loc:__POS__
>>= fun predecessor ->
if Block_hash.equal predecessor (Block_header.hash checkpoint) then
Lwt.return_true
else Lwt.return_false
end
(* Find the branches that are still valid with a given checkpoint, i.e.
heads with lower level, or branches that goes through the checkpoint. *)
let locked_valid_heads_for_checkpoint block_store data checkpoint =
Store.Chain_data.Known_heads.read_all data.chain_data_store
>>= fun heads ->
Block_hash.Set.fold
(fun head acc ->
let valid_header =
Header.read_opt (block_store, head)
>|= Option.unopt_assert ~loc:__POS__
>>= fun header ->
Locked_block.is_valid_for_checkpoint block_store head header checkpoint
>>= fun valid -> Lwt.return (valid, header)
in
acc
>>= fun (valid_heads, invalid_heads) ->
valid_header
>>= fun (valid, header) ->
if valid then Lwt.return ((head, header) :: valid_heads, invalid_heads)
else Lwt.return (valid_heads, (head, header) :: invalid_heads))
heads
(Lwt.return ([], []))
(* Tag as invalid all blocks in `heads` and their predecessors whose
level strictly higher to 'level'. *)
let tag_invalid_heads block_store chain_store heads level =
let rec tag_invalid_head (hash, header) =
if header.Block_header.shell.level <= level then
Store.Chain_data.Known_heads.store chain_store hash
>>= fun () -> Lwt.return_some (hash, header)
else
let errors = [Validation_errors.Checkpoint_error (hash, None)] in
Store.Block.Invalid_block.store
block_store
hash
{level = header.shell.level; errors}
>>= fun () ->
Store.Block.Contents.remove (block_store, hash)
>>= fun () ->
Store.Block.Operation_hashes.remove_all (block_store, hash)
>>= fun () ->
Store.Block.Operations_metadata.remove_all (block_store, hash)
>>= fun () ->
Store.Block.Operations.remove_all (block_store, hash)
>>= fun () ->
Store.Block.Predecessors.remove_all (block_store, hash)
>>= fun () ->
Header.read_opt (block_store, header.shell.predecessor)
>>= function
| None ->
Lwt.return_none
| Some header ->
tag_invalid_head (Block_header.hash header, header)
in
Lwt_list.iter_p
(fun (hash, _header) ->
Store.Chain_data.Known_heads.remove chain_store hash)
heads
>>= fun () -> Lwt_list.filter_map_s tag_invalid_head heads
let prune_block store block_hash =
let st = (store, block_hash) in
Store.Block.Contents.remove st
>>= fun () ->
Store.Block.Invalid_block.remove store block_hash
>>= fun () -> Store.Block.Operations_metadata.remove_all st
let store_header_and_prune_block store block_hash =
let st = (store, block_hash) in
Store.Block.Contents.read_opt st
>>= (function
| Some {header; _} ->
Store.Block.Pruned_contents.store st {header}
| None -> (
Store.Block.Pruned_contents.known st
>>= function
| true ->
Lwt.return_unit
| false ->
State_logging.lwt_log_error
Tag.DSL.(
fun f ->
f "@[cannot find pruned contents of block %a@]"
-% t event "missing_pruned_contents"
-% a Block_hash.Logging.tag block_hash) ))
>>= fun () -> prune_block store block_hash
let delete_block store block_hash =
prune_block store block_hash
>>= fun () ->
let st = (store, block_hash) in
Store.Block.Pruned_contents.remove st
>>= fun () ->
Store.Block.Operations.remove_all st
>>= fun () ->
Store.Block.Operation_hashes.remove_all st
>>= fun () -> Store.Block.Predecessors.remove_all st
(* Remove all blocks that are not in the chain. *)
let cut_alternate_heads block_store chain_store heads =
let rec cut_alternate_head hash header =
Store.Chain_data.In_main_branch.known (chain_store, hash)
>>= fun in_chain ->
if in_chain then Lwt.return_unit
else
Header.read_opt (block_store, header.Block_header.shell.predecessor)
>>= function
| None ->
delete_block block_store hash >>= fun () -> Lwt.return_unit
| Some header ->
delete_block block_store hash
>>= fun () -> cut_alternate_head (Block_header.hash header) header
in
Lwt_list.iter_p
(fun (hash, header) ->
Store.Chain_data.Known_heads.remove chain_store hash
>>= fun () -> cut_alternate_head hash header)
heads
module Chain = struct
type nonrec genesis = genesis = {
time : Time.Protocol.t;
block : Block_hash.t;
protocol : Protocol_hash.t;
}
let genesis_encoding =
let open Data_encoding in
conv
(fun {time; block; protocol} -> (time, block, protocol))
(fun (time, block, protocol) -> {time; block; protocol})
(obj3
(req "timestamp" Time.Protocol.encoding)
(req "block" Block_hash.encoding)
(req "protocol" Protocol_hash.encoding))
type t = chain_state
type chain_state = t
let main {main_chain; _} = main_chain
let test chain_state =
read_chain_data chain_state (fun _ chain_data ->
Lwt.return chain_data.test_chain)
let get_level_indexed_protocol chain_state header =
let chain_id = chain_state.chain_id in
let protocol_level = header.Block_header.shell.proto_level in
let global_state = chain_state.global_state in
Shared.use global_state.global_data (fun global_data ->
let global_store = global_data.global_store in
let chain_store = Store.Chain.get global_store chain_id in
Store.Chain.Protocol_info.read_opt chain_store protocol_level
>>= function
| None ->
Pervasives.failwith "State.Chain.get_level_index_protocol"
| Some (p, _) ->
Lwt.return p)
let update_level_indexed_protocol_store chain_state chain_id protocol_level
protocol_hash block_header =
let global_state = chain_state.global_state in
Shared.use chain_state.block_store (fun block_store ->
Header.read_opt
(block_store, block_header.Block_header.shell.predecessor)
>>= function
| None ->
Lwt.return_none (* should not happen *)
| Some header ->
Lwt.return_some header)
>>= function
| None ->
Lwt.return_unit
| Some pred_header ->
if pred_header.shell.proto_level <> block_header.shell.proto_level then
Shared.use global_state.global_data (fun global_data ->
let global_store = global_data.global_store in
let chain_store = Store.Chain.get global_store chain_id in
Store.Chain.Protocol_info.store
chain_store
protocol_level
(protocol_hash, block_header.shell.level))
else Lwt.return_unit
let allocate ~genesis ~faked_genesis_hash ~save_point ~caboose ~expiration
~allow_forked_chain ~current_head ~checkpoint ~chain_id global_state
context_index chain_data_store block_store =
Header.read_opt (block_store, current_head)
>|= Option.unopt_assert ~loc:__POS__
>>= fun current_block_head ->
let rec chain_data =
{
data =
{
save_point;
caboose;
current_head =
{chain_state; hash = current_head; header = current_block_head};
current_mempool = Mempool.empty;
live_blocks = Block_hash.Set.singleton genesis.block;
live_operations = Operation_hash.Set.empty;
test_chain = None;
};
checkpoint;
chain_data_store;
}
and chain_state =
{
global_state;
chain_id;
chain_data = {Shared.data = chain_data; lock = Lwt_mutex.create ()};
genesis;
faked_genesis_hash;
expiration;
allow_forked_chain;
block_store = Shared.create block_store;
context_index = Shared.create context_index;
block_watcher = Lwt_watcher.create_input ();
block_rpc_directories = Protocol_hash.Table.create 7;
header_rpc_directories = Protocol_hash.Table.create 7;
}
in
Lwt.return chain_state
let locked_create global_state data ?expiration ?(allow_forked_chain = false)
chain_id genesis (genesis_header : Block_header.t) =
let chain_store = Store.Chain.get data.global_store chain_id in
let block_store = Store.Block.get chain_store
and chain_data_store = Store.Chain_data.get chain_store in
let save_point = (genesis_header.shell.level, genesis.block) in
let caboose = (genesis_header.shell.level, genesis.block) in
let proto_level = genesis_header.shell.proto_level in
Store.Chain.Genesis_hash.store chain_store genesis.block
>>= fun () ->
Store.Chain.Genesis_time.store chain_store genesis.time
>>= fun () ->
Store.Chain.Genesis_protocol.store chain_store genesis.protocol
>>= fun () ->
Store.Chain_data.Current_head.store chain_data_store genesis.block
>>= fun () ->
Store.Chain_data.Known_heads.store chain_data_store genesis.block
>>= fun () ->
Store.Chain_data.Checkpoint.store chain_data_store genesis_header
>>= fun () ->
Store.Chain_data.Save_point.store chain_data_store save_point
>>= fun () ->
Store.Chain_data.Caboose.store chain_data_store caboose
>>= fun () ->
Store.Chain.Protocol_info.store
chain_store
proto_level
(genesis.protocol, genesis_header.shell.level)
>>= fun () ->
( match expiration with
| None ->
Lwt.return_unit
| Some time ->
Store.Chain.Expiration.store chain_store time )
>>= fun () ->
( if allow_forked_chain then
Store.Chain.Allow_forked_chain.store data.global_store chain_id
else Lwt.return_unit )
>>= fun () ->
allocate
~genesis
~faked_genesis_hash:(Block_header.hash genesis_header)
~current_head:genesis.block
~expiration
~allow_forked_chain
~checkpoint:genesis_header
~chain_id
~save_point
~caboose
global_state
data.context_index
chain_data_store
block_store
>>= fun chain ->
Chain_id.Table.add data.chains chain_id chain ;
Lwt.return chain
let create state ?allow_forked_chain ~commit_genesis genesis chain_id =
Shared.use state.global_data (fun data ->
let chain_store = Store.Chain.get data.global_store chain_id in
let block_store = Store.Block.get chain_store in
if Chain_id.Table.mem data.chains chain_id then
Pervasives.failwith "State.Chain.create"
else
commit_genesis
~chain_id
~time:genesis.time
~protocol:genesis.protocol
>>=? fun commit ->
Locked_block.store_genesis block_store genesis commit
>>= fun genesis_header ->
locked_create
state
data
?allow_forked_chain
chain_id
genesis
genesis_header
>>= fun chain ->
(* in case this is a forked chain creation,
delete its header from the temporary table*)
Store.Forking_block_hash.remove
data.global_store
(Context.compute_testchain_chain_id genesis.block)
>>= fun () -> return chain)
let locked_read global_state data chain_id =
let chain_store = Store.Chain.get data.global_store chain_id in
let block_store = Store.Block.get chain_store
and chain_data_store = Store.Chain_data.get chain_store in
Store.Chain.Genesis_hash.read chain_store
>>=? fun genesis_hash ->
Store.Chain.Genesis_time.read chain_store
>>=? fun time ->
Store.Chain.Genesis_protocol.read chain_store
>>=? fun protocol ->
Store.Chain.Expiration.read_opt chain_store
>>= fun expiration ->
Store.Chain.Allow_forked_chain.known data.global_store chain_id
>>= fun allow_forked_chain ->
Header.read (block_store, genesis_hash)
>>=? fun genesis_header ->
let genesis = {time; protocol; block = genesis_hash} in
Store.Chain_data.Current_head.read chain_data_store
>>=? fun current_head ->
Store.Chain_data.Checkpoint.read chain_data_store
>>=? fun checkpoint ->
Store.Chain_data.Save_point.read chain_data_store
>>=? fun save_point ->
Store.Chain_data.Caboose.read chain_data_store
>>=? fun caboose ->
try
allocate
~genesis
~faked_genesis_hash:(Block_header.hash genesis_header)
~current_head
~expiration
~allow_forked_chain
~checkpoint
~chain_id
~save_point
~caboose
global_state
data.context_index
chain_data_store
block_store
>>= return
with Not_found -> fail Bad_data_dir
let locked_read_all global_state data =
Store.Chain.list data.global_store
>>= fun ids ->
iter_p
(fun id ->
locked_read global_state data id
>>=? fun chain ->
Chain_id.Table.add data.chains id chain ;
return_unit)
ids
let read_all state =
Shared.use state.global_data (fun data -> locked_read_all state data)
let get_exn state id =
Shared.use state.global_data (fun data ->
Lwt.return (Chain_id.Table.find data.chains id))
let get_opt state id =
Lwt.catch
(fun () -> get_exn state id >>= Lwt.return_some)
(function _ -> Lwt.return_none)
let get state id =
Lwt.catch
(fun () -> get_exn state id >>= return)
(function Not_found -> fail (Unknown_chain id) | exn -> Lwt.fail exn)
let all state =
Shared.use state.global_data (fun {chains; _} ->
Lwt.return
@@ Chain_id.Table.fold (fun _ chain acc -> chain :: acc) chains [])
let id {chain_id; _} = chain_id
let genesis {genesis; _} = genesis
let faked_genesis_hash {faked_genesis_hash; _} = faked_genesis_hash
let expiration {expiration; _} = expiration
let allow_forked_chain {allow_forked_chain; _} = allow_forked_chain
let global_state {global_state; _} = global_state
let checkpoint chain_state =
Shared.use chain_state.chain_data (fun {checkpoint; _} ->
Lwt.return checkpoint)
let save_point chain_state =
Shared.use chain_state.chain_data (fun state ->
Lwt.return state.data.save_point)
let caboose chain_state =
Shared.use chain_state.chain_data (fun state ->
Lwt.return state.data.caboose)
let purge_loop_full ?(chunk_size = 4000) global_store store ~genesis_hash
block_hash caboose_level =
let do_prune blocks =
Store.with_atomic_rw global_store
@@ fun () -> Lwt_list.iter_s (store_header_and_prune_block store) blocks
in
let rec loop block_hash (n_blocks, blocks) =
( if n_blocks >= chunk_size then
do_prune blocks >>= fun () -> Lwt.return (0, [])
else Lwt.return (n_blocks, blocks) )
>>= fun (n_blocks, blocks) ->
Header.read_opt (store, block_hash)
>|= Option.unopt_assert ~loc:__POS__
>>= fun header ->
if Block_hash.equal block_hash genesis_hash then do_prune blocks
else if header.shell.level = caboose_level then
do_prune (block_hash :: blocks)
else loop header.shell.predecessor (n_blocks + 1, block_hash :: blocks)
in
Header.read_opt (store, block_hash)
>|= Option.unopt_assert ~loc:__POS__
>>= fun header -> loop header.shell.predecessor (0, [])
let purge_full chain_state (lvl, hash) =
Shared.use chain_state.global_state.global_data (fun global_data ->
Shared.use chain_state.block_store (fun store ->
update_chain_data chain_state (fun _ data ->
purge_loop_full
global_data.global_store
store
~genesis_hash:chain_state.genesis.block
hash
(fst data.save_point)
>>= fun () ->
let new_data = {data with save_point = (lvl, hash)} in
Lwt.return (Some new_data, ()))
>>= fun () ->
Shared.use chain_state.chain_data (fun data ->
Store.Chain_data.Save_point.store
data.chain_data_store
(lvl, hash)
>>= fun () -> return_unit)))
let purge_loop_rolling global_store store ~genesis_hash block_hash limit =
let do_delete blocks =
Store.with_atomic_rw global_store
@@ fun () -> Lwt_list.iter_s (delete_block store) blocks
in
let rec prune_loop block_hash limit =
if Block_hash.equal genesis_hash block_hash then Lwt.return block_hash
else if limit = 1 then
Header.read_opt (store, block_hash)
>>= function
| None ->
assert false (* Should not happen. *)
| Some header ->
store_header_and_prune_block store block_hash
>>= fun () ->
delete_loop header.shell.predecessor (0, [])
>>= fun () -> Lwt.return block_hash
else
Header.read_opt (store, block_hash)
>>= function
| None ->
assert false (* Should not happen. *)
| Some header ->
store_header_and_prune_block store block_hash
>>= fun () -> prune_loop header.shell.predecessor (limit - 1)
and delete_loop block_hash (n_blocks, blocks) =
( if n_blocks >= 4000 then
do_delete blocks >>= fun () -> Lwt.return (0, [])
else Lwt.return (n_blocks, blocks) )
>>= fun (n_blocks, blocks) ->
Header.read_opt (store, block_hash)
>>= function
| None ->
do_delete blocks
| Some header ->
if Block_hash.equal genesis_hash block_hash then do_delete blocks
else
delete_loop
header.shell.predecessor
(n_blocks + 1, block_hash :: blocks)
in
Header.read_opt (store, block_hash)
>|= Option.unopt_assert ~loc:__POS__
>>= fun header ->
if limit = 0 then
delete_loop header.shell.predecessor (0, [])
>>= fun () -> Lwt.return block_hash
else prune_loop header.shell.predecessor limit
let purge_rolling chain_state ((lvl, hash) as checkpoint) =
Shared.use chain_state.global_state.global_data (fun global_data ->
Shared.use chain_state.block_store (fun store ->
Store.Block.Contents.read_opt (store, hash)
>>= (function
| None ->
fail (Block_contents_not_found hash)
| Some contents ->
return contents)
>>=? fun contents ->
let max_op_ttl = contents.max_operations_ttl in
let limit = max_op_ttl in
purge_loop_rolling
~genesis_hash:chain_state.genesis.block
global_data.global_store
store
hash
limit
>>= fun caboose_hash ->
let caboose_level = Int32.sub lvl (Int32.of_int max_op_ttl) in
let caboose = (caboose_level, caboose_hash) in
update_chain_data chain_state (fun _ data ->
let new_data = {data with save_point = checkpoint; caboose} in
Lwt.return (Some new_data, ()))
>>= fun () ->
Shared.use chain_state.chain_data (fun data ->
Store.Chain_data.Save_point.store
data.chain_data_store
checkpoint
>>= fun () ->
Store.Chain_data.Caboose.store data.chain_data_store caboose
>>= fun () -> return_unit)))
let set_checkpoint chain_state checkpoint =
Shared.use chain_state.block_store (fun store ->
Shared.use chain_state.chain_data (fun data ->
let head_header = data.data.current_head.header in
let head_hash = data.data.current_head.hash in
Locked_block.is_valid_for_checkpoint
store
head_hash
head_header
checkpoint
>>= fun valid ->
assert valid ;
(* Remove outdated invalid blocks. *)
Store.Block.Invalid_block.iter store ~f:(fun hash iblock ->
if iblock.level <= checkpoint.shell.level then
Store.Block.Invalid_block.remove store hash
else Lwt.return_unit)
>>= fun () ->
(* Remove outdated heads and tag invalid branches. *)
locked_valid_heads_for_checkpoint store data checkpoint
>>= (fun (valid_heads, invalid_heads) ->
tag_invalid_heads
store
data.chain_data_store
invalid_heads
checkpoint.shell.level
>>= fun outdated_invalid_heads ->
if head_header.shell.level < checkpoint.shell.level then
Lwt.return_unit
else
let outdated_valid_heads =
List.filter
(fun (hash, {Block_header.shell; _}) ->
shell.level <= checkpoint.shell.level
&& not (Block_hash.equal hash head_hash))
valid_heads
in
cut_alternate_heads
store
data.chain_data_store
outdated_valid_heads
>>= fun () ->
cut_alternate_heads
store
data.chain_data_store
outdated_invalid_heads)
>>= fun () ->
(* Store the new checkpoint. *)
Store.Chain_data.Checkpoint.store data.chain_data_store checkpoint
>>= fun () ->
data.checkpoint <- checkpoint ;
(* TODO 'git fsck' in the context. *)
Lwt.return_unit))
let set_checkpoint_then_purge_full chain_state checkpoint =
set_checkpoint chain_state checkpoint
>>= fun () ->
let lvl = checkpoint.shell.level in
let hash = Block_header.hash checkpoint in
purge_full chain_state (lvl, hash)
let set_checkpoint_then_purge_rolling chain_state checkpoint =
set_checkpoint chain_state checkpoint
>>= fun () ->
let lvl = checkpoint.shell.level in
let hash = Block_header.hash checkpoint in
purge_rolling chain_state (lvl, hash)
let acceptable_block chain_state (header : Block_header.t) =
Shared.use chain_state.chain_data (fun chain_data ->
Locked_block.acceptable chain_data header)
let destroy state chain =
lwt_debug
Tag.DSL.(
fun f -> f "destroy %a" -% t event "destroy" -% a chain_id (id chain))
>>= fun () ->
Shared.use state.global_data (fun {global_store; chains; _} ->
Chain_id.Table.remove chains (id chain) ;
Store.Chain.destroy global_store (id chain))
let store chain_state =
Shared.use chain_state.global_state.global_data (fun global_data ->
Lwt.return global_data.global_store)
end
module Block = struct
type t = block = {
chain_state : Chain.t;
hash : Block_hash.t;
header : Block_header.t;
}
type block = t
module Header = Header
let compare b1 b2 = Block_hash.compare b1.hash b2.hash
let equal b1 b2 = Block_hash.equal b1.hash b2.hash
let hash {hash; _} = hash
let header {header; _} = header
let read_contents block =
Shared.use block.chain_state.block_store (fun store ->
Store.Block.Contents.read_opt (store, block.hash)
>>= function
| None ->
fail (Block_contents_not_found block.hash)
| Some contents ->
return contents)
let header_of_hash chain_state hash =
Shared.use chain_state.block_store (fun store ->
Header.read_opt (store, hash))
let metadata b = read_contents b >>=? fun {metadata; _} -> return metadata
let chain_state {chain_state; _} = chain_state
let chain_id {chain_state = {chain_id; _}; _} = chain_id
let shell_header {header = {shell; _}; _} = shell
let timestamp b = (shell_header b).timestamp
let fitness b = (shell_header b).fitness
let level b = (shell_header b).level
let validation_passes b = (shell_header b).validation_passes
let message b = read_contents b >>=? fun {message; _} -> return message
let max_operations_ttl b =
read_contents b
>>=? fun {max_operations_ttl; _} -> return max_operations_ttl
let last_allowed_fork_level b =
read_contents b
>>=? fun {last_allowed_fork_level; _} -> return last_allowed_fork_level
let is_genesis b = Block_hash.equal b.hash b.chain_state.genesis.block
let known_valid chain_state hash =
Shared.use chain_state.block_store (fun store ->
Header.known (store, hash))
let known_invalid chain_state hash =
Shared.use chain_state.block_store (fun store ->
Store.Block.Invalid_block.known store hash)
let read_invalid chain_state hash =
Shared.use chain_state.block_store (fun store ->
Store.Block.Invalid_block.read_opt store hash)
let list_invalid chain_state =
Shared.use chain_state.block_store (fun store ->
Store.Block.Invalid_block.fold
store
~init:[]
~f:(fun hash {level; errors} acc ->
Lwt.return ((hash, level, errors) :: acc)))
let unmark_invalid chain_state block =
Shared.use chain_state.block_store (fun store ->
Store.Block.Invalid_block.known store block
>>= fun mem ->
if mem then Store.Block.Invalid_block.remove store block >>= return
else fail (Block_not_invalid block))
let is_valid_for_checkpoint block checkpoint =
let chain_state = block.chain_state in
Shared.use chain_state.block_store (fun store ->
Locked_block.is_valid_for_checkpoint
store
block.hash
block.header
checkpoint)
let read_predecessor chain_state ~pred ?(below_save_point = false) hash =
Shared.use chain_state.block_store (fun store ->
predecessor_n ~below_save_point store hash pred
>>= fun hash_opt ->
let new_hash_opt =
match hash_opt with
| Some _ as hash_opt ->
hash_opt
| None ->
if Block_hash.equal hash chain_state.genesis.block then
Some chain_state.genesis.block
else None
in
match new_hash_opt with
| None ->
Lwt.fail Not_found
| Some hash -> (
Header.read_opt (store, hash)
>>= fun header ->
match header with
| Some header ->
Lwt.return_some {chain_state; hash; header}
| None ->
Lwt.return_none ))
let read chain_state hash =
Shared.use chain_state.block_store (fun store ->
Header.read (store, hash)
>>=? fun header -> return {chain_state; hash; header})
let read_opt chain_state hash =
read chain_state hash
>>= function Error _ -> Lwt.return_none | Ok v -> Lwt.return_some v
let predecessor {chain_state; header; hash; _} =
if Block_hash.equal hash header.shell.predecessor then Lwt.return_none
(* we are at genesis *)
else read_opt chain_state header.shell.predecessor
let predecessor_n b n =
Shared.use b.chain_state.block_store (fun block_store ->
predecessor_n block_store b.hash n)
let store ?(dont_enforce_context_hash = false) chain_state block_header
block_header_metadata operations operations_metadata
({context_hash; message; max_operations_ttl; last_allowed_fork_level} :
Block_validation.validation_store) ~forking_testchain =
let bytes = Block_header.to_bytes block_header in
let hash = Block_header.hash_raw bytes in
fail_unless
(block_header.shell.validation_passes = List.length operations)
(failure "State.Block.store: invalid operations length")
>>=? fun () ->
fail_unless
(block_header.shell.validation_passes = List.length operations_metadata)
(failure "State.Block.store: invalid operations_data length")
>>=? fun () ->
fail_unless
(List.for_all2
(fun l1 l2 -> List.length l1 = List.length l2)
operations
operations_metadata)
(failure "State.Block.store: inconsistent operations and operations_data")
>>=? fun () ->
(* let's the validator check the consistency... of fitness, level, ... *)
Shared.use chain_state.block_store (fun store ->
Store.Block.Invalid_block.known store hash
>>= fun known_invalid ->
fail_when known_invalid (failure "Known invalid")
>>=? fun () ->
Store.Block.Contents.known (store, hash)
>>= fun known ->
if known then return_none
else
(* safety check: never ever commit a block that is not compatible
with the current checkpoint. *)
(let predecessor = block_header.shell.predecessor in
Header.known (store, predecessor)
>>= fun valid_predecessor ->
if not valid_predecessor then Lwt.return_false
else
Shared.use chain_state.chain_data (fun chain_data ->
Locked_block.acceptable chain_data block_header))
>>= fun acceptable_block ->
fail_unless acceptable_block (Checkpoint_error (hash, None))
>>=? fun () ->
let commit = context_hash in
Context.exists chain_state.context_index.data commit
>>= fun exists ->
fail_unless
exists
(failure "State.Block.store: context hash not found in context")
>>=? fun _ ->
fail_unless
( dont_enforce_context_hash
|| Context_hash.equal block_header.shell.context commit )
(Inconsistent_hash (commit, block_header.shell.context))
>>=? fun () ->
let header =
if dont_enforce_context_hash then
{
block_header with
shell = {block_header.shell with context = commit};
}
else block_header
in
let contents =
{
header;
Store.Block.message;
max_operations_ttl;
last_allowed_fork_level;
context = commit;
metadata = block_header_metadata;
}
in
Store.Block.Contents.store (store, hash) contents
>>= fun () ->
Lwt_list.iteri_p
(fun i ops ->
Store.Block.Operation_hashes.store
(store, hash)
i
(List.map Operation.hash ops))
operations
>>= fun () ->
Lwt_list.iteri_p
(fun i ops -> Store.Block.Operations.store (store, hash) i ops)
operations
>>= fun () ->
Lwt_list.iteri_p
(fun i ops ->
Store.Block.Operations_metadata.store (store, hash) i ops)
operations_metadata
>>= fun () ->
(* Store predecessors *)
store_predecessors store hash
>>= fun () ->
(* Update the chain state. *)
Shared.use chain_state.chain_data (fun chain_data ->
let store = chain_data.chain_data_store in
let predecessor = block_header.shell.predecessor in
Store.Chain_data.Known_heads.remove store predecessor
>>= fun () -> Store.Chain_data.Known_heads.store store hash)
>>= fun () ->
( if forking_testchain then
Shared.use chain_state.global_state.global_data (fun global_data ->
let genesis = Context.compute_testchain_genesis hash in
Store.Forking_block_hash.store
global_data.global_store
(Context.compute_testchain_chain_id genesis)
hash)
else Lwt.return_unit )
>>= fun () ->
let block = {chain_state; hash; header} in
Lwt_watcher.notify chain_state.block_watcher block ;
Lwt_watcher.notify chain_state.global_state.block_watcher block ;
return_some block)
let store_invalid chain_state block_header errors =
let bytes = Block_header.to_bytes block_header in
let hash = Block_header.hash_raw bytes in
Shared.use chain_state.block_store (fun store ->
Header.known (store, hash)
>>= fun known_valid ->
fail_when known_valid (failure "Known valid")
>>=? fun () ->
Store.Block.Invalid_block.known store hash
>>= fun known_invalid ->
if known_invalid then return_false
else
Store.Block.Invalid_block.store
store
hash
{level = block_header.shell.level; errors}
>>= fun () -> return_true)
let watcher (state : chain_state) =
Lwt_watcher.create_stream state.block_watcher
let compute_operation_path hashes =
let list_hashes = List.map Operation_list_hash.compute hashes in
Operation_list_list_hash.compute_path list_hashes
let operation_hashes {chain_state; hash; header} i =
if i < 0 || header.shell.validation_passes <= i then
invalid_arg "State.Block.operations" ;
Shared.use chain_state.block_store (fun store ->
Lwt_list.map_p
(fun n ->
Store.Block.Operation_hashes.read_opt (store, hash) n
>|= Option.unopt_assert ~loc:__POS__)
(0 -- (header.shell.validation_passes - 1))
>>= fun hashes ->
let path = compute_operation_path hashes in
Lwt.return (List.nth hashes i, path i))
let all_operation_hashes {chain_state; hash; header; _} =
Shared.use chain_state.block_store (fun store ->
Lwt_list.map_p
(fun i ->
Store.Block.Operation_hashes.read_opt (store, hash) i
>|= Option.unopt_assert ~loc:__POS__)
(0 -- (header.shell.validation_passes - 1)))
let operations {chain_state; hash; header; _} i =
if i < 0 || header.shell.validation_passes <= i then
invalid_arg "State.Block.operations" ;
Shared.use chain_state.block_store (fun store ->
Lwt_list.map_p
(fun n ->
Store.Block.Operation_hashes.read_opt (store, hash) n
>|= Option.unopt_assert ~loc:__POS__)
(0 -- (header.shell.validation_passes - 1))
>>= fun hashes ->
let path = compute_operation_path hashes in
Store.Block.Operations.read_opt (store, hash) i
>|= Option.unopt_assert ~loc:__POS__
>>= fun ops -> Lwt.return (ops, path i))
let operations_metadata {chain_state; hash; header; _} i =
if i < 0 || header.shell.validation_passes <= i then
invalid_arg "State.Block.operations_metadata" ;
Shared.use chain_state.block_store (fun store ->
Store.Block.Operations_metadata.read_opt (store, hash) i
>|= Option.unopt_assert ~loc:__POS__)
let all_operations {chain_state; hash; header; _} =
Shared.use chain_state.block_store (fun store ->
Lwt_list.map_p
(fun i ->
Store.Block.Operations.read_opt (store, hash) i
>|= Option.unopt_assert ~loc:__POS__)
(0 -- (header.shell.validation_passes - 1)))
let all_operations_metadata {chain_state; hash; header; _} =
Shared.use chain_state.block_store (fun store ->
Lwt_list.map_p
(fun i ->
Store.Block.Operations_metadata.read_opt (store, hash) i
>|= Option.unopt_assert ~loc:__POS__)
(0 -- (header.shell.validation_passes - 1)))
let context_exn {chain_state; hash; _} =
Shared.use chain_state.block_store (fun block_store ->
Store.Block.Contents.read_opt (block_store, hash))
>|= Option.unopt_assert ~loc:__POS__
>>= fun {context = commit; _} ->
Shared.use chain_state.context_index (fun context_index ->
Context.checkout_exn context_index commit)
let context_opt {chain_state; hash; _} =
Shared.use chain_state.block_store (fun block_store ->
Store.Block.Contents.read_opt (block_store, hash))
>|= Option.unopt_assert ~loc:__POS__
>>= fun {context = commit; _} ->
Shared.use chain_state.context_index (fun context_index ->
Context.checkout context_index commit)
let context block =
context_opt block
>>= function
| Some context ->
return context
| None ->
failwith "State.Block.context failed to checkout context"
let protocol_hash block =
context block >>=? fun context -> Context.get_protocol context >>= return
let protocol_hash_exn block =
context_exn block >>= fun context -> Context.get_protocol context
let protocol_level block = block.header.shell.proto_level
let test_chain block =
context_exn block
>>= fun context ->
Context.get_test_chain context
>>= fun status ->
let lookup_testchain genesis =
let chain_id = Context.compute_testchain_chain_id genesis in
(* otherwise, look in the temporary table *)
Shared.use block.chain_state.global_state.global_data (fun global_data ->
Store.Forking_block_hash.read_opt global_data.global_store chain_id)
>>= function
| Some forking_block_hash ->
read_opt block.chain_state forking_block_hash
>>= fun forking_block -> Lwt.return (status, forking_block)
| None ->
Lwt.return (status, None)
in
match status with
| Running {genesis; _} ->
lookup_testchain genesis
| Forking _ ->
Lwt.return (status, Some block)
| Not_running ->
Lwt.return (status, None)
let known chain_state hash =
Shared.use chain_state.block_store (fun store ->
Header.known (store, hash)
>>= fun known ->
if known then Lwt.return_true
else Store.Block.Invalid_block.known store hash)
let block_validity chain_state block : Block_locator.validity Lwt.t =
known chain_state block
>>= function
| false ->
if Block_hash.equal block (Chain.faked_genesis_hash chain_state) then
Lwt.return Block_locator.Known_valid
else Lwt.return Block_locator.Unknown
| true -> (
known_invalid chain_state block
>>= function
| true ->
Lwt.return Block_locator.Known_invalid
| false ->
Lwt.return Block_locator.Known_valid )
let known_ancestor chain_state locator =
Shared.use chain_state.global_state.global_data (fun {global_store; _} ->
Store.Configuration.History_mode.read_opt global_store
>|= Option.unopt_assert ~loc:__POS__)
>>= fun history_mode ->
Block_locator.unknown_prefix ~is_known:(block_validity chain_state) locator
>>= function
| (Known_valid, prefix_locator) ->
Lwt.return_some prefix_locator
| (Known_invalid, _) ->
Lwt.return_none
| (Unknown, _) -> (
match history_mode with
| Archive ->
Lwt.return_none
| Rolling | Full ->
Lwt.return_some locator )
(* Hypothesis : genesis' predecessor is itself. *)
let get_rpc_directory ({chain_state; _} as block) =
read_opt chain_state block.header.shell.predecessor
>>= function
| None ->
Lwt.return_none (* assert false *)
| Some pred when equal pred block ->
Lwt.return_none (* genesis *)
| Some pred -> (
Chain.save_point chain_state
>>= fun (save_point_level, _) ->
( if Compare.Int32.(level pred < save_point_level) then
Chain.get_level_indexed_protocol chain_state pred.header
else protocol_hash_exn pred )
>>= fun protocol ->
match
Protocol_hash.Table.find_opt
chain_state.block_rpc_directories
protocol
with
| None ->
Lwt.return_none
| Some map ->
protocol_hash_exn block
>>= fun next_protocol ->
Lwt.return (Protocol_hash.Map.find_opt next_protocol map) )
let set_rpc_directory ({chain_state; _} as block) dir =
read_opt chain_state block.header.shell.predecessor
>|= Option.unopt_assert ~loc:__POS__
>>= fun pred ->
protocol_hash_exn block
>>= fun next_protocol ->
Chain.save_point chain_state
>>= fun (save_point_level, _) ->
( if Compare.Int32.(level pred < save_point_level) then
Chain.get_level_indexed_protocol chain_state (header pred)
else protocol_hash_exn pred )
>>= fun protocol ->
let map =
Option.unopt
~default:Protocol_hash.Map.empty
(Protocol_hash.Table.find_opt
chain_state.block_rpc_directories
protocol)
in
Protocol_hash.Table.replace
chain_state.block_rpc_directories
protocol
(Protocol_hash.Map.add next_protocol dir map) ;
Lwt.return_unit
let get_header_rpc_directory chain_state header =
Shared.use chain_state.block_store (fun block_store ->
Header.read_opt (block_store, header.Block_header.shell.predecessor)
>>= function
| None ->
Lwt.return_none (* caboose *)
| Some pred when Block_header.equal pred header ->
Lwt.return_none (* genesis *)
| Some pred -> (
Chain.get_level_indexed_protocol chain_state header
>>= fun protocol ->
match
Protocol_hash.Table.find_opt
chain_state.header_rpc_directories
protocol
with
| None ->
Lwt.return_none
| Some map ->
Chain.get_level_indexed_protocol chain_state pred
>>= fun next_protocol ->
Lwt.return (Protocol_hash.Map.find_opt next_protocol map) ))
let set_header_rpc_directory chain_state header dir =
Shared.use chain_state.block_store (fun block_store ->
Header.read_opt (block_store, header.Block_header.shell.predecessor)
>>= function
| None ->
assert false
| Some pred ->
Chain.get_level_indexed_protocol chain_state header
>>= fun next_protocol ->
Chain.get_level_indexed_protocol chain_state pred
>>= fun protocol ->
let map =
Option.unopt
~default:Protocol_hash.Map.empty
(Protocol_hash.Table.find_opt
chain_state.header_rpc_directories
protocol)
in
Protocol_hash.Table.replace
chain_state.header_rpc_directories
protocol
(Protocol_hash.Map.add next_protocol dir map) ;
Lwt.return_unit)
end
let watcher (state : global_state) =
Lwt_watcher.create_stream state.block_watcher
let read_block {global_data; _} hash =
Shared.use global_data (fun {chains; _} ->
Chain_id.Table.fold
(fun _chain_id chain_state acc ->
acc
>>= function
| Some _ ->
acc
| None -> (
Block.read_opt chain_state hash
>>= function None -> acc | Some block -> Lwt.return_some block ))
chains
Lwt.return_none)
let read_block_exn t hash =
read_block t hash
>>= function None -> Lwt.fail Not_found | Some b -> Lwt.return b
let update_testchain block ~testchain_state =
update_chain_data block.chain_state (fun _ chain_data ->
Lwt.return
(Some {chain_data with test_chain = Some testchain_state.chain_id}, ()))
let fork_testchain block chain_id genesis_hash genesis_header protocol
expiration =
Shared.use block.chain_state.global_state.global_data (fun data ->
let chain_store = Store.Chain.get data.global_store chain_id in
let block_store = Store.Block.get chain_store in
Store.Block.Contents.store
(block_store, genesis_hash)
{
header = genesis_header;
Store.Block.message = Some "Genesis";
max_operations_ttl = 0;
context = genesis_header.shell.context;
metadata = Bytes.create 0;
last_allowed_fork_level = 0l;
}
>>= fun () ->
let genesis =
{block = genesis_hash; time = genesis_header.shell.timestamp; protocol}
in
Chain.locked_create
block.chain_state.global_state
data
chain_id
~expiration
genesis
genesis_header
>>= fun testchain_state ->
Store.Chain.Protocol_info.store
chain_store
genesis_header.shell.proto_level
(protocol, genesis_header.shell.level)
>>= fun () ->
update_testchain block ~testchain_state
>>= fun () -> return testchain_state)
let best_known_head_for_checkpoint chain_state checkpoint =
Shared.use chain_state.block_store (fun store ->
Shared.use chain_state.chain_data (fun data ->
let head_hash = data.data.current_head.hash in
let head_header = data.data.current_head.header in
Locked_block.is_valid_for_checkpoint
store
head_hash
head_header
checkpoint
>>= fun valid ->
if valid then Lwt.return data.data.current_head
else
let find_valid_predecessor hash =
Header.read_opt (store, hash)
>|= Option.unopt_assert ~loc:__POS__
>>= fun header ->
if Compare.Int32.(header.shell.level < checkpoint.shell.level)
then Lwt.return {hash; chain_state; header}
else
predecessor_n
store
hash
( 1
+ ( Int32.to_int
@@ Int32.sub header.shell.level checkpoint.shell.level ) )
>|= Option.unopt_assert ~loc:__POS__
>>= fun pred ->
Header.read_opt (store, pred)
>|= Option.unopt_assert ~loc:__POS__
>>= fun pred_header ->
Lwt.return {hash = pred; chain_state; header = pred_header}
in
Store.Chain_data.Known_heads.read_all data.chain_data_store
>>= fun heads ->
Header.read_opt (store, chain_state.genesis.block)
>|= Option.unopt_assert ~loc:__POS__
>>= fun genesis_header ->
let genesis =
{
hash = chain_state.genesis.block;
chain_state;
header = genesis_header;
}
in
Block_hash.Set.fold
(fun head best ->
let valid_predecessor = find_valid_predecessor head in
best
>>= fun best ->
valid_predecessor
>>= fun pred ->
if
Fitness.(
pred.header.shell.fitness > best.header.shell.fitness)
then Lwt.return pred
else Lwt.return best)
heads
(Lwt.return genesis)))
module Protocol = struct
include Protocol
let known global_state hash =
Shared.use global_state.protocol_store (fun store ->
Store.Protocol.Contents.known store hash)
let read global_state hash =
Shared.use global_state.protocol_store (fun store ->
Store.Protocol.Contents.read store hash)
let read_opt global_state hash =
Shared.use global_state.protocol_store (fun store ->
Store.Protocol.Contents.read_opt store hash)
let read_raw global_state hash =
Shared.use global_state.protocol_store (fun store ->
Store.Protocol.RawContents.read (store, hash))
let read_raw_opt global_state hash =
Shared.use global_state.protocol_store (fun store ->
Store.Protocol.RawContents.read_opt (store, hash))
let store global_state p =
let bytes = Protocol.to_bytes p in
let hash = Protocol.hash_raw bytes in
Shared.use global_state.protocol_store (fun store ->
Store.Protocol.Contents.known store hash
>>= fun known ->
if known then Lwt.return_none
else
Store.Protocol.RawContents.store (store, hash) bytes
>>= fun () ->
Lwt_watcher.notify global_state.protocol_watcher hash ;
Lwt.return_some hash)
let remove global_state hash =
Shared.use global_state.protocol_store (fun store ->
Store.Protocol.Contents.known store hash
>>= fun known ->
if known then Lwt.return_false
else
Store.Protocol.Contents.remove store hash
>>= fun () -> Lwt.return_true)
let list global_state =
Shared.use global_state.protocol_store (fun store ->
Store.Protocol.Contents.fold_keys
store
~init:Protocol_hash.Set.empty
~f:(fun x acc -> Lwt.return (Protocol_hash.Set.add x acc)))
let watcher (state : global_state) =
Lwt_watcher.create_stream state.protocol_watcher
end
module Current_mempool = struct
let set chain_state ~head mempool =
update_chain_data chain_state (fun _chain_data_store data ->
if Block_hash.equal head (Block.hash data.current_head) then
Lwt.return (Some {data with current_mempool = mempool}, ())
else Lwt.return (None, ()))
let get chain_state =
read_chain_data chain_state (fun _chain_data_store data ->
Lwt.return (Block.header data.current_head, data.current_mempool))
end
let may_create_chain ~commit_genesis state chain_id genesis =
Chain.get state chain_id
>>= function
| Ok chain ->
return chain
| Error _ ->
Chain.create
~commit_genesis
~allow_forked_chain:true
state
genesis
chain_id
let read global_store context_index main_chain =
let global_data =
{chains = Chain_id.Table.create 17; global_store; context_index}
in
let state =
{
global_data = Shared.create global_data;
protocol_store = Shared.create @@ Store.Protocol.get global_store;
main_chain;
protocol_watcher = Lwt_watcher.create_input ();
block_watcher = Lwt_watcher.create_input ();
}
in
Chain.read_all state >>=? fun () -> return state
type error +=
| Incorrect_history_mode_switch of {
previous_mode : History_mode.t;
next_mode : History_mode.t;
}
let () =
register_error_kind
`Permanent
~id:"node_config_file.incorrect_history_mode_switch"
~title:"Incorrect history mode switch"
~description:"Incorrect history mode switch."
~pp:(fun ppf (prev, next) ->
Format.fprintf
ppf
"@[cannot switch from history mode %a mode to %a mode@]"
History_mode.pp
prev
History_mode.pp
next)
(Data_encoding.obj2
(Data_encoding.req "previous_mode" History_mode.encoding)
(Data_encoding.req "next_mode" History_mode.encoding))
(function
| Incorrect_history_mode_switch x ->
Some (x.previous_mode, x.next_mode)
| _ ->
None)
(fun (previous_mode, next_mode) ->
Incorrect_history_mode_switch {previous_mode; next_mode})
let init ?patch_context ?commit_genesis ?(store_mapsize = 40_960_000_000L)
?(context_mapsize = 409_600_000_000L) ~store_root ~context_root
?history_mode genesis =
Store.init ~mapsize:store_mapsize store_root
>>=? fun global_store ->
( match commit_genesis with
| Some commit_genesis ->
Context.init
~readonly:true
~mapsize:context_mapsize
?patch_context
context_root
>>= fun context_index -> Lwt.return (context_index, commit_genesis)
| None ->
Context.init
~readonly:false
~mapsize:context_mapsize
?patch_context
context_root
>>= fun context_index ->
let commit_genesis ~chain_id ~time ~protocol =
Context.commit_genesis context_index ~chain_id ~time ~protocol
>>= fun res -> return res
in
Lwt.return (context_index, commit_genesis) )
>>= fun (context_index, commit_genesis) ->
let chain_id = Chain_id.of_block_hash genesis.Chain.block in
read global_store context_index chain_id
>>=? fun state ->
may_create_chain ~commit_genesis state chain_id genesis
>>=? fun main_chain_state ->
Store.Configuration.History_mode.read_opt global_store
>>= (function
| None ->
let mode = Option.unopt ~default:History_mode.Full history_mode in
Store.Configuration.History_mode.store global_store mode
>>= fun () -> return mode
| Some previous_history_mode -> (
match history_mode with
| None ->
return previous_history_mode
| Some history_mode ->
if history_mode <> previous_history_mode then
fail
(Incorrect_history_mode_switch
{
previous_mode = previous_history_mode;
next_mode = history_mode;
})
else return history_mode ))
>>=? fun history_mode ->
return (state, main_chain_state, context_index, history_mode)
let history_mode {global_data; _} =
Shared.use global_data (fun {global_store; _} ->
Store.Configuration.History_mode.read_opt global_store
>|= Option.unopt_assert ~loc:__POS__)
let close {global_data; _} =
Shared.use global_data (fun {global_store; _} ->
Store.close global_store ; Lwt.return_unit)
src/lib_shell/state.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import State_logging.
Import Validation_errors.
Module Shared.
Record t {a : Type} := {
data : a;
lock : Lwt_mutex.t }.
Arguments t : clear implicits.
Definition create {A : Type} (data : A) : t A :=
{| data := data; lock := Lwt_mutex.create tt |}.
Definition use {A B : Type} (function_parameter : t A)
: (A -> Lwt.t B) -> Lwt.t B :=
let '{| data := data; lock := lock |} := function_parameter in
fun f =>
Lwt_mutex.with_lock lock
(fun function_parameter =>
let 'tt := function_parameter in
f data).
End Shared.
Record genesis := {
time : Tezos_base__TzPervasives.Time.Protocol.t;
block : Tezos_base__TzPervasives.Block_hash.t;
protocol : Tezos_base__TzPervasives.Protocol_hash.t }.
.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Module Header.
Definition read
(function_parameter :
Tezos_shell__Store.Block.store * Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_header.t) :=
let '(store, hash) := function_parameter in
op_gtgteq (Store.Block.Contents.read (store, hash))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok {| header := header |} => _return header
| Stdlib.Error _ =>
op_gtgteqquestion (Store.Block.Pruned_contents.read (store, hash))
(fun function_parameter =>
let '{| header := header |} := function_parameter in
_return header)
end).
Definition read_opt
(function_parameter :
Tezos_shell__Store.Block.store * Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t (option Tezos_base__TzPervasives.Block_header.t) :=
let '(store, hash) := function_parameter in
op_gtgteq (read (store, hash))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok header => Lwt.return_some header
| Stdlib.Error _ => Lwt.return_none
end).
Definition known
(function_parameter :
Tezos_shell__Store.Block.store * Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t bool :=
let '(store, hash) := function_parameter in
op_gtgteq (Store.Block.Pruned_contents.known (store, hash))
(fun function_parameter =>
match function_parameter with
| true => Lwt.return_true
| false => Store.Block.Contents.known (store, hash)
end).
End Header.
Definition read_chain_data {A : Type} (function_parameter : chain_state)
: (Tezos_shell.Store.Chain_data.store -> chain_data -> Lwt.t A) -> Lwt.t A :=
let '{| chain_data := chain_data |} := function_parameter in
fun f =>
Shared.use chain_data (fun state => f (chain_data_store state) (data state)).
Definition update_chain_data {A : Type} (function_parameter : chain_state)
: (Tezos_shell.Store.Chain_data.store ->
chain_data -> Lwt.t ((option chain_data) * A)) -> Lwt.t A :=
let '{| chain_data := chain_data |} := function_parameter in
fun f =>
Shared.use chain_data
(fun state =>
op_gtgteq (f (chain_data_store state) (data state))
(fun function_parameter =>
let '(data, res) := function_parameter in
op_gtgteq
(Lwt_utils.may
(fun data =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "data" % string data in
Lwt.return_unit) data)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return res))).
Definition stored_predecessors_size : Z := 12.
Definition store_predecessors
(store : Tezos_shell.Store.Block.store)
(b : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
let fix loop (pred : Tezos_base__TzPervasives.Block_hash.t) (dist : Z)
: Lwt.t unit :=
if equiv_decb dist stored_predecessors_size then
Lwt.return_unit
else
op_gtgteq (Store.Block.Predecessors.read_opt (store, pred) (Z.sub dist 1))
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_unit
| Some p =>
op_gtgteq (Store.Block.Predecessors.store (store, b) dist p)
(fun function_parameter =>
let 'tt := function_parameter in
loop p (Z.add dist 1))
end) in
op_gtgteq
(op_gtpipeeq (Header.read_opt (store, b))
(Option.unopt_assert Stdlib.__POS__))
(fun header =>
let pred := predecessor (shell header) in
if Block_hash.equal b pred then
Lwt.return_unit
else
op_gtgteq (Store.Block.Predecessors.store (store, b) 0 pred)
(fun function_parameter =>
let 'tt := function_parameter in
loop pred 1)).
Definition predecessor_n_raw
(store : Tezos_shell__Store.Block.store)
(block_hash : Tezos_base__TzPervasives.Block_hash.t) (distance : Z)
: Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
let power_of_2 (n : Z) : Z :=
if OCaml.Stdlib.lt n 0 then
OCaml.Stdlib.invalid_arg "negative argument" % string
else
let fix loop (cnt : Z) (res : Z) : Z :=
if OCaml.Stdlib.lt cnt 1 then
res
else
loop (Z.sub cnt 1) (Z.mul res 2) in
loop n 1 in
let closest_power_two_and_rest (n : Z) : Z * Z :=
if OCaml.Stdlib.lt n 0 then
OCaml.Stdlib.invalid_arg "negative argument" % string
else
let fix loop (cnt : Z) (n : Z) (rest : Z) : Z * Z :=
if OCaml.Stdlib.le n 1 then
(cnt, rest)
else
loop (Z.add cnt 1) (Z.div n 2)
(Z.add rest (Z.mul (power_of_2 cnt) (Z.modulo n 2))) in
loop 0 n 0 in
if OCaml.Stdlib.lt distance 0 then
OCaml.Stdlib.invalid_arg
(String.append "State.predecessor: distance < 0 " % string
(OCaml.Stdlib.string_of_int distance))
else
if equiv_decb distance 0 then
Lwt.return_some block_hash
else
let fix loop
(block_hash : Tezos_base__TzPervasives.Block_hash.t) (distance : Z)
: Lwt.t (option Tezos_shell.Store.Block.Predecessors.value) :=
if equiv_decb distance 1 then
Store.Block.Predecessors.read_opt (store, block_hash) 0
else
let '(power, rest) := closest_power_two_and_rest distance in
let '(power, rest) :=
if OCaml.Stdlib.lt power stored_predecessors_size then
(power, rest)
else
let power := Z.sub stored_predecessors_size 1 in
let rest := Z.sub distance (power_of_2 power) in
(power, rest) in
op_gtgteq
(Store.Block.Predecessors.read_opt (store, block_hash) power)
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_none
| Some pred =>
if equiv_decb rest 0 then
Lwt.return_some pred
else
loop pred rest
end) in
loop block_hash distance.
Definition predecessor_n (op_staroptstar : option bool)
: Tezos_shell__Store.Block.store ->
Tezos_base__TzPervasives.Block_hash.t ->
Z -> Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
let below_save_point :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun block_store =>
fun block_hash =>
fun distance =>
op_gtgteq (predecessor_n_raw block_store block_hash distance)
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_none
| Some predecessor =>
op_gtgteq
(if below_save_point then
Header.known (block_store, predecessor)
else
Store.Block.Contents.known (block_store, predecessor))
(fun function_parameter =>
match function_parameter with
| false => Lwt.return_none
| true => Lwt.return_some predecessor
end)
end).
Definition compute_locator_from_hash
(chain_state : chain_state) (op_staroptstar : option Z)
: Tezos_base__TzPervasives.Block_hash.t ->
Tezos_base__TzPervasives.Block_locator.seed ->
Lwt.t Tezos_base__TzPervasives.Block_locator.t :=
let size :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 200
end in
fun head_hash =>
fun seed =>
op_gtgteq
(Shared.use (chain_data chain_state)
(fun state => Lwt._return (caboose (data state))))
(fun function_parameter =>
let '(_lvl, caboose) := function_parameter in
Shared.use (block_store chain_state)
(fun block_store =>
op_gtgteq
(op_gtpipeeq (Header.read_opt (block_store, head_hash))
(Option.unopt_assert Stdlib.__POS__))
(fun header =>
Block_locator.compute (predecessor_n (Some true) block_store)
caboose size head_hash header seed))).
Definition compute_locator
(chain : chain_state) (size : option Z) (head : block)
(seed : Tezos_base__TzPervasives.Block_locator.seed)
: Lwt.t Tezos_base__TzPervasives.Block_locator.t :=
compute_locator_from_hash chain size (hash head) seed.
Definition t := global_state.
Module Locked_block.
Definition store_genesis
(store : Tezos_shell__Store.Block.store) (genesis : genesis)
(context : Tezos_crypto.Context_hash.t)
: Lwt.t Tezos_base__TzPervasives.Block_header.t :=
let shell :=
{|
level :=
(* ❌ Constant of type int32 is converted to int *)
0; proto_level := 0; predecessor := block genesis;
timestamp := time genesis; validation_passes := 0;
operations_hash := Operation_list_list_hash.empty; fitness := [];
context := context |} in
let header := {| shell := shell; protocol_data := Stdlib.Bytes.create 0 |}
in
op_gtgteq
(Store.Block.Contents.store (store, (block genesis))
{| Store.Block.header := header;
Store.Block.message := Some "Genesis" % string;
Store.Block.max_operations_ttl := 0;
Store.Block.last_allowed_fork_level :=
(* ❌ Constant of type int32 is converted to int *)
0; Store.Block.context := context;
Store.Block.metadata := Stdlib.Bytes.create 0 |})
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return header).
Definition acceptable
(chain_data : chain_data_state)
(header : Tezos_base__TzPervasives.Block_header.t) : Lwt.t bool :=
let checkpoint_level := level (shell (checkpoint chain_data)) in
if OCaml.Stdlib.lt checkpoint_level (level (shell header)) then
Lwt.return_true
else
if equiv_decb checkpoint_level (level (shell header)) then
Lwt._return (Block_header.equal header (checkpoint chain_data))
else
let head_level :=
level (shell (header (current_head (data chain_data)))) in
Lwt._return (OCaml.Stdlib.lt head_level checkpoint_level).
Definition is_valid_for_checkpoint
(block_store : Tezos_shell__Store.Block.store)
(hash : Tezos_base__TzPervasives.Block_hash.t)
(header : Tezos_base__TzPervasives.Block_header.t)
(checkpoint : Tezos_base__TzPervasives.Block_header.t) : Lwt.t bool :=
if op_lt (level (shell header)) (level (shell checkpoint)) then
Lwt.return_true
else
op_gtgteq
(op_gtpipeeq
(predecessor_n None block_store hash
(apply Int32.to_int
(Int32.sub (level (shell header)) (level (shell checkpoint)))))
(Option.unopt_assert Stdlib.__POS__))
(fun predecessor =>
if Block_hash.equal predecessor (Block_header.hash checkpoint) then
Lwt.return_true
else
Lwt.return_false).
End Locked_block.
Definition locked_valid_heads_for_checkpoint
(block_store : Tezos_shell__Store.Block.store) (data : chain_data_state)
(checkpoint : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t
((list
(Tezos_base__TzPervasives.Block_hash.Set.elt *
Tezos_base__TzPervasives.Block_header.t)) *
(list
(Tezos_base__TzPervasives.Block_hash.Set.elt *
Tezos_base__TzPervasives.Block_header.t))) :=
op_gtgteq (Store.Chain_data.Known_heads.read_all (chain_data_store data))
(fun heads =>
Block_hash.Set.fold
(fun head =>
fun acc =>
let valid_header :=
op_gtgteq
(op_gtpipeeq (Header.read_opt (block_store, head))
(Option.unopt_assert Stdlib.__POS__))
(fun header =>
op_gtgteq
(Locked_block.is_valid_for_checkpoint block_store head
header checkpoint)
(fun valid => Lwt._return (valid, header))) in
op_gtgteq acc
(fun function_parameter =>
let '(valid_heads, invalid_heads) := function_parameter in
op_gtgteq valid_header
(fun function_parameter =>
let '(valid, header) := function_parameter in
if valid then
Lwt._return
((cons (head, header) valid_heads), invalid_heads)
else
Lwt._return
(valid_heads, (cons (head, header) invalid_heads)))))
heads (Lwt._return ([], []))).
Definition tag_invalid_heads
(block_store : Tezos_shell.Store.Block.Invalid_block.t)
(chain_store : Tezos_shell__Store.Chain_data.store)
(heads :
list
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t)) (level : Stdlib.Int32.t)
: Lwt.t
(list
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t)) :=
let fix tag_invalid_head
(function_parameter :
Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t)
: Lwt.t
(option
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t)) :=
let '(hash, header) := function_parameter in
if OCaml.Stdlib.le (level (Block_header.shell header)) level then
op_gtgteq (Store.Chain_data.Known_heads.store chain_store hash)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_some (hash, header))
else
let errors :=
cons (Tezos_base__TzPervasives.Checkpoint_error hash None) [] in
op_gtgteq
(Store.Block.Invalid_block.store block_store hash
{| level := level (shell header); errors := errors |})
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Store.Block.Contents.remove (block_store, hash))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Block.Operation_hashes.remove_all (block_store, hash))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Block.Operations_metadata.remove_all
(block_store, hash))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Block.Operations.remove_all (block_store, hash))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Block.Predecessors.remove_all
(block_store, hash))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Header.read_opt
(block_store, (predecessor (shell header))))
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_none
| Some header =>
tag_invalid_head
((Block_header.hash header), header)
end))))))) in
op_gtgteq
(Lwt_list.iter_p
(fun function_parameter =>
let '(hash, _header) := function_parameter in
Store.Chain_data.Known_heads.remove chain_store hash) heads)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_list.filter_map_s tag_invalid_head heads).
Definition prune_block
(store : Tezos_shell__Store.Block.store)
(block_hash : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
let st := (store, block_hash) in
op_gtgteq (Store.Block.Contents.remove st)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Store.Block.Invalid_block.remove store block_hash)
(fun function_parameter =>
let 'tt := function_parameter in
Store.Block.Operations_metadata.remove_all st)).
Definition store_header_and_prune_block
(store : Tezos_shell__Store.Block.store)
(block_hash : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
let st := (store, block_hash) in
op_gtgteq
(op_gtgteq (Store.Block.Contents.read_opt st)
(fun function_parameter =>
match function_parameter with
| Some {| header := header |} =>
Store.Block.Pruned_contents.store st {| header := header |}
| None =>
op_gtgteq (Store.Block.Pruned_contents.known st)
(fun function_parameter =>
match function_parameter with
| true => Lwt.return_unit
| false =>
State_logging.lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.String_literal
"cannot find pruned contents of block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))
"@[cannot find pruned contents of block %a@]" %
string))
(t event "missing_pruned_contents" % string))
(a Block_hash.Logging.tag block_hash))
end)
end))
(fun function_parameter =>
let 'tt := function_parameter in
prune_block store block_hash).
Definition delete_block
(store : Tezos_shell__Store.Block.store)
(block_hash : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
op_gtgteq (prune_block store block_hash)
(fun function_parameter =>
let 'tt := function_parameter in
let st := (store, block_hash) in
op_gtgteq (Store.Block.Pruned_contents.remove st)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Store.Block.Operations.remove_all st)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Store.Block.Operation_hashes.remove_all st)
(fun function_parameter =>
let 'tt := function_parameter in
Store.Block.Predecessors.remove_all st)))).
Definition cut_alternate_heads
(block_store : Tezos_shell__Store.Block.store)
(chain_store : Tezos_shell__Store.Chain_data.store)
(heads :
list
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t)) : Lwt.t unit :=
let fix cut_alternate_head
(hash : Tezos_base__TzPervasives.Block_hash.t) (header :
Tezos_base__TzPervasives.Block_header.t) : Lwt.t unit :=
op_gtgteq (Store.Chain_data.In_main_branch.known (chain_store, hash))
(fun in_chain =>
if in_chain then
Lwt.return_unit
else
op_gtgteq
(Header.read_opt
(block_store, (predecessor (Block_header.shell header))))
(fun function_parameter =>
match function_parameter with
| None =>
op_gtgteq (delete_block block_store hash)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_unit)
| Some header =>
op_gtgteq (delete_block block_store hash)
(fun function_parameter =>
let 'tt := function_parameter in
cut_alternate_head (Block_header.hash header) header)
end)) in
Lwt_list.iter_p
(fun function_parameter =>
let '(hash, header) := function_parameter in
op_gtgteq (Store.Chain_data.Known_heads.remove chain_store hash)
(fun function_parameter =>
let 'tt := function_parameter in
cut_alternate_head hash header)) heads.
Module Chain.
Record genesis := {
time : Tezos_base__TzPervasives.Time.Protocol.t;
block : Tezos_base__TzPervasives.Block_hash.t;
protocol : Tezos_base__TzPervasives.Protocol_hash.t }.
Definition genesis_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding genesis :=
conv
(fun function_parameter =>
let '{| time := time; block := block; protocol := protocol |} :=
function_parameter in
(time, block, protocol))
(fun function_parameter =>
let '(time, block, protocol) := function_parameter in
{| time := time; block := block; protocol := protocol |}) None
(obj3 (req None None "timestamp" % string Time.Protocol.encoding)
(req None None "block" % string Block_hash.encoding)
(req None None "protocol" % string Protocol_hash.encoding)).
Definition t := chain_state.
Definition chain_state := t.
Definition main (function_parameter : global_state)
: Tezos_base__TzPervasives.Chain_id.t :=
let '{| main_chain := main_chain |} := function_parameter in
main_chain.
Definition test (chain_state : chain_state)
: Lwt.t (option Tezos_base__TzPervasives.Chain_id.t) :=
read_chain_data chain_state
(fun function_parameter =>
let '_ := function_parameter in
fun chain_data => Lwt._return (test_chain chain_data)).
Definition get_level_indexed_protocol
(chain_state : chain_state)
(header : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t Tezos_base__TzPervasives.Protocol_hash.t :=
let chain_id := chain_id chain_state in
let protocol_level := proto_level (Block_header.shell header) in
let global_state := global_state chain_state in
Shared.use (global_data global_state)
(fun global_data =>
let global_store := global_store global_data in
let chain_store := Store.Chain.get global_store chain_id in
op_gtgteq
(Store.Chain.Protocol_info.read_opt chain_store protocol_level)
(fun function_parameter =>
match function_parameter with
| None =>
Pervasives.failwith
"State.Chain.get_level_index_protocol" % string
| Some (p, _) => Lwt._return p
end)).
Definition update_level_indexed_protocol_store
(chain_state : chain_state) (chain_id : Tezos_base__TzPervasives.Chain_id.t)
(protocol_level : Tezos_shell.Store.Chain.Protocol_info.key)
(protocol_hash : Tezos_base__TzPervasives.Protocol_hash.t)
(block_header : Tezos_base__TzPervasives.Block_header.t) : Lwt.t unit :=
let global_state := global_state chain_state in
op_gtgteq
(Shared.use (block_store chain_state)
(fun block_store =>
op_gtgteq
(Header.read_opt
(block_store, (predecessor (Block_header.shell block_header))))
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_none
| Some header => Lwt.return_some header
end)))
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_unit
| Some pred_header =>
if
nequiv_decb (proto_level (shell pred_header))
(proto_level (shell block_header)) then
Shared.use (global_data global_state)
(fun global_data =>
let global_store := global_store global_data in
let chain_store := Store.Chain.get global_store chain_id in
Store.Chain.Protocol_info.store chain_store protocol_level
(protocol_hash, (level (shell block_header))))
else
Lwt.return_unit
end).
Definition allocate
(genesis : genesis)
(faked_genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
(save_point : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
(caboose : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
(expiration : option Tezos_base__TzPervasives.Time.Protocol.t)
(allow_forked_chain : bool)
(current_head : Tezos_base__TzPervasives.Block_hash.t)
(checkpoint : Tezos_base__TzPervasives.Block_header.t)
(chain_id : Tezos_base__TzPervasives.Chain_id.t)
(global_state : global_state) (context_index : Tezos_storage.Context.index)
(chain_data_store : Tezos_shell.Store.Chain_data.store)
(block_store : Tezos_shell.Store.Block.store) : Lwt.t chain_state :=
op_gtgteq
(op_gtpipeeq (Header.read_opt (block_store, current_head))
(Option.unopt_assert Stdlib.__POS__))
(fun current_block_head =>
let fix chain_data : chain_data_state :=
{|
data :=
{|
current_head :=
{| chain_state := chain_state; hash := current_head;
header := current_block_head |};
current_mempool := Mempool.empty;
live_blocks := Block_hash.Set.singleton (block genesis);
live_operations := Operation_hash.Set.empty; test_chain := None;
save_point := save_point; caboose := caboose |};
checkpoint := checkpoint; chain_data_store := chain_data_store |}
with chain_state : chain_state :=
{| global_state := global_state; chain_id := chain_id;
genesis := genesis; faked_genesis_hash := faked_genesis_hash;
expiration := expiration; allow_forked_chain := allow_forked_chain;
block_store := Shared.create block_store;
context_index := Shared.create context_index;
block_watcher := Lwt_watcher.create_input tt;
chain_data :=
{| Shared.data := chain_data; Shared.lock := Lwt_mutex.create tt
|}; block_rpc_directories := Protocol_hash.Table.create 7;
header_rpc_directories := Protocol_hash.Table.create 7 |} in
Lwt._return chain_state).
Definition locked_create
(global_state : global_state) (data : global_data)
(expiration : option Tezos_base__TzPervasives.Time.Protocol.t)
(op_staroptstar : option bool)
: Tezos_base__TzPervasives.Chain_id.t ->
genesis -> Tezos_base__TzPervasives.Block_header.t -> Lwt.t chain_state :=
let allow_forked_chain :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun chain_id =>
fun genesis =>
fun genesis_header =>
let chain_store := Store.Chain.get (global_store data) chain_id in
let block_store : Tezos_shell.Store.Block.store :=
Store.Block.get chain_store
with chain_data_store : Tezos_shell.Store.Chain_data.store :=
Store.Chain_data.get chain_store in
let save_point := ((level (shell genesis_header)), (block genesis)) in
let caboose := ((level (shell genesis_header)), (block genesis)) in
let proto_level := proto_level (shell genesis_header) in
op_gtgteq (Store.Chain.Genesis_hash.store chain_store (block genesis))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Chain.Genesis_time.store chain_store (time genesis))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Chain.Genesis_protocol.store chain_store
(protocol genesis))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Chain_data.Current_head.store chain_data_store
(block genesis))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Chain_data.Known_heads.store chain_data_store
(block genesis))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Chain_data.Checkpoint.store
chain_data_store genesis_header)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Chain_data.Save_point.store
chain_data_store save_point)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Chain_data.Caboose.store
chain_data_store caboose)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Chain.Protocol_info.store
chain_store proto_level
((protocol genesis),
(level (shell genesis_header))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
match expiration with
| None => Lwt.return_unit
| Some time =>
Store.Chain.Expiration.store
chain_store time
end
(fun function_parameter =>
let 'tt := function_parameter
in
op_gtgteq
(if allow_forked_chain then
Store.Chain.Allow_forked_chain.store
(global_store data)
chain_id
else
Lwt.return_unit)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteq
(allocate genesis
(Block_header.hash
genesis_header)
save_point caboose
expiration
allow_forked_chain
(block genesis)
genesis_header
chain_id global_state
(context_index data)
chain_data_store
block_store)
(fun chain =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Chain_id.Table.add
(chains data)
chain_id chain in
Lwt._return chain)))))))))))).
Definition create
(state : global_state) (allow_forked_chain : option bool)
(commit_genesis :
Tezos_base__TzPervasives.Chain_id.t ->
Tezos_base__TzPervasives.Time.Protocol.t ->
Tezos_base__TzPervasives.Protocol_hash.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_crypto.Context_hash.t))
(genesis : genesis) (chain_id : Tezos_base__TzPervasives.Chain_id.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
Shared.use (global_data state)
(fun data =>
let chain_store := Store.Chain.get (global_store data) chain_id in
let block_store := Store.Block.get chain_store in
if Chain_id.Table.mem (chains data) chain_id then
Pervasives.failwith "State.Chain.create" % string
else
op_gtgteqquestion
(commit_genesis chain_id (time genesis) (protocol genesis))
(fun commit =>
op_gtgteq (Locked_block.store_genesis block_store genesis commit)
(fun genesis_header =>
op_gtgteq
(locked_create state data None allow_forked_chain chain_id
genesis genesis_header)
(fun chain =>
op_gtgteq
(Store.Forking_block_hash.remove (global_store data)
(Context.compute_testchain_chain_id (block genesis)))
(fun function_parameter =>
let 'tt := function_parameter in
_return chain))))).
Definition locked_read
(global_state : global_state) (data : global_data)
(chain_id : Tezos_base__TzPervasives.Chain_id.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
let chain_store := Store.Chain.get (global_store data) chain_id in
let block_store : Tezos_shell.Store.Block.store :=
Store.Block.get chain_store
with chain_data_store : Tezos_shell.Store.Chain_data.store :=
Store.Chain_data.get chain_store in
op_gtgteqquestion (Store.Chain.Genesis_hash.read chain_store)
(fun genesis_hash =>
op_gtgteqquestion (Store.Chain.Genesis_time.read chain_store)
(fun time =>
op_gtgteqquestion (Store.Chain.Genesis_protocol.read chain_store)
(fun protocol =>
op_gtgteq (Store.Chain.Expiration.read_opt chain_store)
(fun expiration =>
op_gtgteq
(Store.Chain.Allow_forked_chain.known (global_store data)
chain_id)
(fun allow_forked_chain =>
op_gtgteqquestion
(Header.read (block_store, genesis_hash))
(fun genesis_header =>
let genesis :=
{| time := time; block := genesis_hash;
protocol := protocol |} in
op_gtgteqquestion
(Store.Chain_data.Current_head.read
chain_data_store)
(fun current_head =>
op_gtgteqquestion
(Store.Chain_data.Checkpoint.read
chain_data_store)
(fun checkpoint =>
op_gtgteqquestion
(Store.Chain_data.Save_point.read
chain_data_store)
(fun save_point =>
op_gtgteqquestion
(Store.Chain_data.Caboose.read
chain_data_store)
(fun caboose =>
(* ❌ Try-with are not handled *)
try
(op_gtgteq
(allocate genesis
(Block_header.hash
genesis_header) save_point
caboose expiration
allow_forked_chain
current_head checkpoint
chain_id global_state
(context_index data)
chain_data_store block_store)
_return))))))))))).
Definition locked_read_all (global_state : global_state) (data : global_data)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (Store.Chain.list (global_store data))
(fun ids =>
iter_p
(fun id =>
op_gtgteqquestion (locked_read global_state data id)
(fun chain =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Chain_id.Table.add (chains data) id chain in
return_unit)) ids).
Definition read_all (state : global_state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
Shared.use (global_data state) (fun data => locked_read_all state data).
Definition get_exn
(state : global_state) (id : Tezos_base__TzPervasives.Chain_id.Table.key)
: Lwt.t chain_state :=
Shared.use (global_data state)
(fun data => Lwt._return (Chain_id.Table.find (chains data) id)).
Definition get_opt
(state : global_state) (id : Tezos_base__TzPervasives.Chain_id.Table.key)
: Lwt.t (option chain_state) :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (get_exn state id) Lwt.return_some)
(fun function_parameter =>
let '_ := function_parameter in
Lwt.return_none).
Definition get
(state : global_state) (id : Tezos_base__TzPervasives.Chain_id.Table.key)
: Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (get_exn state id) _return)
(fun function_parameter =>
match function_parameter with
| OCaml.Not_found => fail (Tezos_base__TzPervasives.Unknown_chain id)
| exn => Lwt.fail exn
end).
Definition all (state : global_state) : Lwt.t (list chain_state) :=
Shared.use (global_data state)
(fun function_parameter =>
let '{| chains := chains |} := function_parameter in
apply Lwt._return
(Chain_id.Table.fold
(fun function_parameter =>
let '_ := function_parameter in
fun chain => fun acc => cons chain acc) chains [])).
Definition id (function_parameter : chain_state)
: Tezos_base__TzPervasives.Chain_id.t :=
let '{| chain_id := chain_id |} := function_parameter in
chain_id.
Definition genesis (function_parameter : chain_state) : genesis :=
let '{| genesis := genesis |} := function_parameter in
genesis.
Definition faked_genesis_hash (function_parameter : chain_state)
: Tezos_base__TzPervasives.Block_hash.t :=
let '{| faked_genesis_hash := faked_genesis_hash |} := function_parameter in
faked_genesis_hash.
Definition expiration (function_parameter : chain_state)
: option Tezos_base__TzPervasives.Time.Protocol.t :=
let '{| expiration := expiration |} := function_parameter in
expiration.
Definition allow_forked_chain (function_parameter : chain_state) : bool :=
let '{| allow_forked_chain := allow_forked_chain |} := function_parameter in
allow_forked_chain.
Definition global_state (function_parameter : chain_state) : global_state :=
let '{| global_state := global_state |} := function_parameter in
global_state.
Definition checkpoint (chain_state : chain_state)
: Lwt.t Tezos_base__TzPervasives.Block_header.t :=
Shared.use (chain_data chain_state)
(fun function_parameter =>
let '{| checkpoint := checkpoint |} := function_parameter in
Lwt._return checkpoint).
Definition save_point (chain_state : chain_state)
: Lwt.t (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t) :=
Shared.use (chain_data chain_state)
(fun state => Lwt._return (save_point (data state))).
Definition caboose (chain_state : chain_state)
: Lwt.t (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t) :=
Shared.use (chain_data chain_state)
(fun state => Lwt._return (caboose (data state))).
Definition purge_loop_full (op_staroptstar : option Z)
: Tezos_shell.Store.t ->
Tezos_shell__Store.Block.store ->
Tezos_base__TzPervasives.Block_hash.t ->
Tezos_base__TzPervasives.Block_hash.t -> Stdlib.Int32.t -> Lwt.t unit :=
let chunk_size :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 4000
end in
fun global_store =>
fun store =>
fun genesis_hash =>
fun block_hash =>
fun caboose_level =>
let do_prune (blocks : list Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t unit :=
apply (Store.with_atomic_rw global_store)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_list.iter_s (store_header_and_prune_block store) blocks)
in
let fix loop
(block_hash : Tezos_base__TzPervasives.Block_hash.t)
(function_parameter :
Z * (list Tezos_base__TzPervasives.Block_hash.t))
: Lwt.t unit :=
let '(n_blocks, blocks) := function_parameter in
op_gtgteq
(if OCaml.Stdlib.ge n_blocks chunk_size then
op_gtgteq (do_prune blocks)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return (0, []))
else
Lwt._return (n_blocks, blocks))
(fun function_parameter =>
let '(n_blocks, blocks) := function_parameter in
op_gtgteq
(op_gtpipeeq (Header.read_opt (store, block_hash))
(Option.unopt_assert Stdlib.__POS__))
(fun header =>
if Block_hash.equal block_hash genesis_hash then
do_prune blocks
else
if equiv_decb (level (shell header)) caboose_level
then
do_prune (cons block_hash blocks)
else
loop (predecessor (shell header))
((Z.add n_blocks 1), (cons block_hash blocks))))
in
op_gtgteq
(op_gtpipeeq (Header.read_opt (store, block_hash))
(Option.unopt_assert Stdlib.__POS__))
(fun header => loop (predecessor (shell header)) (0, [])).
Definition purge_full
(chain_state : chain_state)
(function_parameter : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '(lvl, hash) := function_parameter in
Shared.use (global_data (global_state chain_state))
(fun global_data =>
Shared.use (block_store chain_state)
(fun store =>
op_gtgteq
(update_chain_data chain_state
(fun function_parameter =>
let '_ := function_parameter in
fun data =>
op_gtgteq
(purge_loop_full None (global_store global_data) store
(block (genesis chain_state)) hash
(fst (save_point data)))
(fun function_parameter =>
let 'tt := function_parameter in
let new_data :=
(* ❌ Record substitution not handled *)
record_substitution in
Lwt._return ((Some new_data), tt))))
(fun function_parameter =>
let 'tt := function_parameter in
Shared.use (chain_data chain_state)
(fun data =>
op_gtgteq
(Store.Chain_data.Save_point.store (chain_data_store data)
(lvl, hash))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))).
Definition purge_loop_rolling
(global_store : Tezos_shell.Store.t)
(store : Tezos_shell__Store.Block.store)
(genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
(block_hash : Tezos_base__TzPervasives.Block_hash.t) (limit : Z)
: Lwt.t Tezos_base__TzPervasives.Block_hash.t :=
let do_delete (blocks : list Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t unit :=
apply (Store.with_atomic_rw global_store)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_list.iter_s (delete_block store) blocks) in
let fix prune_loop
(block_hash : Tezos_base__TzPervasives.Block_hash.t) (limit : Z)
: Lwt.t Tezos_base__TzPervasives.Block_hash.t :=
if Block_hash.equal genesis_hash block_hash then
Lwt._return block_hash
else
if equiv_decb limit 1 then
op_gtgteq (Header.read_opt (store, block_hash))
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some header =>
op_gtgteq (store_header_and_prune_block store block_hash)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (delete_loop (predecessor (shell header)) (0, []))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return block_hash))
end)
else
op_gtgteq (Header.read_opt (store, block_hash))
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some header =>
op_gtgteq (store_header_and_prune_block store block_hash)
(fun function_parameter =>
let 'tt := function_parameter in
prune_loop (predecessor (shell header)) (Z.sub limit 1))
end)
with delete_loop
(block_hash : Tezos_crypto.Block_hash.t) (function_parameter :
Z * (list Tezos_base__TzPervasives.Block_hash.t)) : Lwt.t unit :=
let '(n_blocks, blocks) := function_parameter in
op_gtgteq
(if OCaml.Stdlib.ge n_blocks 4000 then
op_gtgteq (do_delete blocks)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return (0, []))
else
Lwt._return (n_blocks, blocks))
(fun function_parameter =>
let '(n_blocks, blocks) := function_parameter in
op_gtgteq (Header.read_opt (store, block_hash))
(fun function_parameter =>
match function_parameter with
| None => do_delete blocks
| Some header =>
if Block_hash.equal genesis_hash block_hash then
do_delete blocks
else
delete_loop (predecessor (shell header))
((Z.add n_blocks 1), (cons block_hash blocks))
end)) in
op_gtgteq
(op_gtpipeeq (Header.read_opt (store, block_hash))
(Option.unopt_assert Stdlib.__POS__))
(fun header =>
if equiv_decb limit 0 then
op_gtgteq (delete_loop (predecessor (shell header)) (0, []))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return block_hash)
else
prune_loop (predecessor (shell header)) limit).
Definition purge_rolling
(chain_state : chain_state)
(function_parameter : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '(lvl, hash) as checkpoint := function_parameter in
Shared.use (global_data (global_state chain_state))
(fun global_data =>
Shared.use (block_store chain_state)
(fun store =>
op_gtgteqquestion
(op_gtgteq (Store.Block.Contents.read_opt (store, hash))
(fun function_parameter =>
match function_parameter with
| None =>
fail
(Tezos_base__TzPervasives.Block_contents_not_found hash)
| Some contents => _return contents
end))
(fun contents =>
let max_op_ttl := max_operations_ttl contents in
let limit := max_op_ttl in
op_gtgteq
(purge_loop_rolling (global_store global_data) store
(block (genesis chain_state)) hash limit)
(fun caboose_hash =>
let caboose_level := Int32.sub lvl (Int32.of_int max_op_ttl)
in
let caboose := (caboose_level, caboose_hash) in
op_gtgteq
(update_chain_data chain_state
(fun function_parameter =>
let '_ := function_parameter in
fun data =>
let new_data :=
(* ❌ Record substitution not handled *)
record_substitution in
Lwt._return ((Some new_data), tt)))
(fun function_parameter =>
let 'tt := function_parameter in
Shared.use (chain_data chain_state)
(fun data =>
op_gtgteq
(Store.Chain_data.Save_point.store
(chain_data_store data) checkpoint)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Chain_data.Caboose.store
(chain_data_store data) caboose)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))))))).
Definition set_checkpoint
(chain_state : chain_state)
(checkpoint : Tezos_base__TzPervasives.Block_header.t) : Lwt.t unit :=
Shared.use (block_store chain_state)
(fun store =>
Shared.use (chain_data chain_state)
(fun data =>
let head_header := header (current_head (data data)) in
let head_hash := hash (current_head (data data)) in
op_gtgteq
(Locked_block.is_valid_for_checkpoint store head_hash head_header
checkpoint)
(fun valid =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert valid in
op_gtgteq
(Store.Block.Invalid_block.iter store
(fun hash =>
fun iblock =>
if
OCaml.Stdlib.le (level iblock)
(level (shell checkpoint)) then
Store.Block.Invalid_block.remove store hash
else
Lwt.return_unit))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtgteq
(locked_valid_heads_for_checkpoint store data checkpoint)
(fun function_parameter =>
let '(valid_heads, invalid_heads) :=
function_parameter in
op_gtgteq
(tag_invalid_heads store (chain_data_store data)
invalid_heads (level (shell checkpoint)))
(fun outdated_invalid_heads =>
if
OCaml.Stdlib.lt (level (shell head_header))
(level (shell checkpoint)) then
Lwt.return_unit
else
let outdated_valid_heads :=
List.filter
(fun function_parameter =>
let
'(hash, {|
Block_header.shell := shell |}) :=
function_parameter in
andb
(OCaml.Stdlib.le (level shell)
(level (shell checkpoint)))
(negb (Block_hash.equal hash head_hash)))
valid_heads in
op_gtgteq
(cut_alternate_heads store
(chain_data_store data) outdated_valid_heads)
(fun function_parameter =>
let 'tt := function_parameter in
cut_alternate_heads store
(chain_data_store data)
outdated_invalid_heads))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Chain_data.Checkpoint.store
(chain_data_store data) checkpoint)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field data "checkpoint" % string
checkpoint in
Lwt.return_unit)))))).
Definition set_checkpoint_then_purge_full
(chain_state : chain_state)
(checkpoint : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (set_checkpoint chain_state checkpoint)
(fun function_parameter =>
let 'tt := function_parameter in
let lvl := level (shell checkpoint) in
let hash := Block_header.hash checkpoint in
purge_full chain_state (lvl, hash)).
Definition set_checkpoint_then_purge_rolling
(chain_state : chain_state)
(checkpoint : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (set_checkpoint chain_state checkpoint)
(fun function_parameter =>
let 'tt := function_parameter in
let lvl := level (shell checkpoint) in
let hash := Block_header.hash checkpoint in
purge_rolling chain_state (lvl, hash)).
Definition acceptable_block
(chain_state : chain_state)
(header : Tezos_base__TzPervasives.Block_header.t) : Lwt.t bool :=
Shared.use (chain_data chain_state)
(fun chain_data => Locked_block.acceptable chain_data header).
Definition destroy (state : global_state) (chain : chain_state)
: Lwt.t unit :=
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "destroy " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"destroy %a" % string)) (t event "destroy" % string))
(a chain_id (id chain))))
(fun function_parameter =>
let 'tt := function_parameter in
Shared.use (global_data state)
(fun function_parameter =>
let '{| chains := chains; global_store := global_store |} :=
function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Chain_id.Table.remove chains (id chain) in
Store.Chain.destroy global_store (id chain))).
Definition store (chain_state : chain_state) : Lwt.t Tezos_shell.Store.t :=
Shared.use (global_data (global_state chain_state))
(fun global_data => Lwt._return (global_store global_data)).
End Chain.
Module Block.
Record t := {
chain_state : Chain.t;
hash : Tezos_base__TzPervasives.Block_hash.t;
header : Tezos_base__TzPervasives.Block_header.t }.
Definition block := t.
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition compare (b1 : t) (b2 : t) : Z :=
Block_hash.compare (hash b1) (hash b2).
Definition equal (b1 : t) (b2 : t) : bool :=
Block_hash.equal (hash b1) (hash b2).
Definition hash (function_parameter : t)
: Tezos_base__TzPervasives.Block_hash.t :=
let '{| hash := hash |} := function_parameter in
hash.
Definition header (function_parameter : t)
: Tezos_base__TzPervasives.Block_header.t :=
let '{| header := header |} := function_parameter in
header.
Definition read_contents (block : t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_shell__Store.Block.contents) :=
Shared.use (block_store (chain_state block))
(fun store =>
op_gtgteq (Store.Block.Contents.read_opt (store, (hash block)))
(fun function_parameter =>
match function_parameter with
| None =>
fail
(Tezos_base__TzPervasives.Block_contents_not_found (hash block))
| Some contents => _return contents
end)).
Definition header_of_hash
(chain_state : chain_state) (hash : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t (option Tezos_base__TzPervasives.Block_header.t) :=
Shared.use (block_store chain_state)
(fun store => Header.read_opt (store, hash)).
Definition metadata (b : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
op_gtgteqquestion (read_contents b)
(fun function_parameter =>
let '{| metadata := metadata |} := function_parameter in
_return metadata).
Definition chain_state (function_parameter : t) : Chain.t :=
let '{| chain_state := chain_state |} := function_parameter in
chain_state.
Definition chain_id (function_parameter : t)
: Tezos_base__TzPervasives.Chain_id.t :=
let '{| chain_state := {| chain_id := chain_id |} |} := function_parameter
in
chain_id.
Definition shell_header (function_parameter : t)
: Tezos_base__TzPervasives.Block_header.shell_header :=
let '{| header := {| shell := shell |} |} := function_parameter in
shell.
Definition timestamp (b : t) : Tezos_base.Time.Protocol.t :=
timestamp (shell_header b).
Definition fitness (b : t) : Tezos_base.Fitness.t := fitness (shell_header b).
Definition level (b : t) : Stdlib.Int32.t := level (shell_header b).
Definition validation_passes (b : t) : Z := validation_passes (shell_header b).
Definition message (b : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult (option string)) :=
op_gtgteqquestion (read_contents b)
(fun function_parameter =>
let '{| message := message |} := function_parameter in
_return message).
Definition max_operations_ttl (b : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Z) :=
op_gtgteqquestion (read_contents b)
(fun function_parameter =>
let '{| max_operations_ttl := max_operations_ttl |} :=
function_parameter in
_return max_operations_ttl).
Definition last_allowed_fork_level (b : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Int32.t) :=
op_gtgteqquestion (read_contents b)
(fun function_parameter =>
let '{| last_allowed_fork_level := last_allowed_fork_level |} :=
function_parameter in
_return last_allowed_fork_level).
Definition is_genesis (b : t) : bool :=
Block_hash.equal (hash b) (block (genesis (chain_state b))).
Definition known_valid
(chain_state : chain_state) (hash : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t bool :=
Shared.use (block_store chain_state)
(fun store => Header.known (store, hash)).
Definition known_invalid
(chain_state : chain_state)
(hash : Tezos_shell.Store.Block.Invalid_block.key) : Lwt.t bool :=
Shared.use (block_store chain_state)
(fun store => Store.Block.Invalid_block.known store hash).
Definition read_invalid
(chain_state : chain_state)
(hash : Tezos_shell.Store.Block.Invalid_block.key)
: Lwt.t (option Tezos_shell.Store.Block.Invalid_block.value) :=
Shared.use (block_store chain_state)
(fun store => Store.Block.Invalid_block.read_opt store hash).
Definition list_invalid (chain_state : chain_state)
: Lwt.t
(list
(Tezos_shell.Store.Block.Invalid_block.key * int32 *
(list Tezos_base__TzPervasives.Error_monad.error))) :=
Shared.use (block_store chain_state)
(fun store =>
Store.Block.Invalid_block.fold store []
(fun hash =>
fun function_parameter =>
let '{| level := level; errors := errors |} := function_parameter
in
fun acc => Lwt._return (cons (hash, level, errors) acc))).
Definition unmark_invalid
(chain_state : chain_state)
(block : Tezos_shell.Store.Block.Invalid_block.key)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
Shared.use (block_store chain_state)
(fun store =>
op_gtgteq (Store.Block.Invalid_block.known store block)
(fun mem =>
if mem then
op_gtgteq (Store.Block.Invalid_block.remove store block) _return
else
fail (Tezos_base__TzPervasives.Block_not_invalid block))).
Definition is_valid_for_checkpoint
(block : t) (checkpoint : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t bool :=
let chain_state := chain_state block in
Shared.use (block_store chain_state)
(fun store =>
Locked_block.is_valid_for_checkpoint store (hash block) (header block)
checkpoint).
Definition read_predecessor
(chain_state : chain_state) (pred : Z) (op_staroptstar : option bool)
: Tezos_base__TzPervasives.Block_hash.t -> Lwt.t (option t) :=
let below_save_point :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun hash =>
Shared.use (block_store chain_state)
(fun store =>
op_gtgteq (predecessor_n (Some below_save_point) store hash pred)
(fun hash_opt =>
let new_hash_opt :=
match hash_opt with
| (Some _) as hash_opt => hash_opt
| None =>
if Block_hash.equal hash (block (genesis chain_state)) then
Some (block (genesis chain_state))
else
None
end in
match new_hash_opt with
| None => Lwt.fail OCaml.Not_found
| Some hash =>
op_gtgteq (Header.read_opt (store, hash))
(fun header =>
match header with
| Some header =>
Lwt.return_some
{| chain_state := chain_state; hash := hash;
header := header |}
| None => Lwt.return_none
end)
end)).
Definition read
(chain_state : Chain.t) (hash : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
Shared.use (block_store chain_state)
(fun store =>
op_gtgteqquestion (Header.read (store, hash))
(fun header =>
_return
{| chain_state := chain_state; hash := hash; header := header |})).
Definition read_opt
(chain_state : Chain.t) (hash : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t (option t) :=
op_gtgteq (read chain_state hash)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ => Lwt.return_none
| Stdlib.Ok v => Lwt.return_some v
end).
Definition predecessor (function_parameter : t) : Lwt.t (option t) :=
let '{| chain_state := chain_state; hash := hash; header := header |} :=
function_parameter in
if Block_hash.equal hash (predecessor (shell header)) then
Lwt.return_none
else
read_opt chain_state (predecessor (shell header)).
Definition predecessor_n (b : t) (n : Z)
: Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
Shared.use (block_store (chain_state b))
(fun block_store => predecessor_n None block_store (hash b) n).
Definition store (op_staroptstar : option bool)
: chain_state ->
Tezos_base__TzPervasives.Block_header.t ->
Stdlib.Bytes.t ->
(list (list Tezos_base__TzPervasives.Operation.t)) ->
(list (list Stdlib.Bytes.t)) ->
Tezos_validation.Block_validation.validation_store ->
bool -> Lwt.t (Tezos_base__TzPervasives.tzresult (option t)) :=
let dont_enforce_context_hash :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun chain_state =>
fun block_header =>
fun block_header_metadata =>
fun operations =>
fun operations_metadata =>
fun function_parameter =>
let '{|
context_hash := context_hash;
message := message;
max_operations_ttl := max_operations_ttl;
last_allowed_fork_level := last_allowed_fork_level
|} := function_parameter in
fun forking_testchain =>
let bytes := Block_header.to_bytes block_header in
let hash := Block_header.hash_raw string in
op_gtgteqquestion
(fail_unless
(equiv_decb (validation_passes (shell block_header))
(List.length operations))
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"State.Block.store: invalid operations length" %
string CamlinternalFormatBasics.End_of_format)
"State.Block.store: invalid operations length" %
string)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_unless
(equiv_decb (validation_passes (shell block_header))
(List.length operations_metadata))
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"State.Block.store: invalid operations_data length"
% string
CamlinternalFormatBasics.End_of_format)
"State.Block.store: invalid operations_data length"
% string)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_unless
(List.for_all2
(fun l1 =>
fun l2 =>
equiv_decb (List.length l1) (List.length l2))
operations operations_metadata)
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"State.Block.store: inconsistent operations and operations_data"
% string
CamlinternalFormatBasics.End_of_format)
"State.Block.store: inconsistent operations and operations_data"
% string)))
(fun function_parameter =>
let 'tt := function_parameter in
Shared.use (block_store chain_state)
(fun store =>
op_gtgteq
(Store.Block.Invalid_block.known store hash)
(fun known_invalid =>
op_gtgteqquestion
(fail_when known_invalid
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Known invalid" % string
CamlinternalFormatBasics.End_of_format)
"Known invalid" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.Block.Contents.known
(store, hash))
(fun known =>
if known then
return_none
else
op_gtgteq
(let predecessor :=
predecessor
(shell block_header) in
op_gtgteq
(Header.known
(store, predecessor))
(fun valid_predecessor =>
if negb valid_predecessor
then
Lwt.return_false
else
Shared.use
(chain_data
chain_state)
(fun chain_data =>
Locked_block.acceptable
chain_data
block_header)))
(fun acceptable_block =>
op_gtgteqquestion
(fail_unless
acceptable_block
(Tezos_base__TzPervasives.Checkpoint_error
hash None))
(fun function_parameter =>
let 'tt :=
function_parameter in
let commit :=
context_hash in
op_gtgteq
(Context._exists
(data
(context_index
chain_state))
commit)
(fun _exists =>
op_gtgteqquestion
(fail_unless
_exists
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"State.Block.store: context hash not found in context"
% string
CamlinternalFormatBasics.End_of_format)
"State.Block.store: context hash not found in context"
% string)))
(fun
function_parameter
=>
let '_ :=
function_parameter
in
op_gtgteqquestion
(fail_unless
(orb
dont_enforce_context_hash
(Context_hash.equal
(context
(shell
block_header))
commit))
(Tezos_base__TzPervasives.Inconsistent_hash
commit
(context
(shell
block_header))))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
let
header :=
if
dont_enforce_context_hash
then
(* ❌ Record substitution not handled *)
record_substitution
else
block_header
in
let
contents :=
{|
Store.Block.header :=
header;
Store.Block.message :=
message;
Store.Block.max_operations_ttl :=
max_operations_ttl;
Store.Block.last_allowed_fork_level :=
last_allowed_fork_level;
Store.Block.context :=
commit;
Store.Block.metadata :=
block_header_metadata
|} in
op_gtgteq
(Store.Block.Contents.store
(store,
hash)
contents)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(Lwt_list.iteri_p
(fun
i
=>
fun
ops
=>
Store.Block.Operation_hashes.store
(store,
hash)
i
(List.map
Operation.hash
ops))
operations)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(Lwt_list.iteri_p
(fun
i
=>
fun
ops
=>
Store.Block.Operations.store
(store,
hash)
i
ops)
operations)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(Lwt_list.iteri_p
(fun
i
=>
fun
ops
=>
Store.Block.Operations_metadata.store
(store,
hash)
i
ops)
operations_metadata)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(store_predecessors
store
hash)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(Shared.use
(chain_data
chain_state)
(fun
chain_data
=>
let
store :=
chain_data_store
chain_data
in
let
predecessor :=
predecessor
(shell
block_header)
in
op_gtgteq
(Store.Chain_data.Known_heads.remove
store
predecessor)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
Store.Chain_data.Known_heads.store
store
hash)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(if
forking_testchain
then
Shared.use
(global_data
(global_state
chain_state))
(fun
global_data
=>
let
genesis :=
Context.compute_testchain_genesis
hash
in
Store.Forking_block_hash.store
(global_store
global_data)
(Context.compute_testchain_chain_id
genesis)
hash)
else
Lwt.return_unit)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
let
block :=
{|
chain_state :=
chain_state;
hash :=
hash;
header :=
header
|}
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
Lwt_watcher.notify
(block_watcher
chain_state)
block
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
Lwt_watcher.notify
(block_watcher
(global_state
chain_state))
block
in
return_some
block))))))))))))))))))).
Definition store_invalid
(chain_state : chain_state)
(block_header : Tezos_base__TzPervasives.Block_header.t)
(errors : list Tezos_base__TzPervasives.Error_monad.error)
: Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
let bytes := Block_header.to_bytes block_header in
let hash := Block_header.hash_raw string in
Shared.use (block_store chain_state)
(fun store =>
op_gtgteq (Header.known (store, hash))
(fun known_valid =>
op_gtgteqquestion
(fail_when known_valid
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Known valid" % string
CamlinternalFormatBasics.End_of_format)
"Known valid" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Store.Block.Invalid_block.known store hash)
(fun known_invalid =>
if known_invalid then
return_false
else
op_gtgteq
(Store.Block.Invalid_block.store store hash
{| level := level (shell block_header);
errors := errors |})
(fun function_parameter =>
let 'tt := function_parameter in
return_true))))).
Definition watcher (state : chain_state)
: (Lwt_stream.t block) * Tezos_base__TzPervasives.Lwt_watcher.stopper :=
Lwt_watcher.create_stream (block_watcher state).
Definition compute_operation_path
(hashes : list (list Tezos_base__TzPervasives.Operation_list_hash.elt))
: Z -> Tezos_base__TzPervasives.Operation_list_list_hash.path :=
let list_hashes := List.map Operation_list_hash.compute hashes in
Operation_list_list_hash.compute_path list_hashes.
Definition operation_hashes (function_parameter : t)
: Z ->
Lwt.t
(Tezos_shell.Store.Block.Operation_hashes.value *
Tezos_base__TzPervasives.Operation_list_list_hash.path) :=
let '{| chain_state := chain_state; hash := hash; header := header |} :=
function_parameter in
fun i =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
orb (OCaml.Stdlib.lt i 0)
(OCaml.Stdlib.le (validation_passes (shell header)) i) then
OCaml.Stdlib.invalid_arg "State.Block.operations" % string
else
tt in
Shared.use (block_store chain_state)
(fun store =>
op_gtgteq
(Lwt_list.map_p
(fun n =>
op_gtpipeeq
(Store.Block.Operation_hashes.read_opt (store, hash) n)
(Option.unopt_assert Stdlib.__POS__))
(op_minusminus 0 (Z.sub (validation_passes (shell header)) 1)))
(fun hashes =>
let path := compute_operation_path hashes in
Lwt._return ((List.nth hashes i), (path i)))).
Definition all_operation_hashes (function_parameter : t)
: Lwt.t (list Tezos_shell.Store.Block.Operation_hashes.value) :=
let '{| chain_state := chain_state; hash := hash; header := header |} :=
function_parameter in
Shared.use (block_store chain_state)
(fun store =>
Lwt_list.map_p
(fun i =>
op_gtpipeeq (Store.Block.Operation_hashes.read_opt (store, hash) i)
(Option.unopt_assert Stdlib.__POS__))
(op_minusminus 0 (Z.sub (validation_passes (shell header)) 1))).
Definition operations (function_parameter : t)
: Tezos_shell.Store.Block.Operations.key ->
Lwt.t
(Tezos_shell.Store.Block.Operations.value *
Tezos_base__TzPervasives.Operation_list_list_hash.path) :=
let '{| chain_state := chain_state; hash := hash; header := header |} :=
function_parameter in
fun i =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
orb (OCaml.Stdlib.lt i 0)
(OCaml.Stdlib.le (validation_passes (shell header)) i) then
OCaml.Stdlib.invalid_arg "State.Block.operations" % string
else
tt in
Shared.use (block_store chain_state)
(fun store =>
op_gtgteq
(Lwt_list.map_p
(fun n =>
op_gtpipeeq
(Store.Block.Operation_hashes.read_opt (store, hash) n)
(Option.unopt_assert Stdlib.__POS__))
(op_minusminus 0 (Z.sub (validation_passes (shell header)) 1)))
(fun hashes =>
let path := compute_operation_path hashes in
op_gtgteq
(op_gtpipeeq (Store.Block.Operations.read_opt (store, hash) i)
(Option.unopt_assert Stdlib.__POS__))
(fun ops => Lwt._return (ops, (path i))))).
Definition operations_metadata (function_parameter : t)
: Tezos_shell.Store.Block.Operations_metadata.key ->
Lwt.t Tezos_shell.Store.Block.Operations_metadata.value :=
let '{| chain_state := chain_state; hash := hash; header := header |} :=
function_parameter in
fun i =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
orb (OCaml.Stdlib.lt i 0)
(OCaml.Stdlib.le (validation_passes (shell header)) i) then
OCaml.Stdlib.invalid_arg "State.Block.operations_metadata" % string
else
tt in
Shared.use (block_store chain_state)
(fun store =>
op_gtpipeeq (Store.Block.Operations_metadata.read_opt (store, hash) i)
(Option.unopt_assert Stdlib.__POS__)).
Definition all_operations (function_parameter : t)
: Lwt.t (list Tezos_shell.Store.Block.Operations.value) :=
let '{| chain_state := chain_state; hash := hash; header := header |} :=
function_parameter in
Shared.use (block_store chain_state)
(fun store =>
Lwt_list.map_p
(fun i =>
op_gtpipeeq (Store.Block.Operations.read_opt (store, hash) i)
(Option.unopt_assert Stdlib.__POS__))
(op_minusminus 0 (Z.sub (validation_passes (shell header)) 1))).
Definition all_operations_metadata (function_parameter : t)
: Lwt.t (list Tezos_shell.Store.Block.Operations_metadata.value) :=
let '{| chain_state := chain_state; hash := hash; header := header |} :=
function_parameter in
Shared.use (block_store chain_state)
(fun store =>
Lwt_list.map_p
(fun i =>
op_gtpipeeq
(Store.Block.Operations_metadata.read_opt (store, hash) i)
(Option.unopt_assert Stdlib.__POS__))
(op_minusminus 0 (Z.sub (validation_passes (shell header)) 1))).
Definition context_exn (function_parameter : t)
: Lwt.t Tezos_storage.Context.context :=
let '{| chain_state := chain_state; hash := hash |} := function_parameter in
op_gtgteq
(op_gtpipeeq
(Shared.use (block_store chain_state)
(fun block_store => Store.Block.Contents.read_opt (block_store, hash)))
(Option.unopt_assert Stdlib.__POS__))
(fun function_parameter =>
let '{| context := commit |} := function_parameter in
Shared.use (context_index chain_state)
(fun context_index => Context.checkout_exn context_index commit)).
Definition context_opt (function_parameter : t)
: Lwt.t (option Tezos_storage.Context.context) :=
let '{| chain_state := chain_state; hash := hash |} := function_parameter in
op_gtgteq
(op_gtpipeeq
(Shared.use (block_store chain_state)
(fun block_store => Store.Block.Contents.read_opt (block_store, hash)))
(Option.unopt_assert Stdlib.__POS__))
(fun function_parameter =>
let '{| context := commit |} := function_parameter in
Shared.use (context_index chain_state)
(fun context_index => Context.checkout context_index commit)).
Definition context (block : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_storage.Context.context) :=
op_gtgteq (context_opt block)
(fun function_parameter =>
match function_parameter with
| Some context => _return context
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"State.Block.context failed to checkout context" % string
CamlinternalFormatBasics.End_of_format)
"State.Block.context failed to checkout context" % string)
end).
Definition protocol_hash (block : t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Protocol_hash.t) :=
op_gtgteqquestion (context block)
(fun context => op_gtgteq (Context.get_protocol context) _return).
Definition protocol_hash_exn (block : t)
: Lwt.t Tezos_base__TzPervasives.Protocol_hash.t :=
op_gtgteq (context_exn block) (fun context => Context.get_protocol context).
Definition protocol_level (block : t) : Z :=
proto_level (shell (header block)).
Definition test_chain (block : t)
: Lwt.t (Tezos_base__TzPervasives.Test_chain_status.t * (option t)) :=
op_gtgteq (context_exn block)
(fun context =>
op_gtgteq (Context.get_test_chain context)
(fun status =>
let lookup_testchain
(genesis : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.Test_chain_status.t * (option t)) :=
let chain_id := Context.compute_testchain_chain_id genesis in
op_gtgteq
(Shared.use (global_data (global_state (chain_state block)))
(fun global_data =>
Store.Forking_block_hash.read_opt (global_store global_data)
chain_id))
(fun function_parameter =>
match function_parameter with
| Some forking_block_hash =>
op_gtgteq (read_opt (chain_state block) forking_block_hash)
(fun forking_block => Lwt._return (status, forking_block))
| None => Lwt._return (status, None)
end) in
match status with
|
Tezos_base__TzPervasives.Test_chain_status.Running {|
genesis := genesis |} => lookup_testchain genesis
| Tezos_base__TzPervasives.Test_chain_status.Forking _ =>
Lwt._return (status, (Some block))
| Tezos_base__TzPervasives.Test_chain_status.Not_running =>
Lwt._return (status, None)
end)).
Definition known
(chain_state : chain_state) (hash : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t bool :=
Shared.use (block_store chain_state)
(fun store =>
op_gtgteq (Header.known (store, hash))
(fun known =>
if known then
Lwt.return_true
else
Store.Block.Invalid_block.known store hash)).
Definition block_validity
(chain_state : chain_state) (block : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t Tezos_base__TzPervasives.Block_locator.validity :=
op_gtgteq (known chain_state block)
(fun function_parameter =>
match function_parameter with
| false =>
if Block_hash.equal block (Chain.faked_genesis_hash chain_state) then
Lwt._return Tezos_base__TzPervasives.Block_locator.Known_valid
else
Lwt._return Tezos_base__TzPervasives.Block_locator.Unknown
| true =>
op_gtgteq (known_invalid chain_state block)
(fun function_parameter =>
match function_parameter with
| true =>
Lwt._return Tezos_base__TzPervasives.Block_locator.Known_invalid
| false =>
Lwt._return Tezos_base__TzPervasives.Block_locator.Known_valid
end)
end).
Definition known_ancestor
(chain_state : chain_state)
(locator : Tezos_base__TzPervasives.Block_locator.t)
: Lwt.t (option Tezos_base__TzPervasives.Block_locator.t) :=
op_gtgteq
(Shared.use (global_data (global_state chain_state))
(fun function_parameter =>
let '{| global_store := global_store |} := function_parameter in
op_gtpipeeq (Store.Configuration.History_mode.read_opt global_store)
(Option.unopt_assert Stdlib.__POS__)))
(fun history_mode =>
op_gtgteq
(Block_locator.unknown_prefix (block_validity chain_state) locator)
(fun function_parameter =>
match function_parameter with
|
(Tezos_base__TzPervasives.Block_locator.Known_valid,
prefix_locator) => Lwt.return_some prefix_locator
| (Tezos_base__TzPervasives.Block_locator.Known_invalid, _) =>
Lwt.return_none
| (Tezos_base__TzPervasives.Block_locator.Unknown, _) =>
match history_mode with
| Tezos_shell_services.History_mode.Archive => Lwt.return_none
|
Tezos_shell_services.History_mode.Rolling |
Tezos_shell_services.History_mode.Full =>
Lwt.return_some locator
end
end)).
Definition get_rpc_directory (function_parameter : t)
: Lwt.t (option (Tezos_base__TzPervasives.RPC_directory.t block)) :=
let '{| chain_state := chain_state |} as block := function_parameter in
op_gtgteq (read_opt chain_state (predecessor (shell (header block))))
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_none
| Some pred => Lwt.return_none
| Some pred =>
op_gtgteq (Chain.save_point chain_state)
(fun function_parameter =>
let '(save_point_level, _) := function_parameter in
op_gtgteq
(if op_lt (level pred) save_point_level then
Chain.get_level_indexed_protocol chain_state (header pred)
else
protocol_hash_exn pred)
(fun protocol =>
match
Protocol_hash.Table.find_opt
(block_rpc_directories chain_state) protocol with
| None => Lwt.return_none
| Some map =>
op_gtgteq (protocol_hash_exn block)
(fun next_protocol =>
Lwt._return
(Protocol_hash.Map.find_opt next_protocol map))
end))
end).
Definition set_rpc_directory (function_parameter : t)
: (Tezos_base__TzPervasives.RPC_directory.t block) -> Lwt.t unit :=
let '{| chain_state := chain_state |} as block := function_parameter in
fun dir =>
op_gtgteq
(op_gtpipeeq (read_opt chain_state (predecessor (shell (header block))))
(Option.unopt_assert Stdlib.__POS__))
(fun pred =>
op_gtgteq (protocol_hash_exn block)
(fun next_protocol =>
op_gtgteq (Chain.save_point chain_state)
(fun function_parameter =>
let '(save_point_level, _) := function_parameter in
op_gtgteq
(if op_lt (level pred) save_point_level then
Chain.get_level_indexed_protocol chain_state (header pred)
else
protocol_hash_exn pred)
(fun protocol =>
let map :=
Option.unopt Protocol_hash.Map.empty
(Protocol_hash.Table.find_opt
(block_rpc_directories chain_state) protocol) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Protocol_hash.Table.replace
(block_rpc_directories chain_state) protocol
(Protocol_hash.Map.add next_protocol dir map) in
Lwt.return_unit)))).
Definition get_header_rpc_directory
(chain_state : chain_state)
(header : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t
(option
(Tezos_base__TzPervasives.RPC_directory.t
(chain_state * Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t))) :=
Shared.use (block_store chain_state)
(fun block_store =>
op_gtgteq
(Header.read_opt
(block_store, (predecessor (Block_header.shell header))))
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_none
| Some pred => Lwt.return_none
| Some pred =>
op_gtgteq (Chain.get_level_indexed_protocol chain_state header)
(fun protocol =>
match
Protocol_hash.Table.find_opt
(header_rpc_directories chain_state) protocol with
| None => Lwt.return_none
| Some map =>
op_gtgteq
(Chain.get_level_indexed_protocol chain_state pred)
(fun next_protocol =>
Lwt._return
(Protocol_hash.Map.find_opt next_protocol map))
end)
end)).
Definition set_header_rpc_directory
(chain_state : chain_state)
(header : Tezos_base__TzPervasives.Block_header.t)
(dir :
Tezos_base__TzPervasives.RPC_directory.t
(chain_state * Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t)) : Lwt.t unit :=
Shared.use (block_store chain_state)
(fun block_store =>
op_gtgteq
(Header.read_opt
(block_store, (predecessor (Block_header.shell header))))
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some pred =>
op_gtgteq (Chain.get_level_indexed_protocol chain_state header)
(fun next_protocol =>
op_gtgteq (Chain.get_level_indexed_protocol chain_state pred)
(fun protocol =>
let map :=
Option.unopt Protocol_hash.Map.empty
(Protocol_hash.Table.find_opt
(header_rpc_directories chain_state) protocol) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Protocol_hash.Table.replace
(header_rpc_directories chain_state) protocol
(Protocol_hash.Map.add next_protocol dir map) in
Lwt.return_unit))
end)).
End Block.
Definition watcher (state : global_state)
: (Lwt_stream.t block) * Tezos_base__TzPervasives.Lwt_watcher.stopper :=
Lwt_watcher.create_stream (block_watcher state).
Definition read_block (function_parameter : global_state)
: Tezos_base__TzPervasives.Block_hash.t -> Lwt.t (option Block.t) :=
let '{| global_data := global_data |} := function_parameter in
fun hash =>
Shared.use global_data
(fun function_parameter =>
let '{| chains := chains |} := function_parameter in
Chain_id.Table.fold
(fun _chain_id =>
fun chain_state =>
fun acc =>
op_gtgteq acc
(fun function_parameter =>
match function_parameter with
| Some _ => acc
| None =>
op_gtgteq (Block.read_opt chain_state hash)
(fun function_parameter =>
match function_parameter with
| None => acc
| Some block => Lwt.return_some block
end)
end)) chains Lwt.return_none).
Definition read_block_exn
(t : global_state) (hash : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t Block.t :=
op_gtgteq (read_block t hash)
(fun function_parameter =>
match function_parameter with
| None => Lwt.fail OCaml.Not_found
| Some b => Lwt._return b
end).
Definition update_testchain (block : block) (testchain_state : chain_state)
: Lwt.t unit :=
update_chain_data (chain_state block)
(fun function_parameter =>
let '_ := function_parameter in
fun chain_data =>
Lwt._return
((Some
(* ❌ Record substitution not handled *)
record_substitution), tt)).
Definition fork_testchain
(block : block) (chain_id : Tezos_base__TzPervasives.Chain_id.t)
(genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
(genesis_header : Tezos_base__TzPervasives.Block_header.t)
(protocol : Tezos_base__TzPervasives.Protocol_hash.t)
(expiration : Tezos_base__TzPervasives.Time.Protocol.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
Shared.use (global_data (global_state (chain_state block)))
(fun data =>
let chain_store := Store.Chain.get (global_store data) chain_id in
let block_store := Store.Block.get chain_store in
op_gtgteq
(Store.Block.Contents.store (block_store, genesis_hash)
{| Store.Block.header := genesis_header;
Store.Block.message := Some "Genesis" % string;
Store.Block.max_operations_ttl := 0;
Store.Block.last_allowed_fork_level :=
(* ❌ Constant of type int32 is converted to int *)
0; Store.Block.context := context (shell genesis_header);
Store.Block.metadata := Stdlib.Bytes.create 0 |})
(fun function_parameter =>
let 'tt := function_parameter in
let genesis :=
{| time := timestamp (shell genesis_header); block := genesis_hash;
protocol := protocol |} in
op_gtgteq
(Chain.locked_create (global_state (chain_state block)) data
(Some expiration) None chain_id genesis genesis_header)
(fun testchain_state =>
op_gtgteq
(Store.Chain.Protocol_info.store chain_store
(proto_level (shell genesis_header))
(protocol, (level (shell genesis_header))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (update_testchain block testchain_state)
(fun function_parameter =>
let 'tt := function_parameter in
_return testchain_state))))).
Definition best_known_head_for_checkpoint
(chain_state : chain_state)
(checkpoint : Tezos_base__TzPervasives.Block_header.t) : Lwt.t block :=
Shared.use (block_store chain_state)
(fun store =>
Shared.use (chain_data chain_state)
(fun data =>
let head_hash := hash (current_head (data data)) in
let head_header := header (current_head (data data)) in
op_gtgteq
(Locked_block.is_valid_for_checkpoint store head_hash head_header
checkpoint)
(fun valid =>
if valid then
Lwt._return (current_head (data data))
else
let find_valid_predecessor
(hash : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t block :=
op_gtgteq
(op_gtpipeeq (Header.read_opt (store, hash))
(Option.unopt_assert Stdlib.__POS__))
(fun header =>
if op_lt (level (shell header)) (level (shell checkpoint))
then
Lwt._return
{| chain_state := chain_state; hash := hash;
header := header |}
else
op_gtgteq
(op_gtpipeeq
(predecessor_n None store hash
(Z.add 1
(apply Int32.to_int
(Int32.sub (level (shell header))
(level (shell checkpoint))))))
(Option.unopt_assert Stdlib.__POS__))
(fun pred =>
op_gtgteq
(op_gtpipeeq (Header.read_opt (store, pred))
(Option.unopt_assert Stdlib.__POS__))
(fun pred_header =>
Lwt._return
{| chain_state := chain_state; hash := pred;
header := pred_header |}))) in
op_gtgteq
(Store.Chain_data.Known_heads.read_all (chain_data_store data))
(fun heads =>
op_gtgteq
(op_gtpipeeq
(Header.read_opt (store, (block (genesis chain_state))))
(Option.unopt_assert Stdlib.__POS__))
(fun genesis_header =>
let genesis :=
{| chain_state := chain_state;
hash := block (genesis chain_state);
header := genesis_header |} in
Block_hash.Set.fold
(fun head =>
fun best =>
let valid_predecessor :=
find_valid_predecessor head in
op_gtgteq best
(fun best =>
op_gtgteq valid_predecessor
(fun pred =>
if
op_gt (fitness (shell (header pred)))
(fitness (shell (header best))) then
Lwt._return pred
else
Lwt._return best))) heads
(Lwt._return genesis)))))).
Module Protocol.
(* ❌ Structure item `include` not handled. *)
include
Definition known
(global_state : global_state)
(hash : Tezos_base__TzPervasives.Protocol_hash.t) : Lwt.t bool :=
Shared.use (protocol_store global_state)
(fun store => Store.Protocol.Contents.known store hash).
Definition read
(global_state : global_state)
(hash : Tezos_base__TzPervasives.Protocol_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Protocol.t) :=
Shared.use (protocol_store global_state)
(fun store => Store.Protocol.Contents.read store hash).
Definition read_opt
(global_state : global_state)
(hash : Tezos_base__TzPervasives.Protocol_hash.t)
: Lwt.t (option Tezos_base__TzPervasives.Protocol.t) :=
Shared.use (protocol_store global_state)
(fun store => Store.Protocol.Contents.read_opt store hash).
Definition read_raw
(global_state : global_state)
(hash : Tezos_base__TzPervasives.Protocol_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
Shared.use (protocol_store global_state)
(fun store => Store.Protocol.RawContents.read (store, hash)).
Definition read_raw_opt
(global_state : global_state)
(hash : Tezos_base__TzPervasives.Protocol_hash.t)
: Lwt.t (option Stdlib.Bytes.t) :=
Shared.use (protocol_store global_state)
(fun store => Store.Protocol.RawContents.read_opt (store, hash)).
Definition store
(global_state : global_state) (p : Tezos_base__TzPervasives.Protocol.t)
: Lwt.t (option Tezos_crypto.Protocol_hash.t) :=
let bytes := Protocol.to_bytes p in
let hash := Protocol.hash_raw string in
Shared.use (protocol_store global_state)
(fun store =>
op_gtgteq (Store.Protocol.Contents.known store hash)
(fun known =>
if known then
Lwt.return_none
else
op_gtgteq (Store.Protocol.RawContents.store (store, hash) string)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_watcher.notify (protocol_watcher global_state) hash in
Lwt.return_some hash))).
Definition remove
(global_state : global_state)
(hash : Tezos_base__TzPervasives.Protocol_hash.t) : Lwt.t bool :=
Shared.use (protocol_store global_state)
(fun store =>
op_gtgteq (Store.Protocol.Contents.known store hash)
(fun known =>
if known then
Lwt.return_false
else
op_gtgteq (Store.Protocol.Contents.remove store hash)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_true))).
Definition list (global_state : global_state)
: Lwt.t Tezos_base__TzPervasives.Protocol_hash.Set.t :=
Shared.use (protocol_store global_state)
(fun store =>
Store.Protocol.Contents.fold_keys store Protocol_hash.Set.empty
(fun x => fun acc => Lwt._return (Protocol_hash.Set.add x acc))).
Definition watcher (state : global_state)
: (Lwt_stream.t Tezos_base__TzPervasives.Protocol_hash.t) *
Tezos_base__TzPervasives.Lwt_watcher.stopper :=
Lwt_watcher.create_stream (protocol_watcher state).
End Protocol.
Module Current_mempool.
Definition set
(chain_state : chain_state) (head : Tezos_base__TzPervasives.Block_hash.t)
(mempool : Tezos_base__TzPervasives.Mempool.t) : Lwt.t unit :=
update_chain_data chain_state
(fun _chain_data_store =>
fun data =>
if Block_hash.equal head (Block.hash (current_head data)) then
Lwt._return
((Some
(* ❌ Record substitution not handled *)
record_substitution), tt)
else
Lwt._return (None, tt)).
Definition get (chain_state : chain_state)
: Lwt.t
(Tezos_base__TzPervasives.Block_header.t *
Tezos_base__TzPervasives.Mempool.t) :=
read_chain_data chain_state
(fun _chain_data_store =>
fun data =>
Lwt._return
((Block.header (current_head data)), (current_mempool data))).
End Current_mempool.
Definition may_create_chain
(commit_genesis :
Tezos_base__TzPervasives.Chain_id.t ->
Tezos_base__TzPervasives.Time.Protocol.t ->
Tezos_base__TzPervasives.Protocol_hash.t ->
Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_crypto.Context_hash.t))
(state : global_state)
(chain_id : Tezos_base__TzPervasives.Chain_id.Table.key)
(genesis : Chain.genesis)
: Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
op_gtgteq (Chain.get state chain_id)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok chain => _return chain
| Stdlib.Error _ =>
Chain.create state (Some true) commit_genesis genesis chain_id
end).
Definition read
(global_store : Tezos_shell.Store.t)
(context_index : Tezos_storage.Context.index)
(main_chain : Tezos_base__TzPervasives.Chain_id.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult global_state) :=
let global_data :=
{| chains := Chain_id.Table.create 17; global_store := global_store;
context_index := context_index |} in
let state :=
{| global_data := Shared.create global_data;
protocol_store := apply Shared.create (Store.Protocol.get global_store);
main_chain := main_chain; protocol_watcher := Lwt_watcher.create_input tt;
block_watcher := Lwt_watcher.create_input tt |} in
op_gtgteqquestion (Chain.read_all state)
(fun function_parameter =>
let 'tt := function_parameter in
_return state).
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition init
(patch_context :
option
(Tezos_storage.Context.context -> Lwt.t Tezos_storage.Context.context))
(commit_genesis :
option
(Tezos_base__TzPervasives.Chain_id.t ->
Tezos_base__TzPervasives.Time.Protocol.t ->
Tezos_base__TzPervasives.Protocol_hash.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_crypto.Context_hash.t)))
(op_staroptstar : option int64)
: (option int64) ->
string ->
string ->
(option Tezos_shell_services.History_mode.t) ->
Chain.genesis ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(global_state * chain_state * Tezos_storage.Context.index *
Tezos_shell_services.History_mode.t)) :=
let store_mapsize :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Constant of type int64 is converted to int *)
40960000000
end in
fun op_staroptstar =>
let context_mapsize :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Constant of type int64 is converted to int *)
409600000000
end in
fun store_root =>
fun context_root =>
fun history_mode =>
fun genesis =>
op_gtgteqquestion (Store.init None (Some store_mapsize) store_root)
(fun global_store =>
op_gtgteq
match commit_genesis with
| Some commit_genesis =>
op_gtgteq
(Context.init patch_context (Some context_mapsize)
(Some true) context_root)
(fun context_index =>
Lwt._return (context_index, commit_genesis))
| None =>
op_gtgteq
(Context.init patch_context (Some context_mapsize)
(Some false) context_root)
(fun context_index =>
let commit_genesis
(chain_id : Tezos_base__TzPervasives.Chain_id.t) (time
: Tezos_base__TzPervasives.Time.Protocol.t) (protocol
: Tezos_base__TzPervasives.Protocol_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Context_hash.t) :=
op_gtgteq
(Context.commit_genesis context_index chain_id time
protocol) (fun res => _return res) in
Lwt._return (context_index, commit_genesis))
end
(fun function_parameter =>
let '(context_index, commit_genesis) := function_parameter
in
let chain_id := Chain_id.of_block_hash (Chain.block genesis)
in
op_gtgteqquestion (read global_store context_index chain_id)
(fun state =>
op_gtgteqquestion
(may_create_chain commit_genesis state chain_id
genesis)
(fun main_chain_state =>
op_gtgteqquestion
(op_gtgteq
(Store.Configuration.History_mode.read_opt
global_store)
(fun function_parameter =>
match function_parameter with
| None =>
let mode :=
Option.unopt
Tezos_shell_services.History_mode.Full
history_mode in
op_gtgteq
(Store.Configuration.History_mode.store
global_store mode)
(fun function_parameter =>
let 'tt := function_parameter in
_return mode)
| Some previous_history_mode =>
match history_mode with
| None => _return previous_history_mode
| Some history_mode =>
if
nequiv_decb history_mode
previous_history_mode then
fail
(Tezos_base__TzPervasives.Incorrect_history_mode_switch
{|
previous_mode :=
previous_history_mode;
next_mode := history_mode |})
else
_return history_mode
end
end))
(fun history_mode =>
_return
(state, main_chain_state, context_index,
history_mode)))))).
Definition history_mode (function_parameter : global_state)
: Lwt.t Tezos_shell_services.History_mode.t :=
let '{| global_data := global_data |} := function_parameter in
Shared.use global_data
(fun function_parameter =>
let '{| global_store := global_store |} := function_parameter in
op_gtpipeeq (Store.Configuration.History_mode.read_opt global_store)
(Option.unopt_assert Stdlib.__POS__)).
Definition close (function_parameter : global_state) : Lwt.t unit :=
let '{| global_data := global_data |} := function_parameter in
Shared.use global_data
(fun function_parameter =>
let '{| global_store := global_store |} := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Store.close global_store in
Lwt.return_unit).
src/lib_shell/store.ml 31 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = Raw_store.t
type global_store = t
(**************************************************************************
* Configuration setup we need to save in order to avoid wrong changes.
**************************************************************************)
module Configuration = struct
module History_mode =
Store_helpers.Make_single_store
(Raw_store)
(struct
let name = ["history_mode"]
end)
(Store_helpers.Make_value (History_mode))
end
(**************************************************************************
* Net store under "chain/"
**************************************************************************)
module Chain = struct
type store = global_store * Chain_id.t
let get s id = (s, id)
module Indexed_store =
Store_helpers.Make_indexed_substore
(Store_helpers.Make_substore
(Raw_store)
(struct
let name = ["chain"]
end))
(Chain_id)
let destroy = Indexed_store.remove_all
let list t =
Indexed_store.fold_indexes t ~init:[] ~f:(fun h acc ->
Lwt.return (h :: acc))
module Genesis_hash =
Store_helpers.Make_single_store
(Indexed_store.Store)
(struct
let name = ["genesis"; "hash"]
end)
(Store_helpers.Make_value (Block_hash))
module Genesis_time =
Store_helpers.Make_single_store
(Indexed_store.Store)
(struct
let name = ["genesis"; "time"]
end)
(Store_helpers.Make_value (Time.Protocol))
module Genesis_protocol =
Store_helpers.Make_single_store
(Indexed_store.Store)
(struct
let name = ["genesis"; "protocol"]
end)
(Store_helpers.Make_value (Protocol_hash))
module Genesis_test_protocol =
Store_helpers.Make_single_store
(Indexed_store.Store)
(struct
let name = ["genesis"; "test_protocol"]
end)
(Store_helpers.Make_value (Protocol_hash))
module Expiration =
Store_helpers.Make_single_store
(Indexed_store.Store)
(struct
let name = ["expiration"]
end)
(Store_helpers.Make_value (Time.Protocol))
module Allow_forked_chain = Indexed_store.Make_set (struct
let name = ["allow_forked_chain"]
end)
module Protocol_index =
Store_helpers.Make_indexed_substore
(Store_helpers.Make_substore
(Indexed_store.Store)
(struct
let name = ["protocol"]
end))
(Store_helpers.Integer_index)
module Protocol_info =
Protocol_index.Make_map
(struct
let name = ["info"]
end)
(Store_helpers.Make_value (struct
type t = Protocol_hash.t * Int32.t
let encoding =
let open Data_encoding in
tup2 Protocol_hash.encoding int32
end))
end
(**************************************************************************
* Temporary test chain forking block store under "forking_block_hash/"
**************************************************************************)
module Forking_block_hash =
Store_helpers.Make_map
(Store_helpers.Make_substore
(Raw_store)
(struct
let name = ["forking_block_hash"]
end))
(Chain_id)
(Store_helpers.Make_value (Block_hash))
(**************************************************************************
* Block_header store under "chain/<id>/blocks/"
**************************************************************************)
module Block = struct
type store = Chain.store
let get x = x
module Indexed_store =
Store_helpers.Make_indexed_substore
(Store_helpers.Make_substore
(Chain.Indexed_store.Store)
(struct
let name = ["blocks"]
end))
(Block_hash)
type contents = {
header : Block_header.t;
message : string option;
max_operations_ttl : int;
last_allowed_fork_level : Int32.t;
context : Context_hash.t;
metadata : Bytes.t;
}
module Contents =
Store_helpers.Make_single_store
(Indexed_store.Store)
(struct
let name = ["contents"]
end)
(Store_helpers.Make_value (struct
type t = contents
let encoding =
let open Data_encoding in
conv
(fun { header;
message;
max_operations_ttl;
last_allowed_fork_level;
context;
metadata } ->
( message,
max_operations_ttl,
last_allowed_fork_level,
context,
metadata,
header ))
(fun ( message,
max_operations_ttl,
last_allowed_fork_level,
context,
metadata,
header ) ->
{
header;
message;
max_operations_ttl;
last_allowed_fork_level;
context;
metadata;
})
(obj6
(opt "message" string)
(req "max_operations_ttl" uint16)
(req "last_allowed_fork_level" int32)
(req "context" Context_hash.encoding)
(req "metadata" bytes)
(req "header" Block_header.encoding))
end))
type pruned_contents = {header : Block_header.t}
module Pruned_contents =
Store_helpers.Make_single_store
(Indexed_store.Store)
(struct
let name = ["pruned_contents"]
end)
(Store_helpers.Make_value (struct
type t = pruned_contents
let encoding =
let open Data_encoding in
conv
(fun {header} -> header)
(fun header -> {header})
(obj1 (req "header" Block_header.encoding))
end))
module Operations_index =
Store_helpers.Make_indexed_substore
(Store_helpers.Make_substore
(Indexed_store.Store)
(struct
let name = ["operations"]
end))
(Store_helpers.Integer_index)
module Operation_hashes =
Operations_index.Make_map
(struct
let name = ["hashes"]
end)
(Store_helpers.Make_value (struct
type t = Operation_hash.t list
let encoding = Data_encoding.list Operation_hash.encoding
end))
module Operations =
Operations_index.Make_map
(struct
let name = ["contents"]
end)
(Store_helpers.Make_value (struct
type t = Operation.t list
let encoding = Data_encoding.(list (dynamic_size Operation.encoding))
end))
module Operations_metadata =
Operations_index.Make_map
(struct
let name = ["metadata"]
end)
(Store_helpers.Make_value (struct
type t = Bytes.t list
let encoding = Data_encoding.(list bytes)
end))
type invalid_block = {level : int32; errors : Error_monad.error list}
module Invalid_block =
Store_helpers.Make_map
(Store_helpers.Make_substore
(Chain.Indexed_store.Store)
(struct
let name = ["invalid_blocks"]
end))
(Block_hash)
(Store_helpers.Make_value (struct
type t = invalid_block
let encoding =
let open Data_encoding in
conv
(fun {level; errors} -> (level, errors))
(fun (level, errors) -> {level; errors})
(tup2 int32 (list Error_monad.error_encoding))
end))
let register s =
Base58.register_resolver Block_hash.b58check_encoding (fun str ->
let pstr = Block_hash.prefix_path str in
Chain.Indexed_store.fold_indexes s ~init:[] ~f:(fun chain acc ->
Indexed_store.resolve_index (s, chain) pstr
>>= fun l -> Lwt.return (List.rev_append l acc)))
module Predecessors =
Store_helpers.Make_map
(Store_helpers.Make_substore
(Indexed_store.Store)
(struct
let name = ["predecessors"]
end))
(Store_helpers.Integer_index)
(Store_helpers.Make_value (Block_hash))
end
(**************************************************************************
* Blockchain data
**************************************************************************)
module Chain_data = struct
type store = Chain.store
let get s = s
module Known_heads =
Store_helpers.Make_buffered_set
(Store_helpers.Make_substore
(Chain.Indexed_store.Store)
(struct
let name = ["known_heads"]
end))
(Block_hash)
(Block_hash.Set)
module Current_head =
Store_helpers.Make_single_store
(Chain.Indexed_store.Store)
(struct
let name = ["current_head"]
end)
(Store_helpers.Make_value (Block_hash))
module In_main_branch =
Store_helpers.Make_single_store
(Block.Indexed_store.Store)
(struct
let name = ["in_chain"]
end)
(Store_helpers.Make_value (Block_hash))
(* successor *)
module Checkpoint =
Store_helpers.Make_single_store
(Chain.Indexed_store.Store)
(struct
let name = ["checkpoint"]
end)
(Store_helpers.Make_value (Block_header))
module Save_point =
Store_helpers.Make_single_store
(Chain.Indexed_store.Store)
(struct
let name = ["save_point"]
end)
(Store_helpers.Make_value (struct
type t = Int32.t * Block_hash.t
let encoding =
let open Data_encoding in
tup2 int32 Block_hash.encoding
end))
module Caboose =
Store_helpers.Make_single_store
(Chain.Indexed_store.Store)
(struct
let name = ["caboose"]
end)
(Store_helpers.Make_value (struct
type t = Int32.t * Block_hash.t
let encoding =
let open Data_encoding in
tup2 int32 Block_hash.encoding
end))
end
(**************************************************************************
* Protocol store under "protocols/"
**************************************************************************)
module Protocol = struct
type store = global_store
let get x = x
module Indexed_store =
Store_helpers.Make_indexed_substore
(Store_helpers.Make_substore
(Raw_store)
(struct
let name = ["protocols"]
end))
(Protocol_hash)
module Contents =
Indexed_store.Make_map
(struct
let name = ["contents"]
end)
(Store_helpers.Make_value (Protocol))
module RawContents =
Store_helpers.Make_single_store
(Indexed_store.Store)
(struct
let name = ["contents"]
end)
(Store_helpers.Raw_value)
let register s =
Base58.register_resolver Protocol_hash.b58check_encoding (fun str ->
let pstr = Protocol_hash.prefix_path str in
Indexed_store.resolve_index s pstr)
end
let init ?readonly ?mapsize dir =
Raw_store.init ?readonly ?mapsize dir
>>=? fun s -> Block.register s ; Protocol.register s ; return s
let close = Raw_store.close
let open_with_atomic_rw = Raw_store.open_with_atomic_rw
let with_atomic_rw = Raw_store.with_atomic_rw
src/lib_shell/store.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := Tezos_storage.Raw_store.t.
Definition global_store := t.
Module Configuration.
(* ❌ Applications of functors are not handled. *)
functor_application
End Configuration.
Module Chain.
Definition store := global_store * Tezos_base__TzPervasives.Chain_id.t.
Definition get {A B : Type} (s : A) (id : B) : A * B := (s, id).
(* ❌ Applications of functors are not handled. *)
functor_application
Definition destroy : Indexed_store.t -> Indexed_store.key -> Lwt.t unit :=
Indexed_store.remove_all.
Definition list (t : Indexed_store.t) : Lwt.t (list Indexed_store.key) :=
Indexed_store.fold_indexes t []
(fun h => fun acc => Lwt._return (cons h acc)).
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
End Chain.
(* ❌ Applications of functors are not handled. *)
functor_application
Module Block.
Definition store := Chain.store.
Definition get {A : Type} (x : A) : A := x.
(* ❌ Applications of functors are not handled. *)
functor_application
Record contents := {
header : Tezos_base__TzPervasives.Block_header.t;
message : option string;
max_operations_ttl : Z;
last_allowed_fork_level : Stdlib.Int32.t;
context : Tezos_base__TzPervasives.Context_hash.t;
metadata : Stdlib.Bytes.t }.
(* ❌ Applications of functors are not handled. *)
functor_application
Record pruned_contents := {
header : Tezos_base__TzPervasives.Block_header.t }.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Record invalid_block := {
level : int32;
errors : list Tezos_base__TzPervasives.Error_monad.error }.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition register (s : Chain.Indexed_store.t) : unit :=
Base58.register_resolver Block_hash.b58check_encoding
(fun str =>
let pstr := Block_hash.prefix_path str in
Chain.Indexed_store.fold_indexes s []
(fun chain =>
fun acc =>
op_gtgteq (Indexed_store.resolve_index (s, chain) pstr)
(fun l => Lwt._return (List.rev_append l acc)))).
(* ❌ Applications of functors are not handled. *)
functor_application
End Block.
Module Chain_data.
Definition store := Chain.store.
Definition get {A : Type} (s : A) : A := s.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
End Chain_data.
Module Protocol.
Definition store := global_store.
Definition get {A : Type} (x : A) : A := x.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Definition register (s : Indexed_store.t) : unit :=
Base58.register_resolver Protocol_hash.b58check_encoding
(fun str =>
let pstr := Protocol_hash.prefix_path str in
Indexed_store.resolve_index s pstr).
End Protocol.
Definition init (readonly : option bool) (mapsize : option int64) (dir : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_storage.Raw_store.t) :=
op_gtgteqquestion (Raw_store.init readonly mapsize dir)
(fun s =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Block.register s in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Protocol.register s in
_return s).
Definition close : Tezos_storage.Raw_store.t -> unit := Raw_store.close.
Definition open_with_atomic_rw {A : Type}
: (option int64) ->
string ->
(Tezos_storage.Raw_store.t ->
Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult A)) ->
Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
Raw_store.open_with_atomic_rw.
Definition with_atomic_rw {A : Type}
: Tezos_storage.Raw_store.t -> (unit -> Lwt.t A) -> Lwt.t A :=
Raw_store.with_atomic_rw.
src/lib_shell/test/assert.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let fail expected given msg =
Format.kasprintf
Pervasives.failwith
"@[%s@ expected: %s@ got: %s@]"
msg
expected
given
let fail_msg ?(expected = "") ?(given = "") fmt =
Format.kasprintf (fail expected given) fmt
let default_printer _ = ""
let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
if not (eq x y) then fail (prn x) (prn y) msg
let equal_operation ?msg op1 op2 =
let eq op1 op2 =
match (op1, op2) with
| (None, None) ->
true
| (Some op1, Some op2) ->
Operation.equal op1 op2
| _ ->
false
in
let prn = function
| None ->
"none"
| Some op ->
Operation_hash.to_b58check (Operation.hash op)
in
equal ?msg ~prn ~eq op1 op2
let equal_block ?msg st1 st2 =
let eq st1 st2 =
match (st1, st2) with
| (None, None) ->
true
| (Some st1, Some st2) ->
Block_header.equal st1 st2
| _ ->
false
in
let prn = function
| None ->
"none"
| Some st ->
Block_hash.to_b58check (Block_header.hash st)
in
equal ?msg ~prn ~eq st1 st2
let make_equal_list eq prn ?(msg = "") x y =
let rec iter i x y =
match (x, y) with
| (hd_x :: tl_x, hd_y :: tl_y) ->
if eq hd_x hd_y then iter (succ i) tl_x tl_y
else
fail_msg
~expected:(prn hd_x)
~given:(prn hd_y)
"%s (at index %d)"
msg
i
| (_ :: _, []) | ([], _ :: _) ->
fail_msg
~expected:""
~given:""
"%s (lists of different sizes %d %d)"
msg
(List.length x)
(List.length y)
| ([], []) ->
()
in
iter 0 x y
let equal_string_list ?msg l1 l2 =
make_equal_list ?msg ( = ) (fun x -> x) l1 l2
let equal_string_list_list ?msg l1 l2 =
let pr_persist l =
let res =
String.concat ";" (List.map (fun s -> Printf.sprintf "%S" s) l)
in
Printf.sprintf "[%s]" res
in
make_equal_list ?msg ( = ) pr_persist l1 l2
let equal_block_set ?msg set1 set2 =
let b1 = Block_hash.Set.elements set1
and b2 = Block_hash.Set.elements set2 in
make_equal_list
?msg
(fun h1 h2 -> Block_hash.equal h1 h2)
Block_hash.to_string
b1
b2
let equal_block_map ?msg ~eq map1 map2 =
let b1 = Block_hash.Map.bindings map1
and b2 = Block_hash.Map.bindings map2 in
make_equal_list
?msg
(fun (h1, b1) (h2, b2) -> Block_hash.equal h1 h2 && eq b1 b2)
(fun (h1, _) -> Block_hash.to_string h1)
b1
b2
let equal_block_hash_list ?msg l1 l2 =
let pr_block_hash = Block_hash.to_short_b58check in
make_equal_list ?msg Block_hash.equal pr_block_hash l1 l2
let is_false ?(msg = "") x = if x then fail "false" "true" msg
let is_true ?(msg = "") x = if not x then fail "true" "false" msg
let equal_checkpoint ?msg cp1 cp2 =
let eq cp1 cp2 =
match (cp1, cp2) with
| (None, None) ->
true
| (Some (x, bh1), Some (y, bh2)) ->
Int32.equal x y && Block_hash.equal bh1 bh2
| _ ->
false
in
let prn = function
| None ->
"none"
| Some (_x, bh) ->
(*let s = Printf.sprintf "%s" x in*)
Block_hash.to_b58check bh
in
equal ?msg ~prn ~eq cp1 cp2
src/lib_shell/test/assert.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition fail {A : Type} (expected : string) (given : string) (msg : string)
: A :=
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "expected: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "got: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[%s@ expected: %s@ got: %s@]" % string) msg expected given.
Definition fail_msg {A B : Type} (op_staroptstar : option string)
: (option string) -> (Stdlib.format4 A Stdlib.Format.formatter unit B) -> A :=
let expected :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun op_staroptstar =>
let given :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun fmt => Format.kasprintf (fail expected given) fmt.
Definition default_printer {A : Type} (function_parameter : A) : string :=
let '_ := function_parameter in
"" % string.
Definition equal {A : Type} (op_staroptstar : option (A -> A -> bool))
: (option (A -> string)) -> (option string) -> A -> A -> unit :=
let eq :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => equiv_decb
end in
fun op_staroptstar =>
let prn :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_printer
end in
fun op_staroptstar =>
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
fun y =>
if negb (eq x y) then
fail (prn x) (prn y) msg
else
tt.
Definition equal_operation
(msg : option string) (op1 : option Tezos_base__TzPervasives.Operation.t)
(op2 : option Tezos_base__TzPervasives.Operation.t) : unit :=
let eq
(op1 : option Tezos_base__TzPervasives.Operation.t) (op2 :
option Tezos_base__TzPervasives.Operation.t) : bool :=
match (op1, op2) with
| (None, None) => true
| (Some op1, Some op2) => Operation.equal op1 op2
| _ => false
end in
let prn (function_parameter : option Tezos_base__TzPervasives.Operation.t)
: string :=
match function_parameter with
| None => "none" % string
| Some op => Operation_hash.to_b58check (Operation.hash op)
end in
equal (Some eq) (Some prn) msg op1 op2.
Definition equal_block
(msg : option string) (st1 : option Tezos_base__TzPervasives.Block_header.t)
(st2 : option Tezos_base__TzPervasives.Block_header.t) : unit :=
let eq
(st1 : option Tezos_base__TzPervasives.Block_header.t) (st2 :
option Tezos_base__TzPervasives.Block_header.t) : bool :=
match (st1, st2) with
| (None, None) => true
| (Some st1, Some st2) => Block_header.equal st1 st2
| _ => false
end in
let prn (function_parameter : option Tezos_base__TzPervasives.Block_header.t)
: string :=
match function_parameter with
| None => "none" % string
| Some st => Block_hash.to_b58check (Block_header.hash st)
end in
equal (Some eq) (Some prn) msg st1 st2.
Definition make_equal_list {A : Type}
(eq : A -> A -> bool) (prn : A -> string) (op_staroptstar : option string)
: (list A) -> (list A) -> unit :=
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
fun y =>
let fix iter (i : Z) (x : list A) (y : list A) : unit :=
match (x, y) with
| (cons hd_x tl_x, cons hd_y tl_y) =>
if eq hd_x hd_y then
iter (Z.succ i) tl_x tl_y
else
fail_msg (Some (prn hd_x)) (Some (prn hd_y))
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (at index " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))
"%s (at index %d)" % string) msg i
| (cons _ _, []) | ([], cons _ _) =>
fail_msg (Some "" % string) (Some "" % string)
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (lists of different sizes " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))))
"%s (lists of different sizes %d %d)" % string) msg
(List.length x) (List.length y)
| ([], []) => tt
end in
iter 0 x y.
Definition equal_string_list
(msg : option string) (l1 : list string) (l2 : list string) : unit :=
make_equal_list equiv_decb (fun x => x) msg l1 l2.
Definition equal_string_list_list
(msg : option string) (l1 : list (list string)) (l2 : list (list string))
: unit :=
let pr_persist (l : list string) : string :=
let res :=
String.concat ";" % string
(List.map
(fun s =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%S" % string) s) l)
in
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "]" % char
CamlinternalFormatBasics.End_of_format))) "[%s]" % string) res in
make_equal_list equiv_decb pr_persist msg l1 l2.
Definition equal_block_set
(msg : option string) (set1 : Tezos_base__TzPervasives.Block_hash.Set.t)
(set2 : Tezos_base__TzPervasives.Block_hash.Set.t) : unit :=
let b1 : list Tezos_base__TzPervasives.Block_hash.Set.elt :=
Block_hash.Set.elements set1
with b2 : list Tezos_base__TzPervasives.Block_hash.Set.elt :=
Block_hash.Set.elements set2 in
make_equal_list (fun h1 => fun h2 => Block_hash.equal h1 h2)
Block_hash.to_string msg b1 b2.
Definition equal_block_map {A : Type}
(msg : option string) (eq : A -> A -> bool)
(map1 : Tezos_base__TzPervasives.Block_hash.Map.t A)
(map2 : Tezos_base__TzPervasives.Block_hash.Map.t A) : unit :=
let b1 : list (Tezos_base__TzPervasives.Block_hash.Map.key * A) :=
Block_hash.Map.bindings map1
with b2 : list (Tezos_base__TzPervasives.Block_hash.Map.key * A) :=
Block_hash.Map.bindings map2 in
make_equal_list
(fun function_parameter =>
let '(h1, b1) := function_parameter in
fun function_parameter =>
let '(h2, b2) := function_parameter in
andb (Block_hash.equal h1 h2) (eq b1 b2))
(fun function_parameter =>
let '(h1, _) := function_parameter in
Block_hash.to_string h1) msg b1 b2.
Definition equal_block_hash_list
(msg : option string) (l1 : list Tezos_base__TzPervasives.Block_hash.t)
(l2 : list Tezos_base__TzPervasives.Block_hash.t) : unit :=
let pr_block_hash := Block_hash.to_short_b58check in
make_equal_list Block_hash.equal pr_block_hash msg l1 l2.
Definition is_false (op_staroptstar : option string) : bool -> unit :=
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
if x then
fail "false" % string "true" % string msg
else
tt.
Definition is_true (op_staroptstar : option string) : bool -> unit :=
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
if negb x then
fail "true" % string "false" % string msg
else
tt.
Definition equal_checkpoint
(msg : option string)
(cp1 : option (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t))
(cp2 : option (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t))
: unit :=
let eq
(cp1 : option (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)) (cp2
: option (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)) : bool :=
match (cp1, cp2) with
| (None, None) => true
| (Some (x, bh1), Some (y, bh2)) =>
andb (Int32.equal x y) (Block_hash.equal bh1 bh2)
| _ => false
end in
let prn {A : Type}
(function_parameter : option (A * Tezos_base__TzPervasives.Block_hash.t))
: string :=
match function_parameter with
| None => "none" % string
| Some (_x, bh) => Block_hash.to_b58check bh
end in
equal (Some eq) (Some prn) msg cp1 cp2.
src/lib_shell/test/test.ml 6 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let () =
Alcotest.run
"tezos-state"
[ ("store", Test_store.tests);
("state", Test_state.tests);
("store checkpoint", Test_store_checkpoint.tests);
("state checkpoint", Test_state_checkpoint.tests) ]
src/lib_shell/test/test.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations.
src/lib_shell/test/test_locator.ml 58 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let ( // ) = Filename.concat
(** Basic blocks *)
let genesis_hash =
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"
let genesis_protocol =
Protocol_hash.of_b58check_exn
"ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"
let genesis_time = Time.Protocol.of_seconds 0L
let state_genesis_block =
{
State.Chain.time = genesis_time;
State.Chain.block = genesis_hash;
State.Chain.protocol = genesis_protocol;
}
let chain_id = Chain_id.of_block_hash genesis_hash
let proto =
match Registered_protocol.get genesis_protocol with
| None ->
assert false
| Some proto ->
proto
module Proto = (val proto)
let incr_timestamp timestamp =
Time.Protocol.add timestamp (Int64.add 1L (Random.int64 10L))
let incr_fitness fitness =
let new_fitness =
match fitness with
| [fitness] ->
Pervasives.(
Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
|> Option.unopt ~default:0L |> Int64.succ
|> Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
| _ ->
Data_encoding.Binary.to_bytes_exn Data_encoding.int64 1L
in
[new_fitness]
(* returns a new state with a single block, genesis *)
let init_chain base_dir : State.Chain.t Lwt.t =
let store_root = base_dir // "store" in
let context_root = base_dir // "context" in
State.init
~store_root
~context_root
~history_mode:Archive
state_genesis_block
>>= function
| Error _ ->
Pervasives.failwith "read err"
| Ok (_state, chain, _index, _history_mode) ->
Lwt.return chain
let block_header ?(context = Context_hash.zero) (pred : State.Block.t) :
Block_header.t =
let pred_header = State.Block.shell_header pred in
let timestamp = incr_timestamp pred_header.timestamp in
let fitness = incr_fitness pred_header.fitness in
{
Block_header.shell =
{
level = Int32.add Int32.one (State.Block.level pred);
proto_level = 0;
predecessor = State.Block.hash pred;
timestamp;
validation_passes = 0;
operations_hash = Operation_list_list_hash.empty;
fitness;
context;
};
Block_header.protocol_data = Bytes.of_string "";
}
let zero = Bytes.create 0
(* adds n blocks on top of an initialized chain *)
let make_empty_chain (chain : State.Chain.t) n : Block_hash.t Lwt.t =
State.Block.read_opt chain genesis_hash
>|= Option.unopt_assert ~loc:__POS__
>>= fun genesis ->
State.Block.context_exn genesis
>>= fun empty_context ->
let header = State.Block.header genesis in
let timestamp = State.Block.timestamp genesis in
let empty_context_hash = Context.hash ~time:timestamp empty_context in
Context.commit ~time:header.shell.timestamp empty_context
>>= fun context ->
let header = {header with shell = {header.shell with context}} in
let empty_result =
{
Block_validation.context_hash = empty_context_hash;
message = None;
max_operations_ttl = 0;
last_allowed_fork_level = 0l;
}
in
let rec loop lvl pred =
if lvl >= n then return pred
else
let header =
{
header with
shell =
{header.shell with predecessor = pred; level = Int32.of_int lvl};
}
in
State.Block.store
chain
header
zero
[]
[]
empty_result
~forking_testchain:false
>>=? fun _ -> loop (lvl + 1) (Block_header.hash header)
in
loop 1 genesis_hash
>>= function
| Ok b ->
Lwt.return b
| Error err ->
Error_monad.pp_print_error Format.err_formatter err ;
assert false
(* helper functions ------------------------------------- *)
(* wall clock time of a unit function *)
let time1 (f : unit -> 'a) : 'a * float =
let t = Unix.gettimeofday () in
let res = f () in
let wall_clock = Unix.gettimeofday () -. t in
(res, wall_clock)
(* returns result from first run and average time of [runs] runs *)
let time ?(runs = 1) f =
if runs < 1 then invalid_arg "time negative arg"
else
let rec loop cnt sum =
if cnt = runs then sum
else
let (_, t) = time1 f in
loop (cnt + 1) (sum +. t)
in
let (res, t) = time1 f in
let sum = loop 1 t in
(res, sum /. float runs)
let rec repeat f n =
if n < 0 then invalid_arg "repeat: negative arg"
else if n = 0 then ()
else
let _ = f () in
repeat f (n - 1)
(* ----------------------------------------------------- *)
let print_block b =
Printf.printf
"%6i %s\n"
(Int32.to_int (State.Block.level b))
(Block_hash.to_b58check (State.Block.hash b))
let print_block_h chain bh =
State.Block.read_opt chain bh
>|= Option.unopt_assert ~loc:__POS__
>|= fun b -> print_block b
(* returns the predecessor at distance one, reading the header *)
let linear_predecessor chain (bh : Block_hash.t) : Block_hash.t option Lwt.t =
State.Block.read_opt chain bh
>|= Option.unopt_assert ~loc:__POS__
>>= fun b ->
State.Block.predecessor b
>|= function None -> None | Some pred -> Some (State.Block.hash pred)
let print_chain chain bh =
let rec loop bh cnt =
let _ = print_block_h chain bh in
linear_predecessor chain bh
>>= function Some pred -> loop pred (cnt + 1) | None -> Lwt.return_unit
in
loop bh 0
(* returns the predecessors at ditance n, traversing all n intermediate blocks *)
let linear_predecessor_n (chain : State.Chain.t) (bh : Block_hash.t)
(distance : int) : Block_hash.t option Lwt.t =
(* let _ = Printf.printf "LP: %4i " distance; print_block_h chain bh in *)
if distance < 1 then invalid_arg "distance<1"
else
let rec loop bh distance =
if distance = 0 then Lwt.return_some bh (* reached distance *)
else
linear_predecessor chain bh
>>= function
| None -> Lwt.return_none | Some pred -> loop pred (distance - 1)
in
loop bh distance
(* Tests that the linear predecessor defined above and the
exponential predecessor implemented in State.predecessor_n
return the same block and it is the block at the distance
requested *)
let test_pred (base_dir : string) : unit tzresult Lwt.t =
let size_chain = 1000 in
init_chain base_dir
>>= fun chain ->
make_empty_chain chain size_chain
>>= fun head ->
let test_once distance =
linear_predecessor_n chain head distance
>>= fun lin_res ->
State.Block.read_opt chain head
>|= Option.unopt_assert ~loc:__POS__
>>= fun head_block ->
State.Block.predecessor_n head_block distance
>>= fun exp_res ->
match (lin_res, exp_res) with
| (None, None) ->
Lwt.return_unit
| (None, Some _) | (Some _, None) ->
Assert.fail_msg "mismatch between exponential and linear predecessor_n"
| (Some lin_res, Some exp_res) ->
(* check that the two results are the same *)
assert (lin_res = exp_res) ;
State.Block.read_opt chain lin_res
>|= Option.unopt_assert ~loc:__POS__
>>= fun pred ->
let level_pred = Int32.to_int (State.Block.level pred) in
State.Block.read_opt chain head
>|= Option.unopt_assert ~loc:__POS__
>>= fun head ->
let level_start = Int32.to_int (State.Block.level head) in
(* check distance using the level *)
assert (level_start - distance = level_pred) ;
Lwt.return_unit
in
let _ = Random.self_init () in
let range = size_chain + (size_chain / 10) in
let repeats = 100 in
return (repeat (fun () -> test_once (1 + Random.int range)) repeats)
let seed =
let receiver_id =
P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size 'r')
in
let sender_id =
P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size 's')
in
{Block_locator.receiver_id; sender_id}
(* compute locator using the linear predecessor *)
let compute_linear_locator chain_state ~size block =
let block_hash = State.Block.hash block in
let header = State.Block.header block in
Block_locator.compute
~get_predecessor:(linear_predecessor_n chain_state)
block_hash
header
~size
seed
(* given the size of a chain, returns the size required for a locator
to reach genesis *)
let compute_size_locator size_chain =
let repeats = 10. in
int_of_float ((log (float size_chain /. repeats) /. log 2.) -. 1.) * 10
(* given the size of a locator, returns the size of the chain that it
can cover back to genesis *)
let compute_size_chain size_locator =
let repeats = 10. in
int_of_float (repeats *. (2. ** float (size_locator + 1)))
(* test if the linear and exponential locator are the same and outputs
their timing.
Run the test with:
$ dune build @runbench_locator
Copy the output to a file timing.dat and plot it with:
$ test_locator_plot.sh timing.dat
*)
(*
chain 1 year 518k covered by locator 150
chain 2 months 86k covered by locator 120
*)
let test_locator base_dir =
let size_chain = 80000 in
(* timing locators with average over [runs] times *)
let runs = 10 in
let _ = Printf.printf "#runs %i\n" runs in
(* limit after which exp should go linear *)
let exp_limit = compute_size_chain 120 in
let _ = Printf.printf "#exp_limit %i\n" exp_limit in
(* size after which locator always reaches genesis *)
let locator_limit = compute_size_locator size_chain in
let _ = Printf.printf "#locator_limit %i\n" locator_limit in
init_chain base_dir
>>= fun chain ->
time1 (fun () -> make_empty_chain chain size_chain)
|> fun (res, t_chain) ->
let _ =
Printf.printf
"#size_chain %i built in %f sec\n# size exp lins\n"
size_chain
t_chain
in
res
>>= fun head ->
let check_locator size : unit tzresult Lwt.t =
State.read_chain_data chain (fun _ data ->
Lwt.return (data.caboose, data.save_point))
>>= fun ((_, caboose), _save_point) ->
State.Block.read chain head
>>=? fun block ->
time ~runs (fun () -> State.compute_locator chain ~size block seed)
|> fun (l_exp, t_exp) ->
time ~runs (fun () -> compute_linear_locator chain ~caboose ~size block)
|> fun (l_lin, t_lin) ->
l_exp
>>= fun l_exp ->
l_lin
>>= fun l_lin ->
let (_, l_exp) = (l_exp : Block_locator.t :> _ * _) in
let (_, l_lin) = (l_lin : Block_locator.t :> _ * _) in
let _ = Printf.printf "%10i %f %f\n" size t_exp t_lin in
List.iter2
(fun hn ho ->
if not (Block_hash.equal hn ho) then
Assert.fail_msg "Invalid locator %i" size)
l_exp
l_lin ;
return_unit
in
let stop = locator_limit + 20 in
let rec loop size =
if size < stop then check_locator size >>=? fun _ -> loop (size + 5)
else return_unit
in
loop 1
let wrap n f =
Alcotest_lwt.test_case n `Quick (fun _ () ->
Lwt_utils_unix.with_tempdir "tezos_test_" (fun dir ->
f dir
>>= function
| Ok () ->
Lwt.return_unit
| Error error ->
Format.kasprintf Pervasives.failwith "%a" pp_print_error error))
let tests = [wrap "test pred" test_pred]
let bench = [wrap "test locator" test_locator]
let tests =
try if Sys.argv.(1) = "--no-bench" then tests else tests @ bench
with _ -> tests @ bench
let () = Alcotest.run ~argv:[|""|] "tezos-shell" [("locator", tests)]
src/lib_shell/test/test_locator.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition genesis_hash : Tezos_base__TzPervasives.Block_hash.t :=
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.
Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
Protocol_hash.of_b58check_exn
"ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.
Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
Time.Protocol.of_seconds
(* ❌ Constant of type int64 is converted to int *)
0.
Definition state_genesis_block : Tezos_shell.State.Chain.genesis :=
{| State.Chain.time := genesis_time; State.Chain.block := genesis_hash;
State.Chain.protocol := genesis_protocol |}.
Definition chain_id : Tezos_base__TzPervasives.Chain_id.t :=
Chain_id.of_block_hash genesis_hash.
Definition proto : Tezos_protocol_updater.Registered_protocol.t :=
match Registered_protocol.get genesis_protocol with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some proto => proto
end.
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition incr_timestamp (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
: Tezos_base__TzPervasives.Time.Protocol.t :=
Time.Protocol.add timestamp
(Int64.add
(* ❌ Constant of type int64 is converted to int *)
1
(Random.int64
(* ❌ Constant of type int64 is converted to int *)
10)).
Definition incr_fitness (fitness : list Stdlib.Bytes.t) : list Stdlib.Bytes.t :=
let new_fitness :=
match fitness with
| cons fitness [] =>
op_pipegt
(op_pipegt
(op_pipegt (Data_encoding.Binary.of_bytes Data_encoding.int64 fitness)
(Option.unopt
(* ❌ Constant of type int64 is converted to int *)
0)) Int64.succ)
(Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
| _ =>
Data_encoding.Binary.to_bytes_exn Data_encoding.int64
(* ❌ Constant of type int64 is converted to int *)
1
end in
cons new_fitness [].
Definition init_chain (base_dir : string) : Lwt.t Tezos_shell.State.Chain.t :=
let store_root := op_divdiv base_dir "store" % string in
let context_root := op_divdiv base_dir "context" % string in
op_gtgteq
(State.init None None None None store_root context_root
(Some Tezos_shell_services.History_mode.Archive) state_genesis_block)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ => Pervasives.failwith "read err" % string
| Stdlib.Ok (_state, chain, _index, _history_mode) => Lwt._return chain
end).
Definition block_header
(op_staroptstar : option Tezos_base__TzPervasives.Context_hash.t)
: Tezos_shell.State.Block.t -> Tezos_base__TzPervasives.Block_header.t :=
let context :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Context_hash.zero
end in
fun pred =>
let pred_header := State.Block.shell_header pred in
let timestamp := incr_timestamp (timestamp pred_header) in
let fitness := incr_fitness (fitness pred_header) in
{|
Block_header.shell :=
{| level := Int32.add Int32.one (State.Block.level pred);
proto_level := 0; predecessor := State.Block.hash pred;
timestamp := timestamp; validation_passes := 0;
operations_hash := Operation_list_list_hash.empty; fitness := fitness;
context := context |};
Block_header.protocol_data := Stdlib.Bytes.of_string "" % string |}.
Definition zero : string := Stdlib.Bytes.create 0.
Definition make_empty_chain (chain : Tezos_shell.State.Chain.t) (n : Z)
: Lwt.t Tezos_base__TzPervasives.Block_hash.t :=
op_gtgteq
(op_gtpipeeq (State.Block.read_opt chain genesis_hash)
(Option.unopt_assert Stdlib.__POS__))
(fun genesis =>
op_gtgteq (State.Block.context_exn genesis)
(fun empty_context =>
let header := State.Block.header genesis in
let timestamp := State.Block.timestamp genesis in
let empty_context_hash := Context.hash timestamp None empty_context in
op_gtgteq
(Context.commit (timestamp (shell header)) None empty_context)
(fun context =>
let header :=
(* ❌ Record substitution not handled *)
record_substitution in
let empty_result :=
{| Block_validation.context_hash := empty_context_hash;
Block_validation.message := None;
Block_validation.max_operations_ttl := 0;
Block_validation.last_allowed_fork_level :=
(* ❌ Constant of type int32 is converted to int *)
0 |} in
let fix loop (lvl : Z) (pred : Tezos_crypto.Block_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_crypto.Block_hash.t) :=
if OCaml.Stdlib.ge lvl n then
_return pred
else
let header :=
(* ❌ Record substitution not handled *)
record_substitution in
op_gtgteqquestion
(State.Block.store None chain header zero [] [] empty_result
false)
(fun function_parameter =>
let '_ := function_parameter in
loop (Z.add lvl 1) (Block_header.hash header)) in
op_gtgteq (loop 1 genesis_hash)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok b => Lwt._return b
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Error_monad.pp_print_error Format.err_formatter err
in
(* ❌ Assert instruction is not handled. *)
assert false
end)))).
Definition time1 {a : Type} (f : unit -> a) : a * Z :=
let t := Unix.gettimeofday tt in
let res := f tt in
let wall_clock := Stdlib.op_minuspoint (Unix.gettimeofday tt) t in
(res, wall_clock).
Definition time {A : Type} (op_staroptstar : option Z) : (unit -> A) -> A * Z :=
let runs :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 1
end in
fun f =>
if OCaml.Stdlib.lt runs 1 then
OCaml.Stdlib.invalid_arg "time negative arg" % string
else
let fix loop (cnt : Z) (sum : Z) : Z :=
if equiv_decb cnt runs then
sum
else
let '(_, t) := time1 f in
loop (Z.add cnt 1) (Stdlib.op_pluspoint sum t) in
let '(res, t) := time1 f in
let sum := loop 1 t in
(res, (Stdlib.op_divpoint sum (Stdlib.float runs))).
Fixpoint repeat {A : Type} (f : unit -> A) (n : Z) : unit :=
if OCaml.Stdlib.lt n 0 then
OCaml.Stdlib.invalid_arg "repeat: negative arg" % string
else
if equiv_decb n 0 then
tt
else
let '_ := f tt in
repeat f (Z.sub n 1).
Definition print_block (b : Tezos_shell.State.Block.t) : unit :=
Printf.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
(CamlinternalFormatBasics.Lit_padding CamlinternalFormatBasics.Right 6)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
CamlinternalFormatBasics.End_of_format)))) "%6i %s
" % string)
(Int32.to_int (State.Block.level b))
(Block_hash.to_b58check (State.Block.hash b)).
Definition print_block_h
(chain : Tezos_shell__State.Chain.t)
(bh : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
op_gtpipeeq
(op_gtpipeeq (State.Block.read_opt chain bh)
(Option.unopt_assert Stdlib.__POS__)) (fun b => print_block b).
Definition linear_predecessor
(chain : Tezos_shell__State.Chain.t)
(bh : Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
op_gtgteq
(op_gtpipeeq (State.Block.read_opt chain bh)
(Option.unopt_assert Stdlib.__POS__))
(fun b =>
op_gtpipeeq (State.Block.predecessor b)
(fun function_parameter =>
match function_parameter with
| None => None
| Some pred => Some (State.Block.hash pred)
end)).
Definition print_chain
(chain : Tezos_shell__State.Chain.t)
(bh : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
let fix loop (bh : Tezos_base__TzPervasives.Block_hash.t) (cnt : Z)
: Lwt.t unit :=
let '_ := print_block_h chain bh in
op_gtgteq (linear_predecessor chain bh)
(fun function_parameter =>
match function_parameter with
| Some pred => loop pred (Z.add cnt 1)
| None => Lwt.return_unit
end) in
loop bh 0.
Definition linear_predecessor_n
(chain : Tezos_shell.State.Chain.t)
(bh : Tezos_base__TzPervasives.Block_hash.t) (distance : Z)
: Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
if OCaml.Stdlib.lt distance 1 then
OCaml.Stdlib.invalid_arg "distance<1" % string
else
let fix loop (bh : Tezos_base__TzPervasives.Block_hash.t) (distance : Z)
: Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
if equiv_decb distance 0 then
Lwt.return_some bh
else
op_gtgteq (linear_predecessor chain bh)
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_none
| Some pred => loop pred (Z.sub distance 1)
end) in
loop bh distance.
Definition test_pred (base_dir : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let size_chain := 1000 in
op_gtgteq (init_chain base_dir)
(fun chain =>
op_gtgteq (make_empty_chain chain size_chain)
(fun head =>
let test_once (distance : Z) : Lwt.t unit :=
op_gtgteq (linear_predecessor_n chain head distance)
(fun lin_res =>
op_gtgteq
(op_gtpipeeq (State.Block.read_opt chain head)
(Option.unopt_assert Stdlib.__POS__))
(fun head_block =>
op_gtgteq (State.Block.predecessor_n head_block distance)
(fun exp_res =>
match (lin_res, exp_res) with
| (None, None) => Lwt.return_unit
| (None, Some _) | (Some _, None) =>
op_startypeminuserrorstar
"mismatch between exponential and linear predecessor_n"
% string
| (Some lin_res, Some exp_res) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb lin_res exp_res) in
op_gtgteq
(op_gtpipeeq (State.Block.read_opt chain lin_res)
(Option.unopt_assert Stdlib.__POS__))
(fun pred =>
let level_pred :=
Int32.to_int (State.Block.level pred) in
op_gtgteq
(op_gtpipeeq (State.Block.read_opt chain head)
(Option.unopt_assert Stdlib.__POS__))
(fun head =>
let level_start :=
Int32.to_int (State.Block.level head) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(equiv_decb (Z.sub level_start distance)
level_pred) in
Lwt.return_unit))
end))) in
let '_ := Random.self_init tt in
let range := Z.add size_chain (Z.div size_chain 10) in
let repeats := 100 in
_return
(repeat
(fun function_parameter =>
let 'tt := function_parameter in
test_once (Z.add 1 (Random.int range))) repeats))).
Definition seed : Tezos_base__TzPervasives.Block_locator.seed :=
let receiver_id :=
P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size "r" % char) in
let sender_id :=
P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size "s" % char) in
{| Block_locator.sender_id := sender_id;
Block_locator.receiver_id := receiver_id |}.
Definition compute_linear_locator
(chain_state : Tezos_shell.State.Chain.t) (size : Z)
(block : Tezos_shell.State.Block.t)
: Tezos_crypto.Block_hash.t -> Lwt.t Tezos_base__TzPervasives.Block_locator.t :=
let block_hash := State.Block.hash block in
let header := State.Block.header block in
Block_locator.compute (linear_predecessor_n chain_state)
(* ❌ expected an argument *)
expected_argument size block_hash header seed.
Definition compute_size_locator (size_chain : Z) : Z :=
let repeats :=
(* ❌ Float constant 10. is approximated by the integer 10 *)
10 in
Z.mul
(Stdlib.int_of_float
(Stdlib.op_minuspoint
(Stdlib.op_divpoint
(Stdlib.log (Stdlib.op_divpoint (Stdlib.float size_chain) repeats))
(Stdlib.log
(* ❌ Float constant 2. is approximated by the integer 2 *)
2))
(* ❌ Float constant 1. is approximated by the integer 1 *)
1)) 10.
Definition compute_size_chain (size_locator : Z) : Z :=
let repeats :=
(* ❌ Float constant 10. is approximated by the integer 10 *)
10 in
Stdlib.int_of_float
(Stdlib.op_starpoint repeats
(Stdlib.op_starstar
(* ❌ Float constant 2. is approximated by the integer 2 *)
2 (Stdlib.float (Z.add size_locator 1)))).
Definition test_locator (base_dir : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let size_chain := 80000 in
let runs := 10 in
let '_ :=
Printf.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "#runs " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal "010" % char
CamlinternalFormatBasics.End_of_format))) "#runs %i
" % string)
runs in
let exp_limit := compute_size_chain 120 in
let '_ :=
Printf.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "#exp_limit " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal "010" % char
CamlinternalFormatBasics.End_of_format)))
"#exp_limit %i
" % string) exp_limit in
let locator_limit := compute_size_locator size_chain in
let '_ :=
Printf.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "#locator_limit " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal "010" % char
CamlinternalFormatBasics.End_of_format)))
"#locator_limit %i
" % string) locator_limit in
op_gtgteq (init_chain base_dir)
(fun chain =>
OCaml.Stdlib.reverse_apply
(time1
(fun function_parameter =>
let 'tt := function_parameter in
make_empty_chain chain size_chain))
(fun function_parameter =>
let '(res, t_chain) := function_parameter in
let '_ :=
Printf.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "#size_chain " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" built in " % string
(CamlinternalFormatBasics.Float
CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" sec
# size exp lins
" % string
CamlinternalFormatBasics.End_of_format)))))
"#size_chain %i built in %f sec
# size exp lins
"
% string) size_chain t_chain in
op_gtgteq res
(fun head =>
let check_locator (size : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq
(State.read_chain_data chain
(fun function_parameter =>
let '_ := function_parameter in
fun data =>
Lwt._return ((caboose data), (save_point data))))
(fun function_parameter =>
let '((_, caboose), _save_point) := function_parameter in
op_gtgteqquestion (State.Block.read chain head)
(fun block =>
OCaml.Stdlib.reverse_apply
(time (Some runs)
(fun function_parameter =>
let 'tt := function_parameter in
State.compute_locator chain (Some size) block seed))
(fun function_parameter =>
let '(l_exp, t_exp) := function_parameter in
OCaml.Stdlib.reverse_apply
(time (Some runs)
(fun function_parameter =>
let 'tt := function_parameter in
compute_linear_locator chain size block
caboose))
(fun function_parameter =>
let '(l_lin, t_lin) := function_parameter in
op_gtgteq l_exp
(fun l_exp =>
op_gtgteq l_lin
(fun l_lin =>
let '(_, l_exp) := l_exp in
let '(_, l_lin) := l_lin in
let '_ :=
Printf.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_i
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Right
10)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
" " % char
(CamlinternalFormatBasics.Float
CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
" " % char
(CamlinternalFormatBasics.Float
CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
"010" % char
CamlinternalFormatBasics.End_of_format))))))
"%10i %f %f
" % string) size t_exp
t_lin in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter2
(fun hn =>
fun ho =>
if negb (Block_hash.equal hn ho)
then
op_startypeminuserrorstar
"Invalid locator %i" %
string size
else
tt) l_exp l_lin in
return_unit)))))) in
let stop := Z.add locator_limit 20 in
let fix loop (size : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if OCaml.Stdlib.lt size stop then
op_gtgteqquestion (check_locator size)
(fun function_parameter =>
let '_ := function_parameter in
loop (Z.add size 5))
else
return_unit in
loop 1))).
Definition wrap {A B : Type}
(n : A) (f : string -> Lwt.t (sum unit Tezos_base__TzPervasives.trace)) : B :=
op_startypeminuserrorstar n
(* ❌ Variants not supported *)
variant
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.with_tempdir "tezos_test_" % string
(fun dir =>
op_gtgteq (f dir)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error error =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
pp_print_error error
end))).
Definition tests {A : Type} : list A :=
cons (wrap "test pred" % string test_pred) [].
Definition bench {A : Type} : list A :=
cons (wrap "test locator" % string test_locator) [].
Definition tests {A : Type} : list A :=
(* ❌ Try-with are not handled *)
try
(if equiv_decb (Array.get Sys.argv 1) "--no-bench" % string then
tests
else
OCaml.Stdlib.app tests bench).
src/lib_shell/test/test_state.ml 208 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let ( // ) = Filename.concat
(** Basic blocks *)
let genesis_block =
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"
let genesis_protocol =
Protocol_hash.of_b58check_exn
"ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"
let genesis_time = Time.Protocol.of_seconds 0L
let proto =
match Registered_protocol.get genesis_protocol with
| None ->
assert false
| Some proto ->
proto
module Proto = (val proto)
let genesis : State.Chain.genesis =
{time = genesis_time; block = genesis_block; protocol = genesis_protocol}
let chain_id = Chain_id.of_block_hash genesis_block
let incr_fitness fitness =
let new_fitness =
match fitness with
| [fitness] ->
Pervasives.(
Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
|> Option.unopt ~default:0L |> Int64.succ
|> Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
| _ ->
Data_encoding.Binary.to_bytes_exn Data_encoding.int64 1L
in
[new_fitness]
let incr_timestamp timestamp =
Time.Protocol.add timestamp (Int64.add 1L (Random.int64 10L))
let operation op =
let op : Operation.t =
{shell = {branch = genesis_block}; proto = Bytes.of_string op}
in
(Operation.hash op, op, Data_encoding.Binary.to_bytes Operation.encoding op)
let block_header_data_encoding =
Data_encoding.(obj1 (req "proto_block_header" string))
let block _state ?(context = Context_hash.zero) ?(operations = [])
(pred : State.Block.t) name : Block_header.t =
let operations_hash =
Operation_list_list_hash.compute [Operation_list_hash.compute operations]
in
let pred_header = State.Block.shell_header pred in
let fitness = incr_fitness pred_header.fitness in
let timestamp = incr_timestamp pred_header.timestamp in
let protocol_data =
Data_encoding.Binary.to_bytes_exn block_header_data_encoding name
in
{
shell =
{
level = Int32.succ pred_header.level;
proto_level = pred_header.proto_level;
predecessor = State.Block.hash pred;
validation_passes = 1;
timestamp;
operations_hash;
fitness;
context;
};
protocol_data;
}
let parsed_block ({shell; protocol_data} : Block_header.t) =
let protocol_data =
Data_encoding.Binary.of_bytes_exn
Proto.block_header_data_encoding
protocol_data
in
({shell; protocol_data} : Proto.block_header)
let zero = Bytes.create 0
let build_valid_chain state vtbl pred names =
Lwt_list.fold_left_s
(fun pred name ->
State.Block.context_exn pred
>>= fun predecessor_context ->
let max_trials = 100 in
let rec attempt trials context =
(let (oph, op, _bytes) = operation name in
let block = block ?context state ~operations:[oph] pred name in
let hash = Block_header.hash block in
let pred_header = State.Block.header pred in
(let predecessor_context =
Shell_context.wrap_disk_context predecessor_context
in
Proto.begin_application
~chain_id:Chain_id.zero
~predecessor_context
~predecessor_timestamp:pred_header.shell.timestamp
~predecessor_fitness:pred_header.shell.fitness
(parsed_block block)
>>=? fun vstate ->
(* no operations *)
Proto.finalize_block vstate)
>>=? fun (result, _metadata) ->
let context = Shell_context.unwrap_disk_context result.context in
Context.commit ~time:block.shell.timestamp context
>>= fun context_hash ->
let validation_store =
( {
context_hash;
message = result.message;
max_operations_ttl = 1;
last_allowed_fork_level = result.last_allowed_fork_level;
}
: Block_validation.validation_store )
in
State.Block.store
state
block
zero
[[op]]
[[zero]]
( {
context_hash;
message = validation_store.message;
max_operations_ttl = 1;
last_allowed_fork_level =
validation_store.last_allowed_fork_level;
}
: Block_validation.validation_store )
~forking_testchain:false
>>=? fun _vblock ->
State.Block.read state hash
>>=? fun vblock ->
Hashtbl.add vtbl name vblock ;
return vblock)
>>= function
| Ok v ->
if trials < max_trials then
Format.eprintf
"Took %d trials to build valid chain"
(max_trials - trials + 1) ;
Lwt.return v
| Error (Validation_errors.Inconsistent_hash (got, _) :: _) ->
(* Kind of a hack, but at least it tests idempotence to some extent. *)
if trials <= 0 then assert false
else (
Format.eprintf
"Inconsistent context hash: got %a, retrying (%d)\n"
Context_hash.pp
got
trials ;
attempt (trials - 1) (Some got) )
| Error err ->
Format.eprintf "Error: %a\n" Error_monad.pp_print_error err ;
assert false
in
attempt max_trials None)
pred
names
>>= fun _ -> Lwt.return_unit
type state = {
vblock : (string, State.Block.t) Hashtbl.t;
state : State.t;
chain : State.Chain.t;
}
let vblock s = Hashtbl.find s.vblock
exception Found of string
let vblocks s =
Hashtbl.fold (fun k v acc -> (k, v) :: acc) s.vblock []
|> List.sort Pervasives.compare
(*******************************************************)
(*
Genesis - A1 - A2 - A3 - A4 - A5 - A6 - A7 - A8
\
B1 - B2 - B3 - B4 - B5 - B6 - B7 - B8
*)
let build_example_tree chain =
let vtbl = Hashtbl.create 23 in
Chain.genesis chain
>>= fun genesis ->
Hashtbl.add vtbl "Genesis" genesis ;
let c = ["A1"; "A2"; "A3"; "A4"; "A5"; "A6"; "A7"; "A8"] in
build_valid_chain chain vtbl genesis c
>>= fun () ->
let a3 = Hashtbl.find vtbl "A3" in
let c = ["B1"; "B2"; "B3"; "B4"; "B5"; "B6"; "B7"; "B8"] in
build_valid_chain chain vtbl a3 c >>= fun () -> Lwt.return vtbl
let wrap_state_init f base_dir =
let store_root = base_dir // "store" in
let context_root = base_dir // "context" in
State.init
~store_mapsize:4_096_000_000L
~context_mapsize:4_096_000_000L
~store_root
~context_root
genesis
>>=? fun (state, chain, _index, _history_mode) ->
build_example_tree chain >>= fun vblock -> f {state; chain; vblock}
let test_init (_ : state) = return_unit
(** State.Block.read *)
let test_read_block (s : state) =
Lwt_list.iter_s
(fun (name, vblock) ->
let hash = State.Block.hash vblock in
State.Block.read s.chain hash
>>= function
| Error _ ->
Assert.fail_msg "Error while reading valid block %s" name
| Ok _vblock' ->
(* FIXME COMPARE read operations ??? *)
Lwt.return_unit)
(vblocks s)
>>= fun () -> return_unit
(****************************************************************************)
(** Chain.set_checkpoint_then_purge_full *)
let test_set_checkpoint_then_purge_full (s : state) =
State.Chain.checkpoint s.chain
>>= fun checkpoint ->
let checkpoint_lvl = checkpoint.shell.level in
let checkpoint_hash = Block_header.hash checkpoint in
(* At the beginning the checkpoint is the genesis. *)
State.Block.read s.chain genesis_block
>>=? fun read_genesis ->
let read_genesis_hash =
Block_header.hash (State.Block.header read_genesis)
in
assert (Block_hash.equal checkpoint_hash read_genesis_hash) ;
assert (checkpoint_lvl = Int32.zero) ;
let a1 = vblock s "A1" in
let ha1 = State.Block.hash a1 in
let b1 = vblock s "B1" in
let hb1 = State.Block.hash b1 in
let b2 = vblock s "B2" in
let hb2 = State.Block.hash b2 in
let la1 = State.Block.level a1 in
let lb1 = State.Block.level b1 in
let lb2 = State.Block.level b2 in
assert (Int32.compare checkpoint_lvl la1 = -1) ;
assert (Int32.compare checkpoint_lvl lb1 = -1) ;
assert (Int32.compare checkpoint_lvl lb2 = -1) ;
State.Chain.store s.chain
>>= fun chain_store ->
let chain_store = Store.Chain.get chain_store (State.Chain.id s.chain) in
let block_store = Store.Block.get chain_store in
(* Let us set a new checkpoint "B1" whose level is greater than the genesis. *)
State.Chain.set_checkpoint_then_purge_full s.chain (State.Block.header b2)
>>=? fun () ->
(* Assert b2 does still exist and is the new checkpoint. *)
State.Block.known s.chain hb2
>|= (fun b -> assert b)
>>= fun () ->
State.Chain.checkpoint s.chain
>|= (fun b ->
assert (Block_hash.equal (Block_header.hash b) hb2) ;
assert (Int32.equal b.shell.level lb2))
>>= fun () ->
(* Assert b1 has been pruned.. *)
Store.Block.Contents.known (block_store, hb1)
>|= (fun b -> assert (not b))
>>= fun () ->
(* pruned, so we can still access its header. *)
State.Block.read_opt s.chain hb1
>|= (function Some _header -> assert true | None -> assert false)
>>= fun () ->
(* Assert a1 has also been pruned .. *)
Store.Block.Contents.known (block_store, ha1)
>|= (fun b -> assert (not b))
>>= fun () ->
(* and we can also access its header. *)
State.Block.read_opt s.chain ha1
>|= (function Some _header -> assert true | None -> assert false)
>>= fun () ->
(* and is accesible in Store.Block.Header *)
Store.Block.Pruned_contents.known (block_store, ha1)
>|= (fun b -> assert b)
>>= fun () -> return_unit
(** Chain.set_checkpoint_then_purge_rolling *)
let test_set_checkpoint_then_purge_rolling (s : state) =
State.Chain.checkpoint s.chain
>>= fun checkpoint ->
let checkpoint_lvl = checkpoint.shell.level in
let checkpoint_hash = Block_header.hash checkpoint in
(* At the beginning the checkpoint is the genesis. *)
State.Block.read s.chain genesis_block
>>=? fun read_genesis ->
let read_genesis_hash =
Block_header.hash (State.Block.header read_genesis)
in
assert (Block_hash.equal checkpoint_hash read_genesis_hash) ;
assert (checkpoint_lvl = Int32.zero) ;
let a1 = vblock s "A1" in
let ha1 = State.Block.hash a1 in
let b1 = vblock s "B1" in
let hb1 = State.Block.hash b1 in
let b2 = vblock s "B2" in
let hb2 = State.Block.hash b2 in
let la1 = State.Block.level a1 in
let lb1 = State.Block.level b1 in
let lb2 = State.Block.level b2 in
assert (Int32.compare checkpoint_lvl la1 = -1) ;
assert (Int32.compare checkpoint_lvl lb1 = -1) ;
assert (Int32.compare checkpoint_lvl lb2 = -1) ;
State.Block.max_operations_ttl b2
>>=? fun max_op_ttl ->
assert (max_op_ttl > 0) ;
let ilb1 = Int32.to_int lb1 in
let ilb2 = Int32.to_int lb2 in
(* Assert b1 is in the to-prune range. *)
assert (ilb2 - ilb1 <= min max_op_ttl ilb2) ;
(* Assert a1 is in the to-delete range. *)
let ila1 = Int32.to_int la1 in
assert (ilb2 - ila1 > min max_op_ttl ilb2) ;
(* Assert b1 is not yet in Store.Block.Header since not pruned *)
State.Chain.store s.chain
>>= fun chain_store ->
let chain_store = Store.Chain.get chain_store (State.Chain.id s.chain) in
let block_store = Store.Block.get chain_store in
Store.Block.Pruned_contents.known (block_store, hb1)
>|= (fun b -> assert (not b))
>>= fun () ->
(* But accessible with State.Block.Header *)
State.Block.known s.chain hb1
>|= (fun b -> assert b)
(* And Store.Block.Contents *)
>>= fun () ->
Store.Block.Contents.known (block_store, hb1)
>|= (fun b -> assert b)
(* Let us set a new checkpoint "B1" whose level is greater than the genesis. *)
>>= fun () ->
State.Chain.set_checkpoint_then_purge_rolling s.chain (State.Block.header b2)
>>=? fun () ->
(* Assert b2 does still exist and is the new checkpoint. *)
State.Block.known s.chain hb2
>|= (fun b -> assert b)
>>= fun () ->
State.Chain.checkpoint s.chain
>|= (fun b ->
assert (Block_hash.equal (Block_header.hash b) hb2) ;
assert (Int32.equal b.shell.level lb2))
>>= fun () ->
(* Assert b1 has been pruned.. *)
Store.Block.Contents.known (block_store, hb1)
>|= (fun b -> assert (not b))
>>= fun () ->
(* pruned, so we can still access its header. *)
State.Block.read_opt s.chain hb1
>|= (function Some _block -> assert true | None -> assert false)
>>= fun () ->
(* Assert b1 is now in Store.Block.Header since it has been pruned *)
Store.Block.Pruned_contents.known (block_store, hb1)
>|= (fun b -> assert b)
>>= fun () ->
(* And also accessible with State.Block.Header *)
State.Block.Header.known (block_store, hb1)
>|= (fun b -> assert b)
(* But not in Store.Block.Contents *)
>>= fun () ->
Store.Block.Contents.known (block_store, hb1)
>|= (fun b -> assert (not b))
>>= fun () ->
(* Assert a1 has been deleted.. *)
State.Block.known s.chain ha1
>|= (fun b -> assert (not b))
>>= fun () ->
(* deleted, so we can not access its header anymore. *)
State.Block.read_opt s.chain ha1
>|= (function Some _header -> assert false | None -> assert true)
>>= fun () ->
(* Assert b1 is now in Store.Block.Header since it has been pruned *)
Store.Block.Pruned_contents.known (block_store, ha1)
>|= (fun b -> assert (not b))
>>= fun () ->
(* And not in State.Block.Header *)
State.Block.Header.known (block_store, ha1)
>|= (fun b -> assert (not b))
(* Neither in Store.Block.Contents *)
>>= fun () ->
Store.Block.Contents.known (block_store, hb1)
>|= (fun b -> assert (not b))
(* *)
>>= fun () -> return_unit
(****************************************************************************)
(** Chain_traversal.path *)
let rec compare_path p1 p2 =
match (p1, p2) with
| ([], []) ->
true
| (h1 :: p1, h2 :: p2) ->
Block_hash.equal h1 h2 && compare_path p1 p2
| _ ->
false
let test_path (s : state) =
let check_path h1 h2 p2 =
Chain_traversal.path (vblock s h1) (vblock s h2)
>>= function
| None ->
Assert.fail_msg "cannot compute path %s -> %s" h1 h2
| Some (p : State.Block.t list) ->
let p = List.map State.Block.hash p in
let p2 = List.map (fun b -> State.Block.hash (vblock s b)) p2 in
if not (compare_path p p2) then
Assert.fail_msg "bad path %s -> %s" h1 h2 ;
Lwt.return_unit
in
check_path "Genesis" "Genesis" []
>>= fun () ->
check_path "A1" "A1" []
>>= fun () ->
check_path "A2" "A6" ["A3"; "A4"; "A5"; "A6"]
>>= fun () ->
check_path "B2" "B6" ["B3"; "B4"; "B5"; "B6"]
>>= fun () ->
check_path "A1" "B3" ["A2"; "A3"; "B1"; "B2"; "B3"] >>= fun () -> return_unit
(****************************************************************************)
(** Chain_traversal.common_ancestor *)
let test_ancestor s =
let check_ancestor h1 h2 expected =
Chain_traversal.common_ancestor (vblock s h1) (vblock s h2)
>>= fun a ->
if not (Block_hash.equal (State.Block.hash a) (State.Block.hash expected))
then Assert.fail_msg "bad ancestor %s %s" h1 h2 ;
Lwt.return_unit
in
check_ancestor "Genesis" "Genesis" (vblock s "Genesis")
>>= fun () ->
check_ancestor "Genesis" "A3" (vblock s "Genesis")
>>= fun () ->
check_ancestor "A3" "Genesis" (vblock s "Genesis")
>>= fun () ->
check_ancestor "A1" "A1" (vblock s "A1")
>>= fun () ->
check_ancestor "A1" "A3" (vblock s "A1")
>>= fun () ->
check_ancestor "A3" "A1" (vblock s "A1")
>>= fun () ->
check_ancestor "A6" "B6" (vblock s "A3")
>>= fun () ->
check_ancestor "B6" "A6" (vblock s "A3")
>>= fun () ->
check_ancestor "A4" "B1" (vblock s "A3")
>>= fun () ->
check_ancestor "B1" "A4" (vblock s "A3")
>>= fun () ->
check_ancestor "A3" "B1" (vblock s "A3")
>>= fun () ->
check_ancestor "B1" "A3" (vblock s "A3")
>>= fun () ->
check_ancestor "A2" "B1" (vblock s "A2")
>>= fun () ->
check_ancestor "B1" "A2" (vblock s "A2") >>= fun () -> return_unit
(****************************************************************************)
let seed =
let receiver_id =
P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size 'r')
in
let sender_id =
P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size 's')
in
{Block_locator.receiver_id; sender_id}
(** Chain_traversal.block_locator *)
let test_locator s =
let check_locator length h1 expected =
State.compute_locator s.chain ~size:length (vblock s h1) seed
>>= fun l ->
let (_, l) = (l : Block_locator.t :> _ * _) in
if List.length l <> List.length expected then
Assert.fail_msg
"Invalid locator length %s (found: %d, expected: %d)"
h1
(List.length l)
(List.length expected) ;
List.iter2
(fun h h2 ->
if not (Block_hash.equal h (State.Block.hash @@ vblock s h2)) then
Assert.fail_msg "Invalid locator %s (expected: %s)" h1 h2)
l
expected ;
Lwt.return_unit
in
check_locator 6 "A8" ["A7"; "A6"; "A5"; "A4"; "A3"; "A2"]
>>= fun () ->
check_locator 8 "B8" ["B7"; "B6"; "B5"; "B4"; "B3"; "B2"; "B1"; "A3"]
>>= fun () ->
check_locator 4 "B8" ["B7"; "B6"; "B5"; "B4"]
>>= fun () ->
check_locator 0 "A5" []
>>= fun () ->
check_locator 100 "A5" ["A4"; "A3"; "A2"; "A1"; "Genesis"]
>>= fun () -> return_unit
(****************************************************************************)
(** Chain.known_heads *)
let compare s name heads l =
if List.length heads <> List.length l then
Assert.fail_msg
"unexpected known_heads size (%s: %d %d)"
name
(List.length heads)
(List.length l) ;
List.iter
(fun bname ->
let hash = State.Block.hash (vblock s bname) in
if
not
(List.exists
(fun b -> Block_hash.equal hash (State.Block.hash b))
heads)
then Assert.fail_msg "missing block in known_heads (%s: %s)" name bname)
l
let test_known_heads s =
Chain.known_heads s.chain
>>= fun heads ->
compare s "initial" heads ["A8"; "B8"] ;
return_unit
(****************************************************************************)
(** Chain.head/set_head *)
let test_head s =
Chain.head s.chain
>>= fun head ->
if not (Block_hash.equal (State.Block.hash head) genesis_block) then
Assert.fail_msg "unexpected head" ;
Chain.set_head s.chain (vblock s "A6")
>>= fun _ ->
Chain.head s.chain
>>= fun head ->
if
not
(Block_hash.equal
(State.Block.hash head)
(State.Block.hash @@ vblock s "A6"))
then Assert.fail_msg "unexpected head" ;
return_unit
(****************************************************************************)
(** Chain.mem *)
let test_mem s =
let mem s x = Chain.mem s.chain (State.Block.hash @@ vblock s x) in
let test_mem s x =
mem s x
>>= function
| true -> Lwt.return_unit | false -> Assert.fail_msg "mem %s" x
in
let test_not_mem s x =
mem s x
>>= function
| false -> Lwt.return_unit | true -> Assert.fail_msg "not (mem %s)" x
in
test_not_mem s "A3"
>>= fun () ->
test_not_mem s "A6"
>>= fun () ->
test_not_mem s "A8"
>>= fun () ->
test_not_mem s "B1"
>>= fun () ->
test_not_mem s "B6"
>>= fun () ->
test_not_mem s "B8"
>>= fun () ->
Chain.set_head s.chain (vblock s "A8")
>>= fun _ ->
test_mem s "A3"
>>= fun () ->
test_mem s "A6"
>>= fun () ->
test_mem s "A8"
>>= fun () ->
test_not_mem s "B1"
>>= fun () ->
test_not_mem s "B6"
>>= fun () ->
test_not_mem s "B8"
>>= fun () ->
Chain.set_head s.chain (vblock s "A6")
>>= fun _ ->
test_mem s "A3"
>>= fun () ->
test_mem s "A6"
>>= fun () ->
test_not_mem s "A8"
>>= fun () ->
test_not_mem s "B1"
>>= fun () ->
test_not_mem s "B6"
>>= fun () ->
test_not_mem s "B8"
>>= fun () ->
Chain.set_head s.chain (vblock s "B6")
>>= fun _ ->
test_mem s "A3"
>>= fun () ->
test_not_mem s "A4"
>>= fun () ->
test_not_mem s "A6"
>>= fun () ->
test_not_mem s "A8"
>>= fun () ->
test_mem s "B1"
>>= fun () ->
test_mem s "B6"
>>= fun () ->
test_not_mem s "B8"
>>= fun () ->
Chain.set_head s.chain (vblock s "B8")
>>= fun _ ->
test_mem s "A3"
>>= fun () ->
test_not_mem s "A4"
>>= fun () ->
test_not_mem s "A6"
>>= fun () ->
test_not_mem s "A8"
>>= fun () ->
test_mem s "B1"
>>= fun () ->
test_mem s "B6" >>= fun () -> test_mem s "B8" >>= fun () -> return_unit
(****************************************************************************)
(** Chain_traversal.new_blocks *)
let test_new_blocks s =
let test s head h expected_ancestor expected =
let to_block = vblock s head and from_block = vblock s h in
Chain_traversal.new_blocks ~from_block ~to_block
>>= fun (ancestor, blocks) ->
if
not
(Block_hash.equal
(State.Block.hash ancestor)
(State.Block.hash @@ vblock s expected_ancestor))
then
Assert.fail_msg
"Invalid ancestor %s -> %s (expected: %s)"
head
h
expected_ancestor ;
if List.length blocks <> List.length expected then
Assert.fail_msg
"Invalid locator length %s (found: %d, expected: %d)"
h
(List.length blocks)
(List.length expected) ;
List.iter2
(fun h1 h2 ->
if
not
(Block_hash.equal
(State.Block.hash h1)
(State.Block.hash @@ vblock s h2))
then
Assert.fail_msg
"Invalid new blocks %s -> %s (expected: %s)"
head
h
h2)
blocks
expected ;
Lwt.return_unit
in
test s "A6" "A6" "A6" []
>>= fun () ->
test s "A8" "A6" "A6" ["A7"; "A8"]
>>= fun () ->
test s "A8" "B7" "A3" ["A4"; "A5"; "A6"; "A7"; "A8"]
>>= fun () -> return_unit
(****************************************************************************)
let tests : (string * (state -> unit tzresult Lwt.t)) list =
[ ("init", test_init);
("read_block", test_read_block);
("path", test_path);
("ancestor", test_ancestor);
("locator", test_locator);
("known_heads", test_known_heads);
("head", test_head);
("mem", test_mem);
("new_blocks", test_new_blocks);
( "set_checkpoint_then_purge_rolling",
test_set_checkpoint_then_purge_rolling );
("set_checkpoint_then_purge_full", test_set_checkpoint_then_purge_full) ]
let wrap (n, f) =
Alcotest_lwt.test_case n `Quick (fun _ () ->
Lwt_utils_unix.with_tempdir "tezos_test_" (fun dir ->
wrap_state_init f dir
>>= function
| Ok () ->
Lwt.return_unit
| Error error ->
Format.kasprintf Pervasives.failwith "%a" pp_print_error error))
let tests = List.map wrap tests
src/lib_shell/test/test_state.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.
Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
Protocol_hash.of_b58check_exn
"ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.
Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
Time.Protocol.of_seconds
(* ❌ Constant of type int64 is converted to int *)
0.
Definition proto : Tezos_protocol_updater.Registered_protocol.t :=
match Registered_protocol.get genesis_protocol with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some proto => proto
end.
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition genesis : Tezos_shell.State.Chain.genesis :=
{| time := genesis_time; block := genesis_block; protocol := genesis_protocol
|}.
Definition chain_id : Tezos_base__TzPervasives.Chain_id.t :=
Chain_id.of_block_hash genesis_block.
Definition incr_fitness (fitness : list Stdlib.Bytes.t) : list Stdlib.Bytes.t :=
let new_fitness :=
match fitness with
| cons fitness [] =>
op_pipegt
(op_pipegt
(op_pipegt (Data_encoding.Binary.of_bytes Data_encoding.int64 fitness)
(Option.unopt
(* ❌ Constant of type int64 is converted to int *)
0)) Int64.succ)
(Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
| _ =>
Data_encoding.Binary.to_bytes_exn Data_encoding.int64
(* ❌ Constant of type int64 is converted to int *)
1
end in
cons new_fitness [].
Definition incr_timestamp (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
: Tezos_base__TzPervasives.Time.Protocol.t :=
Time.Protocol.add timestamp
(Int64.add
(* ❌ Constant of type int64 is converted to int *)
1
(Random.int64
(* ❌ Constant of type int64 is converted to int *)
10)).
Definition operation (op : string)
: Tezos_crypto.Operation_hash.t * Tezos_base__TzPervasives.Operation.t *
(option Stdlib.Bytes.t) :=
let op :=
{| shell := {| branch := genesis_block |};
proto := Stdlib.Bytes.of_string op |} in
((Operation.hash op), op,
(Data_encoding.Binary.to_bytes Operation.encoding op)).
Definition block_header_data_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding string :=
obj1 (req None None "proto_block_header" % string string).
Definition block {A : Type}
(_state : A) (op_staroptstar : option Tezos_base__TzPervasives.Context_hash.t)
: (option (list Tezos_base__TzPervasives.Operation_list_hash.elt)) ->
Tezos_shell.State.Block.t ->
string -> Tezos_base__TzPervasives.Block_header.t :=
let context :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Context_hash.zero
end in
fun op_staroptstar =>
let operations :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun pred =>
fun name =>
let operations_hash :=
Operation_list_list_hash.compute
(cons (Operation_list_hash.compute operations) []) in
let pred_header := State.Block.shell_header pred in
let fitness := incr_fitness (fitness pred_header) in
let timestamp := incr_timestamp (timestamp pred_header) in
let protocol_data :=
Data_encoding.Binary.to_bytes_exn block_header_data_encoding name in
{|
shell :=
{| level := Int32.succ (level pred_header);
proto_level := proto_level pred_header;
predecessor := State.Block.hash pred; timestamp := timestamp;
validation_passes := 1; operations_hash := operations_hash;
fitness := fitness; context := context |};
protocol_data := protocol_data |}.
Definition parsed_block
(function_parameter : Tezos_base__TzPervasives.Block_header.t)
: Proto.(Tezos_protocol_updater__Registered_protocol.T.block_header) :=
let '{| shell := shell; protocol_data := protocol_data |} :=
function_parameter in
let protocol_data :=
Data_encoding.Binary.of_bytes_exn
Proto.(Tezos_protocol_updater__Registered_protocol.T.block_header_data_encoding)
protocol_data in
{| shell := shell; protocol_data := protocol_data |}.
Definition zero : string := Stdlib.Bytes.create 0.
Definition build_valid_chain
(state : Tezos_shell__State.Chain.t)
(vtbl : Stdlib.Hashtbl.t string Tezos_shell.State.Block.t)
(pred : Tezos_shell.State.Block.t) (names : list string) : Lwt.t unit :=
op_gtgteq
(Lwt_list.fold_left_s
(fun pred =>
fun name =>
op_gtgteq (State.Block.context_exn pred)
(fun predecessor_context =>
let max_trials := 100 in
let fix attempt
(trials : Z) (context :
option Tezos_base__TzPervasives.Context_hash.t)
: Lwt.t Tezos_shell.State.Block.t :=
op_gtgteq
(let '(oph, op, _bytes) := operation name in
let block :=
block state context (Some (cons oph [])) pred name in
let hash := Block_header.hash block in
let pred_header := State.Block.header pred in
op_gtgteqquestion
(let predecessor_context :=
Shell_context.wrap_disk_context predecessor_context in
op_gtgteqquestion
(Proto.(Tezos_protocol_updater__Registered_protocol.T.begin_application)
Chain_id.zero predecessor_context
(timestamp (shell pred_header))
(fitness (shell pred_header)) (parsed_block block))
(fun vstate =>
Proto.(Tezos_protocol_updater__Registered_protocol.T.finalize_block)
vstate))
(fun function_parameter =>
let '(result, _metadata) := function_parameter in
let context :=
Shell_context.unwrap_disk_context (context result) in
op_gtgteq
(Context.commit (timestamp (shell block)) None context)
(fun context_hash =>
let validation_store :=
{| context_hash := context_hash;
message := message result;
max_operations_ttl := 1;
last_allowed_fork_level :=
last_allowed_fork_level result |} in
op_gtgteqquestion
(State.Block.store None state block zero
(cons (cons op []) []) (cons (cons zero []) [])
{| context_hash := context_hash;
message := message validation_store;
max_operations_ttl := 1;
last_allowed_fork_level :=
last_allowed_fork_level validation_store |}
false)
(fun _vblock =>
op_gtgteqquestion (State.Block.read state hash)
(fun vblock =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Hashtbl.add vtbl name vblock in
_return vblock)))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok v =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt trials max_trials then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Took " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" trials to build valid chain" % string
CamlinternalFormatBasics.End_of_format)))
"Took %d trials to build valid chain" % string)
(Z.add (Z.sub max_trials trials) 1)
else
tt in
Lwt._return v
|
Stdlib.Error
(cons (Tezos_base__TzPervasives.Inconsistent_hash got _)
_) =>
if OCaml.Stdlib.le trials 0 then
(* ❌ Assert instruction is not handled. *)
assert false
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Inconsistent context hash: got " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", retrying (" % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
")
" % string
CamlinternalFormatBasics.End_of_format)))))
"Inconsistent context hash: got %a, retrying (%d)
"
% string) Context_hash.pp got trials in
attempt (Z.sub trials 1) (Some got)
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"010" % char
CamlinternalFormatBasics.End_of_format)))
"Error: %a
" % string) Error_monad.pp_print_error
err in
(* ❌ Assert instruction is not handled. *)
assert false
end) in
attempt max_trials None)) pred names)
(fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit).
Record state := {
vblock : Stdlib.Hashtbl.t string Tezos_shell.State.Block.t;
state : Tezos_shell.State.t;
chain : Tezos_shell.State.Chain.t }.
Definition vblock (s : state) : string -> Tezos_shell.State.Block.t :=
Hashtbl.find (vblock s).
(* ❌ The definition of exceptions is not handled. *)
exception
Definition vblocks (s : state) : list (string * Tezos_shell.State.Block.t) :=
OCaml.Stdlib.reverse_apply
(Hashtbl.fold (fun k => fun v => fun acc => cons (k, v) acc) (vblock s) [])
(List.sort Pervasives.compare).
Definition build_example_tree (chain : Tezos_shell.State.Chain.t)
: Lwt.t (Stdlib.Hashtbl.t string Tezos_shell.State.Block.t) :=
let vtbl := Hashtbl.create None 23 in
op_gtgteq (Chain.genesis chain)
(fun genesis =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Hashtbl.add vtbl "Genesis" % string genesis in
let c :=
cons "A1" % string
(cons "A2" % string
(cons "A3" % string
(cons "A4" % string
(cons "A5" % string
(cons "A6" % string
(cons "A7" % string (cons "A8" % string []))))))) in
op_gtgteq (build_valid_chain chain vtbl genesis c)
(fun function_parameter =>
let 'tt := function_parameter in
let a3 := Hashtbl.find vtbl "A3" % string in
let c :=
cons "B1" % string
(cons "B2" % string
(cons "B3" % string
(cons "B4" % string
(cons "B5" % string
(cons "B6" % string
(cons "B7" % string (cons "B8" % string []))))))) in
op_gtgteq (build_valid_chain chain vtbl a3 c)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return vtbl))).
Definition wrap_state_init {A : Type}
(f : state -> Lwt.t (Tezos_base__TzPervasives.tzresult A)) (base_dir : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
let store_root := op_divdiv base_dir "store" % string in
let context_root := op_divdiv base_dir "context" % string in
op_gtgteqquestion
(State.init None None
(Some
(* ❌ Constant of type int64 is converted to int *)
4096000000)
(Some
(* ❌ Constant of type int64 is converted to int *)
4096000000) store_root context_root None genesis)
(fun function_parameter =>
let '(state, chain, _index, _history_mode) := function_parameter in
op_gtgteq (build_example_tree chain)
(fun vblock => f {| vblock := vblock; state := state; chain := chain |})).
Definition test_init (function_parameter : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '_ := function_parameter in
return_unit.
Definition test_read_block (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq
(Lwt_list.iter_s
(fun function_parameter =>
let '(name, vblock) := function_parameter in
let hash := State.Block.hash vblock in
op_gtgteq (State.Block.read (chain s) hash)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ =>
op_startypeminuserrorstar
"Error while reading valid block %s" % string name
| Stdlib.Ok _vblock' => Lwt.return_unit
end)) (vblocks s))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit).
Definition test_set_checkpoint_then_purge_full (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (State.Chain.checkpoint (chain s))
(fun checkpoint =>
let checkpoint_lvl := level (shell checkpoint) in
let checkpoint_hash := Block_header.hash checkpoint in
op_gtgteqquestion (State.Block.read (chain s) genesis_block)
(fun read_genesis =>
let read_genesis_hash :=
Block_header.hash (State.Block.header read_genesis) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (Block_hash.equal checkpoint_hash read_genesis_hash) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb checkpoint_lvl Int32.zero) in
let a1 := vblock s "A1" % string in
let ha1 := State.Block.hash a1 in
let b1 := vblock s "B1" % string in
let hb1 := State.Block.hash b1 in
let b2 := vblock s "B2" % string in
let hb2 := State.Block.hash b2 in
let la1 := State.Block.level a1 in
let lb1 := State.Block.level b1 in
let lb2 := State.Block.level b2 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb (Int32.compare checkpoint_lvl la1) (-1)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb (Int32.compare checkpoint_lvl lb1) (-1)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb (Int32.compare checkpoint_lvl lb2) (-1)) in
op_gtgteq (State.Chain.store (chain s))
(fun chain_store =>
let chain_store :=
Store.Chain.get chain_store (State.Chain.id (chain s)) in
let block_store := Store.Block.get chain_store in
op_gtgteqquestion
(State.Chain.set_checkpoint_then_purge_full (chain s)
(State.Block.header b2))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtpipeeq (State.Block.known (chain s) hb2)
(fun b =>
(* ❌ Assert instruction is not handled. *)
assert b))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtpipeeq (State.Chain.checkpoint (chain s))
(fun b =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Block_hash.equal (Block_header.hash b) hb2) in
(* ❌ Assert instruction is not handled. *)
assert (Int32.equal (level (shell b)) lb2)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtpipeeq
(Store.Block.Contents.known (block_store, hb1))
(fun b =>
(* ❌ Assert instruction is not handled. *)
assert (negb b)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtpipeeq
(State.Block.read_opt (chain s) hb1)
(fun function_parameter =>
match function_parameter with
| Some _header =>
(* ❌ Assert instruction is not handled. *)
assert true
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtpipeeq
(Store.Block.Contents.known
(block_store, ha1))
(fun b =>
(* ❌ Assert instruction is not handled. *)
assert (negb b)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtpipeeq
(State.Block.read_opt (chain s) ha1)
(fun function_parameter =>
match function_parameter with
| Some _header =>
(* ❌ Assert instruction is not handled. *)
assert true
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtpipeeq
(Store.Block.Pruned_contents.known
(block_store, ha1))
(fun b =>
(* ❌ Assert instruction is not handled. *)
assert b))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))))))))).
Definition test_set_checkpoint_then_purge_rolling (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (State.Chain.checkpoint (chain s))
(fun checkpoint =>
let checkpoint_lvl := level (shell checkpoint) in
let checkpoint_hash := Block_header.hash checkpoint in
op_gtgteqquestion (State.Block.read (chain s) genesis_block)
(fun read_genesis =>
let read_genesis_hash :=
Block_header.hash (State.Block.header read_genesis) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (Block_hash.equal checkpoint_hash read_genesis_hash) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb checkpoint_lvl Int32.zero) in
let a1 := vblock s "A1" % string in
let ha1 := State.Block.hash a1 in
let b1 := vblock s "B1" % string in
let hb1 := State.Block.hash b1 in
let b2 := vblock s "B2" % string in
let hb2 := State.Block.hash b2 in
let la1 := State.Block.level a1 in
let lb1 := State.Block.level b1 in
let lb2 := State.Block.level b2 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb (Int32.compare checkpoint_lvl la1) (-1)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb (Int32.compare checkpoint_lvl lb1) (-1)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb (Int32.compare checkpoint_lvl lb2) (-1)) in
op_gtgteqquestion (State.Block.max_operations_ttl b2)
(fun max_op_ttl =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.gt max_op_ttl 0) in
let ilb1 := Int32.to_int lb1 in
let ilb2 := Int32.to_int lb2 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(OCaml.Stdlib.le (Z.sub ilb2 ilb1)
(OCaml.Stdlib.min max_op_ttl ilb2)) in
let ila1 := Int32.to_int la1 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(OCaml.Stdlib.gt (Z.sub ilb2 ila1)
(OCaml.Stdlib.min max_op_ttl ilb2)) in
op_gtgteq (State.Chain.store (chain s))
(fun chain_store =>
let chain_store :=
Store.Chain.get chain_store (State.Chain.id (chain s)) in
let block_store := Store.Block.get chain_store in
op_gtgteq
(op_gtpipeeq
(Store.Block.Pruned_contents.known (block_store, hb1))
(fun b =>
(* ❌ Assert instruction is not handled. *)
assert (negb b)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtpipeeq (State.Block.known (chain s) hb1)
(fun b =>
(* ❌ Assert instruction is not handled. *)
assert b))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtpipeeq
(Store.Block.Contents.known (block_store, hb1))
(fun b =>
(* ❌ Assert instruction is not handled. *)
assert b))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(State.Chain.set_checkpoint_then_purge_rolling
(chain s) (State.Block.header b2))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtpipeeq
(State.Block.known (chain s) hb2)
(fun b =>
(* ❌ Assert instruction is not handled. *)
assert b))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtpipeeq
(State.Chain.checkpoint (chain s))
(fun b =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Block_hash.equal
(Block_header.hash b) hb2) in
(* ❌ Assert instruction is not handled. *)
assert
(Int32.equal (level (shell b)) lb2)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtpipeeq
(Store.Block.Contents.known
(block_store, hb1))
(fun b =>
(* ❌ Assert instruction is not handled. *)
assert (negb b)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtpipeeq
(State.Block.read_opt
(chain s) hb1)
(fun function_parameter =>
match function_parameter
with
| Some _block =>
(* ❌ Assert instruction is not handled. *)
assert true
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
end))
(fun function_parameter =>
let 'tt := function_parameter
in
op_gtgteq
(op_gtpipeeq
(Store.Block.Pruned_contents.known
(block_store, hb1))
(fun b =>
(* ❌ Assert instruction is not handled. *)
assert b))
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteq
(op_gtpipeeq
(State.Block.Header.known
(block_store, hb1))
(fun b =>
(* ❌ Assert instruction is not handled. *)
assert b))
(fun function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(op_gtpipeeq
(Store.Block.Contents.known
(block_store,
hb1))
(fun b =>
(* ❌ Assert instruction is not handled. *)
assert (negb b)))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(op_gtpipeeq
(State.Block.known
(chain s)
ha1)
(fun b =>
(* ❌ Assert instruction is not handled. *)
assert
(negb b)))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(op_gtpipeeq
(State.Block.read_opt
(chain s)
ha1)
(fun
function_parameter
=>
match
function_parameter
with
|
Some
_header
=>
(* ❌ Assert instruction is not handled. *)
assert
false
| None
=>
(* ❌ Assert instruction is not handled. *)
assert
true
end))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(op_gtpipeeq
(Store.Block.Pruned_contents.known
(block_store,
ha1))
(fun b
=>
(* ❌ Assert instruction is not handled. *)
assert
(negb
b)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(op_gtpipeeq
(State.Block.Header.known
(block_store,
ha1))
(fun
b
=>
(* ❌ Assert instruction is not handled. *)
assert
(negb
b)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(op_gtpipeeq
(Store.Block.Contents.known
(block_store,
hb1))
(fun
b
=>
(* ❌ Assert instruction is not handled. *)
assert
(negb
b)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
return_unit)))))))))))))))))))).
Fixpoint compare_path
(p1 : list Tezos_base__TzPervasives.Block_hash.t)
(p2 : list Tezos_base__TzPervasives.Block_hash.t) : bool :=
match (p1, p2) with
| ([], []) => true
| (cons h1 p1, cons h2 p2) =>
andb (Block_hash.equal h1 h2) (compare_path p1 p2)
| _ => false
end.
Definition test_path (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let check_path (h1 : string) (h2 : string) (p2 : list string) : Lwt.t unit :=
op_gtgteq (Chain_traversal.path (vblock s h1) (vblock s h2))
(fun function_parameter =>
match function_parameter with
| None =>
op_startypeminuserrorstar "cannot compute path %s -> %s" % string h1
h2
| Some (_ as p) =>
let p := List.map State.Block.hash p in
let p2 := List.map (fun b => State.Block.hash (vblock s b)) p2 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if negb (compare_path p p2) then
op_startypeminuserrorstar "bad path %s -> %s" % string h1 h2
else
tt in
Lwt.return_unit
end) in
op_gtgteq (check_path "Genesis" % string "Genesis" % string [])
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (check_path "A1" % string "A1" % string [])
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_path "A2" % string "A6" % string
(cons "A3" % string
(cons "A4" % string (cons "A5" % string (cons "A6" % string [])))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_path "B2" % string "B6" % string
(cons "B3" % string
(cons "B4" % string
(cons "B5" % string (cons "B6" % string [])))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_path "A1" % string "B3" % string
(cons "A2" % string
(cons "A3" % string
(cons "B1" % string
(cons "B2" % string (cons "B3" % string []))))))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))).
Definition test_ancestor (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let check_ancestor
(h1 : string) (h2 : string) (expected : Tezos_shell.State.Block.t)
: Lwt.t unit :=
op_gtgteq (Chain_traversal.common_ancestor (vblock s h1) (vblock s h2))
(fun a =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
negb
(Block_hash.equal (State.Block.hash a) (State.Block.hash expected))
then
op_startypeminuserrorstar "bad ancestor %s %s" % string h1 h2
else
tt in
Lwt.return_unit) in
op_gtgteq
(check_ancestor "Genesis" % string "Genesis" % string
(vblock s "Genesis" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_ancestor "Genesis" % string "A3" % string
(vblock s "Genesis" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_ancestor "A3" % string "Genesis" % string
(vblock s "Genesis" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_ancestor "A1" % string "A1" % string
(vblock s "A1" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_ancestor "A1" % string "A3" % string
(vblock s "A1" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_ancestor "A3" % string "A1" % string
(vblock s "A1" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_ancestor "A6" % string "B6" % string
(vblock s "A3" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_ancestor "B6" % string "A6" % string
(vblock s "A3" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_ancestor "A4" % string "B1" % string
(vblock s "A3" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_ancestor "B1" % string
"A4" % string (vblock s "A3" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_ancestor "A3" % string
"B1" % string
(vblock s "A3" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_ancestor "B1" % string
"A3" % string
(vblock s "A3" % string))
(fun function_parameter =>
let 'tt := function_parameter
in
op_gtgteq
(check_ancestor
"A2" % string
"B1" % string
(vblock s "A2" % string))
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteq
(check_ancestor
"B1" % string
"A2" % string
(vblock s
"A2" % string))
(fun function_parameter
=>
let 'tt :=
function_parameter
in
return_unit)))))))))))))).
Definition seed : Tezos_base__TzPervasives.Block_locator.seed :=
let receiver_id :=
P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size "r" % char) in
let sender_id :=
P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size "s" % char) in
{| Block_locator.sender_id := sender_id;
Block_locator.receiver_id := receiver_id |}.
Definition test_locator (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let check_locator (length : Z) (h1 : string) (expected : list string)
: Lwt.t unit :=
op_gtgteq (State.compute_locator (chain s) (Some length) (vblock s h1) seed)
(fun l =>
let '(_, l) := l in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb (List.length l) (List.length expected) then
op_startypeminuserrorstar
"Invalid locator length %s (found: %d, expected: %d)" % string h1
(List.length l) (List.length expected)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter2
(fun h =>
fun h2 =>
if
negb
(Block_hash.equal h (apply State.Block.hash (vblock s h2)))
then
op_startypeminuserrorstar
"Invalid locator %s (expected: %s)" % string h1 h2
else
tt) l expected in
Lwt.return_unit) in
op_gtgteq
(check_locator 6 "A8" % string
(cons "A7" % string
(cons "A6" % string
(cons "A5" % string
(cons "A4" % string (cons "A3" % string (cons "A2" % string [])))))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_locator 8 "B8" % string
(cons "B7" % string
(cons "B6" % string
(cons "B5" % string
(cons "B4" % string
(cons "B3" % string
(cons "B2" % string
(cons "B1" % string (cons "A3" % string [])))))))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_locator 4 "B8" % string
(cons "B7" % string
(cons "B6" % string (cons "B5" % string (cons "B4" % string [])))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (check_locator 0 "A5" % string [])
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check_locator 100 "A5" % string
(cons "A4" % string
(cons "A3" % string
(cons "A2" % string
(cons "A1" % string (cons "Genesis" % string []))))))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))).
Definition compare {A : Type}
(s : state) (name : A) (heads : list Tezos_shell.State.Block.t)
(l : list string) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb (List.length heads) (List.length l) then
op_startypeminuserrorstar
"unexpected known_heads size (%s: %d %d)" % string name
(List.length heads) (List.length l)
else
tt in
List.iter
(fun bname =>
let hash := State.Block.hash (vblock s bname) in
if
negb
(List._exists (fun b => Block_hash.equal hash (State.Block.hash b))
heads) then
op_startypeminuserrorstar
"missing block in known_heads (%s: %s)" % string name bname
else
tt) l.
Definition test_known_heads (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (Chain.known_heads (chain s))
(fun heads =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
compare s "initial" % string heads
(cons "A8" % string (cons "B8" % string [])) in
return_unit).
Definition test_head (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (Chain.head (chain s))
(fun head =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if negb (Block_hash.equal (State.Block.hash head) genesis_block) then
op_startypeminuserrorstar "unexpected head" % string
else
tt in
op_gtgteq (Chain.set_head (chain s) (vblock s "A6" % string))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Chain.head (chain s))
(fun head =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
negb
(Block_hash.equal (State.Block.hash head)
(apply State.Block.hash (vblock s "A6" % string))) then
op_startypeminuserrorstar "unexpected head" % string
else
tt in
return_unit))).
Definition test_mem (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let mem (s : state) (x : string) : Lwt.t bool :=
Chain.mem (chain s) (apply State.Block.hash (vblock s x)) in
let test_mem (s : state) (x : string) : Lwt.t unit :=
op_gtgteq (mem s x)
(fun function_parameter =>
match function_parameter with
| true => Lwt.return_unit
| false => op_startypeminuserrorstar "mem %s" % string x
end) in
let test_not_mem (s : state) (x : string) : Lwt.t unit :=
op_gtgteq (mem s x)
(fun function_parameter =>
match function_parameter with
| false => Lwt.return_unit
| true => op_startypeminuserrorstar "not (mem %s)" % string x
end) in
op_gtgteq (test_not_mem s "A3" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (test_not_mem s "A6" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (test_not_mem s "A8" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (test_not_mem s "B1" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (test_not_mem s "B6" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (test_not_mem s "B8" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Chain.set_head (chain s) (vblock s "A8" % string))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (test_mem s "A3" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (test_mem s "A6" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (test_mem s "A8" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(test_not_mem s "B1" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(test_not_mem s "B6" % string)
(fun function_parameter =>
let 'tt := function_parameter
in
op_gtgteq
(test_not_mem s
"B8" % string)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteq
(Chain.set_head
(chain s)
(vblock s
"A6" % string))
(fun function_parameter
=>
let '_ :=
function_parameter
in
op_gtgteq
(test_mem s
"A3" % string)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(test_mem s
"A6" % string)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(test_not_mem
s
"A8" %
string)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(test_not_mem
s
"B1" %
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(test_not_mem
s
"B6"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(test_not_mem
s
"B8"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(Chain.set_head
(chain
s)
(vblock
s
"B6"
%
string))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_gtgteq
(test_mem
s
"A3"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(test_not_mem
s
"A4"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(test_not_mem
s
"A6"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(test_not_mem
s
"A8"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(test_mem
s
"B1"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(test_mem
s
"B6"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(test_not_mem
s
"B8"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(Chain.set_head
(chain
s)
(vblock
s
"B8"
%
string))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_gtgteq
(test_mem
s
"A3"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(test_not_mem
s
"A4"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(test_not_mem
s
"A6"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(test_not_mem
s
"A8"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(test_mem
s
"B1"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(test_mem
s
"B6"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(test_mem
s
"B8"
%
string)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
return_unit)))))))))))))))))))))))))))))))))))).
Definition test_new_blocks (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let test
(s : state) (head : string) (h : string) (expected_ancestor : string)
(expected : list string) : Lwt.t unit :=
let to_block : Tezos_shell.State.Block.t :=
vblock s head
with from_block : Tezos_shell.State.Block.t :=
vblock s h in
op_gtgteq (Chain_traversal.new_blocks from_block to_block)
(fun function_parameter =>
let '(ancestor, blocks) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
negb
(Block_hash.equal (State.Block.hash ancestor)
(apply State.Block.hash (vblock s expected_ancestor))) then
op_startypeminuserrorstar
"Invalid ancestor %s -> %s (expected: %s)" % string head h
expected_ancestor
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb (List.length blocks) (List.length expected) then
op_startypeminuserrorstar
"Invalid locator length %s (found: %d, expected: %d)" % string h
(List.length blocks) (List.length expected)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter2
(fun h1 =>
fun h2 =>
if
negb
(Block_hash.equal (State.Block.hash h1)
(apply State.Block.hash (vblock s h2))) then
op_startypeminuserrorstar
"Invalid new blocks %s -> %s (expected: %s)" % string head h
h2
else
tt) blocks expected in
Lwt.return_unit) in
op_gtgteq (test s "A6" % string "A6" % string "A6" % string [])
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(test s "A8" % string "A6" % string "A6" % string
(cons "A7" % string (cons "A8" % string [])))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(test s "A8" % string "B7" % string "A3" % string
(cons "A4" % string
(cons "A5" % string
(cons "A6" % string
(cons "A7" % string (cons "A8" % string []))))))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))).
Definition tests
: list (string * (state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
cons ("init" % string, test_init)
(cons ("read_block" % string, test_read_block)
(cons ("path" % string, test_path)
(cons ("ancestor" % string, test_ancestor)
(cons ("locator" % string, test_locator)
(cons ("known_heads" % string, test_known_heads)
(cons ("head" % string, test_head)
(cons ("mem" % string, test_mem)
(cons ("new_blocks" % string, test_new_blocks)
(cons
("set_checkpoint_then_purge_rolling" % string,
test_set_checkpoint_then_purge_rolling)
(cons
("set_checkpoint_then_purge_full" % string,
test_set_checkpoint_then_purge_full) [])))))))))).
Definition wrap {A B : Type}
(function_parameter :
A * (state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) : B :=
let '(n, f) := function_parameter in
op_startypeminuserrorstar n
(* ❌ Variants not supported *)
variant
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.with_tempdir "tezos_test_" % string
(fun dir =>
op_gtgteq (wrap_state_init f dir)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error error =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
pp_print_error error
end))).
Definition tests {A : Type} : list A := List.map wrap tests.
src/lib_shell/test/test_state_checkpoint.ml 107 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let ( // ) = Filename.concat
(** Basic blocks *)
let genesis_block =
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"
let genesis_protocol =
Protocol_hash.of_b58check_exn
"ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"
let genesis_time = Time.Protocol.of_seconds 0L
let proto =
match Registered_protocol.get genesis_protocol with
| None ->
assert false
| Some proto ->
proto
module Proto = (val proto)
let genesis : State.Chain.genesis =
{time = genesis_time; block = genesis_block; protocol = genesis_protocol}
let incr_fitness fitness =
let new_fitness =
match fitness with
| [fitness] ->
Pervasives.(
Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
|> Option.unopt ~default:0L |> Int64.succ
|> Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
| _ ->
Data_encoding.Binary.to_bytes_exn Data_encoding.int64 1L
in
[new_fitness]
let incr_timestamp timestamp =
Time.Protocol.add timestamp (Int64.add 1L (Random.int64 10L))
let operation op =
let op : Operation.t =
{shell = {branch = genesis_block}; proto = Bytes.of_string op}
in
(Operation.hash op, op, Data_encoding.Binary.to_bytes Operation.encoding op)
let block_header_data_encoding =
Data_encoding.(obj1 (req "proto_block_header" string))
let block _state ?(context = Context_hash.zero) ?(operations = [])
(pred : State.Block.t) name : Block_header.t =
let operations_hash =
Operation_list_list_hash.compute [Operation_list_hash.compute operations]
in
let pred_header = State.Block.shell_header pred in
let fitness = incr_fitness pred_header.fitness in
let timestamp = incr_timestamp pred_header.timestamp in
let protocol_data =
Data_encoding.Binary.to_bytes_exn block_header_data_encoding name
in
{
shell =
{
level = Int32.succ pred_header.level;
proto_level = pred_header.proto_level;
predecessor = State.Block.hash pred;
validation_passes = 1;
timestamp;
operations_hash;
fitness;
context;
};
protocol_data;
}
let parsed_block ({shell; protocol_data} : Block_header.t) =
let protocol_data =
Data_encoding.Binary.of_bytes_exn
Proto.block_header_data_encoding
protocol_data
in
({shell; protocol_data} : Proto.block_header)
let zero = Bytes.create 0
let block_header_data_encoding =
Data_encoding.(obj1 (req "proto_block_header" string))
let build_valid_chain state vtbl pred names =
Lwt_list.fold_left_s
(fun pred name ->
State.Block.context_exn pred
>>= fun predecessor_context ->
let max_trials = 100 in
let rec attempt trials context =
(let (oph, op, _bytes) = operation name in
let block = block ?context state ~operations:[oph] pred name in
let hash = Block_header.hash block in
let pred_header = State.Block.header pred in
(let predecessor_context =
Shell_context.wrap_disk_context predecessor_context
in
Proto.begin_application
~chain_id:Chain_id.zero
~predecessor_context
~predecessor_timestamp:pred_header.shell.timestamp
~predecessor_fitness:pred_header.shell.fitness
(parsed_block block)
>>=? fun vstate ->
(* no operations *)
Proto.finalize_block vstate)
>>=? fun (result, _metadata) ->
let context = Shell_context.unwrap_disk_context result.context in
Context.commit
~time:(Time.System.to_protocol (Systime_os.now ()))
?message:result.message
context
>>= fun context_hash ->
let validation_store =
( {
context_hash;
message = result.message;
max_operations_ttl = result.max_operations_ttl;
last_allowed_fork_level = result.last_allowed_fork_level;
}
: Tezos_validation.Block_validation.validation_store )
in
State.Block.store
state
block
zero
[[op]]
[[zero]]
validation_store
~forking_testchain:false
>>=? fun _vblock ->
State.Block.read state hash
>>=? fun vblock ->
Hashtbl.add vtbl name vblock ;
return vblock)
>>= function
| Ok v ->
if trials < max_trials then
Format.eprintf
"Took %d trials to build valid chain"
(max_trials - trials + 1) ;
Lwt.return v
| Error (Validation_errors.Inconsistent_hash (got, _) :: _) ->
(* Kind of a hack, but at least it tests idempotence to some extent. *)
if trials <= 0 then assert false
else (
Format.eprintf
"Inconsistent context hash: got %a, retrying (%d)\n"
Context_hash.pp
got
trials ;
attempt (trials - 1) (Some got) )
| Error err ->
Format.eprintf "Error: %a\n" Error_monad.pp_print_error err ;
assert false
in
attempt max_trials None)
pred
names
>>= fun _ -> Lwt.return_unit
type state = {
vblock : (string, State.Block.t) Hashtbl.t;
state : State.t;
chain : State.Chain.t;
}
let vblock s = Hashtbl.find s.vblock
exception Found of string
let vblocks s =
Hashtbl.fold (fun k v acc -> (k, v) :: acc) s.vblock []
|> List.sort Pervasives.compare
(*******************************************************)
(*
Genesis - A1 - A2 - A3 - A4 - A5
\
B1 - B2 - B3 - B4 - B5
*)
let build_example_tree chain =
let vtbl = Hashtbl.create 23 in
Chain.genesis chain
>>= fun genesis ->
Hashtbl.add vtbl "Genesis" genesis ;
let c = ["A1"; "A2"; "A3"; "A4"; "A5"] in
build_valid_chain chain vtbl genesis c
>>= fun () ->
let a2 = Hashtbl.find vtbl "A2" in
let c = ["B1"; "B2"; "B3"; "B4"; "B5"] in
build_valid_chain chain vtbl a2 c >>= fun () -> Lwt.return vtbl
let wrap_state_init f base_dir =
let store_root = base_dir // "store" in
let context_root = base_dir // "context" in
State.init
~store_mapsize:4_096_000_000L
~context_mapsize:4_096_000_000L
~store_root
~context_root
genesis
>>=? fun (state, chain, _index, _history_mode) ->
build_example_tree chain
>>= fun vblock -> f {state; chain; vblock} >>=? fun () -> return_unit
(** State.Chain.checkpoint *)
(*
- Valid branch are kept after setting a checkpoint. Bad branch are cut
- Setting a checkpoint in the future does not remove anything
- Reaching a checkpoint in the future with the right block keeps that
block and remove any concurrent branch
- Reaching a checkpoint in the future with a bad block remove that block and
does not prevent a future good block from correctly being reached
- There are no bad quadratic behaviours *)
let test_basic_checkpoint s =
let block = vblock s "A1" in
let header = State.Block.header block in
State.Chain.set_checkpoint s.chain header
>>= fun () ->
State.Chain.checkpoint s.chain
>>= fun checkpoint_header ->
let c_level = checkpoint_header.shell.level in
let c_block = Block_header.hash checkpoint_header in
if
(not (Block_hash.equal c_block (State.Block.hash block)))
&& Int32.equal c_level (State.Block.level block)
then Assert.fail_msg "unexpected checkpoint"
else return_unit
(*
- cp: checkpoint
Genesis - A1 - A2 (cp) - A3 - A4 - A5
\
B1 - B2 - B3 - B4 - B5
*)
(* State.Chain.acceptable_block:
will the block is compatible with the current checkpoint? *)
let test_acceptable_block s =
let block = vblock s "A2" in
let header = State.Block.header block in
(* let level = State.Block.level block in
* let block_hash = State.Block.hash block in *)
State.Chain.set_checkpoint s.chain header
>>= fun () ->
(* it is accepted only if the current head is lower than the checkpoint *)
let block_1 = vblock s "A1" in
Chain.set_head s.chain block_1
>>=? fun head ->
let header = State.Block.header head in
State.Chain.acceptable_block s.chain header
>>= fun is_accepted_block ->
if is_accepted_block then return_unit
else Assert.fail_msg "unacceptable block"
(*
Genesis - A1 - A2 (cp) - A3 - A4 - A5
\
B1 - B2 - B3 - B4 - B5
*)
(* State.Block.is_valid_for_checkpoint :
is the block still valid for a given checkpoint ? *)
let test_is_valid_checkpoint s =
let block = vblock s "A2" in
let header = State.Block.header block in
(* let block_hash = State.Block.hash block in
* let level = State.Block.level block in *)
State.Chain.set_checkpoint s.chain header
>>= fun () ->
State.Chain.checkpoint s.chain
>>= fun checkpoint_header ->
(* "b3" is valid because:
a1 - a2 (checkpoint) - b1 - b2 - b3
it is not valid when the checkpoint change to a pick different than a2.
*)
State.Block.is_valid_for_checkpoint (vblock s "B3") checkpoint_header
>>= fun is_valid ->
if is_valid then return_unit else Assert.fail_msg "invalid checkpoint"
(* return a block with the best fitness amongst the known blocks which
are compatible with the given checkpoint *)
let test_best_know_head_for_checkpoint s =
let block = vblock s "A2" in
let checkpoint = State.Block.header block in
State.Chain.set_checkpoint s.chain checkpoint
>>= fun () ->
Chain.set_head s.chain (vblock s "B3")
>>= fun _head ->
State.best_known_head_for_checkpoint s.chain checkpoint
>>= fun _block ->
(* the block returns with the best fitness is B3 at level 5 *)
return_unit
(*
setting checkpoint in the future does not remove anything
Genesis - A1 - A2(cp) - A3 - A4 - A5
\
B1 - B2 - B3 - B4 - B5
*)
let test_future_checkpoint s =
let block = vblock s "A2" in
let block_hash = State.Block.hash block in
let level = State.Block.level block in
let header = State.Block.header block in
State.Chain.set_checkpoint s.chain header
>>= fun () ->
State.Chain.checkpoint s.chain
>>= fun checkpoint_header ->
let c_level = checkpoint_header.shell.level in
let c_block = Block_header.hash checkpoint_header in
if Int32.equal c_level level && not (Block_hash.equal c_block block_hash)
then Assert.fail_msg "unexpected checkpoint"
else return_unit
(*
setting checkpoint in the future does not remove anything
- iv = invalid
- (0): level of this block in the chain
Two exammples:
* Genesis (0)- A1 (1) - A2(2) - A3(3) - A4(4) - A5(5) (invalid)
\
B1(3) - B2(4) - B3 (5)(cp) - B4(6) - B5(7)
* Genesis - A1 - A2 - A3 - A4 - A5 (cp)
\
B1 - B2 - B3 (iv)- B4 (iv) - B5 (iv)
*)
let test_future_checkpoint_bad_good_block s =
let block = vblock s "A5" in
let block_hash = State.Block.hash block in
let level = State.Block.level block in
let header = State.Block.header block in
State.Chain.set_checkpoint s.chain header
>>= fun () ->
State.Chain.checkpoint s.chain
>>= fun checkpoint_header ->
let c_level = checkpoint_header.shell.level in
let c_block = Block_header.hash checkpoint_header in
if Int32.equal c_level level && not (Block_hash.equal c_block block_hash)
then Assert.fail_msg "unexpected checkpoint"
else
State.Block.is_valid_for_checkpoint (vblock s "B2") checkpoint_header
>>= fun is_valid ->
if is_valid then return_unit else Assert.fail_msg "invalid checkpoint"
(* check if the checkpoint can be reached
Genesis - A1 (cp) - A2 (head) - A3 - A4 - A5
\
B1 - B2 - B3 - B4 - B5
*)
let test_reach_checkpoint s =
let mem s x = Chain.mem s.chain (State.Block.hash @@ vblock s x) in
let test_mem s x =
mem s x
>>= function
| true -> Lwt.return_unit | false -> Assert.fail_msg "mem %s" x
in
let test_not_mem s x =
mem s x
>>= function
| false -> Lwt.return_unit | true -> Assert.fail_msg "not (mem %s)" x
in
let block = vblock s "A1" in
let block_hash = State.Block.hash block in
let header = State.Block.header block in
State.Chain.set_checkpoint s.chain header
>>= fun () ->
State.Chain.checkpoint s.chain
>>= fun checkpoint_header ->
let time_now = Time.System.to_protocol (Systime_os.now ()) in
if
Time.Protocol.compare
(Time.Protocol.add time_now 15L)
header.shell.timestamp
>= 0
then
let checkpoint_hash = Block_header.hash checkpoint_header in
if
Int32.equal header.shell.level checkpoint_header.shell.level
&& not (Block_hash.equal checkpoint_hash block_hash)
then Assert.fail_msg "checkpoint error"
else
Chain.set_head s.chain (vblock s "A2")
>>= fun _ ->
Chain.head s.chain
>>= fun head ->
let checkpoint_reached =
(State.Block.header head).shell.level >= checkpoint_header.shell.level
in
if checkpoint_reached then
(* if reached the checkpoint, every block before the checkpoint
must be the part of the chain *)
if header.shell.level <= checkpoint_header.shell.level then
test_mem s "Genesis"
>>= fun () ->
test_mem s "A1"
>>= fun () ->
test_mem s "A2"
>>= fun () ->
test_not_mem s "A3"
>>= fun () -> test_not_mem s "B1" >>= fun () -> return_unit
else Assert.fail_msg "checkpoint error"
else Assert.fail_msg "checkpoint error"
else Assert.fail_msg "fail future block header"
(*
Chain.Validator function may_update_checkpoint
- ncp: new checkpoint
Genesis - A1 - A2 - A3 (cp) - A4 - A5
\
B1 - B2 - B3 - B4 - B5
Genesis - A1 (ncp) - A2 - A3 (cp) - A4 (ncp) - A5
\
B1 - B2 - B3 - B4 - B5
*)
let may_update_checkpoint chain_state new_head =
State.Chain.checkpoint chain_state
>>= fun checkpoint_header ->
(* FIXME: the new level is always return 0l even
if the new_head is A4 at level 4l
Or TODO: set a level where allow to have a fork
*)
let old_level = checkpoint_header.shell.level in
State.Block.last_allowed_fork_level new_head
>>=? fun new_level ->
if new_level <= old_level then return_unit
else
let head_level = State.Block.level new_head in
State.Block.predecessor_n
new_head
(Int32.to_int (Int32.sub head_level new_level))
>>= function
| None ->
return @@ Assert.fail_msg "Unexpected None in predecessor query"
| Some hash -> (
State.Block.read_opt chain_state hash
>>= function
| None ->
assert false
| Some b ->
State.Chain.set_checkpoint chain_state (State.Block.header b)
>>= fun () -> return_unit )
let test_may_update_checkpoint s =
let block = vblock s "A3" in
let checkpoint = State.Block.header block in
State.Chain.set_checkpoint s.chain checkpoint
>>= fun () ->
State.Chain.checkpoint s.chain
>>= fun _ ->
Chain.set_head s.chain (vblock s "A4")
>>= fun _ ->
Chain.head s.chain
>>= fun head -> may_update_checkpoint s.chain head >>=? fun () -> return ()
(* Check function may_update_checkpoint in Node.ml
Genesis - A1 - A2 (cp) - A3 - A4 - A5
\
B1 - B2 - B3 - B4 - B5
chain after update:
Genesis - A1 - A2 - A3(cp) - A4 - A5
\
B1 - B2 - B3 - B4 - B5
*)
let note_may_update_checkpoint chain_state checkpoint =
match checkpoint with
| None ->
Lwt.return_unit
| Some checkpoint ->
State.best_known_head_for_checkpoint chain_state checkpoint
>>= fun new_head ->
Chain.set_head chain_state new_head
>>= fun _ -> State.Chain.set_checkpoint chain_state checkpoint
let test_note_may_update_checkpoint s =
(* set checkpoint at (2l, A2) *)
let block = vblock s "A2" in
let header = State.Block.header block in
State.Chain.set_checkpoint s.chain header
>>= fun () ->
(* set new checkpoint at (3l, A3) *)
let block = vblock s "A3" in
let checkpoint = State.Block.header block in
note_may_update_checkpoint s.chain (Some checkpoint)
>>= fun () -> return_unit
(****************************************************************************)
let tests : (string * (state -> unit tzresult Lwt.t)) list =
[ ("basic checkpoint", test_basic_checkpoint);
("is valid checkpoint", test_is_valid_checkpoint);
("acceptable block", test_acceptable_block);
("best know head", test_best_know_head_for_checkpoint);
("future checkpoint", test_future_checkpoint);
("future checkpoint bad/good block", test_future_checkpoint_bad_good_block);
("test_reach_checkpoint", test_reach_checkpoint);
("update checkpoint", test_may_update_checkpoint);
("update checkpoint in node", test_note_may_update_checkpoint) ]
let wrap (n, f) =
Alcotest_lwt.test_case n `Quick (fun _ () ->
Lwt_utils_unix.with_tempdir "tezos_test_" (fun dir ->
wrap_state_init f dir
>>= function
| Ok () ->
Lwt.return_unit
| Error error ->
Format.kasprintf Pervasives.failwith "%a" pp_print_error error))
let tests = List.map wrap tests
src/lib_shell/test/test_state_checkpoint.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.
Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
Protocol_hash.of_b58check_exn
"ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.
Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
Time.Protocol.of_seconds
(* ❌ Constant of type int64 is converted to int *)
0.
Definition proto : Tezos_protocol_updater.Registered_protocol.t :=
match Registered_protocol.get genesis_protocol with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some proto => proto
end.
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition genesis : Tezos_shell.State.Chain.genesis :=
{| time := genesis_time; block := genesis_block; protocol := genesis_protocol
|}.
Definition incr_fitness (fitness : list Stdlib.Bytes.t) : list Stdlib.Bytes.t :=
let new_fitness :=
match fitness with
| cons fitness [] =>
op_pipegt
(op_pipegt
(op_pipegt (Data_encoding.Binary.of_bytes Data_encoding.int64 fitness)
(Option.unopt
(* ❌ Constant of type int64 is converted to int *)
0)) Int64.succ)
(Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
| _ =>
Data_encoding.Binary.to_bytes_exn Data_encoding.int64
(* ❌ Constant of type int64 is converted to int *)
1
end in
cons new_fitness [].
Definition incr_timestamp (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
: Tezos_base__TzPervasives.Time.Protocol.t :=
Time.Protocol.add timestamp
(Int64.add
(* ❌ Constant of type int64 is converted to int *)
1
(Random.int64
(* ❌ Constant of type int64 is converted to int *)
10)).
Definition operation (op : string)
: Tezos_crypto.Operation_hash.t * Tezos_base__TzPervasives.Operation.t *
(option Stdlib.Bytes.t) :=
let op :=
{| shell := {| branch := genesis_block |};
proto := Stdlib.Bytes.of_string op |} in
((Operation.hash op), op,
(Data_encoding.Binary.to_bytes Operation.encoding op)).
Definition block_header_data_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding string :=
obj1 (req None None "proto_block_header" % string string).
Definition block {A : Type}
(_state : A) (op_staroptstar : option Tezos_base__TzPervasives.Context_hash.t)
: (option (list Tezos_base__TzPervasives.Operation_list_hash.elt)) ->
Tezos_shell.State.Block.t ->
string -> Tezos_base__TzPervasives.Block_header.t :=
let context :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Context_hash.zero
end in
fun op_staroptstar =>
let operations :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun pred =>
fun name =>
let operations_hash :=
Operation_list_list_hash.compute
(cons (Operation_list_hash.compute operations) []) in
let pred_header := State.Block.shell_header pred in
let fitness := incr_fitness (fitness pred_header) in
let timestamp := incr_timestamp (timestamp pred_header) in
let protocol_data :=
Data_encoding.Binary.to_bytes_exn block_header_data_encoding name in
{|
shell :=
{| level := Int32.succ (level pred_header);
proto_level := proto_level pred_header;
predecessor := State.Block.hash pred; timestamp := timestamp;
validation_passes := 1; operations_hash := operations_hash;
fitness := fitness; context := context |};
protocol_data := protocol_data |}.
Definition parsed_block
(function_parameter : Tezos_base__TzPervasives.Block_header.t)
: Proto.(Tezos_protocol_updater__Registered_protocol.T.block_header) :=
let '{| shell := shell; protocol_data := protocol_data |} :=
function_parameter in
let protocol_data :=
Data_encoding.Binary.of_bytes_exn
Proto.(Tezos_protocol_updater__Registered_protocol.T.block_header_data_encoding)
protocol_data in
{| shell := shell; protocol_data := protocol_data |}.
Definition zero : string := Stdlib.Bytes.create 0.
Definition block_header_data_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding string :=
obj1 (req None None "proto_block_header" % string string).
Definition build_valid_chain
(state : Tezos_shell__State.Chain.t)
(vtbl : Stdlib.Hashtbl.t string Tezos_shell.State.Block.t)
(pred : Tezos_shell.State.Block.t) (names : list string) : Lwt.t unit :=
op_gtgteq
(Lwt_list.fold_left_s
(fun pred =>
fun name =>
op_gtgteq (State.Block.context_exn pred)
(fun predecessor_context =>
let max_trials := 100 in
let fix attempt
(trials : Z) (context :
option Tezos_base__TzPervasives.Context_hash.t)
: Lwt.t Tezos_shell.State.Block.t :=
op_gtgteq
(let '(oph, op, _bytes) := operation name in
let block :=
block state context (Some (cons oph [])) pred name in
let hash := Block_header.hash block in
let pred_header := State.Block.header pred in
op_gtgteqquestion
(let predecessor_context :=
Shell_context.wrap_disk_context predecessor_context in
op_gtgteqquestion
(Proto.(Tezos_protocol_updater__Registered_protocol.T.begin_application)
Chain_id.zero predecessor_context
(timestamp (shell pred_header))
(fitness (shell pred_header)) (parsed_block block))
(fun vstate =>
Proto.(Tezos_protocol_updater__Registered_protocol.T.finalize_block)
vstate))
(fun function_parameter =>
let '(result, _metadata) := function_parameter in
let context :=
Shell_context.unwrap_disk_context (context result) in
op_gtgteq
(Context.commit
(Time.System.to_protocol (Systime_os.now tt))
(message result) context)
(fun context_hash =>
let validation_store :=
{| context_hash := context_hash;
message := message result;
max_operations_ttl := max_operations_ttl result;
last_allowed_fork_level :=
last_allowed_fork_level result |} in
op_gtgteqquestion
(State.Block.store None state block zero
(cons (cons op []) []) (cons (cons zero []) [])
validation_store false)
(fun _vblock =>
op_gtgteqquestion (State.Block.read state hash)
(fun vblock =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Hashtbl.add vtbl name vblock in
_return vblock)))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok v =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt trials max_trials then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Took " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" trials to build valid chain" % string
CamlinternalFormatBasics.End_of_format)))
"Took %d trials to build valid chain" % string)
(Z.add (Z.sub max_trials trials) 1)
else
tt in
Lwt._return v
|
Stdlib.Error
(cons (Tezos_base__TzPervasives.Inconsistent_hash got _)
_) =>
if OCaml.Stdlib.le trials 0 then
(* ❌ Assert instruction is not handled. *)
assert false
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Inconsistent context hash: got " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", retrying (" % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
")
" % string
CamlinternalFormatBasics.End_of_format)))))
"Inconsistent context hash: got %a, retrying (%d)
"
% string) Context_hash.pp got trials in
attempt (Z.sub trials 1) (Some got)
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"010" % char
CamlinternalFormatBasics.End_of_format)))
"Error: %a
" % string) Error_monad.pp_print_error
err in
(* ❌ Assert instruction is not handled. *)
assert false
end) in
attempt max_trials None)) pred names)
(fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit).
Record state := {
vblock : Stdlib.Hashtbl.t string Tezos_shell.State.Block.t;
state : Tezos_shell.State.t;
chain : Tezos_shell.State.Chain.t }.
Definition vblock (s : state) : string -> Tezos_shell.State.Block.t :=
Hashtbl.find (vblock s).
(* ❌ The definition of exceptions is not handled. *)
exception
Definition vblocks (s : state) : list (string * Tezos_shell.State.Block.t) :=
OCaml.Stdlib.reverse_apply
(Hashtbl.fold (fun k => fun v => fun acc => cons (k, v) acc) (vblock s) [])
(List.sort Pervasives.compare).
Definition build_example_tree (chain : Tezos_shell.State.Chain.t)
: Lwt.t (Stdlib.Hashtbl.t string Tezos_shell.State.Block.t) :=
let vtbl := Hashtbl.create None 23 in
op_gtgteq (Chain.genesis chain)
(fun genesis =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Hashtbl.add vtbl "Genesis" % string genesis in
let c :=
cons "A1" % string
(cons "A2" % string
(cons "A3" % string (cons "A4" % string (cons "A5" % string []))))
in
op_gtgteq (build_valid_chain chain vtbl genesis c)
(fun function_parameter =>
let 'tt := function_parameter in
let a2 := Hashtbl.find vtbl "A2" % string in
let c :=
cons "B1" % string
(cons "B2" % string
(cons "B3" % string (cons "B4" % string (cons "B5" % string []))))
in
op_gtgteq (build_valid_chain chain vtbl a2 c)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return vtbl))).
Definition wrap_state_init
(f : state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
(base_dir : string) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let store_root := op_divdiv base_dir "store" % string in
let context_root := op_divdiv base_dir "context" % string in
op_gtgteqquestion
(State.init None None
(Some
(* ❌ Constant of type int64 is converted to int *)
4096000000)
(Some
(* ❌ Constant of type int64 is converted to int *)
4096000000) store_root context_root None genesis)
(fun function_parameter =>
let '(state, chain, _index, _history_mode) := function_parameter in
op_gtgteq (build_example_tree chain)
(fun vblock =>
op_gtgteqquestion
(f {| vblock := vblock; state := state; chain := chain |})
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))).
Definition test_basic_checkpoint (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let block := vblock s "A1" % string in
let header := State.Block.header block in
op_gtgteq (State.Chain.set_checkpoint (chain s) header)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Chain.checkpoint (chain s))
(fun checkpoint_header =>
let c_level := level (shell checkpoint_header) in
let c_block := Block_header.hash checkpoint_header in
if
andb (negb (Block_hash.equal c_block (State.Block.hash block)))
(Int32.equal c_level (State.Block.level block)) then
op_startypeminuserrorstar "unexpected checkpoint" % string
else
return_unit)).
Definition test_acceptable_block (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let block := vblock s "A2" % string in
let header := State.Block.header block in
op_gtgteq (State.Chain.set_checkpoint (chain s) header)
(fun function_parameter =>
let 'tt := function_parameter in
let block_1 := vblock s "A1" % string in
op_gtgteqquestion (Chain.set_head (chain s) block_1)
(fun head =>
let header := State.Block.header head in
op_gtgteq (State.Chain.acceptable_block (chain s) header)
(fun is_accepted_block =>
if is_accepted_block then
return_unit
else
op_startypeminuserrorstar "unacceptable block" % string))).
Definition test_is_valid_checkpoint (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let block := vblock s "A2" % string in
let header := State.Block.header block in
op_gtgteq (State.Chain.set_checkpoint (chain s) header)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Chain.checkpoint (chain s))
(fun checkpoint_header =>
op_gtgteq
(State.Block.is_valid_for_checkpoint (vblock s "B3" % string)
checkpoint_header)
(fun is_valid =>
if is_valid then
return_unit
else
op_startypeminuserrorstar "invalid checkpoint" % string))).
Definition test_best_know_head_for_checkpoint (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let block := vblock s "A2" % string in
let checkpoint := State.Block.header block in
op_gtgteq (State.Chain.set_checkpoint (chain s) checkpoint)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Chain.set_head (chain s) (vblock s "B3" % string))
(fun _head =>
op_gtgteq (State.best_known_head_for_checkpoint (chain s) checkpoint)
(fun _block => return_unit))).
Definition test_future_checkpoint (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let block := vblock s "A2" % string in
let block_hash := State.Block.hash block in
let level := State.Block.level block in
let header := State.Block.header block in
op_gtgteq (State.Chain.set_checkpoint (chain s) header)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Chain.checkpoint (chain s))
(fun checkpoint_header =>
let c_level := level (shell checkpoint_header) in
let c_block := Block_header.hash checkpoint_header in
if
andb (Int32.equal c_level level)
(negb (Block_hash.equal c_block block_hash)) then
op_startypeminuserrorstar "unexpected checkpoint" % string
else
return_unit)).
Definition test_future_checkpoint_bad_good_block (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let block := vblock s "A5" % string in
let block_hash := State.Block.hash block in
let level := State.Block.level block in
let header := State.Block.header block in
op_gtgteq (State.Chain.set_checkpoint (chain s) header)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Chain.checkpoint (chain s))
(fun checkpoint_header =>
let c_level := level (shell checkpoint_header) in
let c_block := Block_header.hash checkpoint_header in
if
andb (Int32.equal c_level level)
(negb (Block_hash.equal c_block block_hash)) then
op_startypeminuserrorstar "unexpected checkpoint" % string
else
op_gtgteq
(State.Block.is_valid_for_checkpoint (vblock s "B2" % string)
checkpoint_header)
(fun is_valid =>
if is_valid then
return_unit
else
op_startypeminuserrorstar "invalid checkpoint" % string))).
Definition test_reach_checkpoint (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let mem (s : state) (x : string) : Lwt.t bool :=
Chain.mem (chain s) (apply State.Block.hash (vblock s x)) in
let test_mem (s : state) (x : string) : Lwt.t unit :=
op_gtgteq (mem s x)
(fun function_parameter =>
match function_parameter with
| true => Lwt.return_unit
| false => op_startypeminuserrorstar "mem %s" % string x
end) in
let test_not_mem (s : state) (x : string) : Lwt.t unit :=
op_gtgteq (mem s x)
(fun function_parameter =>
match function_parameter with
| false => Lwt.return_unit
| true => op_startypeminuserrorstar "not (mem %s)" % string x
end) in
let block := vblock s "A1" % string in
let block_hash := State.Block.hash block in
let header := State.Block.header block in
op_gtgteq (State.Chain.set_checkpoint (chain s) header)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Chain.checkpoint (chain s))
(fun checkpoint_header =>
let time_now := Time.System.to_protocol (Systime_os.now tt) in
if
OCaml.Stdlib.ge
(Time.Protocol.compare
(Time.Protocol.add time_now
(* ❌ Constant of type int64 is converted to int *)
15) (timestamp (shell header))) 0 then
let checkpoint_hash := Block_header.hash checkpoint_header in
if
andb
(Int32.equal (level (shell header))
(level (shell checkpoint_header)))
(negb (Block_hash.equal checkpoint_hash block_hash)) then
op_startypeminuserrorstar "checkpoint error" % string
else
op_gtgteq (Chain.set_head (chain s) (vblock s "A2" % string))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Chain.head (chain s))
(fun head =>
let checkpoint_reached :=
OCaml.Stdlib.ge
(level (shell (State.Block.header head)))
(level (shell checkpoint_header)) in
if checkpoint_reached then
if
OCaml.Stdlib.le (level (shell header))
(level (shell checkpoint_header)) then
op_gtgteq (test_mem s "Genesis" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (test_mem s "A1" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (test_mem s "A2" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (test_not_mem s "A3" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(test_not_mem s "B1" % string)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))))
else
op_startypeminuserrorstar "checkpoint error" % string
else
op_startypeminuserrorstar "checkpoint error" % string))
else
op_startypeminuserrorstar "fail future block header" % string)).
Definition may_update_checkpoint
(chain_state : Tezos_shell.State.Chain.chain_state)
(new_head : Tezos_shell.State.Block.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (State.Chain.checkpoint chain_state)
(fun checkpoint_header =>
let old_level := level (shell checkpoint_header) in
op_gtgteqquestion (State.Block.last_allowed_fork_level new_head)
(fun new_level =>
if OCaml.Stdlib.le new_level old_level then
return_unit
else
let head_level := State.Block.level new_head in
op_gtgteq
(State.Block.predecessor_n new_head
(Int32.to_int (Int32.sub head_level new_level)))
(fun function_parameter =>
match function_parameter with
| None =>
apply _return
(op_startypeminuserrorstar
"Unexpected None in predecessor query" % string)
| Some hash =>
op_gtgteq (State.Block.read_opt chain_state hash)
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some b =>
op_gtgteq
(State.Chain.set_checkpoint chain_state
(State.Block.header b))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end)
end))).
Definition test_may_update_checkpoint (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let block := vblock s "A3" % string in
let checkpoint := State.Block.header block in
op_gtgteq (State.Chain.set_checkpoint (chain s) checkpoint)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (State.Chain.checkpoint (chain s))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Chain.set_head (chain s) (vblock s "A4" % string))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (Chain.head (chain s))
(fun head =>
op_gtgteqquestion (may_update_checkpoint (chain s) head)
(fun function_parameter =>
let 'tt := function_parameter in
_return tt))))).
Definition note_may_update_checkpoint
(chain_state : Tezos_shell.State.Chain.t)
(checkpoint : option Tezos_base__TzPervasives.Block_header.t) : Lwt.t unit :=
match checkpoint with
| None => Lwt.return_unit
| Some checkpoint =>
op_gtgteq (State.best_known_head_for_checkpoint chain_state checkpoint)
(fun new_head =>
op_gtgteq (Chain.set_head chain_state new_head)
(fun function_parameter =>
let '_ := function_parameter in
State.Chain.set_checkpoint chain_state checkpoint))
end.
Definition test_note_may_update_checkpoint (s : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let block := vblock s "A2" % string in
let header := State.Block.header block in
op_gtgteq (State.Chain.set_checkpoint (chain s) header)
(fun function_parameter =>
let 'tt := function_parameter in
let block := vblock s "A3" % string in
let checkpoint := State.Block.header block in
op_gtgteq (note_may_update_checkpoint (chain s) (Some checkpoint))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)).
Definition tests
: list (string * (state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
cons ("basic checkpoint" % string, test_basic_checkpoint)
(cons ("is valid checkpoint" % string, test_is_valid_checkpoint)
(cons ("acceptable block" % string, test_acceptable_block)
(cons ("best know head" % string, test_best_know_head_for_checkpoint)
(cons ("future checkpoint" % string, test_future_checkpoint)
(cons
("future checkpoint bad/good block" % string,
test_future_checkpoint_bad_good_block)
(cons ("test_reach_checkpoint" % string, test_reach_checkpoint)
(cons ("update checkpoint" % string, test_may_update_checkpoint)
(cons
("update checkpoint in node" % string,
test_note_may_update_checkpoint) [])))))))).
Definition wrap {A B : Type}
(function_parameter :
A * (state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) : B :=
let '(n, f) := function_parameter in
op_startypeminuserrorstar n
(* ❌ Variants not supported *)
variant
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.with_tempdir "tezos_test_" % string
(fun dir =>
op_gtgteq (wrap_state_init f dir)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error error =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
pp_print_error error
end))).
Definition tests {A : Type} : list A := List.map wrap tests.
src/lib_shell/test/test_store.ml 144 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Store
let ( >>= ) = Lwt.bind
let ( >|= ) = Lwt.( >|= )
let ( // ) = Filename.concat
(** Basic blocks *)
let genesis_block =
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"
let genesis_protocol =
Protocol_hash.of_b58check_exn
"ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"
let genesis_time = Time.Protocol.of_seconds 0L
(** *)
let mapsize = 4_096_000_000L (* ~4 GiB *)
let wrap_store_init f _ () =
Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
let root = base_dir // "store" in
Store.init ~mapsize root
>>= function
| Ok store ->
Lwt.finalize
(fun () -> f store)
(fun () -> Store.close store ; Lwt.return_unit)
| Error err ->
Format.kasprintf
Pervasives.failwith
"@[Cannot initialize store:@ %a@]"
pp_print_error
err)
let wrap_raw_store_init f _ () =
Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
let root = base_dir // "store" in
Raw_store.init ~mapsize root
>>= function
| Ok store ->
Lwt.finalize
(fun () -> f store)
(fun () -> Raw_store.close store ; Lwt.return_unit)
| Error err ->
Format.kasprintf
Pervasives.failwith
"@[Cannot initialize store:@ %a@]"
pp_print_error
err)
let test_init _ = Lwt.return_unit
let chain_id = Chain_id.of_block_hash genesis_block
(** Operation store *)
let make proto : Operation.t = {shell = {branch = genesis_block}; proto}
let op1 = make (Bytes.of_string "Capadoce")
let oph1 = Operation.hash op1
let op2 = make (Bytes.of_string "Kivu")
let oph2 = Operation.hash op2
(** Block store *)
let lolblock ?(operations = []) header =
let operations_hash =
Operation_list_list_hash.compute [Operation_list_hash.compute operations]
in
let block_header =
{
Block_header.shell =
{
timestamp = Time.Protocol.of_seconds (Random.int64 1500L);
level = 0l;
(* dummy *)
proto_level = 0;
(* dummy *)
validation_passes = Random.int 32;
predecessor = genesis_block;
operations_hash;
fitness =
[ Bytes.of_string @@ string_of_int @@ String.length header;
Bytes.of_string @@ string_of_int @@ 12 ];
context = Context_hash.zero;
};
protocol_data = Bytes.of_string header;
}
in
let block_contents =
{
header = block_header;
Store.Block.metadata = Bytes.create 0;
max_operations_ttl = 0;
message = None;
context = Context_hash.zero;
last_allowed_fork_level = 0l;
}
in
(block_header, block_contents)
let ((b1_header, b1_contents) as b1) = lolblock "Blop !"
let bh1 = Block_header.hash b1_header
let ((b2_header, b2_contents) as b2) = lolblock "Tacatlopo"
let bh2 = Block_header.hash b2_header
let ((b3_header, b3_contents) as b3) =
lolblock ~operations:[oph1; oph2] "Persil"
let bh3 = Block_header.hash b3_header
let bh3' =
let raw = Bytes.of_string @@ Block_hash.to_string bh3 in
Bytes.set raw 31 '\000' ;
Bytes.set raw 30 '\000' ;
Block_hash.of_string_exn @@ Bytes.to_string raw
let equal ((b1_header, b1_contents) : Block_header.t * Store.Block.contents)
((b2_header, b2_contents) : Block_header.t * Store.Block.contents) =
Block_header.equal b1_header b2_header
&& b1_contents.message = b2_contents.message
let check_block s h b =
Store.Block.Contents.read (s, h)
>>= function
| Ok bc' -> (
Store.Block.Pruned_contents.read (s, h)
>>= function
| Ok {header} when equal b (header, bc') ->
Lwt.return_unit
| Ok _ ->
Format.eprintf
"Error while reading block %a\n%!"
Block_hash.pp_short
h ;
exit 1
| Error err ->
Format.eprintf
"@[Error while reading block header %a:@ %a\n@]"
Block_hash.pp_short
h
pp_print_error
err ;
exit 1 )
| Error err ->
Format.eprintf
"@[Error while reading block %a:@ %a\n@]"
Block_hash.pp_short
h
pp_print_error
err ;
exit 1
let test_block s =
let s = Store.Chain.get s chain_id in
let s = Store.Block.get s in
Block.Contents.store (s, bh1) b1_contents
>>= fun () ->
Block.Contents.store (s, bh2) b2_contents
>>= fun () ->
Block.Contents.store (s, bh3) b3_contents
>>= fun () ->
Block.Pruned_contents.store (s, bh1) {header = b1_header}
>>= fun () ->
Block.Pruned_contents.store (s, bh2) {header = b2_header}
>>= fun () ->
Block.Pruned_contents.store (s, bh3) {header = b3_header}
>>= fun () ->
check_block s bh1 b1
>>= fun () -> check_block s bh2 b2 >>= fun () -> check_block s bh3 b3
let test_expand s =
let s = Store.Chain.get s chain_id in
let s = Store.Block.get s in
Block.Contents.store (s, bh1) b1_contents
>>= fun () ->
Block.Contents.store (s, bh2) b2_contents
>>= fun () ->
Block.Contents.store (s, bh3) b3_contents
>>= fun () ->
Block.Contents.store (s, bh3') b3_contents
>>= fun () ->
Block.Pruned_contents.store (s, bh1) {header = b1_header}
>>= fun () ->
Block.Pruned_contents.store (s, bh2) {header = b2_header}
>>= fun () ->
Block.Pruned_contents.store (s, bh3) {header = b3_header}
>>= fun () ->
Block.Pruned_contents.store (s, bh3') {header = b3_header}
>>= fun () ->
Base58.complete (Block_hash.to_short_b58check bh1)
>>= fun res ->
Assert.equal_string_list ~msg:__LOC__ res [Block_hash.to_b58check bh1] ;
Base58.complete (Block_hash.to_short_b58check bh2)
>>= fun res ->
Assert.equal_string_list ~msg:__LOC__ res [Block_hash.to_b58check bh2] ;
Base58.complete (Block_hash.to_short_b58check bh3)
>>= fun res ->
Assert.equal_string_list
~msg:__LOC__
(List.sort String.compare res)
[Block_hash.to_b58check bh3'; Block_hash.to_b58check bh3] ;
Lwt.return_unit
(** Generic store *)
let check (type t) (module Store : Store_sigs.STORE with type t = t)
(s : Store.t) k d =
Store.read_opt s k
>|= function
| Some d' when Bytes.equal d d' ->
()
| Some d' ->
Assert.fail_msg
~expected:(Bytes.to_string d)
~given:(Bytes.to_string d')
"Error while reading key %d %S\n%!"
Bytes.(compare d d')
(String.concat Filename.dir_sep k)
| None ->
Assert.fail_msg
~expected:(Bytes.to_string d)
~given:""
"Error while reading key %S\n%!"
(String.concat Filename.dir_sep k)
let check_none (type t) (module Store : Store_sigs.STORE with type t = t)
(s : Store.t) k =
Store.read_opt s k
>|= function
| None ->
()
| Some _ ->
Assert.fail_msg
"Error while reading non-existent key %S\n%!"
(String.concat Filename.dir_sep k)
let test_generic (type t) (module Store : Store_sigs.STORE with type t = t)
(s : Store.t) =
Store.store s ["day"; "current"] (Bytes.of_string "Mercredi")
>>= fun () ->
Store.store s ["day"; "next"] (Bytes.of_string "Jeudi")
>>= fun () ->
Store.store s ["day"; "truc"; "chose"] (Bytes.of_string "Vendredi")
>>= fun () ->
check (module Store) s ["day"; "current"] (Bytes.of_string "Mercredi")
>>= fun () ->
check (module Store) s ["day"; "next"] (Bytes.of_string "Jeudi")
>>= fun () -> check_none (module Store) s ["day"]
let list (type t) (module Store : Store_sigs.STORE with type t = t)
(s : Store.t) k =
Store.keys s k
let test_generic_list (type t)
(module Store : Store_sigs.STORE with type t = t) (s : Store.t) =
Store.store s ["a"; "b"] (Bytes.of_string "Novembre")
>>= fun () ->
Store.store s ["a"; "c"] (Bytes.of_string "Juin")
>>= fun () ->
Store.store s ["a"; "d"; "e"] (Bytes.of_string "Septembre")
>>= fun () ->
Store.store s ["f"] (Bytes.of_string "Avril")
>>= fun () ->
Store.store s ["g"; "h"] (Bytes.of_string "Avril")
>>= fun () ->
list (module Store) s []
>>= fun l ->
Assert.equal_string_list_list
~msg:__LOC__
[["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]; ["f"]; ["g"; "h"]]
(List.sort compare l) ;
list (module Store) s ["a"]
>>= fun l ->
Assert.equal_string_list_list
~msg:__LOC__
[["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]]
(List.sort compare l) ;
list (module Store) s ["f"]
>>= fun l ->
Assert.equal_string_list_list ~msg:__LOC__ [] l ;
list (module Store) s ["g"]
>>= fun l ->
Assert.equal_string_list_list ~msg:__LOC__ [["g"; "h"]] (List.sort compare l) ;
list (module Store) s ["i"]
>>= fun l ->
Assert.equal_string_list_list ~msg:__LOC__ [] l ;
Lwt.return_unit
(** HashSet *)
open Store_helpers
let test_hashset (type t) (module Store : Store_sigs.STORE with type t = t)
(s : Store.t) =
let module BlockSet = Block_hash.Set in
let module StoreSet =
Make_buffered_set
(Make_substore
(Store)
(struct
let name = ["test_set"]
end))
(Block_hash)
(BlockSet)
in
let bhset = BlockSet.(add bh2 (add bh1 empty)) in
StoreSet.store_all s bhset
>>= fun () ->
StoreSet.read_all s
>>= fun bhset' ->
Assert.equal_block_set ~msg:__LOC__ bhset bhset' ;
let bhset2 = BlockSet.(bhset |> add bh3 |> remove bh1) in
StoreSet.store_all s bhset2
>>= fun () ->
StoreSet.read_all s
>>= fun bhset2' ->
Assert.equal_block_set ~msg:__LOC__ bhset2 bhset2' ;
StoreSet.fold s ~init:BlockSet.empty ~f:(fun bh acc ->
Lwt.return (BlockSet.add bh acc))
>>= fun bhset2'' ->
Assert.equal_block_set ~msg:__LOC__ bhset2 bhset2'' ;
Store.store s ["day"; "current"] (Bytes.of_string "Mercredi")
>>= fun () ->
StoreSet.remove_all s
>>= fun () ->
StoreSet.read_all s
>>= fun empty ->
Assert.equal_block_set ~msg:__LOC__ BlockSet.empty empty ;
check (module Store) s ["day"; "current"] (Bytes.of_string "Mercredi")
>>= fun () -> Lwt.return_unit
(** HashMap *)
let test_hashmap (type t) (module Store : Store_sigs.STORE with type t = t)
(s : Store.t) =
let module BlockMap = Block_hash.Map in
let module StoreMap =
Make_buffered_map
(Make_substore
(Store)
(struct
let name = ["test_map"]
end))
(Block_hash)
(Make_value (struct
type t = int * char
let encoding =
Data_encoding.(tup2 int31 (conv int_of_char char_of_int int8))
end))
(BlockMap)
in
let eq = ( = ) in
let map = BlockMap.(empty |> add bh1 (1, 'a') |> add bh2 (2, 'b')) in
StoreMap.store_all s map
>>= fun () ->
StoreMap.read_all s
>>= fun map' ->
Assert.equal_block_map ~msg:__LOC__ ~eq map map' ;
let map2 = map |> BlockMap.add bh3 (3, 'c') |> BlockMap.remove bh1 in
StoreMap.store_all s map2
>>= fun () ->
StoreMap.read_all s
>>= fun map2' ->
Assert.equal_block_map ~msg:__LOC__ ~eq map2 map2' ;
Lwt.return_unit
(** Functors *)
let test_single (type t) (module Store : Store_sigs.STORE with type t = t)
(s : Store.t) =
let module Single =
Make_single_store
(Store)
(struct
let name = ["plop"]
end)
(Make_value (struct
type t = int * string
let encoding = Data_encoding.(tup2 int31 string)
end))
in
Single.known s
>>= fun known ->
Assert.is_false ~msg:__LOC__ known ;
Single.read_opt s
>>= fun v' ->
Assert.equal ~msg:__LOC__ None v' ;
let v = (3, "Non!") in
Single.store s v
>>= fun () ->
Single.known s
>>= fun known ->
Assert.is_true ~msg:__LOC__ known ;
Single.read_opt s
>>= fun v' ->
Assert.equal ~msg:__LOC__ (Some v) v' ;
Single.remove s
>>= fun () ->
Single.known s
>>= fun known ->
Assert.is_false ~msg:__LOC__ known ;
Single.read_opt s
>>= fun v' ->
Assert.equal ~msg:__LOC__ None v' ;
Lwt.return_unit
module Sub =
Make_substore
(Raw_store)
(struct
let name = ["plop"; "plip"]
end)
module SubBlocks =
Make_indexed_substore
(Make_substore
(Raw_store)
(struct
let name = ["blocks"]
end))
(Block_hash)
module SubBlocksSet =
SubBlocks.Make_buffered_set
(struct
let name = ["test_set"]
end)
(Block_hash.Set)
module SubBlocksMap =
SubBlocks.Make_buffered_map
(struct
let name = ["test_map"]
end)
(Make_value (struct
type t = int * string
let encoding = Data_encoding.(tup2 int31 string)
end))
(Block_hash.Map)
let test_subblock s =
SubBlocksSet.known s bh1
>>= fun known ->
Assert.is_false ~msg:__LOC__ known ;
SubBlocksSet.store s bh1
>>= fun () ->
SubBlocksSet.store s bh2
>>= fun () ->
SubBlocksSet.known s bh2
>>= fun known ->
Assert.is_true ~msg:__LOC__ known ;
SubBlocksSet.read_all s
>>= fun set ->
let set' = Block_hash.Set.(empty |> add bh1 |> add bh2) in
Assert.equal_block_set ~msg:__LOC__ set set' ;
SubBlocksSet.remove s bh2
>>= fun () ->
let set = Block_hash.Set.(empty |> add bh3' |> add bh3) in
SubBlocksSet.store_all s set
>>= fun () ->
SubBlocksSet.elements s
>>= fun elts ->
Assert.equal_block_hash_list
~msg:__LOC__
(List.sort Block_hash.compare elts)
(List.sort Block_hash.compare [bh3; bh3']) ;
SubBlocksSet.store s bh2
>>= fun () ->
SubBlocksSet.remove s bh3
>>= fun () ->
SubBlocksSet.elements s
>>= fun elts ->
Assert.equal_block_hash_list
~msg:__LOC__
(List.sort Block_hash.compare elts)
(List.sort Block_hash.compare [bh2; bh3']) ;
SubBlocksMap.known s bh1
>>= fun known ->
Assert.is_false ~msg:__LOC__ known ;
let v1 = (3, "Non!") and v2 = (12, "Beurk.") in
SubBlocksMap.store s bh1 v1
>>= fun () ->
SubBlocksMap.store s bh2 v2
>>= fun () ->
SubBlocksMap.known s bh1
>>= fun known ->
SubBlocksMap.read_opt s bh1
>>= fun v1' ->
Assert.equal ~msg:__LOC__ (Some v1) v1' ;
Assert.is_true ~msg:__LOC__ known ;
let map = Block_hash.Map.(empty |> add bh1 v1 |> add bh2 v2) in
SubBlocksMap.read_all s
>>= fun map' ->
Assert.equal_block_map ~eq:( = ) ~msg:__LOC__ map map' ;
SubBlocksSet.remove_all s
>>= fun () ->
SubBlocksSet.elements s
>>= fun elts ->
Assert.equal_block_hash_list ~msg:__LOC__ elts [] ;
SubBlocksMap.read_all s
>>= fun map' ->
Assert.equal_block_map ~eq:( = ) ~msg:__LOC__ map map' ;
SubBlocksSet.store s bh3
>>= fun () ->
SubBlocks.indexes s
>>= fun keys ->
Assert.equal_block_hash_list
~msg:__LOC__
(List.sort Block_hash.compare keys)
(List.sort Block_hash.compare [bh1; bh2; bh3]) ;
Lwt.return_unit
module SubSubBlocks =
Make_indexed_substore
(Make_substore
(SubBlocks.Store)
(struct
let name = ["sub_blocks"]
end))
(Block_hash)
(** *)
let tests_raw : (string * (Raw_store.t -> unit Lwt.t)) list =
[ ("init", test_init);
("generic", test_generic (module Raw_store));
("generic_substore", test_generic (module Sub));
( "generic_indexedstore",
fun s -> test_generic (module SubBlocks.Store) (s, bh1) );
( "generic_indexedsubstore",
fun s -> test_generic (module SubSubBlocks.Store) ((s, bh1), bh2) );
("single", test_single (module Raw_store));
("single_substore", test_single (module Sub));
( "single_indexedstore",
fun s -> test_single (module SubBlocks.Store) (s, bh1) );
( "single_indexedsubstore",
fun s -> test_single (module SubSubBlocks.Store) ((s, bh1), bh2) );
("generic_list", test_generic_list (module Raw_store));
("generic_substore_list", test_generic_list (module Sub));
( "generic_indexedstore_list",
fun s -> test_generic_list (module SubBlocks.Store) (s, bh1) );
( "generic_indexedsubstore_list",
fun s -> test_generic_list (module SubSubBlocks.Store) ((s, bh1), bh2) );
("hashset", test_hashset (module Raw_store));
("hashset_substore", test_hashset (module Sub));
( "hashset_indexedstore",
fun s -> test_hashset (module SubBlocks.Store) (s, bh1) );
( "hashset_indexedsubstore",
fun s -> test_hashset (module SubSubBlocks.Store) ((s, bh1), bh2) );
("hashmap", test_hashmap (module Raw_store));
("hashmap_substore", test_hashmap (module Sub));
( "hashmap_indexedstore",
fun s -> test_hashmap (module SubBlocks.Store) (s, bh1) );
( "hashmap_indexedsubstore",
fun s -> test_hashmap (module SubSubBlocks.Store) ((s, bh1), bh2) );
("subblock", test_subblock) ]
let tests : (string * (Store.t -> unit Lwt.t)) list =
[("expand", test_expand); ("block", test_block)]
let tests =
List.map
(fun (s, f) -> Alcotest_lwt.test_case s `Quick (wrap_raw_store_init f))
tests_raw
@ List.map
(fun (s, f) -> Alcotest_lwt.test_case s `Quick (wrap_store_init f))
tests
src/lib_shell/test/test_store.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Store.
Definition op_gtgteq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
Lwt.bind.
Definition op_gtpipeeq {A B : Type} : (Lwt.t A) -> (A -> B) -> Lwt.t B :=
Lwt.op_gtpipeeq.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.
Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
Protocol_hash.of_b58check_exn
"ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.
Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
Time.Protocol.of_seconds
(* ❌ Constant of type int64 is converted to int *)
0.
Definition mapsize : int64 :=
(* ❌ Constant of type int64 is converted to int *)
4096000000.
Definition wrap_store_init {A B : Type}
(f : Tezos_shell.Store.t -> Lwt.t A) (function_parameter : B)
: unit -> Lwt.t A :=
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.with_tempdir "tezos_test_" % string
(fun base_dir =>
let root := op_divdiv base_dir "store" % string in
op_gtgteq (Store.init None (Some mapsize) root)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok store =>
Lwt.finalize
(fun function_parameter =>
let 'tt := function_parameter in
f store)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Store.close store in
Lwt.return_unit)
| Stdlib.Error err =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Cannot initialize store:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Cannot initialize store:@ %a@]" % string) pp_print_error
err
end)).
Definition wrap_raw_store_init {A B : Type}
(f : Tezos_storage.Raw_store.t -> Lwt.t A) (function_parameter : B)
: unit -> Lwt.t A :=
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.with_tempdir "tezos_test_" % string
(fun base_dir =>
let root := op_divdiv base_dir "store" % string in
op_gtgteq (Raw_store.init None (Some mapsize) root)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok store =>
Lwt.finalize
(fun function_parameter =>
let 'tt := function_parameter in
f store)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Raw_store.close store in
Lwt.return_unit)
| Stdlib.Error err =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Cannot initialize store:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Cannot initialize store:@ %a@]" % string) pp_print_error
err
end)).
Definition test_init {A : Type} (function_parameter : A) : Lwt.t unit :=
let '_ := function_parameter in
Lwt.return_unit.
Definition chain_id : Tezos_base__TzPervasives.Chain_id.t :=
Chain_id.of_block_hash genesis_block.
Definition make (proto : Stdlib.Bytes.t)
: Tezos_base__TzPervasives.Operation.t :=
{| shell := {| branch := genesis_block |}; proto := proto |}.
Definition op1 : Tezos_base__TzPervasives.Operation.t :=
make (Stdlib.Bytes.of_string "Capadoce" % string).
Definition oph1 : Tezos_crypto.Operation_hash.t := Operation.hash op1.
Definition op2 : Tezos_base__TzPervasives.Operation.t :=
make (Stdlib.Bytes.of_string "Kivu" % string).
Definition oph2 : Tezos_crypto.Operation_hash.t := Operation.hash op2.
Definition lolblock
(op_staroptstar :
option (list Tezos_base__TzPervasives.Operation_list_hash.elt))
: string ->
Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents :=
let operations :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun header =>
let operations_hash :=
Operation_list_list_hash.compute
(cons (Operation_list_hash.compute operations) []) in
let block_header :=
{|
Block_header.shell :=
{|
level :=
(* ❌ Constant of type int32 is converted to int *)
0; proto_level := 0; predecessor := genesis_block;
timestamp :=
Time.Protocol.of_seconds
(Random.int64
(* ❌ Constant of type int64 is converted to int *)
1500); validation_passes := Random.int 32;
operations_hash := operations_hash;
fitness :=
cons
(apply Stdlib.Bytes.of_string
(apply OCaml.Stdlib.string_of_int (String.length header)))
(cons
(apply Stdlib.Bytes.of_string
(apply OCaml.Stdlib.string_of_int 12)) []);
context := Context_hash.zero |};
Block_header.protocol_data := Stdlib.Bytes.of_string header |} in
let block_contents :=
{| Store.Block.header := block_header; Store.Block.message := None;
Store.Block.max_operations_ttl := 0;
Store.Block.last_allowed_fork_level :=
(* ❌ Constant of type int32 is converted to int *)
0; Store.Block.context := Context_hash.zero;
Store.Block.metadata := Stdlib.Bytes.create 0 |} in
(block_header, block_contents).
Definition bh1 : Tezos_crypto.Block_hash.t := Block_header.hash b1_header.
Definition bh2 : Tezos_crypto.Block_hash.t := Block_header.hash b2_header.
Definition bh3 : Tezos_crypto.Block_hash.t := Block_header.hash b3_header.
Definition bh3' : Tezos_base__TzPervasives.Block_hash.t :=
let raw := apply Stdlib.Bytes.of_string (Block_hash.to_string bh3) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.Bytes.set raw 31 "000" % char in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.Bytes.set raw 30 "000" % char in
apply Block_hash.of_string_exn (Stdlib.Bytes.to_string raw).
Definition equal
(function_parameter :
Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents)
: (Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents)
-> bool :=
let '(b1_header, b1_contents) := function_parameter in
fun function_parameter =>
let '(b2_header, b2_contents) := function_parameter in
andb (Block_header.equal b1_header b2_header)
(equiv_decb (message b1_contents) (message b2_contents)).
Definition check_block
(s : Tezos_shell__Store.Block.store)
(h : Tezos_base__TzPervasives.Block_hash.t)
(b :
Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents)
: Lwt.t unit :=
op_gtgteq (Store.Block.Contents.read (s, h))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok bc' =>
op_gtgteq (Store.Block.Pruned_contents.read (s, h))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok {| header := header |} => Lwt.return_unit
| Stdlib.Ok _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error while reading block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))))
"Error while reading block %a
%!" % string)
Block_hash.pp_short h in
Stdlib.exit 1
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Error while reading block header " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"@[Error while reading block header %a:@ %a
@]" % string)
Block_hash.pp_short h pp_print_error err in
Stdlib.exit 1
end)
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Error while reading block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"@[Error while reading block %a:@ %a
@]" % string)
Block_hash.pp_short h pp_print_error err in
Stdlib.exit 1
end).
Definition test_block (s : Tezos_shell__Store.global_store) : Lwt.t unit :=
let s := Store.Chain.get s chain_id in
let s := Store.Block.get s in
op_gtgteq (Block.Contents.store (s, bh1) b1_contents)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Block.Contents.store (s, bh2) b2_contents)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Block.Contents.store (s, bh3) b3_contents)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Block.Pruned_contents.store (s, bh1) {| header := b1_header |})
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Block.Pruned_contents.store (s, bh2)
{| header := b2_header |})
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Block.Pruned_contents.store (s, bh3)
{| header := b3_header |})
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (check_block s bh1 b1)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (check_block s bh2 b2)
(fun function_parameter =>
let 'tt := function_parameter in
check_block s bh3 b3)))))))).
Definition test_expand (s : Tezos_shell__Store.global_store) : Lwt.t unit :=
let s := Store.Chain.get s chain_id in
let s := Store.Block.get s in
op_gtgteq (Block.Contents.store (s, bh1) b1_contents)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Block.Contents.store (s, bh2) b2_contents)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Block.Contents.store (s, bh3) b3_contents)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Block.Contents.store (s, bh3') b3_contents)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Block.Pruned_contents.store (s, bh1)
{| header := b1_header |})
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Block.Pruned_contents.store (s, bh2)
{| header := b2_header |})
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Block.Pruned_contents.store (s, bh3)
{| header := b3_header |})
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Block.Pruned_contents.store (s, bh3')
{| header := b3_header |})
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Base58.complete None
(Block_hash.to_short_b58check bh1))
(fun res =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
res
(cons (Block_hash.to_b58check bh1) [])
in
op_gtgteq
(Base58.complete None
(Block_hash.to_short_b58check bh2))
(fun res =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__ res
(cons (Block_hash.to_b58check bh2)
[]) in
op_gtgteq
(Base58.complete None
(Block_hash.to_short_b58check bh3))
(fun res =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(List.sort String.compare res)
(cons
(Block_hash.to_b58check bh3')
(cons
(Block_hash.to_b58check
bh3) [])) in
Lwt.return_unit))))))))))).
Definition check {A : Type}
(Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
: A -> (list string) -> Stdlib.Bytes.t -> Lwt.t unit :=
let Store := projT2 Store in
fun s =>
fun k =>
fun d =>
op_gtpipeeq (Store.(Tezos_storage__Store_sigs.STORE.read_opt) s k)
(fun function_parameter =>
match function_parameter with
| Some d' => tt
| Some d' =>
op_startypeminuserrorstar (Stdlib.Bytes.to_string d)
(Stdlib.Bytes.to_string d')
"Error while reading key %d %S
%!" % string
(Stdlib.Bytes.compare d d') (String.concat Filename.dir_sep k)
| None =>
op_startypeminuserrorstar (Stdlib.Bytes.to_string d) "" % string
"Error while reading key %S
%!" % string
(String.concat Filename.dir_sep k)
end).
Definition check_none {A : Type}
(Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
: A -> (list string) -> Lwt.t unit :=
let Store := projT2 Store in
fun s =>
fun k =>
op_gtpipeeq (Store.(Tezos_storage__Store_sigs.STORE.read_opt) s k)
(fun function_parameter =>
match function_parameter with
| None => tt
| Some _ =>
op_startypeminuserrorstar
"Error while reading non-existent key %S
%!" % string
(String.concat Filename.dir_sep k)
end).
Definition test_generic {A : Type}
(Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
: A -> Lwt.t unit :=
let Store := projT2 Store in
fun s =>
op_gtgteq
(Store.(Tezos_storage__Store_sigs.STORE.store) s
(cons "day" % string (cons "current" % string []))
(Stdlib.Bytes.of_string "Mercredi" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.(Tezos_storage__Store_sigs.STORE.store) s
(cons "day" % string (cons "next" % string []))
(Stdlib.Bytes.of_string "Jeudi" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.(Tezos_storage__Store_sigs.STORE.store) s
(cons "day" % string
(cons "truc" % string (cons "chose" % string [])))
(Stdlib.Bytes.of_string "Vendredi" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check Store s
(cons "day" % string (cons "current" % string []))
(Stdlib.Bytes.of_string "Mercredi" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(check Store s
(cons "day" % string (cons "next" % string []))
(Stdlib.Bytes.of_string "Jeudi" % string))
(fun function_parameter =>
let 'tt := function_parameter in
check_none Store s (cons "day" % string [])))))).
Definition list {A : Type}
(Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
: A -> (list string) -> Lwt.t (list (list string)) :=
let Store := projT2 Store in
fun s => fun k => Store.(Tezos_storage__Store_sigs.STORE.keys) s k.
Definition test_generic_list {A : Type}
(Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
: A -> Lwt.t unit :=
let Store := projT2 Store in
fun s =>
op_gtgteq
(Store.(Tezos_storage__Store_sigs.STORE.store) s
(cons "a" % string (cons "b" % string []))
(Stdlib.Bytes.of_string "Novembre" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.(Tezos_storage__Store_sigs.STORE.store) s
(cons "a" % string (cons "c" % string []))
(Stdlib.Bytes.of_string "Juin" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.(Tezos_storage__Store_sigs.STORE.store) s
(cons "a" % string (cons "d" % string (cons "e" % string [])))
(Stdlib.Bytes.of_string "Septembre" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.(Tezos_storage__Store_sigs.STORE.store) s
(cons "f" % string [])
(Stdlib.Bytes.of_string "Avril" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Store.(Tezos_storage__Store_sigs.STORE.store) s
(cons "g" % string (cons "h" % string []))
(Stdlib.Bytes.of_string "Avril" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (list Store s [])
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(cons (cons "a" % string (cons "b" % string []))
(cons
(cons "a" % string (cons "c" % string []))
(cons
(cons "a" % string
(cons "d" % string
(cons "e" % string [])))
(cons (cons "f" % string [])
(cons
(cons "g" % string
(cons "h" % string [])) [])))))
(List.sort OCaml.Stdlib.compare l) in
op_gtgteq (list Store s (cons "a" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(cons
(cons "a" % string (cons "b" % string []))
(cons
(cons "a" % string
(cons "c" % string []))
(cons
(cons "a" % string
(cons "d" % string
(cons "e" % string []))) [])))
(List.sort OCaml.Stdlib.compare l) in
op_gtgteq (list Store s (cons "f" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
[] l in
op_gtgteq
(list Store s (cons "g" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(cons
(cons "g" % string
(cons "h" % string [])) [])
(List.sort OCaml.Stdlib.compare l)
in
op_gtgteq
(list Store s (cons "i" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__ [] l in
Lwt.return_unit)))))))))).
Import Store_helpers.
Definition test_hashset {A : Type}
(Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
: A -> Lwt.t unit :=
let Store := projT2 Store in
fun s =>
let BlockSet := Block_hash.Set in
let StoreSet :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
let bhset := add bh2 (add bh1 empty) in
op_gtgteq
(StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store_all) s bhset)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.read_all) s)
(fun bhset' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ bhset bhset' in
let bhset2 :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply bhset (add bh3)) (remove bh1) in
op_gtgteq
(StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store_all)
s bhset2)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.read_all)
s)
(fun bhset2' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ bhset2 bhset2' in
op_gtgteq
(StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.fold)
s BlockSet.empty
(fun bh => fun acc => Lwt._return (BlockSet.add bh acc)))
(fun bhset2'' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ bhset2
bhset2'' in
op_gtgteq
(Store.(Tezos_storage__Store_sigs.STORE.store) s
(cons "day" % string (cons "current" % string []))
(Stdlib.Bytes.of_string "Mercredi" % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.remove_all)
s)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.read_all)
s)
(fun empty =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
BlockSet.empty empty in
op_gtgteq
(check Store s
(cons "day" % string
(cons "current" % string []))
(Stdlib.Bytes.of_string
"Mercredi" % string))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_unit))))))))).
Definition test_hashmap {A : Type}
(Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
: A -> Lwt.t unit :=
let Store := projT2 Store in
fun s =>
let BlockMap := Block_hash.Map in
let StoreMap :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
let eq := equiv_decb in
let map :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply empty (add bh1 (1, "a" % char)))
(add bh2 (2, "b" % char)) in
op_gtgteq
(StoreMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.store_all) s map)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(StoreMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_all) s)
(fun map' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ eq map map' in
let map2 :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply map
(BlockMap.add bh3 (3, "c" % char))) (BlockMap.remove bh1) in
op_gtgteq
(StoreMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.store_all)
s map2)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(StoreMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_all)
s)
(fun map2' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ eq map2 map2' in
Lwt.return_unit)))).
Definition test_single {A : Type}
(Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
: A -> Lwt.t unit :=
let Store := projT2 Store in
fun s =>
let Single :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
op_gtgteq (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known) s)
(fun known =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ known in
op_gtgteq (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt) s)
(fun v' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ None v' in
let v := (3, "Non!" % string) in
op_gtgteq
(Single.(Tezos_storage__Store_sigs.SINGLE_STORE.store) s v)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known) s)
(fun known =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ known in
op_gtgteq
(Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt)
s)
(fun v' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ (Some v) v'
in
op_gtgteq
(Single.(Tezos_storage__Store_sigs.SINGLE_STORE.remove)
s)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known)
s)
(fun known =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ known
in
op_gtgteq
(Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt)
s)
(fun v' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
None v' in
Lwt.return_unit)))))))).
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Definition test_subblock
(s : SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.t))
: Lwt.t unit :=
op_gtgteq
(SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.known) s bh1)
(fun known =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ known in
op_gtgteq
(SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store) s bh1)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store) s
bh2)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.known)
s bh2)
(fun known =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ known in
op_gtgteq
(SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.read_all)
s)
(fun set =>
let set' :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply empty (add bh1)) (add bh2)
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ set set'
in
op_gtgteq
(SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.remove)
s bh2)
(fun function_parameter =>
let 'tt := function_parameter in
let set :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply empty (add bh3'))
(add bh3) in
op_gtgteq
(SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store_all)
s set)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.elements)
s)
(fun elts =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(List.sort Block_hash.compare elts)
(List.sort Block_hash.compare
(cons bh3 (cons bh3' []))) in
op_gtgteq
(SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store)
s bh2)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.remove)
s bh3)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.elements)
s)
(fun elts =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(List.sort Block_hash.compare
elts)
(List.sort Block_hash.compare
(cons bh2 (cons bh3' [])))
in
op_gtgteq
(SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.known)
s bh1)
(fun known =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__ known in
let v1 : Z * string :=
(3, "Non!" % string)
with v2 : Z * string :=
(12, "Beurk." % string) in
op_gtgteq
(SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.store)
s bh1 v1)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteq
(SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.store)
s bh2 v2)
(fun function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.known)
s bh1)
(fun known =>
op_gtgteq
(SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_opt)
s bh1)
(fun v1' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(Some v1)
v1' in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
known in
let map :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
empty
(add bh1
v1))
(add bh2
v2) in
op_gtgteq
(SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_all)
s)
(fun map' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
equiv_decb
Stdlib.__LOC__
map
map'
in
op_gtgteq
(SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.remove_all)
s)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.elements)
s)
(fun
elts
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
Stdlib.__LOC__
elts
[]
in
op_gtgteq
(SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_all)
s)
(fun
map'
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
equiv_decb
Stdlib.__LOC__
map
map'
in
op_gtgteq
(SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store)
s
bh3)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteq
(SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.indexes)
s)
(fun
keys
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let
_
:=
op_startypeminuserrorstar
Stdlib.__LOC__
(List.sort
Block_hash.compare
keys)
(List.sort
Block_hash.compare
(cons
bh1
(cons
bh2
(cons
bh3
[]))))
in
Lwt.return_unit)))))))))))))))))))))).
(* ❌ Applications of functors are not handled. *)
functor_application
Definition tests_raw
: list (string * (Tezos_storage.Raw_store.t -> Lwt.t unit)) :=
cons ("init" % string, test_init)
(cons ("generic" % string, (test_generic Raw_store))
(cons ("generic_substore" % string, (test_generic Sub))
(cons
("generic_indexedstore" % string,
(fun s =>
test_generic
SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
(s, bh1)))
(cons
("generic_indexedsubstore" % string,
(fun s =>
test_generic
SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
((s, bh1), bh2)))
(cons ("single" % string, (test_single Raw_store))
(cons ("single_substore" % string, (test_single Sub))
(cons
("single_indexedstore" % string,
(fun s =>
test_single
SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
(s, bh1)))
(cons
("single_indexedsubstore" % string,
(fun s =>
test_single
SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
((s, bh1), bh2)))
(cons
("generic_list" % string, (test_generic_list Raw_store))
(cons
("generic_substore_list" % string,
(test_generic_list Sub))
(cons
("generic_indexedstore_list" % string,
(fun s =>
test_generic_list
SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
(s, bh1)))
(cons
("generic_indexedsubstore_list" % string,
(fun s =>
test_generic_list
SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
((s, bh1), bh2)))
(cons ("hashset" % string, (test_hashset Raw_store))
(cons
("hashset_substore" % string, (test_hashset Sub))
(cons
("hashset_indexedstore" % string,
(fun s =>
test_hashset
SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
(s, bh1)))
(cons
("hashset_indexedsubstore" % string,
(fun s =>
test_hashset
SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
((s, bh1), bh2)))
(cons
("hashmap" % string,
(test_hashmap Raw_store))
(cons
("hashmap_substore" % string,
(test_hashmap Sub))
(cons
("hashmap_indexedstore" % string,
(fun s =>
test_hashmap
SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
(s, bh1)))
(cons
("hashmap_indexedsubstore" % string,
(fun s =>
test_hashmap
SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
((s, bh1), bh2)))
(cons
("subblock" % string,
test_subblock) []))))))))))))))))))))).
Definition tests : list (string * (Tezos_shell.Store.t -> Lwt.t unit)) :=
cons ("expand" % string, test_expand) (cons ("block" % string, test_block) []).
Definition tests {A : Type} : list A :=
OCaml.Stdlib.app
(List.map
(fun function_parameter =>
let '(s, f) := function_parameter in
op_startypeminuserrorstar s
(* ❌ Variants not supported *)
variant (wrap_raw_store_init f)) tests_raw)
(List.map
(fun function_parameter =>
let '(s, f) := function_parameter in
op_startypeminuserrorstar s
(* ❌ Variants not supported *)
variant (wrap_store_init f)) tests).
src/lib_shell/test/test_store_checkpoint.ml 20 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let mapsize = 4_096_000_000L (* ~4 GiB *)
let ( // ) = Filename.concat
let wrap_raw_store_init f _ () =
Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
let root = base_dir // "store" in
Raw_store.init ~mapsize root
>>= function
| Ok store ->
Lwt.finalize
(fun () -> f store)
(fun () -> Raw_store.close store ; Lwt.return_unit)
| Error err ->
Format.kasprintf
Pervasives.failwith
"@[Cannot initialize store:@ %a@]"
pp_print_error
err)
(**************************************************************************)
(** Basic blocks *)
let genesis_block =
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"
(**************************************************************************)
(** Block store *)
let lolblock ?(operations = []) header =
let operations_hash =
Operation_list_list_hash.compute [Operation_list_hash.compute operations]
in
let block_header =
{
Block_header.shell =
{
timestamp = Time.Protocol.of_seconds (Random.int64 1500L);
level = 0l;
(* dummy *)
proto_level = 0;
(* dummy *)
validation_passes = Random.int 32;
predecessor = genesis_block;
operations_hash;
fitness =
[ Bytes.of_string @@ string_of_int @@ String.length header;
Bytes.of_string @@ string_of_int @@ 12 ];
context = Context_hash.zero;
};
protocol_data = Bytes.of_string header;
}
in
let block_contents =
{
header = block_header;
Store.Block.metadata = Bytes.create 0;
max_operations_ttl = 0;
message = None;
context = Context_hash.zero;
last_allowed_fork_level = 0l;
}
in
(block_header, block_contents)
let (block_header, _) = lolblock "A1"
let block_hash = Block_header.hash block_header
(****************************************************)
open Store_helpers
let test_single (type t) (module Store : Store_sigs.STORE with type t = t)
(s : Store.t) =
let module Single =
Make_single_store
(Store)
(struct
let name = ["checkpoint"]
end)
(Store_helpers.Make_value (struct
type t = Int32.t * Block_hash.t
let encoding = Data_encoding.(tup2 int32 Block_hash.encoding)
end))
in
(* is there any checkpoint in store *)
Single.known s
>>= fun is_known ->
Assert.is_false ~msg:__LOC__ is_known ;
Single.read_opt s
>>= fun checkpoint' ->
Assert.equal_checkpoint ~msg:__LOC__ None checkpoint' ;
(* store new checkpoint: (1, A1) *)
let checkpoint = (1l, block_hash) in
Single.store s checkpoint
>>= fun () ->
Single.known s
>>= fun is_known ->
Assert.is_true ~msg:__LOC__ is_known ;
Single.read_opt s
>>= fun checkpoint' ->
Assert.equal_checkpoint ~msg:__LOC__ (Some checkpoint) checkpoint' ;
(* remove the checkpoint just store *)
Single.remove s
>>= fun () ->
Single.known s
>>= fun is_known ->
Assert.is_false ~msg:__LOC__ is_known ;
Single.read_opt s
>>= fun checkpoint' ->
Assert.equal_checkpoint ~msg:__LOC__ None checkpoint' ;
Lwt.return_unit
(**************************************************************************)
let tests_raw : (string * (Raw_store.t -> unit Lwt.t)) list =
[("single", test_single (module Raw_store))]
let tests =
List.map
(fun (s, f) -> Alcotest_lwt.test_case s `Quick (wrap_raw_store_init f))
tests_raw
src/lib_shell/test/test_store_checkpoint.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition mapsize : int64 :=
(* ❌ Constant of type int64 is converted to int *)
4096000000.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition wrap_raw_store_init {A B : Type}
(f : Tezos_storage.Raw_store.t -> Lwt.t A) (function_parameter : B)
: unit -> Lwt.t A :=
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.with_tempdir "tezos_test_" % string
(fun base_dir =>
let root := op_divdiv base_dir "store" % string in
op_gtgteq (Raw_store.init None (Some mapsize) root)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok store =>
Lwt.finalize
(fun function_parameter =>
let 'tt := function_parameter in
f store)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Raw_store.close store in
Lwt.return_unit)
| Stdlib.Error err =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Cannot initialize store:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Cannot initialize store:@ %a@]" % string) pp_print_error
err
end)).
Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.
Definition lolblock
(op_staroptstar :
option (list Tezos_base__TzPervasives.Operation_list_hash.elt))
: string ->
Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents :=
let operations :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun header =>
let operations_hash :=
Operation_list_list_hash.compute
(cons (Operation_list_hash.compute operations) []) in
let block_header :=
{|
Block_header.shell :=
{|
level :=
(* ❌ Constant of type int32 is converted to int *)
0; proto_level := 0; predecessor := genesis_block;
timestamp :=
Time.Protocol.of_seconds
(Random.int64
(* ❌ Constant of type int64 is converted to int *)
1500); validation_passes := Random.int 32;
operations_hash := operations_hash;
fitness :=
cons
(apply Stdlib.Bytes.of_string
(apply OCaml.Stdlib.string_of_int (String.length header)))
(cons
(apply Stdlib.Bytes.of_string
(apply OCaml.Stdlib.string_of_int 12)) []);
context := Context_hash.zero |};
Block_header.protocol_data := Stdlib.Bytes.of_string header |} in
let block_contents :=
{| Store.Block.header := block_header; Store.Block.message := None;
Store.Block.max_operations_ttl := 0;
Store.Block.last_allowed_fork_level :=
(* ❌ Constant of type int32 is converted to int *)
0; Store.Block.context := Context_hash.zero;
Store.Block.metadata := Stdlib.Bytes.create 0 |} in
(block_header, block_contents).
Definition block_hash : Tezos_crypto.Block_hash.t :=
Block_header.hash block_header.
Import Store_helpers.
Definition test_single {A : Type}
(Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
: A -> Lwt.t unit :=
let Store := projT2 Store in
fun s =>
let Single :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
op_gtgteq (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known) s)
(fun is_known =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ is_known in
op_gtgteq (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt) s)
(fun checkpoint' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ None checkpoint'
in
let checkpoint :=
((* ❌ Constant of type int32 is converted to int *)
1, block_hash) in
op_gtgteq
(Single.(Tezos_storage__Store_sigs.SINGLE_STORE.store) s
checkpoint)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known) s)
(fun is_known =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ is_known
in
op_gtgteq
(Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt)
s)
(fun checkpoint' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(Some checkpoint) checkpoint' in
op_gtgteq
(Single.(Tezos_storage__Store_sigs.SINGLE_STORE.remove)
s)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known)
s)
(fun is_known =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
is_known in
op_gtgteq
(Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt)
s)
(fun checkpoint' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
None checkpoint' in
Lwt.return_unit)))))))).
Definition tests_raw
: list (string * (Tezos_storage.Raw_store.t -> Lwt.t unit)) :=
cons ("single" % string, (test_single Raw_store)) [].
Definition tests {A : Type} : list A :=
List.map
(fun function_parameter =>
let '(s, f) := function_parameter in
op_startypeminuserrorstar s
(* ❌ Variants not supported *)
variant (wrap_raw_store_init f)) tests_raw.
src/lib_shell/validator.ml 30 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make_semantic (struct
let name = "node.validator"
end)
type t = {
state : State.t;
db : Distributed_db.t;
block_validator : Block_validator.t;
chain_validator_limits : Chain_validator.limits;
peer_validator_limits : Peer_validator.limits;
block_validator_limits : Block_validator.limits;
prevalidator_limits : Prevalidator.limits;
start_testchain : bool;
valid_block_input : State.Block.t Lwt_watcher.input;
chains_input : (Chain_id.t * bool) Lwt_watcher.input;
active_chains : Chain_validator.t Chain_id.Table.t;
}
let create state db peer_validator_limits block_validator_limits
block_validator_kind prevalidator_limits chain_validator_limits
~start_testchain =
Block_validator.create
block_validator_limits
db
block_validator_kind
~start_testchain
>>=? fun block_validator ->
let valid_block_input = Lwt_watcher.create_input () in
let chains_input = Lwt_watcher.create_input () in
return
{
state;
db;
start_testchain;
block_validator;
block_validator_limits;
prevalidator_limits;
peer_validator_limits;
chain_validator_limits;
valid_block_input;
chains_input;
active_chains = Chain_id.Table.create 7;
}
let activate v ~start_prevalidator ~validator_process chain_state =
let chain_id = State.Chain.id chain_state in
lwt_log_notice
Tag.DSL.(
fun f ->
f "activate chain %a" -% t event "active_chain"
-% a State_logging.chain_id chain_id)
>>= fun () ->
match Chain_id.Table.find_opt v.active_chains chain_id with
| Some chain ->
return chain
| None ->
Chain_validator.create
~start_prevalidator
~start_testchain:v.start_testchain
~active_chains:v.active_chains
~block_validator_process:validator_process
v.peer_validator_limits
v.prevalidator_limits
v.block_validator
v.valid_block_input
v.chains_input
v.db
chain_state
v.chain_validator_limits
let get_exn {active_chains; _} chain_id =
Chain_id.Table.find active_chains chain_id
let get {active_chains; _} chain_id =
match Chain_id.Table.find_opt active_chains chain_id with
| Some nv ->
Ok nv
| None ->
error (Validation_errors.Inactive_chain chain_id)
let get_active_chains {active_chains; _} =
let l = Chain_id.Table.fold (fun c _ acc -> c :: acc) active_chains [] in
List.rev l
let validate_block v ?(force = false) ?chain_id bytes operations =
let hash = Block_hash.hash_bytes [bytes] in
match Block_header.of_bytes bytes with
| None ->
failwith "Cannot parse block header."
| Some block ->
( match chain_id with
| None -> (
Distributed_db.read_block_header v.db block.shell.predecessor
>>= function
| None ->
failwith
"Unknown predecessor (%a), cannot inject the block."
Block_hash.pp_short
block.shell.predecessor
| Some (chain_id, _bh) ->
Lwt.return (get v chain_id) )
| Some chain_id -> (
Lwt.return (get v chain_id)
>>=? fun nv ->
if force then return nv
else
Distributed_db.Block_header.known
(Chain_validator.chain_db nv)
block.shell.predecessor
>>= function
| true ->
return nv
| false ->
failwith
"Unknown predecessor (%a), cannot inject the block."
Block_hash.pp_short
block.shell.predecessor ) )
>>=? fun nv ->
let validation =
Chain_validator.validate_block nv ~force hash block operations
in
return (hash, validation)
let shutdown {active_chains; block_validator; _} =
let block_validator_job =
lwt_log_notice
Tag.DSL.(
fun f -> f "Shutting down the block validator..." -% t event "shutdown")
>>= fun () -> Block_validator.shutdown block_validator
in
let chain_validator_jobs =
List.of_seq
@@ Seq.map
(fun (id, nv) ->
lwt_log_notice
Tag.DSL.(
fun f ->
f "Shutting down the chain validator %a..."
-% t event "shutdown"
-% a State_logging.chain_id id)
>>= fun () -> Chain_validator.shutdown nv)
(Chain_id.Table.to_seq active_chains)
in
Lwt.join (block_validator_job :: chain_validator_jobs)
let watcher {valid_block_input; _} =
Lwt_watcher.create_stream valid_block_input
let chains_watcher {chains_input; _} = Lwt_watcher.create_stream chains_input
let inject_operation v ?chain_id op =
( match chain_id with
| None -> (
Distributed_db.read_block_header v.db op.Operation.shell.branch
>>= function
| None ->
failwith
"Unknown branch (%a), cannot inject the operation."
Block_hash.pp_short
op.shell.branch
| Some (chain_id, _bh) ->
Lwt.return (get v chain_id) )
| Some chain_id -> (
Lwt.return (get v chain_id)
>>=? fun nv ->
Distributed_db.Block_header.known
(Chain_validator.chain_db nv)
op.shell.branch
>>= function
| true ->
return nv
| false ->
failwith
"Unknown branch (%a), cannot inject the operation."
Block_hash.pp_short
op.shell.branch ) )
>>=? fun nv ->
let pv_opt = Chain_validator.prevalidator nv in
match pv_opt with
| Some pv ->
Prevalidator.inject_operation pv op
| None ->
failwith "Prevalidator is not running, cannot inject the operation."
let distributed_db {db; _} = db
src/lib_shell/validator.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Record t := {
state : Tezos_shell.State.t;
db : Tezos_shell.Distributed_db.t;
block_validator : Tezos_shell.Block_validator.t;
chain_validator_limits : Tezos_shell.Chain_validator.limits;
peer_validator_limits : Tezos_shell.Peer_validator.limits;
block_validator_limits : Tezos_shell.Block_validator.limits;
prevalidator_limits : Tezos_shell.Prevalidator.limits;
start_testchain : bool;
valid_block_input :
Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t;
chains_input :
Tezos_base__TzPervasives.Lwt_watcher.input
(Tezos_base__TzPervasives.Chain_id.t * bool);
active_chains :
Tezos_base__TzPervasives.Chain_id.Table.t Tezos_shell.Chain_validator.t }.
Definition create
(state : Tezos_shell.State.t) (db : Tezos_shell.Distributed_db.t)
(peer_validator_limits : Tezos_shell.Peer_validator.limits)
(block_validator_limits : Tezos_shell.Block_validator.limits)
(block_validator_kind : Tezos_shell.Block_validator_process.t)
(prevalidator_limits : Tezos_shell.Prevalidator.limits)
(chain_validator_limits : Tezos_shell.Chain_validator.limits)
(start_testchain : bool) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
op_gtgteqquestion
(Block_validator.create block_validator_limits db block_validator_kind
start_testchain)
(fun block_validator =>
let valid_block_input := Lwt_watcher.create_input tt in
let chains_input := Lwt_watcher.create_input tt in
_return
{| state := state; db := db; block_validator := block_validator;
chain_validator_limits := chain_validator_limits;
peer_validator_limits := peer_validator_limits;
block_validator_limits := block_validator_limits;
prevalidator_limits := prevalidator_limits;
start_testchain := start_testchain;
valid_block_input := valid_block_input; chains_input := chains_input;
active_chains := Chain_id.Table.create 7 |}).
Definition activate
(v : t) (start_prevalidator : bool)
(validator_process : Tezos_shell.Block_validator_process.t)
(chain_state : Tezos_shell.State.Chain.chain_state)
: Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_shell.Chain_validator.t) :=
let chain_id := State.Chain.id chain_state in
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"activate chain " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"activate chain %a" % string)) (t event "active_chain" % string))
(a State_logging.chain_id chain_id)))
(fun function_parameter =>
let 'tt := function_parameter in
match Chain_id.Table.find_opt (active_chains v) chain_id with
| Some chain => _return chain
| None =>
Chain_validator.create start_prevalidator (start_testchain v)
(active_chains v) validator_process (peer_validator_limits v)
(prevalidator_limits v) (block_validator v) (valid_block_input v)
(chains_input v) (db v) chain_state (chain_validator_limits v)
end).
Definition get_exn (function_parameter : t)
: Tezos_base__TzPervasives.Chain_id.Table.key -> Tezos_shell.Chain_validator.t :=
let '{| active_chains := active_chains |} := function_parameter in
fun chain_id => Chain_id.Table.find active_chains chain_id.
Definition get (function_parameter : t)
: Tezos_base__TzPervasives.Chain_id.Table.key ->
sum Tezos_shell.Chain_validator.t Tezos_base__TzPervasives.trace :=
let '{| active_chains := active_chains |} := function_parameter in
fun chain_id =>
match Chain_id.Table.find_opt active_chains chain_id with
| Some nv => Stdlib.Ok nv
| None => error (Tezos_base__TzPervasives.Inactive_chain chain_id)
end.
Definition get_active_chains (function_parameter : t)
: list Tezos_base__TzPervasives.Chain_id.Table.key :=
let '{| active_chains := active_chains |} := function_parameter in
let l :=
Chain_id.Table.fold
(fun c =>
fun function_parameter =>
let '_ := function_parameter in
fun acc => cons c acc) active_chains [] in
List.rev l.
Definition validate_block (v : t) (op_staroptstar : option bool)
: (option Tezos_base__TzPervasives.Chain_id.Table.key) ->
Stdlib.Bytes.t ->
(list (list Tezos_base__TzPervasives.Operation.t)) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Block_hash.t *
(Lwt.t
(Tezos_base__TzPervasives.tzresult
(option Tezos_shell.State.Block.t))))) :=
let force :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun chain_id =>
fun bytes =>
fun operations =>
let hash := Block_hash.hash_bytes None (cons string []) in
match Block_header.of_bytes string with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot parse block header." % string
CamlinternalFormatBasics.End_of_format)
"Cannot parse block header." % string)
| Some block =>
op_gtgteqquestion
match chain_id with
| None =>
op_gtgteq
(Distributed_db.read_block_header (db v)
(predecessor (shell block)))
(fun function_parameter =>
match function_parameter with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown predecessor (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"), cannot inject the block." % string
CamlinternalFormatBasics.End_of_format)))
"Unknown predecessor (%a), cannot inject the block." %
string) Block_hash.pp_short
(predecessor (shell block))
| Some (chain_id, _bh) => Lwt._return (get v chain_id)
end)
| Some chain_id =>
op_gtgteqquestion (Lwt._return (get v chain_id))
(fun nv =>
if force then
_return nv
else
op_gtgteq
(Distributed_db.Block_header.known
(Chain_validator.chain_db nv)
(predecessor (shell block)))
(fun function_parameter =>
match function_parameter with
| true => _return nv
| false =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown predecessor (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"), cannot inject the block." % string
CamlinternalFormatBasics.End_of_format)))
"Unknown predecessor (%a), cannot inject the block."
% string) Block_hash.pp_short
(predecessor (shell block))
end))
end
(fun nv =>
let validation :=
Chain_validator.validate_block nv (Some force) hash block
operations in
_return (hash, validation))
end.
Definition shutdown (function_parameter : t) : Lwt.t unit :=
let '{|
block_validator := block_validator; active_chains := active_chains |} :=
function_parameter in
let block_validator_job :=
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down the block validator..." % string
CamlinternalFormatBasics.End_of_format)
"Shutting down the block validator..." % string))
(t event "shutdown" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
Block_validator.shutdown block_validator) in
let chain_validator_jobs :=
apply List.of_seq
(Seq.map
(fun function_parameter =>
let '(id, nv) := function_parameter in
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shutting down the chain validator " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"..." % string
CamlinternalFormatBasics.End_of_format)))
"Shutting down the chain validator %a..." % string))
(t event "shutdown" % string)) (a State_logging.chain_id id)))
(fun function_parameter =>
let 'tt := function_parameter in
Chain_validator.shutdown nv))
(Chain_id.Table.to_seq active_chains)) in
Lwt.join (cons block_validator_job chain_validator_jobs).
Definition watcher (function_parameter : t)
: (Lwt_stream.t Tezos_shell.State.Block.t) *
Tezos_base__TzPervasives.Lwt_watcher.stopper :=
let '{| valid_block_input := valid_block_input |} := function_parameter in
Lwt_watcher.create_stream valid_block_input.
Definition chains_watcher (function_parameter : t)
: (Lwt_stream.t (Tezos_base__TzPervasives.Chain_id.t * bool)) *
Tezos_base__TzPervasives.Lwt_watcher.stopper :=
let '{| chains_input := chains_input |} := function_parameter in
Lwt_watcher.create_stream chains_input.
Definition inject_operation
(v : t) (chain_id : option Tezos_base__TzPervasives.Chain_id.Table.key)
(op : Tezos_base__TzPervasives.Operation.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
match chain_id with
| None =>
op_gtgteq
(Distributed_db.read_block_header (db v) (branch (Operation.shell op)))
(fun function_parameter =>
match function_parameter with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown branch (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"), cannot inject the operation." % string
CamlinternalFormatBasics.End_of_format)))
"Unknown branch (%a), cannot inject the operation." % string)
Block_hash.pp_short (branch (shell op))
| Some (chain_id, _bh) => Lwt._return (get v chain_id)
end)
| Some chain_id =>
op_gtgteqquestion (Lwt._return (get v chain_id))
(fun nv =>
op_gtgteq
(Distributed_db.Block_header.known (Chain_validator.chain_db nv)
(branch (shell op)))
(fun function_parameter =>
match function_parameter with
| true => _return nv
| false =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown branch (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"), cannot inject the operation." % string
CamlinternalFormatBasics.End_of_format)))
"Unknown branch (%a), cannot inject the operation." % string)
Block_hash.pp_short (branch (shell op))
end))
end
(fun nv =>
let pv_opt := Chain_validator.prevalidator nv in
match pv_opt with
| Some pv => Prevalidator.inject_operation pv op
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Prevalidator is not running, cannot inject the operation." %
string CamlinternalFormatBasics.End_of_format)
"Prevalidator is not running, cannot inject the operation." % string)
end).
Definition distributed_db (function_parameter : t)
: Tezos_shell.Distributed_db.t :=
let '{| db := db |} := function_parameter in
db.
src/lib_shell/worker.ml 39 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type NAME = sig
val base : string list
type t
val encoding : t Data_encoding.t
val pp : Format.formatter -> t -> unit
end
module type EVENT = sig
type t
val level : t -> Internal_event.level
val encoding : t Data_encoding.t
val pp : Format.formatter -> t -> unit
end
module type REQUEST = sig
type 'a t
type view
val view : 'a t -> view
val encoding : view Data_encoding.t
val pp : Format.formatter -> view -> unit
end
module type TYPES = sig
type state
type parameters
type view
val view : state -> parameters -> view
val encoding : view Data_encoding.t
val pp : Format.formatter -> view -> unit
end
module type LOGGER = sig
module Event : EVENT
module Request : REQUEST
type status =
| WorkerEvent of Event.t
| Request of
(Request.view * Worker_types.request_status * error list option)
| Terminated
| Timeout
| Crashed of error list
| Started of string option
| Triggering_shutdown
| Duplicate of string
type t = status Time.System.stamped
module MakeDefinition (Static : sig
val worker_name : string
end) : Internal_event.EVENT_DEFINITION with type t = t
end
(** An error returned when trying to communicate with a worker that
has been closed.*)
type worker_name = {base : string; name : string}
type Error_monad.error += Closed of worker_name
let () =
register_error_kind
`Permanent
~id:"worker.closed"
~title:"Worker closed"
~description:
"An operation on a worker could not complete before it was shut down."
~pp:(fun ppf w ->
Format.fprintf ppf "Worker %s[%s] has been shut down." w.base w.name)
Data_encoding.(
conv
(fun {base; name} -> (base, name))
(fun (name, base) -> {base; name})
(obj1 (req "worker" (tup2 string string))))
(function Closed w -> Some w | _ -> None)
(fun w -> Closed w)
module type T = sig
module Name : NAME
module Event : EVENT
module Request : REQUEST
module Types : TYPES
(** A handle to a specific worker, parameterized by the type of
internal message buffer. *)
type 'kind t
(** A handle to a table of workers. *)
type 'kind table
(** Internal buffer kinds used as parameters to {!t}. *)
type 'a queue
and bounded
and infinite
type dropbox
(** Supported kinds of internal buffers. *)
type _ buffer_kind =
| Queue : infinite queue buffer_kind
| Bounded : {size : int} -> bounded queue buffer_kind
| Dropbox : {
merge :
dropbox t -> any_request -> any_request option -> any_request option;
}
-> dropbox buffer_kind
and any_request = Any_request : _ Request.t -> any_request
(** Create a table of workers. *)
val create_table : 'kind buffer_kind -> 'kind table
(** The callback handlers specific to each worker instance. *)
module type HANDLERS = sig
(** Placeholder replaced with {!t} with the right parameters
provided by the type of buffer chosen at {!launch}.*)
type self
(** Builds the initial internal state of a worker at launch.
It is possible to initialize the message queue.
Of course calling {!state} will fail at that point. *)
val on_launch :
self -> Name.t -> Types.parameters -> Types.state tzresult Lwt.t
(** The main request processor, i.e. the body of the event loop. *)
val on_request : self -> 'a Request.t -> 'a tzresult Lwt.t
(** Called when no request has been made before the timeout, if
the parameter has been passed to {!launch}. *)
val on_no_request : self -> unit tzresult Lwt.t
(** A function called when terminating a worker. *)
val on_close : self -> unit Lwt.t
(** A function called at the end of the worker loop in case of an
abnormal error. This function can handle the error by
returning [Ok ()], or leave the default unexpected error
behaviour by returning its parameter. A possibility is to
handle the error for ad-hoc logging, and still use
{!trigger_shutdown} to kill the worker. *)
val on_error :
self ->
Request.view ->
Worker_types.request_status ->
error list ->
unit tzresult Lwt.t
(** A function called at the end of the worker loop in case of a
successful treatment of the current request. *)
val on_completion :
self -> 'a Request.t -> 'a -> Worker_types.request_status -> unit Lwt.t
end
(** Creates a new worker instance.
Parameter [queue_size] not passed means unlimited queue. *)
val launch :
'kind table ->
?timeout:Time.System.Span.t ->
Worker_types.limits ->
Name.t ->
Types.parameters ->
(module HANDLERS with type self = 'kind t) ->
'kind t tzresult Lwt.t
(** Triggers a worker termination and waits for its completion.
Cannot be called from within the handlers. *)
val shutdown : _ t -> unit Lwt.t
module type BOX = sig
type t
val put_request : t -> 'a Request.t -> unit
val put_request_and_wait : t -> 'a Request.t -> 'a tzresult Lwt.t
end
module type QUEUE = sig
type 'a t
val push_request_and_wait : 'q t -> 'a Request.t -> 'a tzresult Lwt.t
val push_request : 'q t -> 'a Request.t -> unit Lwt.t
val pending_requests : 'a t -> (Time.System.t * Request.view) list
val pending_requests_length : 'a t -> int
end
module type BOUNDED_QUEUE = sig
type t
val try_push_request_now : t -> 'a Request.t -> bool
end
module Dropbox : sig
include BOX with type t := dropbox t
end
module Queue : sig
include QUEUE with type 'a t := 'a queue t
include BOUNDED_QUEUE with type t := bounded queue t
(** Adds a message to the queue immediately. *)
val push_request_now : infinite queue t -> 'a Request.t -> unit
end
(** Detects cancellation from within the request handler to stop
asynchronous operations. *)
val protect :
_ t ->
?on_error:(error list -> 'b tzresult Lwt.t) ->
(unit -> 'b tzresult Lwt.t) ->
'b tzresult Lwt.t
(** Exports the canceler to allow cancellation of other tasks when this
worker is shutdowned or when it dies. *)
val canceler : _ t -> Lwt_canceler.t
(** Triggers a worker termination. *)
val trigger_shutdown : _ t -> unit
(** Recod an event in the backlog. *)
val record_event : _ t -> Event.t -> unit
(** Record an event and make sure it is logged. *)
val log_event : _ t -> Event.t -> unit Lwt.t
(** Access the internal state, once initialized. *)
val state : _ t -> Types.state
(** Access the event backlog. *)
val last_events : _ t -> (Internal_event.level * Event.t list) list
(** Introspect the message queue, gives the times requests were pushed. *)
val pending_requests : _ queue t -> (Time.System.t * Request.view) list
(** Get the running status of a worker. *)
val status : _ t -> Worker_types.worker_status
(** Get the request being treated by a worker.
Gives the time the request was pushed, and the time its
treatment started. *)
val current_request :
_ t -> (Time.System.t * Time.System.t * Request.view) option
val information : _ t -> Worker_types.worker_information
(** Introspect the state of a worker. *)
val view : _ t -> Types.view
(** Lists the running workers in this group. *)
val list : 'a table -> (Name.t * 'a t) list
(** [find_opt table n] is [Some worker] if the [worker] is in the [table] and
has name [n]. *)
val find_opt : 'a table -> Name.t -> 'a t option
end
module Make
(Name : NAME)
(Event : EVENT)
(Request : REQUEST)
(Types : TYPES)
(Logger : LOGGER with module Event = Event and module Request = Request) =
struct
module Name = Name
module Event = Event
module Request = Request
module Types = Types
module Logger = Logger
let base_name = String.concat "-" Name.base
type message = Message : 'a Request.t * 'a tzresult Lwt.u option -> message
type 'a queue
and bounded
and infinite
type dropbox
type _ buffer_kind =
| Queue : infinite queue buffer_kind
| Bounded : {size : int} -> bounded queue buffer_kind
| Dropbox : {
merge :
dropbox t -> any_request -> any_request option -> any_request option;
}
-> dropbox buffer_kind
and any_request = Any_request : _ Request.t -> any_request
and _ buffer =
| Queue_buffer :
(Time.System.t * message) Lwt_pipe.t
-> infinite queue buffer
| Bounded_buffer :
(Time.System.t * message) Lwt_pipe.t
-> bounded queue buffer
| Dropbox_buffer :
(Time.System.t * message) Lwt_dropbox.t
-> dropbox buffer
and 'kind t = {
limits : Worker_types.limits;
timeout : Time.System.Span.t option;
parameters : Types.parameters;
mutable (* only for init *) worker : unit Lwt.t;
mutable (* only for init *) state : Types.state option;
buffer : 'kind buffer;
event_log : (Internal_event.level * Event.t Ring.t) list;
canceler : Lwt_canceler.t;
name : Name.t;
id : int;
mutable status : Worker_types.worker_status;
mutable current_request :
(Time.System.t * Time.System.t * Request.view) option;
logEvent : (module Internal_event.EVENT with type t = Logger.t);
table : 'kind table;
}
and 'kind table = {
buffer_kind : 'kind buffer_kind;
mutable last_id : int;
instances : (Name.t, 'kind t) Hashtbl.t;
}
let queue_item ?u r = (Systime_os.now (), Message (r, u))
let drop_request w merge message_box request =
try
match
match Lwt_dropbox.peek message_box with
| None ->
merge w (Any_request request) None
| Some (_, Message (old, _)) ->
Lwt.ignore_result (Lwt_dropbox.take message_box) ;
merge w (Any_request request) (Some (Any_request old))
with
| None ->
()
| Some (Any_request neu) ->
Lwt_dropbox.put message_box (Systime_os.now (), Message (neu, None))
with Lwt_dropbox.Closed -> ()
let push_request_and_wait w message_queue request =
let (t, u) = Lwt.wait () in
Lwt.catch
(fun () ->
Lwt_pipe.push message_queue (queue_item ~u request) >>= fun () -> t)
(function
| Lwt_pipe.Closed ->
let name = Format.asprintf "%a" Name.pp w.name in
fail (Closed {base = base_name; name})
| exn ->
fail (Exn exn))
let drop_request_and_wait w message_box request =
let (t, u) = Lwt.wait () in
Lwt.catch
(fun () ->
Lwt_dropbox.put message_box (queue_item ~u request) ;
t)
(function
| Lwt_pipe.Closed ->
let name = Format.asprintf "%a" Name.pp w.name in
fail (Closed {base = base_name; name})
| exn ->
fail (Exn exn))
module type BOX = sig
type t
val put_request : t -> 'a Request.t -> unit
val put_request_and_wait : t -> 'a Request.t -> 'a tzresult Lwt.t
end
module type QUEUE = sig
type 'a t
val push_request_and_wait : 'q t -> 'a Request.t -> 'a tzresult Lwt.t
val push_request : 'q t -> 'a Request.t -> unit Lwt.t
val pending_requests : 'a t -> (Time.System.t * Request.view) list
val pending_requests_length : 'a t -> int
end
module type BOUNDED_QUEUE = sig
type t
val try_push_request_now : t -> 'a Request.t -> bool
end
module Dropbox = struct
let put_request (w : dropbox t) request =
let (Dropbox {merge}) = w.table.buffer_kind in
let (Dropbox_buffer message_box) = w.buffer in
drop_request w merge message_box request
let put_request_and_wait (w : dropbox t) request =
let (Dropbox_buffer message_box) = w.buffer in
drop_request_and_wait w message_box request
end
module Queue = struct
let push_request (type a) (w : a queue t) request =
match w.buffer with
| Queue_buffer message_queue ->
Lwt_pipe.push message_queue (queue_item request)
| Bounded_buffer message_queue ->
Lwt_pipe.push message_queue (queue_item request)
let push_request_now (w : infinite queue t) request =
let (Queue_buffer message_queue) = w.buffer in
Lwt_pipe.push_now_exn message_queue (queue_item request)
let try_push_request_now (w : bounded queue t) request =
let (Bounded_buffer message_queue) = w.buffer in
Lwt_pipe.push_now message_queue (queue_item request)
let push_request_and_wait (type a) (w : a queue t) request =
let message_queue =
match w.buffer with
| Queue_buffer message_queue ->
message_queue
| Bounded_buffer message_queue ->
message_queue
in
push_request_and_wait w message_queue request
let pending_requests (type a) (w : a queue t) =
let message_queue =
match w.buffer with
| Queue_buffer message_queue ->
message_queue
| Bounded_buffer message_queue ->
message_queue
in
List.map
(function (t, Message (req, _)) -> (t, Request.view req))
(Lwt_pipe.peek_all message_queue)
let pending_requests_length (type a) (w : a queue t) =
let pipe_length (type a) (q : a buffer) =
match q with
| Queue_buffer queue ->
Lwt_pipe.length queue
| Bounded_buffer queue ->
Lwt_pipe.length queue
| Dropbox_buffer _ ->
1
in
pipe_length w.buffer
end
let close (type a) (w : a t) =
let wakeup = function
| (_, Message (_, Some u)) ->
let name = Format.asprintf "%a" Name.pp w.name in
Lwt.wakeup_later u (error (Closed {base = base_name; name}))
| (_, Message (_, None)) ->
()
in
let close_queue message_queue =
let messages = Lwt_pipe.pop_all_now message_queue in
List.iter wakeup messages ;
Lwt_pipe.close message_queue
in
match w.buffer with
| Queue_buffer message_queue ->
close_queue message_queue
| Bounded_buffer message_queue ->
close_queue message_queue
| Dropbox_buffer message_box ->
Option.iter ~f:wakeup (Lwt_dropbox.peek message_box) ;
Lwt_dropbox.close message_box
let pop (type a) (w : a t) =
let pop_queue message_queue =
match w.timeout with
| None ->
Lwt_pipe.pop message_queue >>= fun m -> return_some m
| Some timeout ->
Lwt_pipe.pop_with_timeout (Systime_os.sleep timeout) message_queue
>>= fun m -> return m
in
match w.buffer with
| Queue_buffer message_queue ->
pop_queue message_queue
| Bounded_buffer message_queue ->
pop_queue message_queue
| Dropbox_buffer message_box -> (
match w.timeout with
| None ->
Lwt_dropbox.take message_box >>= fun m -> return_some m
| Some timeout ->
Lwt_dropbox.take_with_timeout (Systime_os.sleep timeout) message_box
>>= fun m -> return m )
let trigger_shutdown w = Lwt.ignore_result (Lwt_canceler.cancel w.canceler)
let canceler {canceler; _} = canceler
let lwt_emit w (status : Logger.status) =
let (module LogEvent) = w.logEvent in
let time = Systime_os.now () in
LogEvent.emit
~section:(Internal_event.Section.make_sanitized Name.base)
(fun () -> Time.System.stamp ~time status)
>>= function
| Ok () ->
Lwt.return_unit
| Error el ->
Format.kasprintf
Lwt.fail_with
"Worker_event.emit: %a"
pp_print_error
el
let log_event w evt =
lwt_emit w (Logger.WorkerEvent evt)
>>= fun () ->
if Event.level evt >= w.limits.backlog_level then
Ring.add (List.assoc (Event.level evt) w.event_log) evt ;
Lwt.return_unit
let record_event w evt = Lwt.ignore_result (log_event w evt)
module type HANDLERS = sig
type self
val on_launch :
self -> Name.t -> Types.parameters -> Types.state tzresult Lwt.t
val on_request : self -> 'a Request.t -> 'a tzresult Lwt.t
val on_no_request : self -> unit tzresult Lwt.t
val on_close : self -> unit Lwt.t
val on_error :
self ->
Request.view ->
Worker_types.request_status ->
error list ->
unit tzresult Lwt.t
val on_completion :
self -> 'a Request.t -> 'a -> Worker_types.request_status -> unit Lwt.t
end
let create_table buffer_kind =
{buffer_kind; last_id = 0; instances = Hashtbl.create 10}
let worker_loop (type kind) handlers (w : kind t) =
let (module Handlers : HANDLERS with type self = kind t) = handlers in
let do_close errs =
let t0 =
match w.status with
| Running t0 ->
t0
| Launching _ | Closing _ | Closed _ ->
assert false
in
w.status <- Closing (t0, Systime_os.now ()) ;
close w ;
Lwt_canceler.cancel w.canceler
>>= fun () ->
w.status <- Closed (t0, Systime_os.now (), errs) ;
Hashtbl.remove w.table.instances w.name ;
Handlers.on_close w
>>= fun () ->
w.state <- None ;
Lwt.ignore_result
( List.iter (fun (_, ring) -> Ring.clear ring) w.event_log ;
Lwt.return_unit ) ;
Lwt.return_unit
in
let rec loop () =
protect ~canceler:w.canceler (fun () -> pop w)
>>=? (function
| None ->
Handlers.on_no_request w
| Some (pushed, Message (request, u)) -> (
let current_request = Request.view request in
let treated = Systime_os.now () in
w.current_request <- Some (pushed, treated, current_request) ;
match u with
| None ->
Handlers.on_request w request
>>=? fun res ->
let completed = Systime_os.now () in
w.current_request <- None ;
let status = Worker_types.{pushed; treated; completed} in
Handlers.on_completion w request res status
>>= fun () ->
lwt_emit w (Request (current_request, status, None))
>>= fun () -> return_unit
| Some u ->
Handlers.on_request w request
>>= fun res ->
Lwt.wakeup_later u res ;
Lwt.return res
>>=? fun res ->
let completed = Systime_os.now () in
let status = Worker_types.{pushed; treated; completed} in
w.current_request <- None ;
Handlers.on_completion w request res status
>>= fun () ->
lwt_emit w (Request (current_request, status, None))
>>= fun () -> return_unit ))
>>= function
| Ok () ->
loop ()
| Error (Canceled :: _)
| Error (Exn Lwt.Canceled :: _)
| Error (Exn Lwt_pipe.Closed :: _)
| Error (Exn Lwt_dropbox.Closed :: _) ->
lwt_emit w Terminated >>= fun () -> do_close None
| Error errs -> (
( match w.current_request with
| Some (pushed, treated, request) ->
let completed = Systime_os.now () in
w.current_request <- None ;
Handlers.on_error
w
request
Worker_types.{pushed; treated; completed}
errs
| None ->
assert false )
>>= function
| Ok () ->
loop ()
| Error (Timeout :: _ as errs) ->
lwt_emit w Terminated >>= fun () -> do_close (Some errs)
| Error errs ->
lwt_emit w (Crashed errs) >>= fun () -> do_close (Some errs) )
in
loop ()
let launch :
type kind.
kind table ->
?timeout:Time.System.Span.t ->
Worker_types.limits ->
Name.t ->
Types.parameters ->
(module HANDLERS with type self = kind t) ->
kind t tzresult Lwt.t =
fun table ?timeout limits name parameters (module Handlers) ->
let name_s = Format.asprintf "%a" Name.pp name in
let full_name =
if name_s = "" then base_name
else Format.asprintf "%s_%s" base_name name_s
in
if Hashtbl.mem table.instances name then
invalid_arg
(Format.asprintf "Worker.launch: duplicate worker %s" full_name)
else
let id =
table.last_id <- table.last_id + 1 ;
table.last_id
in
let id_name =
if name_s = "" then base_name else Format.asprintf "%s_%d" base_name id
in
let canceler = Lwt_canceler.create () in
let buffer : kind buffer =
match table.buffer_kind with
| Queue ->
Queue_buffer (Lwt_pipe.create ())
| Bounded {size} ->
Bounded_buffer (Lwt_pipe.create ~size:(size, fun _ -> 1) ())
| Dropbox _ ->
Dropbox_buffer (Lwt_dropbox.create ())
in
let event_log =
let levels =
Internal_event.[Debug; Info; Notice; Warning; Error; Fatal]
in
List.map (fun l -> (l, Ring.create limits.backlog_size)) levels
in
let module Definition = Logger.MakeDefinition (struct
let worker_name = id_name
end) in
let module LogEvent = Internal_event.Make (Definition) in
let w =
{
limits;
parameters;
name;
canceler;
table;
buffer;
state = None;
id;
worker = Lwt.return_unit;
event_log;
timeout;
current_request = None;
logEvent = (module LogEvent);
status = Launching (Systime_os.now ());
}
in
Hashtbl.add table.instances name w ;
( if id_name = base_name then lwt_emit w (Started None)
else lwt_emit w (Started (Some name_s)) )
>>= fun () ->
Handlers.on_launch w name parameters
>>=? fun state ->
w.status <- Running (Systime_os.now ()) ;
w.state <- Some state ;
w.worker <-
Lwt_utils.worker
full_name
~on_event:Internal_event.Lwt_worker_event.on_event
~run:(fun () -> worker_loop (module Handlers) w)
~cancel:(fun () -> Lwt_canceler.cancel w.canceler) ;
return w
let shutdown w =
lwt_emit w Triggering_shutdown
>>= fun () -> Lwt_canceler.cancel w.canceler >>= fun () -> w.worker
let state w =
match (w.state, w.status) with
| (None, Launching _) ->
invalid_arg
(Format.asprintf
"Worker.state (%s[%a]): state called before worker was initialized"
base_name
Name.pp
w.name)
| (None, (Closing _ | Closed _)) ->
invalid_arg
(Format.asprintf
"Worker.state (%s[%a]): state called after worker was terminated"
base_name
Name.pp
w.name)
| (None, _) ->
assert false
| (Some state, _) ->
state
let pending_requests q = Queue.pending_requests q
let last_events w =
List.map (fun (level, ring) -> (level, Ring.elements ring)) w.event_log
let status {status; _} = status
let current_request {current_request; _} = current_request
let information (type a) (w : a t) =
{
Worker_types.instances_number = Hashtbl.length w.table.instances;
wstatus = w.status;
queue_length =
( match w.buffer with
| Queue_buffer pipe ->
Lwt_pipe.length pipe
| Bounded_buffer pipe ->
Lwt_pipe.length pipe
| Dropbox_buffer _ ->
1 );
}
let view w = Types.view (state w) w.parameters
let list {instances; _} =
Hashtbl.fold (fun n w acc -> (n, w) :: acc) instances []
let find_opt {instances; _} = Hashtbl.find_opt instances
(* TODO? add a list of cancelers for nested protection ? *)
let protect {canceler; _} ?on_error f = protect ?on_error ~canceler f
end
src/lib_shell/worker.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module NAME.
Record signature {t : Type} := {
base : list string;
t := t;
encoding : Tezos_base__TzPervasives.Data_encoding.t t;
pp : Stdlib.Format.formatter -> t -> unit;
}.
Arguments signature : clear implicits.
End NAME.
Module EVENT.
Record signature {t : Type} := {
t := t;
level : t -> Tezos_base__TzPervasives.Internal_event.level;
encoding : Tezos_base__TzPervasives.Data_encoding.t t;
pp : Stdlib.Format.formatter -> t -> unit;
}.
Arguments signature : clear implicits.
End EVENT.
Module REQUEST.
Record signature {t view : Type} := {
polymorphic_abstract_type;
view := view;
view : forall {a : Type}, (t a) -> view;
encoding : Tezos_base__TzPervasives.Data_encoding.t view;
pp : Stdlib.Format.formatter -> view -> unit;
}.
Arguments signature : clear implicits.
End REQUEST.
Module TYPES.
Record signature {state parameters view : Type} := {
state := state;
parameters := parameters;
view := view;
view : state -> parameters -> view;
encoding : Tezos_base__TzPervasives.Data_encoding.t view;
pp : Stdlib.Format.formatter -> view -> unit;
}.
Arguments signature : clear implicits.
End TYPES.
Module LOGGER.
Record signature {Event_t Request_t Request_view status : Type} := {
Event : EVENT.signature Event_t;
Request : REQUEST.signature Request_t Request_view;
status := status;
t := Tezos_base__TzPervasives.Time.System.stamped status;
MakeDefinition : functor;
}.
Arguments signature : clear implicits.
End LOGGER.
Record worker_name := {
base : string;
name : string }.
(* ❌ Structure item `typext` not handled. *)
type_extension
Module T.
Record signature {Name_t Event_t Request_t Request_view Types_state
Types_parameters Types_view t table queue bounded infinite dropbox
buffer_kind any_request : Type} := {
Name : NAME.signature Name_t;
Event : EVENT.signature Event_t;
Request : REQUEST.signature Request_t Request_view;
Types : TYPES.signature Types_state Types_parameters Types_view;
polymorphic_abstract_type;
polymorphic_abstract_type;
mutual_type;
dropbox := dropbox;
mutual_type;
create_table : forall {kind : Type}, (buffer_kind kind) -> table kind;
module_type;
launch : forall {kind : Type}, (table kind) ->
(option Tezos_base__TzPervasives.Time.System.Span.t) ->
Tezos_shell_services.Worker_types.limits ->
Name.(NAME.t) ->
Types.(TYPES.parameters) ->
{_ : unit & HANDLERS.signature (t kind)} ->
Lwt.t (Tezos_base__TzPervasives.tzresult (t kind));
shutdown : forall {_ : Type}, (t _) -> Lwt.t unit;
module_type;
module_type;
module_type;
Dropbox : signature;
Queue : signature;
protect : forall {_ b : Type}, (t _) ->
(option
((list Tezos_base__TzPervasives.error) ->
Lwt.t (Tezos_base__TzPervasives.tzresult b))) ->
(unit -> Lwt.t (Tezos_base__TzPervasives.tzresult b)) ->
Lwt.t (Tezos_base__TzPervasives.tzresult b);
canceler : forall {_ : Type}, (t _) ->
Tezos_base__TzPervasives.Lwt_canceler.t;
trigger_shutdown : forall {_ : Type}, (t _) -> unit;
record_event : forall {_ : Type}, (t _) -> Event.(EVENT.t) -> unit;
log_event : forall {_ : Type}, (t _) -> Event.(EVENT.t) -> Lwt.t unit;
state : forall {_ : Type}, (t _) -> Types.(TYPES.state);
last_events : forall {_ : Type}, (t _) ->
list
(Tezos_base__TzPervasives.Internal_event.level * (list Event.(EVENT.t)));
pending_requests : forall {_ : Type}, (t (queue _)) ->
list (Tezos_base__TzPervasives.Time.System.t * Request.(REQUEST.view));
status : forall {_ : Type}, (t _) ->
Tezos_shell_services.Worker_types.worker_status;
current_request : forall {_ : Type}, (t _) ->
option
(Tezos_base__TzPervasives.Time.System.t *
Tezos_base__TzPervasives.Time.System.t * Request.(REQUEST.view));
information : forall {_ : Type}, (t _) ->
Tezos_shell_services.Worker_types.worker_information;
view : forall {_ : Type}, (t _) -> Types.(TYPES.view);
list : forall {a : Type}, (table a) -> list (Name.(NAME.t) * (t a));
find_opt : forall {a : Type}, (table a) -> Name.(NAME.t) -> option (t a);
}.
Arguments signature : clear implicits.
End T.
(* ❌ Functors are not handled. *)
functor
src/lib_shell/worker_directory.ml 27 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let build_rpc_directory state =
let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
let register0 s f =
dir := RPC_directory.register !dir s (fun () p q -> f p q)
in
let register1 s f =
dir := RPC_directory.register !dir s (fun ((), a) p q -> f a p q)
in
let register2 s f =
dir := RPC_directory.register !dir s (fun (((), a), b) p q -> f a b p q)
in
(* Workers : Prevalidators *)
register0 Worker_services.Prevalidators.S.list (fun () () ->
let workers = Prevalidator.running_workers () in
let statuses =
List.map
(fun (chain_id, _, t) ->
( chain_id,
Prevalidator.status t,
Prevalidator.information t,
Prevalidator.pipeline_length t ))
workers
in
return statuses) ;
register1 Worker_services.Prevalidators.S.state (fun chain () () ->
Chain_directory.get_chain_id state chain
>>= fun chain_id ->
let workers = Prevalidator.running_workers () in
let (_, _, t) =
(* NOTE: it is technically possible to use the Prevalidator interface to
* register multiple Prevalidator for a single chain (using distinct
* protocols). However, this is never done. *)
List.find (fun (c, _, _) -> Chain_id.equal c chain_id) workers
in
let status = Prevalidator.status t in
let pending_requests = Prevalidator.pending_requests t in
let backlog = Prevalidator.last_events t in
let current_request = Prevalidator.current_request t in
return {Worker_types.status; pending_requests; backlog; current_request}) ;
(* Workers : Block_validator *)
register0 Worker_services.Block_validator.S.state (fun () () ->
let w = Block_validator.running_worker () in
return
{
Worker_types.status = Block_validator.status w;
pending_requests = Block_validator.pending_requests w;
backlog = Block_validator.last_events w;
current_request = Block_validator.current_request w;
}) ;
(* Workers : Peer validators *)
register1 Worker_services.Peer_validators.S.list (fun chain () () ->
Chain_directory.get_chain_id state chain
>>= fun chain_id ->
return
(List.filter_map
(fun ((id, peer_id), w) ->
if Chain_id.equal id chain_id then
Some
( peer_id,
Peer_validator.status w,
Peer_validator.information w,
Peer_validator.pipeline_length w )
else None)
(Peer_validator.running_workers ()))) ;
register2 Worker_services.Peer_validators.S.state (fun chain peer_id () () ->
Chain_directory.get_chain_id state chain
>>= fun chain_id ->
let w =
List.assoc (chain_id, peer_id) (Peer_validator.running_workers ())
in
return
{
Worker_types.status = Peer_validator.status w;
pending_requests = [];
backlog = Peer_validator.last_events w;
current_request = Peer_validator.current_request w;
}) ;
(* Workers : Net validators *)
register0 Worker_services.Chain_validators.S.list (fun () () ->
return
(List.map
(fun (id, w) ->
( id,
Chain_validator.status w,
Chain_validator.information w,
Chain_validator.pending_requests_length w ))
(Chain_validator.running_workers ()))) ;
register1 Worker_services.Chain_validators.S.state (fun chain () () ->
Chain_directory.get_chain_id state chain
>>= fun chain_id ->
let w = List.assoc chain_id (Chain_validator.running_workers ()) in
return
{
Worker_types.status = Chain_validator.status w;
pending_requests = Chain_validator.pending_requests w;
backlog = Chain_validator.last_events w;
current_request = Chain_validator.current_request w;
}) ;
(* DistributedDB *)
register1 Worker_services.Chain_validators.S.ddb_state (fun chain () () ->
Chain_directory.get_chain_id state chain
>>= fun chain_id ->
let w = List.assoc chain_id (Chain_validator.running_workers ()) in
return (Chain_validator.ddb_information w)) ;
!dir
src/lib_shell/worker_directory.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition build_rpc_directory (state : Tezos_shell.State.t)
: Tezos_base__TzPervasives.RPC_directory.t unit :=
let dir := Stdlib.ref RPC_directory.empty in
let register0 {A B C : Type}
(s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
A -> B -> Lwt.t (Tezos_error_monad.Error_monad.tzresult C)) : unit :=
Stdlib.op_coloneq dir
(RPC_directory.register (Stdlib.op_exclamation dir) s
(fun function_parameter =>
let 'tt := function_parameter in
fun p => fun q => f p q)) in
let register1 {A B C D : Type}
(s : Tezos_rpc.RPC_service.t variant unit (unit * A) B C D) (f :
A -> B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
Stdlib.op_coloneq dir
(RPC_directory.register (Stdlib.op_exclamation dir) s
(fun function_parameter =>
let '(tt, a) := function_parameter in
fun p => fun q => f a p q)) in
let register2 {A B C D E : Type}
(s : Tezos_rpc.RPC_service.t variant unit ((unit * A) * B) C D E) (f :
A -> B -> C -> D -> Lwt.t (Tezos_error_monad.Error_monad.tzresult E))
: unit :=
Stdlib.op_coloneq dir
(RPC_directory.register (Stdlib.op_exclamation dir) s
(fun function_parameter =>
let '((tt, a), b) := function_parameter in
fun p => fun q => f a b p q)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 Worker_services.Prevalidators.S.list
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
let workers := Prevalidator.running_workers tt in
let statuses :=
List.map
(fun function_parameter =>
let '(chain_id, _, t) := function_parameter in
(chain_id, (Prevalidator.status t),
(Prevalidator.information t), (Prevalidator.pipeline_length t)))
workers in
_return statuses) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 Worker_services.Prevalidators.S.state
(fun chain =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Chain_directory.get_chain_id state chain)
(fun chain_id =>
let workers := Prevalidator.running_workers tt in
let '(_, _, t) :=
List.find
(fun function_parameter =>
let '(c, _, _) := function_parameter in
Chain_id.equal c chain_id) workers in
let status := Prevalidator.status t in
let pending_requests := Prevalidator.pending_requests t in
let backlog := Prevalidator.last_events t in
let current_request := Prevalidator.current_request t in
_return
{| Worker_types.status := status;
Worker_types.pending_requests := pending_requests;
Worker_types.backlog := backlog;
Worker_types.current_request := current_request |})) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 Worker_services.Block_validator.S.state
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
let w := Block_validator.running_worker tt in
_return
{| Worker_types.status := Block_validator.status w;
Worker_types.pending_requests :=
Block_validator.pending_requests w;
Worker_types.backlog := Block_validator.last_events w;
Worker_types.current_request := Block_validator.current_request w
|}) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 Worker_services.Peer_validators.S.list
(fun chain =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Chain_directory.get_chain_id state chain)
(fun chain_id =>
_return
(List.filter_map
(fun function_parameter =>
let '((id, peer_id), w) := function_parameter in
if Chain_id.equal id chain_id then
Some
(peer_id, (Peer_validator.status w),
(Peer_validator.information w),
(Peer_validator.pipeline_length w))
else
None) (Peer_validator.running_workers tt)))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register2 Worker_services.Peer_validators.S.state
(fun chain =>
fun peer_id =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Chain_directory.get_chain_id state chain)
(fun chain_id =>
let w :=
List.assoc (chain_id, peer_id)
(Peer_validator.running_workers tt) in
_return
{| Worker_types.status := Peer_validator.status w;
Worker_types.pending_requests := [];
Worker_types.backlog := Peer_validator.last_events w;
Worker_types.current_request :=
Peer_validator.current_request w |})) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 Worker_services.Chain_validators.S.list
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
_return
(List.map
(fun function_parameter =>
let '(id, w) := function_parameter in
(id, (Chain_validator.status w),
(Chain_validator.information w),
(Chain_validator.pending_requests_length w)))
(Chain_validator.running_workers tt))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 Worker_services.Chain_validators.S.state
(fun chain =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Chain_directory.get_chain_id state chain)
(fun chain_id =>
let w :=
List.assoc chain_id (Chain_validator.running_workers tt) in
_return
{| Worker_types.status := Chain_validator.status w;
Worker_types.pending_requests :=
Chain_validator.pending_requests w;
Worker_types.backlog := Chain_validator.last_events w;
Worker_types.current_request :=
Chain_validator.current_request w |})) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 Worker_services.Chain_validators.S.ddb_state
(fun chain =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Chain_directory.get_chain_id state chain)
(fun chain_id =>
let w :=
List.assoc chain_id (Chain_validator.running_workers tt) in
_return (Chain_validator.ddb_information w))) in
Stdlib.op_exclamation dir.
src/lib_shell/worker_logger.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Worker
module Make (Event : EVENT) (Request : REQUEST) = struct
module Event = Event
module Request = Request
type status =
| WorkerEvent of Event.t
| Request of
(Request.view * Worker_types.request_status * error list option)
| Terminated
| Timeout
| Crashed of error list
| Started of string option
| Triggering_shutdown
| Duplicate of string
type t = status Time.System.stamped
let status_encoding =
let open Data_encoding in
Time.System.stamped_encoding
@@ union
[ case
(Tag 0)
~title:"Event"
Event.encoding
(function WorkerEvent e -> Some e | _ -> None)
(fun e -> WorkerEvent e);
case
(Tag 1)
~title:"Request"
(obj3
(req "request_view" (dynamic_size Request.encoding))
(req "request_status" Worker_types.request_status_encoding)
(req "errors" (option (list error_encoding))))
(function Request (v, s, e) -> Some (v, s, e) | _ -> None)
(fun (v, s, e) -> Request (v, s, e));
case
(Tag 2)
~title:"Terminated"
Data_encoding.empty
(function Terminated -> Some () | _ -> None)
(fun () -> Terminated);
case
(Tag 3)
~title:"Timeout"
Data_encoding.empty
(function Timeout -> Some () | _ -> None)
(fun () -> Timeout);
case
(Tag 4)
~title:"Crashed"
(list error_encoding)
(function Crashed errs -> Some errs | _ -> None)
(fun errs -> Crashed errs);
case
(Tag 5)
~title:"Started"
(option string)
(function Started n -> Some n | _ -> None)
(fun n -> Started n);
case
(Tag 6)
~title:"Triggering_shutdown"
Data_encoding.empty
(function Triggering_shutdown -> Some () | _ -> None)
(fun () -> Triggering_shutdown);
case
(Tag 7)
~title:"Duplicate"
string
(function Duplicate n -> Some n | _ -> None)
(fun n -> Duplicate n) ]
let pp base_name ppf = function
| WorkerEvent evt ->
Format.fprintf ppf "%a" Event.pp evt
| Request (view, {pushed; treated; completed}, None) ->
Format.fprintf
ppf
"@[<v 0>%a@, %a@]"
Request.pp
view
Worker_types.pp_status
{pushed; treated; completed}
| Request (view, {pushed; treated; completed}, Some errors) ->
Format.fprintf
ppf
"@[<v 0>%a@, %a, %a@]"
Request.pp
view
Worker_types.pp_status
{pushed; treated; completed}
(Format.pp_print_list Error_monad.pp)
errors
| Terminated ->
Format.fprintf ppf "@[Worker terminated [%s] @]" base_name
| Timeout ->
Format.fprintf ppf "@[Worker terminated with timeout [%s] @]" base_name
| Crashed errs ->
Format.fprintf
ppf
"@[<v 0>Worker crashed [%s]:@,%a@]"
base_name
(Format.pp_print_list Error_monad.pp)
errs
| Started None ->
Format.fprintf ppf "Worker started"
| Started (Some n) ->
Format.fprintf ppf "Worker started for %s" n
| Triggering_shutdown ->
Format.fprintf ppf "Triggering shutdown"
| Duplicate name ->
let full_name =
if name = "" then base_name
else Format.asprintf "%s_%s" base_name name
in
Format.fprintf ppf "Worker.launch: duplicate worker %s" full_name
module MakeDefinition (Static : sig
val worker_name : string
end) : Internal_event.EVENT_DEFINITION with type t = t = struct
let name = Static.worker_name
type nonrec t = t
let encoding =
let open Data_encoding in
let v0_encoding = status_encoding in
With_version.(encoding ~name (first_version v0_encoding))
let pp ppf (status : t) =
Format.fprintf ppf "%a" (pp Static.worker_name) status.data
let doc = "Worker status."
let level (status : t) =
match status.data with
| WorkerEvent evt ->
Event.level evt
| Request _ ->
Internal_event.Debug
| Terminated | Timeout | Started _ ->
Internal_event.Notice
| Crashed _ ->
Internal_event.Error
| Triggering_shutdown ->
Internal_event.Debug
| Duplicate _ ->
Internal_event.Error
end
end
src/lib_shell/worker_logger.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. Import Worker. (* ❌ Functors are not handled. *) functor
src/lib_shell_services/block_services.ml 64 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Data_encoding
type chain = [`Main | `Test | `Hash of Chain_id.t]
let parse_chain s =
try
match s with
| "main" ->
Ok `Main
| "test" ->
Ok `Test
| h ->
Ok (`Hash (Chain_id.of_b58check_exn h))
with _ -> Error "Cannot parse chain identifier."
let chain_to_string = function
| `Main ->
"main"
| `Test ->
"test"
| `Hash h ->
Chain_id.to_b58check h
let chain_arg =
let name = "chain_id" in
let descr =
"A chain identifier. This is either a chain hash in Base58Check notation \
or a one the predefined aliases: 'main', 'test'."
in
let construct = chain_to_string in
let destruct = parse_chain in
RPC_arg.make ~name ~descr ~construct ~destruct ()
type block =
[ `Genesis
| `Head of int
| `Alias of [`Caboose | `Checkpoint | `Save_point] * int
| `Hash of Block_hash.t * int
| `Level of Int32.t ]
let parse_block s =
let delims = ['~'; '-'; '+'] in
let count_delims s =
List.map
(fun d ->
(String.fold_left (fun i c -> if c = d then i + 1 else i) 0 s, d))
delims
in
let split_on_delim counts =
match List.fold_left (fun i (v, _) -> i + v) 0 counts with
| 0 ->
([s], ' ')
| 1 ->
let delim = List.assoc 1 counts in
(String.split delim s, delim)
| _ ->
raise Exit
in
try
match split_on_delim (count_delims s) with
| (["genesis"], _) ->
Ok `Genesis
| (["genesis"; n], '+') ->
Ok (`Level (Int32.of_string n))
| (["head"], _) ->
Ok (`Head 0)
| (["head"; n], '~') | (["head"; n], '-') ->
Ok (`Head (int_of_string n))
| (["checkpoint"], _) ->
Ok (`Alias (`Checkpoint, 0))
| (["checkpoint"; n], '~') | (["checkpoint"; n], '-') ->
Ok (`Alias (`Checkpoint, int_of_string n))
| (["checkpoint"; n], '+') ->
Ok (`Alias (`Checkpoint, -int_of_string n))
| (["save_point"], _) ->
Ok (`Alias (`Save_point, 0))
| (["save_point"; n], '~') | (["save_point"; n], '-') ->
Ok (`Alias (`Save_point, int_of_string n))
| (["save_point"; n], '+') ->
Ok (`Alias (`Save_point, -int_of_string n))
| (["caboose"], _) ->
Ok (`Alias (`Caboose, 0))
| (["caboose"; n], '~') | (["caboose"; n], '-') ->
Ok (`Alias (`Caboose, int_of_string n))
| (["caboose"; n], '+') ->
Ok (`Alias (`Caboose, -int_of_string n))
| ([hol], _) -> (
match Block_hash.of_b58check_opt hol with
| Some h ->
Ok (`Hash (h, 0))
| None ->
let l = Int32.of_string s in
if Compare.Int32.(l < 0l) then raise Exit
else if Compare.Int32.(l = 0l) then Ok `Genesis
else Ok (`Level (Int32.of_string s)) )
| ([h; n], '~') | ([h; n], '-') ->
Ok (`Hash (Block_hash.of_b58check_exn h, int_of_string n))
| ([h; n], '+') ->
Ok (`Hash (Block_hash.of_b58check_exn h, -int_of_string n))
| _ ->
raise Exit
with _ -> Error "Cannot parse block identifier."
let alias_to_string = function
| `Checkpoint ->
"checkpoint"
| `Save_point ->
"save_point"
| `Caboose ->
"caboose"
let to_string = function
| `Genesis ->
"genesis"
| `Alias (a, 0) ->
alias_to_string a
| `Alias (a, n) when n < 0 ->
Printf.sprintf "%s+%d" (alias_to_string a) (-n)
| `Alias (a, n) ->
Printf.sprintf "%s~%d" (alias_to_string a) n
| `Head 0 ->
"head"
| `Head n when n < 0 ->
Printf.sprintf "head+%d" (-n)
| `Head n ->
Printf.sprintf "head~%d" n
| `Hash (h, 0) ->
Block_hash.to_b58check h
| `Hash (h, n) when n < 0 ->
Printf.sprintf "%s+%d" (Block_hash.to_b58check h) (-n)
| `Hash (h, n) ->
Printf.sprintf "%s~%d" (Block_hash.to_b58check h) n
| `Level i ->
Printf.sprintf "%d" (Int32.to_int i)
let blocks_arg =
let name = "block_id" in
let descr =
"A block identifier. This is either a block hash in Base58Check notation, \
one the predefined aliases: 'genesis', 'head' or a block level (index in \
the chain). One might also use 'head~N' or '<hash>~N' where N is an \
integer to denote the Nth predecessor of the designated block.Also, \
'<hash>+N' denotes the Nth successor of a block."
in
let construct = to_string in
let destruct = parse_block in
RPC_arg.make ~name ~descr ~construct ~destruct ()
type chain_prefix = unit * chain
type prefix = chain_prefix * block
let chain_path = RPC_path.(root / "chains" /: chain_arg)
let mempool_path p = RPC_path.(p / "mempool")
let live_blocks_path p = RPC_path.(p / "live_blocks")
let dir_path : (chain_prefix, chain_prefix) RPC_path.t =
RPC_path.(open_root / "blocks")
let path = RPC_path.(dir_path /: blocks_arg)
type operation_list_quota = {max_size : int; max_op : int option}
let operation_list_quota_encoding =
conv
(fun {max_size; max_op} -> (max_size, max_op))
(fun (max_size, max_op) -> {max_size; max_op})
(obj2 (req "max_size" int31) (opt "max_op" int31))
type raw_context = Key of Bytes.t | Dir of (string * raw_context) list | Cut
let rec pp_raw_context ppf = function
| Cut ->
Format.fprintf ppf "..."
| Key v ->
Hex.pp ppf (Hex.of_bytes v)
| Dir l ->
Format.fprintf
ppf
"{@[<v 1>@,%a@]@,}"
(Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf (s, t) ->
Format.fprintf ppf "%s : %a" s pp_raw_context t))
l
let raw_context_encoding =
mu "raw_context" (fun encoding ->
union
[ case
(Tag 0)
bytes
~title:"Key"
(function Key k -> Some k | _ -> None)
(fun k -> Key k);
case
(Tag 1)
(assoc encoding)
~title:"Dir"
(function Dir k -> Some k | _ -> None)
(fun k -> Dir k);
case
(Tag 2)
null
~title:"Cut"
(function Cut -> Some () | _ -> None)
(fun () -> Cut) ])
type error += Invalid_depth_arg of int
let () =
register_error_kind
`Permanent
~id:"raw_context.invalid_depth"
~title:"Invalid depth argument"
~description:"The raw context extraction depth argument must be positive."
~pp:(fun ppf depth ->
Format.fprintf ppf "Extraction depth %d is invalid" depth)
Data_encoding.(obj1 (req "depth" int31))
(function Invalid_depth_arg depth -> Some depth | _ -> None)
(fun depth -> Invalid_depth_arg depth)
module type PROTO = sig
val hash : Protocol_hash.t
type block_header_data
val block_header_data_encoding : block_header_data Data_encoding.t
type block_header_metadata
val block_header_metadata_encoding : block_header_metadata Data_encoding.t
type operation_data
type operation_receipt
type operation = {
shell : Operation.shell_header;
protocol_data : operation_data;
}
val operation_data_encoding : operation_data Data_encoding.t
val operation_receipt_encoding : operation_receipt Data_encoding.t
val operation_data_and_receipt_encoding :
(operation_data * operation_receipt) Data_encoding.t
end
type protocols = {
current_protocol : Protocol_hash.t;
next_protocol : Protocol_hash.t;
}
let raw_protocol_encoding =
conv
(fun {current_protocol; next_protocol} ->
((current_protocol, next_protocol), ()))
(fun ((current_protocol, next_protocol), ()) ->
{current_protocol; next_protocol})
(merge_objs
(obj2
(req "protocol" Protocol_hash.encoding)
(req "next_protocol" Protocol_hash.encoding))
unit)
module Make (Proto : PROTO) (Next_proto : PROTO) = struct
let protocol_hash = Protocol_hash.to_b58check Proto.hash
let next_protocol_hash = Protocol_hash.to_b58check Next_proto.hash
type raw_block_header = {
shell : Block_header.shell_header;
protocol_data : Proto.block_header_data;
}
let raw_block_header_encoding =
def "raw_block_header"
@@ conv
(fun {shell; protocol_data} -> (shell, protocol_data))
(fun (shell, protocol_data) -> {shell; protocol_data})
(merge_objs
Block_header.shell_header_encoding
Proto.block_header_data_encoding)
type block_header = {
chain_id : Chain_id.t;
hash : Block_hash.t;
shell : Block_header.shell_header;
protocol_data : Proto.block_header_data;
}
let block_header_encoding =
def "block_header"
@@ conv
(fun {chain_id; hash; shell; protocol_data} ->
(((), chain_id, hash), {shell; protocol_data}))
(fun (((), chain_id, hash), {shell; protocol_data}) ->
{chain_id; hash; shell; protocol_data})
(merge_objs
(obj3
(req "protocol" (constant protocol_hash))
(req "chain_id" Chain_id.encoding)
(req "hash" Block_hash.encoding))
raw_block_header_encoding)
type block_metadata = {
protocol_data : Proto.block_header_metadata;
test_chain_status : Test_chain_status.t;
(* for the next block: *)
max_operations_ttl : int;
max_operation_data_length : int;
max_block_header_length : int;
operation_list_quota : operation_list_quota list;
}
let block_metadata_encoding =
def "block_header_metadata"
@@ conv
(fun { protocol_data;
test_chain_status;
max_operations_ttl;
max_operation_data_length;
max_block_header_length;
operation_list_quota } ->
( ( (),
(),
test_chain_status,
max_operations_ttl,
max_operation_data_length,
max_block_header_length,
operation_list_quota ),
protocol_data ))
(fun ( ( (),
(),
test_chain_status,
max_operations_ttl,
max_operation_data_length,
max_block_header_length,
operation_list_quota ),
protocol_data ) ->
{
protocol_data;
test_chain_status;
max_operations_ttl;
max_operation_data_length;
max_block_header_length;
operation_list_quota;
})
(merge_objs
(obj7
(req "protocol" (constant protocol_hash))
(req "next_protocol" (constant next_protocol_hash))
(req "test_chain_status" Test_chain_status.encoding)
(req "max_operations_ttl" int31)
(req "max_operation_data_length" int31)
(req "max_block_header_length" int31)
(req
"max_operation_list_length"
(dynamic_size (list operation_list_quota_encoding))))
Proto.block_header_metadata_encoding)
let next_operation_encoding =
let open Data_encoding in
def "next_operation"
@@ conv
(fun Next_proto.{shell; protocol_data} ->
((), (shell, protocol_data)))
(fun ((), (shell, protocol_data)) -> {shell; protocol_data})
(merge_objs
(obj1 (req "protocol" (constant next_protocol_hash)))
(merge_objs
(dynamic_size Operation.shell_header_encoding)
(dynamic_size Next_proto.operation_data_encoding)))
type operation = {
chain_id : Chain_id.t;
hash : Operation_hash.t;
shell : Operation.shell_header;
protocol_data : Proto.operation_data;
receipt : Proto.operation_receipt;
}
let operation_encoding =
def "operation"
@@
let open Data_encoding in
conv
(fun {chain_id; hash; shell; protocol_data; receipt} ->
(((), chain_id, hash), (shell, (protocol_data, receipt))))
(fun (((), chain_id, hash), (shell, (protocol_data, receipt))) ->
{chain_id; hash; shell; protocol_data; receipt})
(merge_objs
(obj3
(req "protocol" (constant protocol_hash))
(req "chain_id" Chain_id.encoding)
(req "hash" Operation_hash.encoding))
(merge_objs
(dynamic_size Operation.shell_header_encoding)
(dynamic_size Proto.operation_data_and_receipt_encoding)))
type block_info = {
chain_id : Chain_id.t;
hash : Block_hash.t;
header : raw_block_header;
metadata : block_metadata;
operations : operation list list;
}
let block_info_encoding =
conv
(fun {chain_id; hash; header; metadata; operations} ->
((), chain_id, hash, header, metadata, operations))
(fun ((), chain_id, hash, header, metadata, operations) ->
{chain_id; hash; header; metadata; operations})
(obj6
(req "protocol" (constant protocol_hash))
(req "chain_id" Chain_id.encoding)
(req "hash" Block_hash.encoding)
(req "header" (dynamic_size raw_block_header_encoding))
(req "metadata" (dynamic_size block_metadata_encoding))
(req "operations" (list (dynamic_size (list operation_encoding)))))
module S = struct
let path : prefix RPC_path.context = RPC_path.open_root
let hash =
RPC_service.get_service
~description:"The block's hash, its unique identifier."
~query:RPC_query.empty
~output:Block_hash.encoding
RPC_path.(path / "hash")
let header =
RPC_service.get_service
~description:"The whole block header."
~query:RPC_query.empty
~output:block_header_encoding
RPC_path.(path / "header")
let raw_header =
RPC_service.get_service
~description:"The whole block header (unparsed)."
~query:RPC_query.empty
~output:bytes
RPC_path.(path / "header" / "raw")
let metadata =
RPC_service.get_service
~description:"All the metadata associated to the block."
~query:RPC_query.empty
~output:block_metadata_encoding
RPC_path.(path / "metadata")
let protocols =
RPC_service.get_service
~description:"Current and next protocol."
~query:RPC_query.empty
~output:raw_protocol_encoding
RPC_path.(path / "protocols")
module Header = struct
let path = RPC_path.(path / "header")
let shell_header =
RPC_service.get_service
~description:"The shell-specific fragment of the block header."
~query:RPC_query.empty
~output:Block_header.shell_header_encoding
RPC_path.(path / "shell")
let protocol_data =
RPC_service.get_service
~description:"The version-specific fragment of the block header."
~query:RPC_query.empty
~output:
(conv
(fun h -> ((), h))
(fun ((), h) -> h)
(merge_objs
(obj1 (req "protocol" (constant protocol_hash)))
Proto.block_header_data_encoding))
RPC_path.(path / "protocol_data")
let raw_protocol_data =
RPC_service.get_service
~description:
"The version-specific fragment of the block header (unparsed)."
~query:RPC_query.empty
~output:bytes
RPC_path.(path / "protocol_data" / "raw")
end
module Operations = struct
let path = RPC_path.(path / "operations")
let operations =
RPC_service.get_service
~description:"All the operations included in the block."
~query:RPC_query.empty
~output:(list (dynamic_size (list operation_encoding)))
path
let list_arg =
let name = "list_offset" in
let descr = "Index `n` of the requested validation pass." in
let construct = string_of_int in
let destruct s =
try Ok (int_of_string s)
with _ -> Error (Format.sprintf "Invalid list offset (%s)" s)
in
RPC_arg.make ~name ~descr ~construct ~destruct ()
let offset_arg =
let name = "operation_offset" in
let descr =
"Index `m` of the requested operation in its validation pass."
in
let construct = string_of_int in
let destruct s =
try Ok (int_of_string s)
with _ -> Error (Format.sprintf "Invalid operation offset (%s)" s)
in
RPC_arg.make ~name ~descr ~construct ~destruct ()
let operations_in_pass =
RPC_service.get_service
~description:
"All the operations included in `n-th` validation pass of the \
block."
~query:RPC_query.empty
~output:(list operation_encoding)
RPC_path.(path /: list_arg)
let operation =
RPC_service.get_service
~description:
"The `m-th` operation in the `n-th` validation pass of the block."
~query:RPC_query.empty
~output:operation_encoding
RPC_path.(path /: list_arg /: offset_arg)
end
module Operation_hashes = struct
let path = RPC_path.(path / "operation_hashes")
let operation_hashes =
RPC_service.get_service
~description:
"The hashes of all the operations included in the block."
~query:RPC_query.empty
~output:(list (list Operation_hash.encoding))
path
let operation_hashes_in_pass =
RPC_service.get_service
~description:
"All the operations included in `n-th` validation pass of the \
block."
~query:RPC_query.empty
~output:(list Operation_hash.encoding)
RPC_path.(path /: Operations.list_arg)
let operation_hash =
RPC_service.get_service
~description:
"The hash of then `m-th` operation in the `n-th` validation pass \
of the block."
~query:RPC_query.empty
~output:Operation_hash.encoding
RPC_path.(path /: Operations.list_arg /: Operations.offset_arg)
end
module Helpers = struct
let path = RPC_path.(path / "helpers")
module Forge = struct
let block_header =
RPC_service.post_service
~description:"Forge a block header"
~query:RPC_query.empty
~input:Block_header.encoding
~output:(obj1 (req "block" bytes))
RPC_path.(path / "forge_block_header")
end
module Preapply = struct
let path = RPC_path.(path / "preapply")
let block_result_encoding =
obj2
(req "shell_header" Block_header.shell_header_encoding)
(req
"operations"
(list (Preapply_result.encoding RPC_error.encoding)))
type block_param = {
protocol_data : Next_proto.block_header_data;
operations : Next_proto.operation list list;
}
let block_param_encoding =
conv
(fun {protocol_data; operations} -> (protocol_data, operations))
(fun (protocol_data, operations) -> {protocol_data; operations})
(obj2
(req
"protocol_data"
(conv
(fun h -> ((), h))
(fun ((), h) -> h)
(merge_objs
(obj1 (req "protocol" (constant next_protocol_hash)))
(dynamic_size Next_proto.block_header_data_encoding))))
(req
"operations"
(list (dynamic_size (list next_operation_encoding)))))
let block_query =
let open RPC_query in
query (fun sort timestamp ->
object
method sort_operations = sort
method timestamp = timestamp
end)
|+ flag "sort" (fun t -> t#sort_operations)
|+ opt_field "timestamp" Time.Protocol.rpc_arg (fun t -> t#timestamp)
|> seal
let block =
RPC_service.post_service
~description:
"Simulate the validation of a block that would contain the \
given operations and return the resulting fitness and context \
hash."
~query:block_query
~input:block_param_encoding
~output:block_result_encoding
RPC_path.(path / "block")
let operations =
RPC_service.post_service
~description:"Simulate the validation of an operation."
~query:RPC_query.empty
~input:(list next_operation_encoding)
~output:
(list
(dynamic_size Next_proto.operation_data_and_receipt_encoding))
RPC_path.(path / "operations")
end
let complete =
let prefix_arg =
let destruct s = Ok s and construct s = s in
RPC_arg.make ~name:"prefix" ~destruct ~construct ()
in
RPC_service.get_service
~description:
"Try to complete a prefix of a Base58Check-encoded data. This RPC \
is actually able to complete hashes of block, operations, \
public_keys and contracts."
~query:RPC_query.empty
~output:(list string)
RPC_path.(path / "complete" /: prefix_arg)
end
module Context = struct
let path = RPC_path.(path / "context" / "raw" / "bytes")
let context_path_arg : string RPC_arg.t =
let name = "context_path" in
let descr = "A path inside the context" in
let construct s = s in
let destruct s = Ok s in
RPC_arg.make ~name ~descr ~construct ~destruct ()
let raw_context_query : < depth : int option > RPC_query.t =
let open RPC_query in
query (fun depth ->
object
method depth = depth
end)
|+ opt_field "depth" RPC_arg.int (fun t -> t#depth)
|> seal
let read =
RPC_service.get_service
~description:"Returns the raw context."
~query:raw_context_query
~output:raw_context_encoding
RPC_path.(path /:* context_path_arg)
end
let info =
RPC_service.get_service
~description:"All the information about a block."
~query:RPC_query.empty
~output:block_info_encoding
path
module Mempool = struct
type t = {
applied : (Operation_hash.t * Next_proto.operation) list;
refused : (Next_proto.operation * error list) Operation_hash.Map.t;
branch_refused :
(Next_proto.operation * error list) Operation_hash.Map.t;
branch_delayed :
(Next_proto.operation * error list) Operation_hash.Map.t;
unprocessed : Next_proto.operation Operation_hash.Map.t;
}
let encoding =
conv
(fun {applied; refused; branch_refused; branch_delayed; unprocessed} ->
(applied, refused, branch_refused, branch_delayed, unprocessed))
(fun (applied, refused, branch_refused, branch_delayed, unprocessed) ->
{applied; refused; branch_refused; branch_delayed; unprocessed})
(obj5
(req
"applied"
(list
(conv
(fun (hash, (op : Next_proto.operation)) ->
((hash, op.shell), op.protocol_data))
(fun ((hash, shell), protocol_data) ->
(hash, {shell; protocol_data}))
(merge_objs
(merge_objs
(obj1 (req "hash" Operation_hash.encoding))
(dynamic_size Operation.shell_header_encoding))
(dynamic_size Next_proto.operation_data_encoding)))))
(req
"refused"
(Operation_hash.Map.encoding
(merge_objs
(dynamic_size next_operation_encoding)
(obj1 (req "error" RPC_error.encoding)))))
(req
"branch_refused"
(Operation_hash.Map.encoding
(merge_objs
(dynamic_size next_operation_encoding)
(obj1 (req "error" RPC_error.encoding)))))
(req
"branch_delayed"
(Operation_hash.Map.encoding
(merge_objs
(dynamic_size next_operation_encoding)
(obj1 (req "error" RPC_error.encoding)))))
(req
"unprocessed"
(Operation_hash.Map.encoding
(dynamic_size next_operation_encoding))))
let pending_operations path =
(* TODO: branch_delayed/... *)
RPC_service.get_service
~description:"List the prevalidated operations."
~query:RPC_query.empty
~output:encoding
RPC_path.(path / "pending_operations")
let mempool_query =
let open RPC_query in
query (fun applied refused branch_refused branch_delayed ->
object
method applied = applied
method refused = refused
method branch_refused = branch_refused
method branch_delayed = branch_delayed
end)
|+ field
~descr:"Include applied operations (set by default)"
"applied"
RPC_arg.bool
true
(fun t -> t#applied)
|+ field
~descr:"Include refused operations"
"refused"
RPC_arg.bool
false
(fun t -> t#refused)
|+ field
~descr:"Include branch refused operations"
"branch_refused"
RPC_arg.bool
false
(fun t -> t#branch_refused)
|+ field
~descr:"Include branch delayed operations (set by default)"
"branch_delayed"
RPC_arg.bool
true
(fun t -> t#branch_delayed)
|> seal
let monitor_operations path =
RPC_service.get_service
~description:"Monitor the mempool operations."
~query:mempool_query
~output:(list next_operation_encoding)
RPC_path.(path / "monitor_operations")
let request_operations path =
RPC_service.post_service
~description:"Request the operations of your peers."
~input:Data_encoding.empty
~query:RPC_query.empty
~output:Data_encoding.empty
RPC_path.(path / "request_operations")
end
let live_blocks =
RPC_service.get_service
~description:
"List the ancestors of the given block which, if referred to as the \
branch in an operation header, are recent enough for that \
operation to be included in the current block."
~query:RPC_query.empty
~output:Block_hash.Set.encoding
RPC_path.(live_blocks_path open_root)
end
let path = RPC_path.prefix chain_path path
let make_call0 s ctxt a b q p =
let s = RPC_service.prefix path s in
RPC_context.make_call2 s ctxt a b q p
let make_call1 s ctxt a b c q p =
let s = RPC_service.prefix path s in
RPC_context.make_call3 s ctxt a b c q p
let make_call2 s ctxt a b c d q p =
let s = RPC_service.prefix path s in
RPC_context.make_call s ctxt (((((), a), b), c), d) q p
let hash ctxt =
let f = make_call0 S.hash ctxt in
fun ?(chain = `Main) ?(block = `Head 0) () ->
match block with `Hash (h, 0) -> return h | _ -> f chain block () ()
let header ctxt =
let f = make_call0 S.header ctxt in
fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
let raw_header ctxt =
let f = make_call0 S.raw_header ctxt in
fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
let metadata ctxt =
let f = make_call0 S.metadata ctxt in
fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
let protocols ctxt =
let f = make_call0 S.protocols ctxt in
fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
module Header = struct
module S = S.Header
let shell_header ctxt =
let f = make_call0 S.shell_header ctxt in
fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
let protocol_data ctxt =
let f = make_call0 S.protocol_data ctxt in
fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
let raw_protocol_data ctxt =
let f = make_call0 S.raw_protocol_data ctxt in
fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
end
module Operations = struct
module S = S.Operations
let operations ctxt =
let f = make_call0 S.operations ctxt in
fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
let operations_in_pass ctxt =
let f = make_call1 S.operations_in_pass ctxt in
fun ?(chain = `Main) ?(block = `Head 0) n -> f chain block n () ()
let operation ctxt =
let f = make_call2 S.operation ctxt in
fun ?(chain = `Main) ?(block = `Head 0) n m -> f chain block n m () ()
end
module Operation_hashes = struct
module S = S.Operation_hashes
let operation_hashes ctxt =
let f = make_call0 S.operation_hashes ctxt in
fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
let operation_hashes_in_pass ctxt =
let f = make_call1 S.operation_hashes_in_pass ctxt in
fun ?(chain = `Main) ?(block = `Head 0) n -> f chain block n () ()
let operation_hash ctxt =
let f = make_call2 S.operation_hash ctxt in
fun ?(chain = `Main) ?(block = `Head 0) n m -> f chain block n m () ()
end
module Context = struct
module S = S.Context
let read ctxt =
let f = make_call1 S.read ctxt in
fun ?(chain = `Main) ?(block = `Head 0) ?depth path ->
f
chain
block
path
(object
method depth = depth
end)
()
end
module Helpers = struct
module S = S.Helpers
module Forge = struct
module S = S.Forge
let block_header ctxt =
let f = make_call0 S.block_header ctxt in
fun ?(chain = `Main) ?(block = `Head 0) header ->
f chain block () header
end
module Preapply = struct
module S = S.Preapply
let block ctxt =
let f = make_call0 S.block ctxt in
fun ?(chain = `Main)
?(block = `Head 0)
?(sort = false)
?timestamp
~protocol_data
operations ->
f
chain
block
(object
method sort_operations = sort
method timestamp = timestamp
end)
{protocol_data; operations}
let operations ctxt =
let f = make_call0 S.operations ctxt in
fun ?(chain = `Main) ?(block = `Head 0) operations ->
f chain block () operations
end
let complete ctxt =
let f = make_call1 S.complete ctxt in
fun ?(chain = `Main) ?(block = `Head 0) s -> f chain block s () ()
end
let info ctxt =
let f = make_call0 S.info ctxt in
fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
module Mempool = struct
type t = S.Mempool.t = {
applied : (Operation_hash.t * Next_proto.operation) list;
refused : (Next_proto.operation * error list) Operation_hash.Map.t;
branch_refused :
(Next_proto.operation * error list) Operation_hash.Map.t;
branch_delayed :
(Next_proto.operation * error list) Operation_hash.Map.t;
unprocessed : Next_proto.operation Operation_hash.Map.t;
}
let pending_operations ctxt ?(chain = `Main) () =
let s = S.Mempool.pending_operations (mempool_path chain_path) in
RPC_context.make_call1 s ctxt chain () ()
let monitor_operations ctxt ?(chain = `Main) ?(applied = true)
?(branch_delayed = true) ?(branch_refused = false) ?(refused = false)
() =
let s = S.Mempool.monitor_operations (mempool_path chain_path) in
RPC_context.make_streamed_call
s
ctxt
((), chain)
(object
method applied = applied
method refused = refused
method branch_refused = branch_refused
method branch_delayed = branch_delayed
end)
()
let request_operations ctxt ?(chain = `Main) () =
let s = S.Mempool.request_operations (mempool_path chain_path) in
RPC_context.make_call1 s ctxt chain () ()
end
let live_blocks ctxt =
let f = make_call0 S.live_blocks ctxt in
fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
end
module Fake_protocol = struct
let hash = Protocol_hash.zero
type block_header_data = unit
let block_header_data_encoding = Data_encoding.empty
type block_header_metadata = unit
let block_header_metadata_encoding = Data_encoding.empty
type operation_data = unit
type operation_receipt = unit
type operation = {
shell : Operation.shell_header;
protocol_data : operation_data;
}
let operation_data_encoding = Data_encoding.empty
let operation_receipt_encoding = Data_encoding.empty
let operation_data_and_receipt_encoding =
Data_encoding.conv
(fun ((), ()) -> ())
(fun () -> ((), ()))
Data_encoding.empty
end
module Empty = Make (Fake_protocol) (Fake_protocol)
let () =
Printexc.register_printer (function
| ( Json_schema.Cannot_parse _
| Json_schema.Dangling_reference _
| Json_schema.Bad_reference _
| Json_schema.Unexpected _
| Json_schema.Duplicate_definition _ ) as exn ->
Some
(Format.asprintf "%a" (fun ppf -> Json_schema.print_error ppf) exn)
| _ ->
None)
let protocols = Empty.protocols
src/lib_shell_services/block_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Data_encoding.
Definition chain := variant.
Definition parse_chain (s : string) : sum variant string :=
(* ❌ Try-with are not handled *)
try
match s with
| "main" % string =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
| "test" % string =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
| h =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
end.
Definition chain_to_string (function_parameter : variant) : string :=
match function_parameter with
| Main => "main" % string
| Test => "test" % string
| Hash h => Chain_id.to_b58check h
end.
Definition chain_arg : Tezos_base__TzPervasives.RPC_arg.arg variant :=
let name := "chain_id" % string in
let descr :=
"A chain identifier. This is either a chain hash in Base58Check notation or a one the predefined aliases: 'main', 'test'."
% string in
let construct := chain_to_string in
let destruct := parse_chain in
RPC_arg.make (Some descr) name destruct construct tt.
Definition block := variant.
Definition parse_block (s : string) : sum variant string :=
let delims := cons "~" % char (cons "-" % char (cons "+" % char [])) in
let count_delims (s : string) : list (Z * ascii) :=
List.map
(fun d =>
((String.fold_left
(fun i =>
fun c =>
if equiv_decb c d then
Z.add i 1
else
i) 0 s), d)) delims in
let split_on_delim (counts : list (Z * ascii)) : (list string) * ascii :=
match
List.fold_left
(fun i =>
fun function_parameter =>
let '(v, _) := function_parameter in
Z.add i v) 0 counts with
| 0 => ((cons s []), " " % char)
| 1 =>
let delim := List.assoc 1 counts in
((String.split delim None None s), delim)
| _ => Stdlib.raise Exit
end in
(* ❌ Try-with are not handled *)
try
match split_on_delim (count_delims s) with
| (cons "genesis" % string [], _) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
| (cons "genesis" % string (cons n []), "+" % char) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
| (cons "head" % string [], _) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
|
(cons "head" % string (cons n []), "~" % char) |
(cons "head" % string (cons n []), "-" % char) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
| (cons "checkpoint" % string [], _) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
|
(cons "checkpoint" % string (cons n []), "~" % char) |
(cons "checkpoint" % string (cons n []), "-" % char) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
| (cons "checkpoint" % string (cons n []), "+" % char) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
| (cons "save_point" % string [], _) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
|
(cons "save_point" % string (cons n []), "~" % char) |
(cons "save_point" % string (cons n []), "-" % char) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
| (cons "save_point" % string (cons n []), "+" % char) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
| (cons "caboose" % string [], _) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
|
(cons "caboose" % string (cons n []), "~" % char) |
(cons "caboose" % string (cons n []), "-" % char) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
| (cons "caboose" % string (cons n []), "+" % char) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
| (cons hol [], _) =>
match Block_hash.of_b58check_opt hol with
| Some h =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
| None =>
let l := Int32.of_string s in
if
op_lt l
(* ❌ Constant of type int32 is converted to int *)
0 then
Stdlib.raise Exit
else
if
op_eq l
(* ❌ Constant of type int32 is converted to int *)
0 then
Stdlib.Ok
(* ❌ Variants not supported *)
variant
else
Stdlib.Ok
(* ❌ Variants not supported *)
variant
end
| (cons h (cons n []), "~" % char) | (cons h (cons n []), "-" % char) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
| (cons h (cons n []), "+" % char) =>
Stdlib.Ok
(* ❌ Variants not supported *)
variant
| _ => Stdlib.raise Exit
end.
Definition alias_to_string (function_parameter : variant) : string :=
match function_parameter with
| Checkpoint => "checkpoint" % string
| Save_point => "save_point" % string
| Caboose => "caboose" % string
end.
Definition to_string (function_parameter : variant) : string :=
match function_parameter with
| Genesis => "genesis" % string
| Alias (a, 0) => alias_to_string a
| Alias (a, n) =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "+" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))) "%s+%d" % string)
(alias_to_string a) (Z.opp n)
| Alias (a, n) =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "~" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))) "%s~%d" % string)
(alias_to_string a) n
| Head 0 => "head" % string
| Head n =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "head+" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "head+%d" % string)
(Z.opp n)
| Head n =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "head~" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)) "head~%d" % string) n
| Hash (h, 0) => Block_hash.to_b58check h
| Hash (h, n) =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "+" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))) "%s+%d" % string)
(Block_hash.to_b58check h) (Z.opp n)
| Hash (h, n) =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "~" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))) "%s~%d" % string)
(Block_hash.to_b58check h) n
| Level i =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format) "%d" % string)
(Int32.to_int i)
end.
Definition blocks_arg : Tezos_base__TzPervasives.RPC_arg.arg variant :=
let name := "block_id" % string in
let descr :=
"A block identifier. This is either a block hash in Base58Check notation, one the predefined aliases: 'genesis', 'head' or a block level (index in the chain). One might also use 'head~N' or '<hash>~N' where N is an integer to denote the Nth predecessor of the designated block.Also, '<hash>+N' denotes the Nth successor of a block."
% string in
let construct := to_string in
let destruct := parse_block in
RPC_arg.make (Some descr) name destruct construct tt.
Definition chain_prefix := unit * chain.
Definition prefix := chain_prefix * block.
Definition chain_path
: Tezos_base__TzPervasives.RPC_path.path unit (unit * variant) :=
op_divcolon (op_div root "chains" % string) chain_arg.
Definition mempool_path {A B : Type}
(p : Tezos_base__TzPervasives.RPC_path.path A B)
: Tezos_base__TzPervasives.RPC_path.path A B := op_div p "mempool" % string.
Definition live_blocks_path {A B : Type}
(p : Tezos_base__TzPervasives.RPC_path.path A B)
: Tezos_base__TzPervasives.RPC_path.path A B :=
op_div p "live_blocks" % string.
Definition dir_path
: Tezos_base__TzPervasives.RPC_path.t chain_prefix chain_prefix :=
op_div open_root "blocks" % string.
Definition path
: Tezos_base__TzPervasives.RPC_path.path chain_prefix (chain_prefix * variant) :=
op_divcolon dir_path blocks_arg.
Record operation_list_quota := {
max_size : Z;
max_op : option Z }.
Definition operation_list_quota_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding operation_list_quota :=
conv
(fun function_parameter =>
let '{| max_size := max_size; max_op := max_op |} := function_parameter in
(max_size, max_op))
(fun function_parameter =>
let '(max_size, max_op) := function_parameter in
{| max_size := max_size; max_op := max_op |}) None
(obj2 (req None None "max_size" % string int31)
(opt None None "max_op" % string int31)).
Inductive raw_context : Type :=
| Key : Stdlib.Bytes.t -> raw_context
| Dir : (list (string * raw_context)) -> raw_context
| Cut : raw_context.
Fixpoint pp_raw_context
(ppf : Stdlib.Format.formatter) (function_parameter : raw_context) : unit :=
match function_parameter with
| Cut =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "..." % string
CamlinternalFormatBasics.End_of_format) "..." % string)
| Key v => Hex.pp ppf (Hex.of_bytes None v)
| Dir l =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "{" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 1>" % string
CamlinternalFormatBasics.End_of_format) "<v 1>" % string))
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Char_literal "}" % char
CamlinternalFormatBasics.End_of_format)))))))
"{@[<v 1>@,%a@]@,}" % string)
(Format.pp_print_list (Some Format.pp_print_cut)
(fun ppf =>
fun function_parameter =>
let '(s, t) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " : " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))
"%s : %a" % string) s pp_raw_context t)) l
end.
Definition raw_context_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding raw_context :=
mu "raw_context" % string None None
(fun encoding =>
union None
(cons
(case "Key" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0) bytes
(fun function_parameter =>
match function_parameter with
| Key k => Some k
| _ => None
end) (fun k => Key k))
(cons
(case "Dir" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1) (assoc encoding)
(fun function_parameter =>
match function_parameter with
| Dir k => Some k
| _ => None
end) (fun k => Dir k))
(cons
(case "Cut" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 2) null
(fun function_parameter =>
match function_parameter with
| Cut => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Cut)) [])))).
(* ❌ Structure item `typext` not handled. *)
type_extension
Module PROTO.
Record signature {block_header_data block_header_metadata operation_data
operation_receipt operation : Type} := {
hash : Tezos_base__TzPervasives.Protocol_hash.t;
block_header_data := block_header_data;
block_header_data_encoding : Tezos_base__TzPervasives.Data_encoding.t
block_header_data;
block_header_metadata := block_header_metadata;
block_header_metadata_encoding : Tezos_base__TzPervasives.Data_encoding.t
block_header_metadata;
operation_data := operation_data;
operation_receipt := operation_receipt;
operation := operation;
operation_data_encoding : Tezos_base__TzPervasives.Data_encoding.t
operation_data;
operation_receipt_encoding : Tezos_base__TzPervasives.Data_encoding.t
operation_receipt;
operation_data_and_receipt_encoding : Tezos_base__TzPervasives.Data_encoding.t
(operation_data * operation_receipt);
}.
Arguments signature : clear implicits.
End PROTO.
Record protocols := {
current_protocol : Tezos_base__TzPervasives.Protocol_hash.t;
next_protocol : Tezos_base__TzPervasives.Protocol_hash.t }.
Definition raw_protocol_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding protocols :=
conv
(fun function_parameter =>
let '{|
current_protocol := current_protocol;
next_protocol := next_protocol
|} := function_parameter in
((current_protocol, next_protocol), tt))
(fun function_parameter =>
let '((current_protocol, next_protocol), tt) := function_parameter in
{| current_protocol := current_protocol; next_protocol := next_protocol |})
None
(merge_objs
(obj2 (req None None "protocol" % string Protocol_hash.encoding)
(req None None "next_protocol" % string Protocol_hash.encoding)) unit).
(* ❌ Functors are not handled. *)
functor
Module Fake_protocol.
Definition hash : Tezos_base__TzPervasives.Protocol_hash.t :=
Protocol_hash.zero.
Definition block_header_data := unit.
Definition block_header_data_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding unit :=
Data_encoding.empty.
Definition block_header_metadata := unit.
Definition block_header_metadata_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding unit :=
Data_encoding.empty.
Definition operation_data := unit.
Definition operation_receipt := unit.
Record operation := {
shell : Tezos_base__TzPervasives.Operation.shell_header;
protocol_data : operation_data }.
Definition operation_data_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding unit :=
Data_encoding.empty.
Definition operation_receipt_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding unit :=
Data_encoding.empty.
Definition operation_data_and_receipt_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding (unit * unit) :=
Data_encoding.conv
(fun function_parameter =>
let '(tt, tt) := function_parameter in
tt)
(fun function_parameter =>
let 'tt := function_parameter in
(tt, tt)) None Data_encoding.empty.
End Fake_protocol.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition protocols {E F i o p q : Type}
: (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F) ->
(option variant) ->
(option variant) ->
unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult protocols) :=
Empty.protocols.
src/lib_shell_services/block_validator_errors.ml 18 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type block_error =
| Cannot_parse_operation of Operation_hash.t
| Invalid_fitness of {expected : Fitness.t; found : Fitness.t}
| Non_increasing_timestamp
| Non_increasing_fitness
| Invalid_level of {expected : Int32.t; found : Int32.t}
| Invalid_proto_level of {expected : int; found : int}
| Replayed_operation of Operation_hash.t
| Outdated_operation of {
operation : Operation_hash.t;
originating_block : Block_hash.t;
}
| Expired_chain of {
chain_id : Chain_id.t;
expiration : Time.Protocol.t;
timestamp : Time.Protocol.t;
}
| Unexpected_number_of_validation_passes of int (* uint8 *)
| Too_many_operations of {pass : int; found : int; max : int}
| Oversized_operation of {
operation : Operation_hash.t;
size : int;
max : int;
}
| Unallowed_pass of {
operation : Operation_hash.t;
pass : int;
allowed_pass : int list;
}
| Cannot_parse_block_header
| Economic_protocol_error of error list
let block_error_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Cannot_parse_operation"
(obj2
(req "error" (constant "cannot_parse_operation"))
(req "operation" Operation_hash.encoding))
(function
| Cannot_parse_operation operation ->
Some ((), operation)
| _ ->
None)
(fun ((), operation) -> Cannot_parse_operation operation);
case
(Tag 1)
~title:"Invalid_fitness"
(obj3
(req "error" (constant "invalid_fitness"))
(req "expected" Fitness.encoding)
(req "found" Fitness.encoding))
(function
| Invalid_fitness {expected; found} ->
Some ((), expected, found)
| _ ->
None)
(fun ((), expected, found) -> Invalid_fitness {expected; found});
case
(Tag 2)
~title:"Non_increasing_timestamp"
(obj1 (req "error" (constant "non_increasing_timestamp")))
(function Non_increasing_timestamp -> Some () | _ -> None)
(fun () -> Non_increasing_timestamp);
case
(Tag 3)
~title:"Non_increasing_fitness"
(obj1 (req "error" (constant "non_increasing_fitness")))
(function Non_increasing_fitness -> Some () | _ -> None)
(fun () -> Non_increasing_fitness);
case
(Tag 4)
~title:"Invalid_level"
(obj3
(req "error" (constant "invalid_level"))
(req "expected" int32)
(req "found" int32))
(function
| Invalid_level {expected; found} ->
Some ((), expected, found)
| _ ->
None)
(fun ((), expected, found) -> Invalid_level {expected; found});
case
(Tag 5)
~title:"Invalid_proto_level"
(obj3
(req "error" (constant "invalid_proto_level"))
(req "expected" uint8)
(req "found" uint8))
(function
| Invalid_proto_level {expected; found} ->
Some ((), expected, found)
| _ ->
None)
(fun ((), expected, found) -> Invalid_proto_level {expected; found});
case
(Tag 6)
~title:"Replayed_operation"
(obj2
(req "error" (constant "replayed_operation"))
(req "operation" Operation_hash.encoding))
(function
| Replayed_operation operation -> Some ((), operation) | _ -> None)
(fun ((), operation) -> Replayed_operation operation);
case
(Tag 7)
~title:"Outdated_operation"
(obj3
(req "error" (constant "outdated_operation"))
(req "operation" Operation_hash.encoding)
(req "originating_block" Block_hash.encoding))
(function
| Outdated_operation {operation; originating_block} ->
Some ((), operation, originating_block)
| _ ->
None)
(fun ((), operation, originating_block) ->
Outdated_operation {operation; originating_block});
case
(Tag 8)
~title:"Expired_chain"
(obj4
(req "error" (constant "expired_chain"))
(req "chain_id" Chain_id.encoding)
(req "expiration" Time.Protocol.encoding)
(req "timestamp" Time.Protocol.encoding))
(function
| Expired_chain {chain_id; expiration; timestamp} ->
Some ((), chain_id, expiration, timestamp)
| _ ->
None)
(fun ((), chain_id, expiration, timestamp) ->
Expired_chain {chain_id; expiration; timestamp});
case
(Tag 9)
~title:"Unexpected_number_of_validation_passes"
(obj2
(req "error" (constant "unexpected_number_of_passes"))
(req "found" uint8))
(function
| Unexpected_number_of_validation_passes n ->
Some ((), n)
| _ ->
None)
(fun ((), n) -> Unexpected_number_of_validation_passes n);
case
(Tag 10)
~title:"Too_many_operations"
(obj4
(req "error" (constant "too_many_operations"))
(req "validation_pass" uint8)
(req "found" uint16)
(req "max" uint16))
(function
| Too_many_operations {pass; found; max} ->
Some ((), pass, found, max)
| _ ->
None)
(fun ((), pass, found, max) -> Too_many_operations {pass; found; max});
case
(Tag 11)
~title:"Oversized_operation"
(obj4
(req "error" (constant "oversized_operation"))
(req "operation" Operation_hash.encoding)
(req "found" int31)
(req "max" int31))
(function
| Oversized_operation {operation; size; max} ->
Some ((), operation, size, max)
| _ ->
None)
(fun ((), operation, size, max) ->
Oversized_operation {operation; size; max});
case
(Tag 12)
~title:"Unallowed_pass"
(obj4
(req "error" (constant "invalid_pass"))
(req "operation" Operation_hash.encoding)
(req "pass" uint8)
(req "allowed_pass" (list uint8)))
(function
| Unallowed_pass {operation; pass; allowed_pass} ->
Some ((), operation, pass, allowed_pass)
| _ ->
None)
(fun ((), operation, pass, allowed_pass) ->
Unallowed_pass {operation; pass; allowed_pass});
case
(Tag 13)
~title:"Cannot_parse_block_header"
(obj1 (req "error" (constant "cannot_parse_bock_header")))
(function Cannot_parse_block_header -> Some () | _ -> None)
(fun () -> Cannot_parse_block_header) ]
let pp_block_error ppf = function
| Cannot_parse_operation oph ->
Format.fprintf
ppf
"Failed to parse the operation %a."
Operation_hash.pp_short
oph
| Invalid_fitness {expected; found} ->
Format.fprintf
ppf
"@[<v 2>Invalid fitness:@ expected %a@ found %a@]"
Fitness.pp
expected
Fitness.pp
found
| Non_increasing_timestamp ->
Format.fprintf ppf "Non increasing timestamp"
| Non_increasing_fitness ->
Format.fprintf ppf "Non increasing fitness"
| Invalid_level {expected; found} ->
Format.fprintf
ppf
"Invalid level:@ expected %ld@ found %ld"
expected
found
| Invalid_proto_level {expected; found} ->
Format.fprintf
ppf
"Invalid protocol level:@ expected %d@ found %d"
expected
found
| Replayed_operation oph ->
Format.fprintf
ppf
"The operation %a was previously included in the chain."
Operation_hash.pp_short
oph
| Outdated_operation {operation; originating_block} ->
Format.fprintf
ppf
"The operation %a is outdated (originated in block: %a)"
Operation_hash.pp_short
operation
Block_hash.pp_short
originating_block
| Expired_chain {chain_id; expiration; timestamp} ->
Format.fprintf
ppf
"The block timestamp (%a) is later than its chain expiration date: %a \
(chain: %a)."
Time.System.pp_hum
(Time.System.of_protocol_exn timestamp)
Time.System.pp_hum
(Time.System.of_protocol_exn expiration)
Chain_id.pp_short
chain_id
| Unexpected_number_of_validation_passes n ->
Format.fprintf ppf "Invalid number of validation passes (found: %d)" n
| Too_many_operations {pass; found; max} ->
Format.fprintf
ppf
"Too many operations in validation pass %d (found: %d, max: %d)"
pass
found
max
| Oversized_operation {operation; size; max} ->
Format.fprintf
ppf
"Oversized operation %a (size: %d, max: %d)"
Operation_hash.pp_short
operation
size
max
| Unallowed_pass {operation; pass; allowed_pass} ->
Format.fprintf
ppf
"Operation %a included in validation pass %d, while only the \
following passes are allowed: @[<h>%a@]"
Operation_hash.pp_short
operation
pass
Format.(pp_print_list pp_print_int)
allowed_pass
| Cannot_parse_block_header ->
Format.fprintf ppf "Failed to parse the block header."
| Economic_protocol_error err ->
Format.fprintf
ppf
"Failed to validate the economic-protocol content of the block: %a."
Error_monad.pp_print_error
err
type validation_process_error =
| Missing_handshake
| Inconsistent_handshake of string
| Protocol_dynlink_failure of string
let validation_process_error_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Missing_handshake"
(obj1 (req "constant" (constant "missing_handshake")))
(function Missing_handshake -> Some () | _ -> None)
(fun () -> Missing_handshake);
case
(Tag 1)
~title:"Inconsistent_handshake"
(obj1 (req "inconsistent_handshake" string))
(function Inconsistent_handshake msg -> Some msg | _ -> None)
(fun msg -> Inconsistent_handshake msg);
case
(Tag 2)
~title:"Protocol_dynlink_failure"
(obj1 (req "pretocol_dynlink_failure" string))
(function Protocol_dynlink_failure msg -> Some msg | _ -> None)
(fun msg -> Protocol_dynlink_failure msg) ]
let pp_validation_process_error ppf = function
| Missing_handshake ->
Format.fprintf
ppf
"Missing handshake while initializing validation process."
| Protocol_dynlink_failure msg ->
Format.fprintf ppf "%s" msg
| Inconsistent_handshake msg ->
Format.fprintf ppf "Inconsistent handshake: %s." msg
type error +=
| Invalid_block of {block : Block_hash.t; error : block_error}
| Unavailable_protocol of {block : Block_hash.t; protocol : Protocol_hash.t}
| Inconsistent_operations_hash of {
block : Block_hash.t;
expected : Operation_list_list_hash.t;
found : Operation_list_list_hash.t;
}
| Failed_to_checkout_context of Context_hash.t
| System_error of {errno : string; fn : string; msg : string}
| Missing_test_protocol of Protocol_hash.t
| Validation_process_failed of validation_process_error
let () =
Error_monad.register_error_kind
`Permanent
~id:"validator.invalid_block"
~title:"Invalid block"
~description:"Invalid block."
~pp:(fun ppf (block, error) ->
Format.fprintf
ppf
"@[<v 2>Invalid block %a@ %a@]"
Block_hash.pp_short
block
pp_block_error
error)
Data_encoding.(
merge_objs
(obj1 (req "invalid_block" Block_hash.encoding))
block_error_encoding)
(function
| Invalid_block {block; error} -> Some (block, error) | _ -> None)
(fun (block, error) -> Invalid_block {block; error}) ;
Error_monad.register_error_kind
`Temporary
~id:"validator.unavailable_protocol"
~title:"Missing protocol"
~description:"The protocol required for validating a block is missing."
~pp:(fun ppf (block, protocol) ->
Format.fprintf
ppf
"Missing protocol (%a) when validating the block %a."
Protocol_hash.pp_short
protocol
Block_hash.pp_short
block)
Data_encoding.(
obj2
(req "block" Block_hash.encoding)
(req "missing_protocol" Protocol_hash.encoding))
(function
| Unavailable_protocol {block; protocol} ->
Some (block, protocol)
| _ ->
None)
(fun (block, protocol) -> Unavailable_protocol {block; protocol}) ;
Error_monad.register_error_kind
`Temporary
~id:"validator.inconsistent_operations_hash"
~title:"Invalid merkle tree"
~description:
"The provided list of operations is inconsistent with the block header."
~pp:(fun ppf (block, expected, found) ->
Format.fprintf
ppf
"@[<v 2>The provided list of operations for block %a is inconsistent \
with the block header@ expected: %a@ found: %a@]"
Block_hash.pp_short
block
Operation_list_list_hash.pp_short
expected
Operation_list_list_hash.pp_short
found)
Data_encoding.(
obj3
(req "block" Block_hash.encoding)
(req "expected" Operation_list_list_hash.encoding)
(req "found" Operation_list_list_hash.encoding))
(function
| Inconsistent_operations_hash {block; expected; found} ->
Some (block, expected, found)
| _ ->
None)
(fun (block, expected, found) ->
Inconsistent_operations_hash {block; expected; found}) ;
Error_monad.register_error_kind
`Permanent
~id:"Block_validator_process.failed_to_checkout_context"
~title:"Fail during checkout context"
~description:"The context checkout failed using a given hash"
~pp:(fun ppf (hash : Context_hash.t) ->
Format.fprintf
ppf
"@[Failed to checkout the context with hash %a@]"
Context_hash.pp_short
hash)
Data_encoding.(obj1 (req "hash" Context_hash.encoding))
(function Failed_to_checkout_context h -> Some h | _ -> None)
(fun h -> Failed_to_checkout_context h) ;
Error_monad.register_error_kind
`Temporary
~id:"Validator_process.system_error_while_validating"
~title:"Failed to validate block because of a system error"
~description:"The validator failed because of a system error"
~pp:(fun ppf (errno, fn, msg) ->
Format.fprintf
ppf
"System error while validating a block (in function %s(%s)):@ %s"
fn
msg
errno)
Data_encoding.(
obj3 (req "errno" string) (req "function" string) (req "msg" string))
(function
| System_error {errno; fn; msg} -> Some (errno, fn, msg) | _ -> None)
(fun (errno, fn, msg) -> System_error {errno; fn; msg}) ;
Error_monad.register_error_kind
`Temporary
~id:"validator.missing_test_protocol"
~title:"Missing test protocol"
~description:"Missing test protocol when forking the test chain"
~pp:(fun ppf protocol ->
Format.fprintf
ppf
"Missing test protocol %a when forking the test chain."
Protocol_hash.pp
protocol)
Data_encoding.(obj1 (req "test_protocol" Protocol_hash.encoding))
(function Missing_test_protocol protocol -> Some protocol | _ -> None)
(fun protocol -> Missing_test_protocol protocol) ;
Error_monad.register_error_kind
`Temporary
~id:"validator.validation_process_failed"
~title:"Validation process failed"
~description:"Failed to validate block using exteranl validation process."
~pp:(fun ppf error ->
Format.fprintf
ppf
"Failed to validate block using exteranl validation process. %a"
pp_validation_process_error
error)
Data_encoding.(obj1 (req "error" validation_process_error_encoding))
(function Validation_process_failed error -> Some error | _ -> None)
(fun error -> Validation_process_failed error)
let invalid_block block error = Invalid_block {block; error}
src/lib_shell_services/block_validator_errors.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive block_error : Type :=
| Cannot_parse_operation : Tezos_base__TzPervasives.Operation_hash.t ->
block_error
| Invalid_fitness : Tezos_base__TzPervasives.Fitness.t ->
Tezos_base__TzPervasives.Fitness.t -> block_error
| Non_increasing_timestamp : block_error
| Non_increasing_fitness : block_error
| Invalid_level : Stdlib.Int32.t -> Stdlib.Int32.t -> block_error
| Invalid_proto_level : Z -> Z -> block_error
| Replayed_operation : Tezos_base__TzPervasives.Operation_hash.t -> block_error
| Outdated_operation : Tezos_base__TzPervasives.Operation_hash.t ->
Tezos_base__TzPervasives.Block_hash.t -> block_error
| Expired_chain : Tezos_base__TzPervasives.Chain_id.t ->
Tezos_base__TzPervasives.Time.Protocol.t ->
Tezos_base__TzPervasives.Time.Protocol.t -> block_error
| Unexpected_number_of_validation_passes : Z -> block_error
| Too_many_operations : Z -> Z -> Z -> block_error
| Oversized_operation : Tezos_base__TzPervasives.Operation_hash.t -> Z -> Z ->
block_error
| Unallowed_pass : Tezos_base__TzPervasives.Operation_hash.t -> Z -> (list Z) ->
block_error
| Cannot_parse_block_header : block_error
| Economic_protocol_error : (list Tezos_base__TzPervasives.error) -> block_error.
Definition block_error_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding block_error :=
union None
(cons
(case "Cannot_parse_operation" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(obj2
(req None None "error" % string
(constant "cannot_parse_operation" % string))
(req None None "operation" % string Operation_hash.encoding))
(fun function_parameter =>
match function_parameter with
| Cannot_parse_operation operation => Some (tt, operation)
| _ => None
end)
(fun function_parameter =>
let '(tt, operation) := function_parameter in
Cannot_parse_operation operation))
(cons
(case "Invalid_fitness" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj3
(req None None "error" % string
(constant "invalid_fitness" % string))
(req None None "expected" % string Fitness.encoding)
(req None None "found" % string Fitness.encoding))
(fun function_parameter =>
match function_parameter with
| Invalid_fitness {| expected := expected; found := found |} =>
Some (tt, expected, found)
| _ => None
end)
(fun function_parameter =>
let '(tt, expected, found) := function_parameter in
Invalid_fitness {| expected := expected; found := found |}))
(cons
(case "Non_increasing_timestamp" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 2)
(obj1
(req None None "error" % string
(constant "non_increasing_timestamp" % string)))
(fun function_parameter =>
match function_parameter with
| Non_increasing_timestamp => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Non_increasing_timestamp))
(cons
(case "Non_increasing_fitness" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 3)
(obj1
(req None None "error" % string
(constant "non_increasing_fitness" % string)))
(fun function_parameter =>
match function_parameter with
| Non_increasing_fitness => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Non_increasing_fitness))
(cons
(case "Invalid_level" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 4)
(obj3
(req None None "error" % string
(constant "invalid_level" % string))
(req None None "expected" % string int32)
(req None None "found" % string int32))
(fun function_parameter =>
match function_parameter with
| Invalid_level {| expected := expected; found := found |} =>
Some (tt, expected, found)
| _ => None
end)
(fun function_parameter =>
let '(tt, expected, found) := function_parameter in
Invalid_level {| expected := expected; found := found |}))
(cons
(case "Invalid_proto_level" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 5)
(obj3
(req None None "error" % string
(constant "invalid_proto_level" % string))
(req None None "expected" % string uint8)
(req None None "found" % string uint8))
(fun function_parameter =>
match function_parameter with
|
Invalid_proto_level {|
expected := expected; found := found |} =>
Some (tt, expected, found)
| _ => None
end)
(fun function_parameter =>
let '(tt, expected, found) := function_parameter in
Invalid_proto_level
{| expected := expected; found := found |}))
(cons
(case "Replayed_operation" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 6)
(obj2
(req None None "error" % string
(constant "replayed_operation" % string))
(req None None "operation" % string
Operation_hash.encoding))
(fun function_parameter =>
match function_parameter with
| Replayed_operation operation => Some (tt, operation)
| _ => None
end)
(fun function_parameter =>
let '(tt, operation) := function_parameter in
Replayed_operation operation))
(cons
(case "Outdated_operation" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 7)
(obj3
(req None None "error" % string
(constant "outdated_operation" % string))
(req None None "operation" % string
Operation_hash.encoding)
(req None None "originating_block" % string
Block_hash.encoding))
(fun function_parameter =>
match function_parameter with
|
Outdated_operation {|
operation := operation;
originating_block := originating_block
|} => Some (tt, operation, originating_block)
| _ => None
end)
(fun function_parameter =>
let '(tt, operation, originating_block) :=
function_parameter in
Outdated_operation
{| operation := operation;
originating_block := originating_block |}))
(cons
(case "Expired_chain" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 8)
(obj4
(req None None "error" % string
(constant "expired_chain" % string))
(req None None "chain_id" % string Chain_id.encoding)
(req None None "expiration" % string
Time.Protocol.encoding)
(req None None "timestamp" % string
Time.Protocol.encoding))
(fun function_parameter =>
match function_parameter with
|
Expired_chain {|
chain_id := chain_id;
expiration := expiration;
timestamp := timestamp
|} => Some (tt, chain_id, expiration, timestamp)
| _ => None
end)
(fun function_parameter =>
let '(tt, chain_id, expiration, timestamp) :=
function_parameter in
Expired_chain
{| chain_id := chain_id; expiration := expiration;
timestamp := timestamp |}))
(cons
(case "Unexpected_number_of_validation_passes" % string
None (Tezos_base__TzPervasives.Data_encoding.Tag 9)
(obj2
(req None None "error" % string
(constant "unexpected_number_of_passes" % string))
(req None None "found" % string uint8))
(fun function_parameter =>
match function_parameter with
| Unexpected_number_of_validation_passes n =>
Some (tt, n)
| _ => None
end)
(fun function_parameter =>
let '(tt, n) := function_parameter in
Unexpected_number_of_validation_passes n))
(cons
(case "Too_many_operations" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 10)
(obj4
(req None None "error" % string
(constant "too_many_operations" % string))
(req None None "validation_pass" % string uint8)
(req None None "found" % string uint16)
(req None None "max" % string uint16))
(fun function_parameter =>
match function_parameter with
|
Too_many_operations {|
pass := pass;
found := found;
max := max
|} => Some (tt, pass, found, max)
| _ => None
end)
(fun function_parameter =>
let '(tt, pass, found, max) := function_parameter
in
Too_many_operations
{| pass := pass; found := found; max := max |}))
(cons
(case "Oversized_operation" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 11)
(obj4
(req None None "error" % string
(constant "oversized_operation" % string))
(req None None "operation" % string
Operation_hash.encoding)
(req None None "found" % string int31)
(req None None "max" % string int31))
(fun function_parameter =>
match function_parameter with
|
Oversized_operation {|
operation := operation;
size := size;
max := max
|} => Some (tt, operation, size, max)
| _ => None
end)
(fun function_parameter =>
let '(tt, operation, size, max) :=
function_parameter in
Oversized_operation
{| operation := operation; size := size;
max := max |}))
(cons
(case "Unallowed_pass" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 12)
(obj4
(req None None "error" % string
(constant "invalid_pass" % string))
(req None None "operation" % string
Operation_hash.encoding)
(req None None "pass" % string uint8)
(req None None "allowed_pass" % string
(list None uint8)))
(fun function_parameter =>
match function_parameter with
|
Unallowed_pass {|
operation := operation;
pass := pass;
allowed_pass := allowed_pass
|} =>
Some (tt, operation, pass, allowed_pass)
| _ => None
end)
(fun function_parameter =>
let '(tt, operation, pass, allowed_pass) :=
function_parameter in
Unallowed_pass
{| operation := operation; pass := pass;
allowed_pass := allowed_pass |}))
(cons
(case "Cannot_parse_block_header" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 13)
(obj1
(req None None "error" % string
(constant
"cannot_parse_bock_header" % string)))
(fun function_parameter =>
match function_parameter with
| Cannot_parse_block_header => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Cannot_parse_block_header)) [])))))))))))))).
Definition pp_block_error
(ppf : Stdlib.Format.formatter) (function_parameter : block_error) : unit :=
match function_parameter with
| Cannot_parse_operation oph =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to parse the operation " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))
"Failed to parse the operation %a." % string) Operation_hash.pp_short
oph
| Invalid_fitness {| expected := expected; found := found |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Invalid fitness:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal " expected " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal " found " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[<v 2>Invalid fitness:@ expected %a@ found %a@]" % string)
Fitness.pp expected Fitness.pp found
| Non_increasing_timestamp =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Non increasing timestamp" % string
CamlinternalFormatBasics.End_of_format)
"Non increasing timestamp" % string)
| Non_increasing_fitness =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Non increasing fitness" % string
CamlinternalFormatBasics.End_of_format)
"Non increasing fitness" % string)
| Invalid_level {| expected := expected; found := found |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Invalid level:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal " expected " % string
(CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal " found " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)))))))
"Invalid level:@ expected %ld@ found %ld" % string) expected found
| Invalid_proto_level {| expected := expected; found := found |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid protocol level:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal " expected " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal " found " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)))))))
"Invalid protocol level:@ expected %d@ found %d" % string) expected
found
| Replayed_operation oph =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "The operation " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" was previously included in the chain." % string
CamlinternalFormatBasics.End_of_format)))
"The operation %a was previously included in the chain." % string)
Operation_hash.pp_short oph
|
Outdated_operation {|
operation := operation; originating_block := originating_block |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "The operation " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is outdated (originated in block: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"The operation %a is outdated (originated in block: %a)" % string)
Operation_hash.pp_short operation Block_hash.pp_short originating_block
|
Expired_chain {|
chain_id := chain_id;
expiration := expiration;
timestamp := timestamp
|} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The block timestamp (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
") is later than its chain expiration date: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (chain: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ")." % string
CamlinternalFormatBasics.End_of_format)))))))
"The block timestamp (%a) is later than its chain expiration date: %a (chain: %a)."
% string) Time.System.pp_hum (Time.System.of_protocol_exn timestamp)
Time.System.pp_hum (Time.System.of_protocol_exn expiration)
Chain_id.pp_short chain_id
| Unexpected_number_of_validation_passes n =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid number of validation passes (found: " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"Invalid number of validation passes (found: %d)" % string) n
| Too_many_operations {| pass := pass; found := found; max := max |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Too many operations in validation pass " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " (found: " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ", max: " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))))
"Too many operations in validation pass %d (found: %d, max: %d)" %
string) pass found max
| Oversized_operation {| operation := operation; size := size; max := max |}
=>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Oversized operation " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (size: " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ", max: " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))))
"Oversized operation %a (size: %d, max: %d)" % string)
Operation_hash.pp_short operation size max
|
Unallowed_pass {|
operation := operation; pass := pass; allowed_pass := allowed_pass |}
=>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Operation " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" included in validation pass " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
", while only the following passes are allowed: " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<h>" % string
CamlinternalFormatBasics.End_of_format) "<h>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"Operation %a included in validation pass %d, while only the following passes are allowed: @[<h>%a@]"
% string) Operation_hash.pp_short operation pass
(pp_print_list None pp_print_int) allowed_pass
| Cannot_parse_block_header =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to parse the block header." % string
CamlinternalFormatBasics.End_of_format)
"Failed to parse the block header." % string)
| Economic_protocol_error err =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to validate the economic-protocol content of the block: " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))
"Failed to validate the economic-protocol content of the block: %a." %
string) Error_monad.pp_print_error err
end.
Inductive validation_process_error : Type :=
| Missing_handshake : validation_process_error
| Inconsistent_handshake : string -> validation_process_error
| Protocol_dynlink_failure : string -> validation_process_error.
Definition validation_process_error_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding validation_process_error :=
union None
(cons
(case "Missing_handshake" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(obj1
(req None None "constant" % string
(constant "missing_handshake" % string)))
(fun function_parameter =>
match function_parameter with
| Missing_handshake => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Missing_handshake))
(cons
(case "Inconsistent_handshake" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj1 (req None None "inconsistent_handshake" % string string))
(fun function_parameter =>
match function_parameter with
| Inconsistent_handshake msg => Some msg
| _ => None
end) (fun msg => Inconsistent_handshake msg))
(cons
(case "Protocol_dynlink_failure" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 2)
(obj1 (req None None "pretocol_dynlink_failure" % string string))
(fun function_parameter =>
match function_parameter with
| Protocol_dynlink_failure msg => Some msg
| _ => None
end) (fun msg => Protocol_dynlink_failure msg)) []))).
Definition pp_validation_process_error
(ppf : Stdlib.Format.formatter)
(function_parameter : validation_process_error) : unit :=
match function_parameter with
| Missing_handshake =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Missing handshake while initializing validation process." % string
CamlinternalFormatBasics.End_of_format)
"Missing handshake while initializing validation process." % string)
| Protocol_dynlink_failure msg =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) msg
| Inconsistent_handshake msg =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Inconsistent handshake: " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))
"Inconsistent handshake: %s." % string) msg
end.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition invalid_block
(block : Tezos_base__TzPervasives.Block_hash.t) (error : block_error)
: Tezos_base__TzPervasives.error :=
Tezos_base__TzPervasives.Invalid_block {| block := block; error := error |}.
src/lib_shell_services/block_validator_worker_state.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Request = struct
type view = {
chain_id : Chain_id.t;
block : Block_hash.t;
peer : P2p_peer.Id.t option;
}
let encoding =
let open Data_encoding in
conv
(fun {chain_id; block; peer} -> (block, chain_id, peer))
(fun (block, chain_id, peer) -> {chain_id; block; peer})
(obj3
(req "block" Block_hash.encoding)
(req "chain_id" Chain_id.encoding)
(opt "peer" P2p_peer.Id.encoding))
let pp ppf {chain_id; block; peer} =
Format.fprintf
ppf
"Validation of %a (chain: %a)"
Block_hash.pp
block
Chain_id.pp_short
chain_id ;
match peer with
| None ->
()
| Some peer ->
Format.fprintf ppf "from peer %a" P2p_peer.Id.pp_short peer
end
module Event = struct
type t =
| Validation_success of Request.view * Worker_types.request_status
| Validation_failure of
Request.view * Worker_types.request_status * error list
| Debug of string
let level req =
match req with
| Debug _ ->
Internal_event.Debug
| Validation_success _ | Validation_failure _ ->
Internal_event.Notice
let encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Debug"
(obj1 (req "message" string))
(function Debug msg -> Some msg | _ -> None)
(fun msg -> Debug msg);
case
(Tag 1)
~title:"Validation_success"
(obj2
(req "successful_validation" Request.encoding)
(req "status" Worker_types.request_status_encoding))
(function Validation_success (r, s) -> Some (r, s) | _ -> None)
(fun (r, s) -> Validation_success (r, s));
case
(Tag 2)
~title:"Validation_failure"
(obj3
(req "failed_validation" Request.encoding)
(req "status" Worker_types.request_status_encoding)
(dft "errors" RPC_error.encoding []))
(function
| Validation_failure (r, s, err) -> Some (r, s, err) | _ -> None)
(fun (r, s, err) -> Validation_failure (r, s, err)) ]
let pp ppf = function
| Debug msg ->
Format.fprintf ppf "%s" msg
| Validation_success (req, {pushed; treated; completed}) ->
Format.fprintf
ppf
"@[<v 0>Block %a successfully validated@,%a@]"
Block_hash.pp
req.block
Worker_types.pp_status
{pushed; treated; completed}
| Validation_failure (req, {pushed; treated; completed}, errs) ->
Format.fprintf
ppf
"@[<v 0>Validation of block %a failed@,%a, %a@]"
Block_hash.pp
req.block
Worker_types.pp_status
{pushed; treated; completed}
(Format.pp_print_list Error_monad.pp)
errs
end
module Worker_state = struct
type view = unit
let encoding = Data_encoding.empty
let pp _ppf _view = ()
end
src/lib_shell_services/block_validator_worker_state.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Request.
Record view := {
chain_id : Tezos_base__TzPervasives.Chain_id.t;
block : Tezos_base__TzPervasives.Block_hash.t;
peer : option Tezos_base__TzPervasives.P2p_peer.Id.t }.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
conv
(fun function_parameter =>
let '{| chain_id := chain_id; block := block; peer := peer |} :=
function_parameter in
(block, chain_id, peer))
(fun function_parameter =>
let '(block, chain_id, peer) := function_parameter in
{| chain_id := chain_id; block := block; peer := peer |}) None
(obj3 (req None None "block" % string Block_hash.encoding)
(req None None "chain_id" % string Chain_id.encoding)
(opt None None "peer" % string P2p_peer.Id.encoding)).
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : view)
: unit :=
let '{| chain_id := chain_id; block := block; peer := peer |} :=
function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Validation of " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (chain: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"Validation of %a (chain: %a)" % string) Block_hash.pp block
Chain_id.pp_short chain_id in
match peer with
| None => tt
| Some peer =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "from peer " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "from peer %a" % string)
P2p_peer.Id.pp_short peer
end.
End Request.
Module Event.
Inductive t : Type :=
| Validation_success : Request.view ->
Tezos_shell_services.Worker_types.request_status -> t
| Validation_failure : Request.view ->
Tezos_shell_services.Worker_types.request_status ->
(list Tezos_base__TzPervasives.error) -> t
| Debug : string -> t.
Definition level (req : t) : Tezos_base__TzPervasives.Internal_event.level :=
match req with
| Debug _ => Tezos_base__TzPervasives.Internal_event.Debug
| Validation_success _ _ | Validation_failure _ _ _ =>
Tezos_base__TzPervasives.Internal_event.Notice
end.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
union None
(cons
(case "Debug" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(obj1 (req None None "message" % string string))
(fun function_parameter =>
match function_parameter with
| Debug msg => Some msg
| _ => None
end) (fun msg => Debug msg))
(cons
(case "Validation_success" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj2
(req None None "successful_validation" % string Request.encoding)
(req None None "status" % string
Worker_types.request_status_encoding))
(fun function_parameter =>
match function_parameter with
| Validation_success r s => Some (r, s)
| _ => None
end)
(fun function_parameter =>
let '(r, s) := function_parameter in
Validation_success r s))
(cons
(case "Validation_failure" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 2)
(obj3
(req None None "failed_validation" % string Request.encoding)
(req None None "status" % string
Worker_types.request_status_encoding)
(dft None None "errors" % string RPC_error.encoding []))
(fun function_parameter =>
match function_parameter with
| Validation_failure r s err => Some (r, s, err)
| _ => None
end)
(fun function_parameter =>
let '(r, s, err) := function_parameter in
Validation_failure r s err)) []))).
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
match function_parameter with
| Debug msg =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) msg
|
Validation_success req {|
pushed := pushed; treated := treated; completed := completed |} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal "Block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" successfully validated" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 0>Block %a successfully validated@,%a@]" % string) Block_hash.pp
(block req) Worker_types.pp_status
{| pushed := pushed; treated := treated; completed := completed |}
|
Validation_failure req {|
pushed := pushed; treated := treated; completed := completed |} errs
=>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Validation of block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " failed" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ", " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[<v 0>Validation of block %a failed@,%a, %a@]" % string)
Block_hash.pp (block req) Worker_types.pp_status
{| pushed := pushed; treated := treated; completed := completed |}
(Format.pp_print_list None Error_monad.pp) errs
end.
End Event.
Module Worker_state.
Definition view := unit.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
Data_encoding.empty.
Definition pp {A B : Type} (_ppf : A) (_view : B) : unit := tt.
End Worker_state.
src/lib_shell_services/chain_services.ml 77 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Data_encoding
type chain = [`Main | `Test | `Hash of Chain_id.t]
let chain_arg = Block_services.chain_arg
let to_string = Block_services.chain_to_string
let parse_chain = Block_services.parse_chain
type invalid_block = {
hash : Block_hash.t;
level : Int32.t;
errors : error list;
}
type prefix = Block_services.chain_prefix
let path = Block_services.chain_path
let checkpoint_encoding =
obj4
(req "block" Block_header.encoding)
(req "save_point" int32)
(req "caboose" int32)
(req "history_mode" History_mode.encoding)
let invalid_block_encoding =
conv
(fun {hash; level; errors} -> (hash, level, errors))
(fun (hash, level, errors) -> {hash; level; errors})
(obj3
(req "block" Block_hash.encoding)
(req "level" int32)
(req "errors" RPC_error.encoding))
module S = struct
let path : prefix RPC_path.context = RPC_path.open_root
let chain_id =
RPC_service.get_service
~description:"The chain unique identifier."
~query:RPC_query.empty
~output:Chain_id.encoding
RPC_path.(path / "chain_id")
let checkpoint =
RPC_service.get_service
~description:"The current checkpoint for this chain."
~query:RPC_query.empty
~output:checkpoint_encoding
RPC_path.(path / "checkpoint")
module Blocks = struct
let list_query =
let open RPC_query in
query (fun length heads min_date ->
object
method length = length
method heads = heads
method min_date = min_date
end)
|+ opt_field
"length"
~descr:
"The requested number of predecessors to returns (per requested \
head)."
RPC_arg.int
(fun x -> x#length)
|+ multi_field
"head"
~descr:
"An empty argument requests blocks from the current heads. A non \
empty list allow to request specific fragment of the chain."
Block_hash.rpc_arg
(fun x -> x#heads)
|+ opt_field
"min_date"
~descr:
"When `min_date` is provided, heads with a timestamp before \
`min_date` are filtered out"
Time.Protocol.rpc_arg
(fun x -> x#min_date)
|> seal
let path = RPC_path.(path / "blocks")
let list =
let open Data_encoding in
RPC_service.get_service
~description:
"Lists known heads of the blockchain sorted with decreasing \
fitness. Optional arguments allows to returns the list of \
predecessors for known heads or the list of predecessors for a \
given list of blocks."
~query:list_query
~output:(list (list Block_hash.encoding))
path
end
module Invalid_blocks = struct
let path = RPC_path.(path / "invalid_blocks")
let list =
RPC_service.get_service
~description:
"Lists blocks that have been declared invalid along with the errors \
that led to them being declared invalid."
~query:RPC_query.empty
~output:(list invalid_block_encoding)
path
let get =
RPC_service.get_service
~description:"The errors that appears during the block (in)validation."
~query:RPC_query.empty
~output:invalid_block_encoding
RPC_path.(path /: Block_hash.rpc_arg)
let delete =
RPC_service.delete_service
~description:"Remove an invalid block for the tezos storage"
~query:RPC_query.empty
~output:Data_encoding.empty
RPC_path.(path /: Block_hash.rpc_arg)
end
end
let make_call0 s ctxt chain q p =
let s = RPC_service.prefix path s in
RPC_context.make_call1 s ctxt chain q p
let make_call1 s ctxt chain a q p =
let s = RPC_service.prefix path s in
RPC_context.make_call2 s ctxt chain a q p
let chain_id ctxt =
let f = make_call0 S.chain_id ctxt in
fun ?(chain = `Main) () ->
match chain with `Hash h -> return h | _ -> f chain () ()
let checkpoint ctxt ?(chain = `Main) () =
make_call0 S.checkpoint ctxt chain () ()
module Blocks = struct
let list ctxt =
let f = make_call0 S.Blocks.list ctxt in
fun ?(chain = `Main) ?(heads = []) ?length ?min_date () ->
f
chain
(object
method heads = heads
method length = length
method min_date = min_date
end)
()
include Block_services.Empty
type protocols = Block_services.protocols = {
current_protocol : Protocol_hash.t;
next_protocol : Protocol_hash.t;
}
let protocols = Block_services.protocols
end
module Mempool = Block_services.Empty.Mempool
module Invalid_blocks = struct
let list ctxt =
let f = make_call0 S.Invalid_blocks.list ctxt in
fun ?(chain = `Main) () -> f chain () ()
let get ctxt =
let f = make_call1 S.Invalid_blocks.get ctxt in
fun ?(chain = `Main) block -> f chain block () ()
let delete ctxt =
let f = make_call1 S.Invalid_blocks.delete ctxt in
fun ?(chain = `Main) block -> f chain block () ()
end
src/lib_shell_services/chain_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Data_encoding.
Definition chain := variant.
Definition chain_arg
: Tezos_base__TzPervasives.RPC_arg.t Tezos_shell_services.Block_services.chain :=
Block_services.chain_arg.
Definition to_string : Tezos_shell_services.Block_services.chain -> string :=
Block_services.chain_to_string.
Definition parse_chain
: string -> sum Tezos_shell_services.Block_services.chain string :=
Block_services.parse_chain.
Record invalid_block := {
hash : Tezos_base__TzPervasives.Block_hash.t;
level : Stdlib.Int32.t;
errors : list Tezos_base__TzPervasives.error }.
Definition prefix := Tezos_shell_services.Block_services.chain_prefix.
Definition path
: Tezos_base__TzPervasives.RPC_path.t unit
Tezos_shell_services.Block_services.chain_prefix :=
Block_services.chain_path.
Definition checkpoint_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
(Tezos_base__TzPervasives.Block_header.t * int32 * int32 *
Tezos_shell_services.History_mode.t) :=
obj4 (req None None "block" % string Block_header.encoding)
(req None None "save_point" % string int32)
(req None None "caboose" % string int32)
(req None None "history_mode" % string History_mode.encoding).
Definition invalid_block_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding invalid_block :=
conv
(fun function_parameter =>
let '{| hash := hash; level := level; errors := errors |} :=
function_parameter in
(hash, level, errors))
(fun function_parameter =>
let '(hash, level, errors) := function_parameter in
{| hash := hash; level := level; errors := errors |}) None
(obj3 (req None None "block" % string Block_hash.encoding)
(req None None "level" % string int32)
(req None None "errors" % string RPC_error.encoding)).
Module S.
Definition path : Tezos_base__TzPervasives.RPC_path.context prefix :=
RPC_path.open_root.
Definition chain_id
: Tezos_base__TzPervasives.RPC_service.service variant prefix prefix unit
unit Tezos_base__TzPervasives.Chain_id.t :=
RPC_service.get_service (Some "The chain unique identifier." % string)
RPC_query.empty Chain_id.encoding (op_div path "chain_id" % string).
Definition checkpoint
: Tezos_base__TzPervasives.RPC_service.service variant prefix prefix unit
unit
(Tezos_base__TzPervasives.Block_header.t * int32 * int32 *
Tezos_shell_services.History_mode.t) :=
RPC_service.get_service
(Some "The current checkpoint for this chain." % string) RPC_query.empty
checkpoint_encoding (op_div path "checkpoint" % string).
Module Blocks.
Definition list_query
: Tezos_base__TzPervasives.RPC_query.t
(((option Z) *
((list Tezos_base__TzPervasives.Block_hash.t) *
((option Tezos_base__TzPervasives.Time.Protocol.t) * nil)))) :=
OCaml.Stdlib.reverse_apply
(op_pipeplus
(op_pipeplus
(op_pipeplus
(query
(fun length =>
fun heads =>
fun min_date =>
(* ❌ Creation of objects is not handled *)
object))
(opt_field
(Some
"The requested number of predecessors to returns (per requested head)."
% string) "length" % string RPC_arg.int
(fun x =>
(* ❌ Sending method message is not handled *)
send)))
(multi_field
(Some
"An empty argument requests blocks from the current heads. A non empty list allow to request specific fragment of the chain."
% string) "head" % string Block_hash.rpc_arg
(fun x =>
(* ❌ Sending method message is not handled *)
send)))
(opt_field
(Some
"When `min_date` is provided, heads with a timestamp before `min_date` are filtered out"
% string) "min_date" % string Time.Protocol.rpc_arg
(fun x =>
(* ❌ Sending method message is not handled *)
send))) seal.
Definition path : Tezos_base__TzPervasives.RPC_path.path prefix prefix :=
op_div path "blocks" % string.
Definition list
: Tezos_base__TzPervasives.RPC_service.service variant prefix prefix
(((option Z) *
((list Tezos_base__TzPervasives.Block_hash.t) *
((option Tezos_base__TzPervasives.Time.Protocol.t) * nil)))) unit
(list (list Tezos_base__TzPervasives.Block_hash.t)) :=
RPC_service.get_service
(Some
"Lists known heads of the blockchain sorted with decreasing fitness. Optional arguments allows to returns the list of predecessors for known heads or the list of predecessors for a given list of blocks."
% string) list_query (list None (list None Block_hash.encoding))
path.
End Blocks.
Module Invalid_blocks.
Definition path : Tezos_base__TzPervasives.RPC_path.path prefix prefix :=
op_div path "invalid_blocks" % string.
Definition list
: Tezos_base__TzPervasives.RPC_service.service variant prefix prefix unit
unit (list invalid_block) :=
RPC_service.get_service
(Some
"Lists blocks that have been declared invalid along with the errors that led to them being declared invalid."
% string) RPC_query.empty (list None invalid_block_encoding) path.
Definition get
: Tezos_base__TzPervasives.RPC_service.service variant prefix
(prefix * Tezos_base__TzPervasives.Block_hash.t) unit unit invalid_block :=
RPC_service.get_service
(Some
"The errors that appears during the block (in)validation." % string)
RPC_query.empty invalid_block_encoding
(op_divcolon path Block_hash.rpc_arg).
Definition delete
: Tezos_base__TzPervasives.RPC_service.service variant prefix
(prefix * Tezos_base__TzPervasives.Block_hash.t) unit unit unit :=
RPC_service.delete_service
(Some "Remove an invalid block for the tezos storage" % string)
RPC_query.empty Data_encoding.empty
(op_divcolon path Block_hash.rpc_arg).
End Invalid_blocks.
End S.
Definition make_call0 {A B C D I J i o p q : Type}
(s :
Tezos_base__TzPervasives.RPC_service.raw variant
Tezos_shell_services.Block_services.chain_prefix (unit * A) B C D
Tezos_rpc.RPC_service.error)
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(I * p * q * i * o)) * J) * J) (chain : A) (q : B) (p : C)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult D) :=
let s := RPC_service.prefix path s in
RPC_context.make_call1 s ctxt chain q p.
Definition make_call1 {A B C D E J K i o p q : Type}
(s :
Tezos_base__TzPervasives.RPC_service.raw variant
Tezos_shell_services.Block_services.chain_prefix ((unit * A) * B) C D E
Tezos_rpc.RPC_service.error)
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(J * p * q * i * o)) * K) * K) (chain : A) (a : B) (q : C) (p : D)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult E) :=
let s := RPC_service.prefix path s in
RPC_context.make_call2 s ctxt chain a q p.
Definition chain_id {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: (option variant) ->
unit ->
Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Chain_id.t) :=
let f := make_call0 S.chain_id ctxt in
fun op_staroptstar =>
let chain :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun function_parameter =>
let 'tt := function_parameter in
match chain with
| Hash h => _return h
| _ => f chain tt tt
end.
Definition checkpoint {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F) (op_staroptstar : option variant)
: unit ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(Tezos_base__TzPervasives.Block_header.t * int32 * int32 *
Tezos_shell_services.History_mode.t)) :=
let chain :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun function_parameter =>
let 'tt := function_parameter in
make_call0 S.checkpoint ctxt chain tt tt.
Module Blocks.
Definition list {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: (option variant) ->
(option (list Tezos_base__TzPervasives.Block_hash.t)) ->
(option Z) ->
(option Tezos_base__TzPervasives.Time.Protocol.t) ->
unit ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(list (list Tezos_base__TzPervasives.Block_hash.t))) :=
let f := make_call0 S.Blocks.list ctxt in
fun op_staroptstar =>
let chain :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun op_staroptstar =>
let heads :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun length =>
fun min_date =>
fun function_parameter =>
let 'tt := function_parameter in
f chain
(* ❌ Creation of objects is not handled *)
object tt.
(* ❌ Structure item `include` not handled. *)
include
Record protocols := {
current_protocol : Tezos_base__TzPervasives.Protocol_hash.t;
next_protocol : Tezos_base__TzPervasives.Protocol_hash.t }.
Definition protocols {E F i o p q : Type}
: (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F) ->
(option Tezos_shell_services.Block_services.chain) ->
(option Tezos_shell_services.Block_services.block) ->
unit ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_shell_services.Block_services.protocols) :=
Block_services.protocols.
End Blocks.
(* ❌ This kind of module is not handled. *)
unhandled_module
Module Invalid_blocks.
Definition list {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: (option variant) ->
unit ->
Lwt.t (Tezos_error_monad.Error_monad.tzresult (list invalid_block)) :=
let f := make_call0 S.Invalid_blocks.list ctxt in
fun op_staroptstar =>
let chain :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun function_parameter =>
let 'tt := function_parameter in
f chain tt tt.
Definition get {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: (option Tezos_shell_services.Block_services.chain) ->
Tezos_base__TzPervasives.Block_hash.t ->
Lwt.t (Tezos_error_monad.Error_monad.tzresult invalid_block) :=
let f := make_call1 S.Invalid_blocks.get ctxt in
fun op_staroptstar =>
let chain :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun block => f chain block tt tt.
Definition delete {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: (option Tezos_shell_services.Block_services.chain) ->
Tezos_base__TzPervasives.Block_hash.t ->
Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
let f := make_call1 S.Invalid_blocks.delete ctxt in
fun op_staroptstar =>
let chain :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun block => f chain block tt tt.
End Invalid_blocks.
src/lib_shell_services/chain_validator_worker_state.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Request = struct
type view = Block_hash.t
let encoding = Block_hash.encoding
let pp = Block_hash.pp
end
module Event = struct
type update = Ignored_head | Branch_switch | Head_increment
type t =
| Processed_block of {
request : Request.view;
request_status : Worker_types.request_status;
update : update;
fitness : Fitness.t;
}
| Could_not_switch_testchain of error list
let level = function
| Processed_block req -> (
match req.update with
| Ignored_head ->
Internal_event.Info
| Branch_switch | Head_increment ->
Internal_event.Notice )
| Could_not_switch_testchain _ ->
Internal_event.Error
let encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Processed_block"
(obj4
(req "request" Request.encoding)
(req "status" Worker_types.request_status_encoding)
(req
"outcome"
(string_enum
[ ("ignored", Ignored_head);
("branch", Branch_switch);
("increment", Head_increment) ]))
(req "fitness" Fitness.encoding))
(function
| Processed_block {request; request_status; update; fitness} ->
Some (request, request_status, update, fitness)
| _ ->
None)
(fun (request, request_status, update, fitness) ->
Processed_block {request; request_status; update; fitness});
case
(Tag 1)
~title:"Could_not_switch_testchain"
RPC_error.encoding
(function Could_not_switch_testchain err -> Some err | _ -> None)
(fun err -> Could_not_switch_testchain err) ]
let pp ppf = function
| Processed_block req ->
Format.fprintf ppf "@[<v 0>" ;
( match req.update with
| Ignored_head ->
Format.fprintf
ppf
"Current head is better than %a (fitness %a), we do not switch@,"
| Branch_switch ->
Format.fprintf
ppf
"Update current head to %a (fitness %a), changing branch@,"
| Head_increment ->
Format.fprintf
ppf
"Update current head to %a (fitness %a), same branch@," )
Request.pp
req.request
Fitness.pp
req.fitness ;
Format.fprintf ppf "%a@]" Worker_types.pp_status req.request_status
| Could_not_switch_testchain err ->
Format.fprintf
ppf
"@[<v 0>Error while switching test chain:@ %a@]"
(Format.pp_print_list Error_monad.pp)
err
end
module Worker_state = struct
type view = {
active_peers : P2p_peer.Id.t list;
bootstrapped_peers : P2p_peer.Id.t list;
bootstrapped : bool;
}
let encoding =
let open Data_encoding in
conv
(fun {bootstrapped; bootstrapped_peers; active_peers} ->
(bootstrapped, bootstrapped_peers, active_peers))
(fun (bootstrapped, bootstrapped_peers, active_peers) ->
{bootstrapped; bootstrapped_peers; active_peers})
(obj3
(req "bootstrapped" bool)
(req "bootstrapped_peers" (list P2p_peer.Id.encoding))
(req "active_peers" (list P2p_peer.Id.encoding)))
let pp ppf {bootstrapped; bootstrapped_peers; active_peers} =
Format.fprintf
ppf
"@[<v 0>Network is%s bootstrapped.@,\
@[<v 2>Active peers:%a@]@,\
@[<v 2>Bootstrapped peers:%a@]@]"
(if bootstrapped then "" else " not yet")
(fun ppf -> List.iter (Format.fprintf ppf "@,- %a" P2p_peer.Id.pp))
active_peers
(fun ppf -> List.iter (Format.fprintf ppf "@,- %a" P2p_peer.Id.pp))
bootstrapped_peers
end
module Distributed_db_state = struct
type table_scheduler = {table_length : int; scheduler_length : int}
type view = {
p2p_readers_length : int;
active_chains_length : int;
operation_db : table_scheduler;
operations_db : table_scheduler;
block_header_db : table_scheduler;
operations_hashed_db : table_scheduler;
active_connections_length : int;
active_peers_length : int;
}
let table_scheduler_encoding =
let open Data_encoding in
conv
(fun {table_length; scheduler_length} ->
(table_length, scheduler_length))
(fun (table_length, scheduler_length) ->
{table_length; scheduler_length})
(obj2 (req "table_length" int31) (req "scheduler_length" int31))
let encoding =
let open Data_encoding in
conv
(fun { p2p_readers_length;
active_chains_length;
operation_db;
operations_db;
block_header_db;
operations_hashed_db;
active_connections_length;
active_peers_length } ->
( p2p_readers_length,
active_chains_length,
operation_db,
operations_db,
block_header_db,
operations_hashed_db,
active_connections_length,
active_peers_length ))
(fun ( p2p_readers_length,
active_chains_length,
operation_db,
operations_db,
block_header_db,
operations_hashed_db,
active_connections_length,
active_peers_length ) ->
{
p2p_readers_length;
active_chains_length;
operation_db;
operations_db;
block_header_db;
operations_hashed_db;
active_connections_length;
active_peers_length;
})
(obj8
(req "p2p_readers" int31)
(req "active_chains" int31)
(req "operation_db" table_scheduler_encoding)
(req "operations_db" table_scheduler_encoding)
(req "block_header_db" table_scheduler_encoding)
(req "operations_hashed_db" table_scheduler_encoding)
(req "active_connections" int31)
(req "active_peers" int31))
end
src/lib_shell_services/chain_validator_worker_state.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Request.
Definition view := Tezos_base__TzPervasives.Block_hash.t.
Definition encoding
: Tezos_data_encoding.Data_encoding.t Tezos_base__TzPervasives.Block_hash.t :=
Block_hash.encoding.
Definition pp
: Stdlib.Format.formatter -> Tezos_base__TzPervasives.Block_hash.t -> unit :=
Block_hash.pp.
End Request.
Module Event.
Inductive update : Type :=
| Ignored_head : update
| Branch_switch : update
| Head_increment : update.
Inductive t : Type :=
| Processed_block : Request.view ->
Tezos_shell_services.Worker_types.request_status -> update ->
Tezos_base__TzPervasives.Fitness.t -> t
| Could_not_switch_testchain : (list Tezos_base__TzPervasives.error) -> t.
Definition level (function_parameter : t)
: Tezos_base__TzPervasives.Internal_event.level :=
match function_parameter with
| Processed_block req =>
match update req with
| Ignored_head => Tezos_base__TzPervasives.Internal_event.Info
| Branch_switch | Head_increment =>
Tezos_base__TzPervasives.Internal_event.Notice
end
| Could_not_switch_testchain _ =>
Tezos_base__TzPervasives.Internal_event.Error
end.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
union None
(cons
(case "Processed_block" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(obj4 (req None None "request" % string Request.encoding)
(req None None "status" % string
Worker_types.request_status_encoding)
(req None None "outcome" % string
(string_enum
(cons ("ignored" % string, Ignored_head)
(cons ("branch" % string, Branch_switch)
(cons ("increment" % string, Head_increment) [])))))
(req None None "fitness" % string Fitness.encoding))
(fun function_parameter =>
match function_parameter with
|
Processed_block {|
request := request;
request_status := request_status;
update := update;
fitness := fitness
|} => Some (request, request_status, update, fitness)
| _ => None
end)
(fun function_parameter =>
let '(request, request_status, update, fitness) :=
function_parameter in
Processed_block
{| request := request; request_status := request_status;
update := update; fitness := fitness |}))
(cons
(case "Could_not_switch_testchain" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1) RPC_error.encoding
(fun function_parameter =>
match function_parameter with
| Could_not_switch_testchain err => Some err
| _ => None
end) (fun err => Could_not_switch_testchain err)) [])).
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
match function_parameter with
| Processed_block req =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match update req with
| Ignored_head =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Current head is better than " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (fitness " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"), we do not switch" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format))))))
"Current head is better than %a (fitness %a), we do not switch@,"
% string)
| Branch_switch =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Update current head to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (fitness " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"), changing branch" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format))))))
"Update current head to %a (fitness %a), changing branch@," %
string)
| Head_increment =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Update current head to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (fitness " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"), same branch" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format))))))
"Update current head to %a (fitness %a), same branch@," % string)
end Request.pp (request req) Fitness.pp (fitness req) in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)) "%a@]" % string)
Worker_types.pp_status (request_status req)
| Could_not_switch_testchain err =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Error while switching test chain:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 0>Error while switching test chain:@ %a@]" % string)
(Format.pp_print_list None Error_monad.pp) err
end.
End Event.
Module Worker_state.
Record view := {
active_peers : list Tezos_base__TzPervasives.P2p_peer.Id.t;
bootstrapped_peers : list Tezos_base__TzPervasives.P2p_peer.Id.t;
bootstrapped : bool }.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
conv
(fun function_parameter =>
let '{|
active_peers := active_peers;
bootstrapped_peers := bootstrapped_peers;
bootstrapped := bootstrapped
|} := function_parameter in
(bootstrapped, bootstrapped_peers, active_peers))
(fun function_parameter =>
let '(bootstrapped, bootstrapped_peers, active_peers) :=
function_parameter in
{| active_peers := active_peers;
bootstrapped_peers := bootstrapped_peers; bootstrapped := bootstrapped
|}) None
(obj3 (req None None "bootstrapped" % string bool)
(req None None "bootstrapped_peers" % string
(list None P2p_peer.Id.encoding))
(req None None "active_peers" % string (list None P2p_peer.Id.encoding))).
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : view)
: unit :=
let '{|
active_peers := active_peers;
bootstrapped_peers := bootstrapped_peers;
bootstrapped := bootstrapped
|} := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal "Network is" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " bootstrapped." % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Active peers:" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Bootstrapped peers:" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))))
"@[<v 0>Network is%s bootstrapped.@,@[<v 2>Active peers:%a@]@,@[<v 2>Bootstrapped peers:%a@]@]"
% string)
(if bootstrapped then
"" % string
else
" not yet" % string)
(fun ppf =>
List.iter
(Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "- " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))) "@,- %a" % string)
P2p_peer.Id.pp)) active_peers
(fun ppf =>
List.iter
(Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "- " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))) "@,- %a" % string)
P2p_peer.Id.pp)) bootstrapped_peers.
End Worker_state.
Module Distributed_db_state.
Record table_scheduler := {
table_length : Z;
scheduler_length : Z }.
Record view := {
p2p_readers_length : Z;
active_chains_length : Z;
operation_db : table_scheduler;
operations_db : table_scheduler;
block_header_db : table_scheduler;
operations_hashed_db : table_scheduler;
active_connections_length : Z;
active_peers_length : Z }.
Definition table_scheduler_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding table_scheduler :=
conv
(fun function_parameter =>
let '{|
table_length := table_length;
scheduler_length := scheduler_length
|} := function_parameter in
(table_length, scheduler_length))
(fun function_parameter =>
let '(table_length, scheduler_length) := function_parameter in
{| table_length := table_length; scheduler_length := scheduler_length |})
None
(obj2 (req None None "table_length" % string int31)
(req None None "scheduler_length" % string int31)).
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
conv
(fun function_parameter =>
let '{|
p2p_readers_length := p2p_readers_length;
active_chains_length := active_chains_length;
operation_db := operation_db;
operations_db := operations_db;
block_header_db := block_header_db;
operations_hashed_db := operations_hashed_db;
active_connections_length := active_connections_length;
active_peers_length := active_peers_length
|} := function_parameter in
(p2p_readers_length, active_chains_length, operation_db, operations_db,
block_header_db, operations_hashed_db, active_connections_length,
active_peers_length))
(fun function_parameter =>
let
'(p2p_readers_length, active_chains_length, operation_db,
operations_db, block_header_db, operations_hashed_db,
active_connections_length, active_peers_length) :=
function_parameter in
{| p2p_readers_length := p2p_readers_length;
active_chains_length := active_chains_length;
operation_db := operation_db; operations_db := operations_db;
block_header_db := block_header_db;
operations_hashed_db := operations_hashed_db;
active_connections_length := active_connections_length;
active_peers_length := active_peers_length |}) None
(obj8 (req None None "p2p_readers" % string int31)
(req None None "active_chains" % string int31)
(req None None "operation_db" % string table_scheduler_encoding)
(req None None "operations_db" % string table_scheduler_encoding)
(req None None "block_header_db" % string table_scheduler_encoding)
(req None None "operations_hashed_db" % string table_scheduler_encoding)
(req None None "active_connections" % string int31)
(req None None "active_peers" % string int31)).
End Distributed_db_state.
src/lib_shell_services/connection_metadata.ml success
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {disable_mempool : bool; private_node : bool}
let encoding =
let open Data_encoding in
(conv
(fun {disable_mempool; private_node} -> (disable_mempool, private_node))
(fun (disable_mempool, private_node) -> {disable_mempool; private_node}))
(obj2 (req "disable_mempool" bool) (req "private_node" bool))
let pp _ppf _ = ()
src/lib_shell_services/connection_metadata.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record t := {
disable_mempool : bool;
private_node : bool }.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
(conv
(fun function_parameter =>
let '{|
disable_mempool := disable_mempool; private_node := private_node |} :=
function_parameter in
(disable_mempool, private_node))
(fun function_parameter =>
let '(disable_mempool, private_node) := function_parameter in
{| disable_mempool := disable_mempool; private_node := private_node |}))
None
(obj2 (req None None "disable_mempool" % string bool)
(req None None "private_node" % string bool)).
Definition pp {A B : Type} (_ppf : A) (function_parameter : B) : unit :=
let '_ := function_parameter in
tt.
src/lib_shell_services/history_mode.ml success
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs. <contact@tezcore.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = Archive | Full | Rolling
let encoding =
Data_encoding.string_enum
[("archive", Archive); ("full", Full); ("rolling", Rolling)]
let equal hm1 hm2 =
match (hm1, hm2) with
| (Archive, Archive) | (Full, Full) | (Rolling, Rolling) ->
true
| (Archive, _) | (Full, _) | (Rolling, _) ->
false
let pp ppf = function
| Archive ->
Format.fprintf ppf "archive"
| Full ->
Format.fprintf ppf "full"
| Rolling ->
Format.fprintf ppf "rolling"
let tag = Tag.def "history_mode" pp
src/lib_shell_services/history_mode.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive t : Type :=
| Archive : t
| Full : t
| Rolling : t.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
Data_encoding.string_enum
(cons ("archive" % string, Archive)
(cons ("full" % string, Full) (cons ("rolling" % string, Rolling) []))).
Definition equal (hm1 : t) (hm2 : t) : bool :=
match (hm1, hm2) with
| (Archive, Archive) | (Full, Full) | (Rolling, Rolling) => true
| (Archive, _) | (Full, _) | (Rolling, _) => false
end.
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
match function_parameter with
| Archive =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "archive" % string
CamlinternalFormatBasics.End_of_format) "archive" % string)
| Full =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "full" % string
CamlinternalFormatBasics.End_of_format) "full" % string)
| Rolling =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "rolling" % string
CamlinternalFormatBasics.End_of_format) "rolling" % string)
end.
Definition tag : Tezos_base__TzPervasives.Tag.def t :=
Tag.def None "history_mode" % string pp.
src/lib_shell_services/injection_services.ml 51 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module S = struct
open Data_encoding
let path = RPC_path.(root / "injection")
let block_query =
let open RPC_query in
query (fun async force chain ->
object
method async = async
method force = force
method chain = chain
end)
|+ flag "async" (fun t -> t#async)
|+ flag "force" (fun t -> t#force)
|+ opt_field "chain" Chain_services.chain_arg (fun t -> t#chain)
|> seal
let block_param =
obj2
(req "data" bytes)
(req
"operations"
(list (dynamic_size (list (dynamic_size Operation.encoding)))))
let block =
RPC_service.post_service
~description:
"Inject a block in the node and broadcast it. The `operations` \
embedded in `blockHeader` might be pre-validated using a contextual \
RPCs from the latest block (e.g. '/blocks/head/context/preapply'). \
Returns the ID of the block. By default, the RPC will wait for the \
block to be validated before answering. If ?async is true, the \
function returns immediately. Otherwise, the block will be validated \
before the result is returned. If ?force is true, it will be \
injected even on non strictly increasing fitness. An optional ?chain \
parameter can be used to specify whether to inject on the test chain \
or the main chain."
~query:block_query
~input:block_param
~output:Block_hash.encoding
RPC_path.(path / "block")
let operation_query =
let open RPC_query in
query (fun async chain ->
object
method async = async
method chain = chain
end)
|+ flag "async" (fun t -> t#async)
|+ opt_field "chain" Chain_services.chain_arg (fun t -> t#chain)
|> seal
let operation =
RPC_service.post_service
~description:
"Inject an operation in node and broadcast it. Returns the ID of the \
operation. The `signedOperationContents` should be constructed using \
a contextual RPCs from the latest block and signed by the client. By \
default, the RPC will wait for the operation to be (pre-)validated \
before answering. See RPCs under /blocks/prevalidation for more \
details on the prevalidation context. If ?async is true, the \
function returns immediately. Otherwise, the operation will be \
validated before the result is returned. An optional ?chain \
parameter can be used to specify whether to inject on the test chain \
or the main chain."
~query:operation_query
~input:bytes
~output:Operation_hash.encoding
RPC_path.(path / "operation")
let protocol_query =
let open RPC_query in
query (fun async ->
object
method async = async
end)
|+ flag "async" (fun t -> t#async)
|> seal
let protocol =
RPC_service.post_service
~description:
"Inject a protocol in node. Returns the ID of the protocol. If ?async \
is true, the function returns immediately. Otherwise, the protocol \
will be validated before the result is returned."
~query:protocol_query
~input:Protocol.encoding
~output:Protocol_hash.encoding
RPC_path.(path / "protocol")
end
open RPC_context
let block ctxt ?(async = false) ?(force = false) ?chain raw operations =
make_call
S.block
ctxt
()
(object
method async = async
method force = force
method chain = chain
end)
(raw, operations)
let operation ctxt ?(async = false) ?chain operation =
make_call
S.operation
ctxt
()
(object
method async = async
method chain = chain
end)
operation
let protocol ctxt ?(async = false) protocol =
make_call
S.protocol
ctxt
()
(object
method async = async
end)
protocol
src/lib_shell_services/injection_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module S.
Import Data_encoding.
Definition path : Tezos_base__TzPervasives.RPC_path.path unit unit :=
op_div root "injection" % string.
Definition block_query
: Tezos_base__TzPervasives.RPC_query.t
((bool *
(bool * ((option Tezos_shell_services.Chain_services.chain) * nil)))) :=
OCaml.Stdlib.reverse_apply
(op_pipeplus
(op_pipeplus
(op_pipeplus
(query
(fun async =>
fun force =>
fun chain =>
(* ❌ Creation of objects is not handled *)
object))
(flag None "async" % string
(fun t =>
(* ❌ Sending method message is not handled *)
send)))
(flag None "force" % string
(fun t =>
(* ❌ Sending method message is not handled *)
send)))
(opt_field None "chain" % string Chain_services.chain_arg
(fun t =>
(* ❌ Sending method message is not handled *)
send))) seal.
Definition block_param
: Tezos_base__TzPervasives.Data_encoding.encoding
(Stdlib.Bytes.t * (list (list Tezos_base__TzPervasives.Operation.t))) :=
obj2 (req None None "data" % string bytes)
(req None None "operations" % string
(list None
(dynamic_size None (list None (dynamic_size None Operation.encoding))))).
Definition block
: Tezos_base__TzPervasives.RPC_service.service variant unit unit
((bool *
(bool * ((option Tezos_shell_services.Chain_services.chain) * nil))))
(Stdlib.Bytes.t * (list (list Tezos_base__TzPervasives.Operation.t)))
Tezos_base__TzPervasives.Block_hash.t :=
RPC_service.post_service
(Some
"Inject a block in the node and broadcast it. The `operations` embedded in `blockHeader` might be pre-validated using a contextual RPCs from the latest block (e.g. '/blocks/head/context/preapply'). Returns the ID of the block. By default, the RPC will wait for the block to be validated before answering. If ?async is true, the function returns immediately. Otherwise, the block will be validated before the result is returned. If ?force is true, it will be injected even on non strictly increasing fitness. An optional ?chain parameter can be used to specify whether to inject on the test chain or the main chain."
% string) block_query block_param Block_hash.encoding
(op_div path "block" % string).
Definition operation_query
: Tezos_base__TzPervasives.RPC_query.t
((bool * ((option Tezos_shell_services.Chain_services.chain) * nil))) :=
OCaml.Stdlib.reverse_apply
(op_pipeplus
(op_pipeplus
(query
(fun async =>
fun chain =>
(* ❌ Creation of objects is not handled *)
object))
(flag None "async" % string
(fun t =>
(* ❌ Sending method message is not handled *)
send)))
(opt_field None "chain" % string Chain_services.chain_arg
(fun t =>
(* ❌ Sending method message is not handled *)
send))) seal.
Definition operation
: Tezos_base__TzPervasives.RPC_service.service variant unit unit
((bool * ((option Tezos_shell_services.Chain_services.chain) * nil)))
Stdlib.Bytes.t Tezos_base__TzPervasives.Operation_hash.t :=
RPC_service.post_service
(Some
"Inject an operation in node and broadcast it. Returns the ID of the operation. The `signedOperationContents` should be constructed using a contextual RPCs from the latest block and signed by the client. By default, the RPC will wait for the operation to be (pre-)validated before answering. See RPCs under /blocks/prevalidation for more details on the prevalidation context. If ?async is true, the function returns immediately. Otherwise, the operation will be validated before the result is returned. An optional ?chain parameter can be used to specify whether to inject on the test chain or the main chain."
% string) operation_query bytes Operation_hash.encoding
(op_div path "operation" % string).
Definition protocol_query
: Tezos_base__TzPervasives.RPC_query.t ((bool * nil)) :=
OCaml.Stdlib.reverse_apply
(op_pipeplus
(query
(fun async =>
(* ❌ Creation of objects is not handled *)
object))
(flag None "async" % string
(fun t =>
(* ❌ Sending method message is not handled *)
send))) seal.
Definition protocol
: Tezos_base__TzPervasives.RPC_service.service variant unit unit
((bool * nil)) Tezos_base__TzPervasives.Protocol.t
Tezos_base__TzPervasives.Protocol_hash.t :=
RPC_service.post_service
(Some
"Inject a protocol in node. Returns the ID of the protocol. If ?async is true, the function returns immediately. Otherwise, the protocol will be validated before the result is returned."
% string) protocol_query Protocol.encoding Protocol_hash.encoding
(op_div path "protocol" % string).
End S.
Import RPC_context.
Definition block {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F) (op_staroptstar : option bool)
: (option bool) ->
(option Tezos_shell_services.Chain_services.chain) ->
Stdlib.Bytes.t ->
(list (list Tezos_base__TzPervasives.Operation.t)) ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
Tezos_base__TzPervasives.Block_hash.t) :=
let async :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun op_staroptstar =>
let force :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun chain =>
fun raw =>
fun operations =>
make_call S.block ctxt tt
(* ❌ Creation of objects is not handled *)
object (raw, operations).
Definition operation {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F) (op_staroptstar : option bool)
: (option Tezos_shell_services.Chain_services.chain) ->
Stdlib.Bytes.t ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
Tezos_base__TzPervasives.Operation_hash.t) :=
let async :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun chain =>
fun operation =>
make_call S.operation ctxt tt
(* ❌ Creation of objects is not handled *)
object operation.
Definition protocol {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F) (op_staroptstar : option bool)
: Tezos_base__TzPervasives.Protocol.t ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
Tezos_base__TzPervasives.Protocol_hash.t) :=
let async :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun protocol =>
make_call S.protocol ctxt tt
(* ❌ Creation of objects is not handled *)
object protocol.
src/lib_shell_services/monitor_services.ml 63 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type chain_status =
| Active_main of Chain_id.t
| Active_test of {
chain : Chain_id.t;
protocol : Protocol_hash.t;
expiration_date : Time.Protocol.t;
}
| Stopping of Chain_id.t
let chain_status_encoding =
let open Data_encoding in
union
~tag_size:`Uint8
[ case
(Tag 0)
~title:"Main"
(obj1 (req "chain_id" Chain_id.encoding))
(function Active_main chain_id -> Some chain_id | _ -> None)
(fun chain_id -> Active_main chain_id);
case
(Tag 1)
~title:"Test"
(obj3
(req "chain_id" Chain_id.encoding)
(req "test_protocol" Protocol_hash.encoding)
(req "expiration_date" Time.Protocol.encoding))
(function
| Active_test {chain; protocol; expiration_date} ->
Some (chain, protocol, expiration_date)
| _ ->
None)
(fun (chain, protocol, expiration_date) ->
Active_test {chain; protocol; expiration_date});
case
(Tag 2)
~title:"Stopping"
(obj1 (req "stopping" Chain_id.encoding))
(function Stopping chain_id -> Some chain_id | _ -> None)
(fun chain_id -> Stopping chain_id) ]
module S = struct
open Data_encoding
let path = RPC_path.(root / "monitor")
let bootstrapped =
RPC_service.get_service
~description:
"Wait for the node to have synchronized its chain with a few peers \
(configured by the node's administrator), streaming head updates \
that happen during the bootstrapping process, and closing the stream \
at the end. If the node was already bootstrapped, returns the \
current head immediately."
~query:RPC_query.empty
~output:
(obj2
(req "block" Block_hash.encoding)
(req "timestamp" Time.Protocol.encoding))
RPC_path.(path / "bootstrapped")
let valid_blocks_query =
let open RPC_query in
query (fun protocols next_protocols chains ->
object
method protocols = protocols
method next_protocols = next_protocols
method chains = chains
end)
|+ multi_field "protocol" Protocol_hash.rpc_arg (fun t -> t#protocols)
|+ multi_field "next_protocol" Protocol_hash.rpc_arg (fun t ->
t#next_protocols)
|+ multi_field "chain" Chain_services.chain_arg (fun t -> t#chains)
|> seal
let valid_blocks =
RPC_service.get_service
~description:
"Monitor all blocks that are successfully validated by the node, \
disregarding whether they were selected as the new head or not."
~query:valid_blocks_query
~output:
(merge_objs
(obj2
(req "chain_id" Chain_id.encoding)
(req "hash" Block_hash.encoding))
Block_header.encoding)
RPC_path.(path / "valid_blocks")
let heads_query =
let open RPC_query in
query (fun next_protocols ->
object
method next_protocols = next_protocols
end)
|+ multi_field "next_protocol" Protocol_hash.rpc_arg (fun t ->
t#next_protocols)
|> seal
let heads =
RPC_service.get_service
~description:
"Monitor all blocks that are successfully validated by the node and \
selected as the new head of the given chain."
~query:heads_query
~output:
(merge_objs
(obj1 (req "hash" Block_hash.encoding))
Block_header.encoding)
RPC_path.(path / "heads" /: Chain_services.chain_arg)
let protocols =
RPC_service.get_service
~description:
"Monitor all economic protocols that are retrieved and successfully \
loaded and compiled by the node."
~query:RPC_query.empty
~output:Protocol_hash.encoding
RPC_path.(path / "protocols")
let commit_hash =
RPC_service.get_service
~description:"Get information on the build of the node."
~query:RPC_query.empty
~output:string
RPC_path.(path / "commit_hash")
let active_chains =
RPC_service.get_service
~description:
"Monitor every chain creation and destruction. Currently active \
chains will be given as first elements"
~query:RPC_query.empty
~output:(Data_encoding.list chain_status_encoding)
RPC_path.(path / "active_chains")
end
open RPC_context
let bootstrapped ctxt = make_streamed_call S.bootstrapped ctxt () () ()
let valid_blocks ctxt ?(chains = [`Main]) ?(protocols = [])
?(next_protocols = []) () =
make_streamed_call
S.valid_blocks
ctxt
()
(object
method chains = chains
method protocols = protocols
method next_protocols = next_protocols
end)
()
let heads ctxt ?(next_protocols = []) chain =
make_streamed_call
S.heads
ctxt
((), chain)
(object
method next_protocols = next_protocols
end)
()
let protocols ctxt = make_streamed_call S.protocols ctxt () () ()
let commit_hash ctxt = make_call S.commit_hash ctxt () () ()
let active_chains ctxt = make_streamed_call S.active_chains ctxt () () ()
src/lib_shell_services/monitor_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive chain_status : Type :=
| Active_main : Tezos_base__TzPervasives.Chain_id.t -> chain_status
| Active_test : Tezos_base__TzPervasives.Chain_id.t ->
Tezos_base__TzPervasives.Protocol_hash.t ->
Tezos_base__TzPervasives.Time.Protocol.t -> chain_status
| Stopping : Tezos_base__TzPervasives.Chain_id.t -> chain_status.
Definition chain_status_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding chain_status :=
union
(Some
(* ❌ Variants not supported *)
variant)
(cons
(case "Main" % string None (Tezos_base__TzPervasives.Data_encoding.Tag 0)
(obj1 (req None None "chain_id" % string Chain_id.encoding))
(fun function_parameter =>
match function_parameter with
| Active_main chain_id => Some chain_id
| _ => None
end) (fun chain_id => Active_main chain_id))
(cons
(case "Test" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj3 (req None None "chain_id" % string Chain_id.encoding)
(req None None "test_protocol" % string Protocol_hash.encoding)
(req None None "expiration_date" % string Time.Protocol.encoding))
(fun function_parameter =>
match function_parameter with
|
Active_test {|
chain := chain;
protocol := protocol;
expiration_date := expiration_date
|} => Some (chain, protocol, expiration_date)
| _ => None
end)
(fun function_parameter =>
let '(chain, protocol, expiration_date) := function_parameter in
Active_test
{| chain := chain; protocol := protocol;
expiration_date := expiration_date |}))
(cons
(case "Stopping" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 2)
(obj1 (req None None "stopping" % string Chain_id.encoding))
(fun function_parameter =>
match function_parameter with
| Stopping chain_id => Some chain_id
| _ => None
end) (fun chain_id => Stopping chain_id)) []))).
Module S.
Import Data_encoding.
Definition path : Tezos_base__TzPervasives.RPC_path.path unit unit :=
op_div root "monitor" % string.
Definition bootstrapped
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Time.Protocol.t) :=
RPC_service.get_service
(Some
"Wait for the node to have synchronized its chain with a few peers (configured by the node's administrator), streaming head updates that happen during the bootstrapping process, and closing the stream at the end. If the node was already bootstrapped, returns the current head immediately."
% string) RPC_query.empty
(obj2 (req None None "block" % string Block_hash.encoding)
(req None None "timestamp" % string Time.Protocol.encoding))
(op_div path "bootstrapped" % string).
Definition valid_blocks_query
: Tezos_base__TzPervasives.RPC_query.t
(((list Tezos_base__TzPervasives.Protocol_hash.t) *
((list Tezos_base__TzPervasives.Protocol_hash.t) *
((list Tezos_shell_services.Chain_services.chain) * nil)))) :=
OCaml.Stdlib.reverse_apply
(op_pipeplus
(op_pipeplus
(op_pipeplus
(query
(fun protocols =>
fun next_protocols =>
fun chains =>
(* ❌ Creation of objects is not handled *)
object))
(multi_field None "protocol" % string Protocol_hash.rpc_arg
(fun t =>
(* ❌ Sending method message is not handled *)
send)))
(multi_field None "next_protocol" % string Protocol_hash.rpc_arg
(fun t =>
(* ❌ Sending method message is not handled *)
send)))
(multi_field None "chain" % string Chain_services.chain_arg
(fun t =>
(* ❌ Sending method message is not handled *)
send))) seal.
Definition valid_blocks
: Tezos_base__TzPervasives.RPC_service.service variant unit unit
(((list Tezos_base__TzPervasives.Protocol_hash.t) *
((list Tezos_base__TzPervasives.Protocol_hash.t) *
((list Tezos_shell_services.Chain_services.chain) * nil)))) unit
((Tezos_base__TzPervasives.Chain_id.t *
Tezos_base__TzPervasives.Block_hash.t) *
Tezos_base__TzPervasives.Block_header.t) :=
RPC_service.get_service
(Some
"Monitor all blocks that are successfully validated by the node, disregarding whether they were selected as the new head or not."
% string) valid_blocks_query
(merge_objs
(obj2 (req None None "chain_id" % string Chain_id.encoding)
(req None None "hash" % string Block_hash.encoding))
Block_header.encoding) (op_div path "valid_blocks" % string).
Definition heads_query
: Tezos_base__TzPervasives.RPC_query.t
(((list Tezos_base__TzPervasives.Protocol_hash.t) * nil)) :=
OCaml.Stdlib.reverse_apply
(op_pipeplus
(query
(fun next_protocols =>
(* ❌ Creation of objects is not handled *)
object))
(multi_field None "next_protocol" % string Protocol_hash.rpc_arg
(fun t =>
(* ❌ Sending method message is not handled *)
send))) seal.
Definition heads
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_shell_services.Chain_services.chain)
(((list Tezos_base__TzPervasives.Protocol_hash.t) * nil)) unit
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t) :=
RPC_service.get_service
(Some
"Monitor all blocks that are successfully validated by the node and selected as the new head of the given chain."
% string) heads_query
(merge_objs (obj1 (req None None "hash" % string Block_hash.encoding))
Block_header.encoding)
(op_divcolon (op_div path "heads" % string) Chain_services.chain_arg).
Definition protocols
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
Tezos_base__TzPervasives.Protocol_hash.t :=
RPC_service.get_service
(Some
"Monitor all economic protocols that are retrieved and successfully loaded and compiled by the node."
% string) RPC_query.empty Protocol_hash.encoding
(op_div path "protocols" % string).
Definition commit_hash
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
string :=
RPC_service.get_service
(Some "Get information on the build of the node." % string)
RPC_query.empty string (op_div path "commit_hash" % string).
Definition active_chains
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
(list chain_status) :=
RPC_service.get_service
(Some
"Monitor every chain creation and destruction. Currently active chains will be given as first elements"
% string) RPC_query.empty
(Data_encoding.list None chain_status_encoding)
(op_div path "active_chains" % string).
End S.
Import RPC_context.
Definition bootstrapped {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
* (E * p * q * i * o)) * F) * F)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
((Lwt_stream.t
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Time.Protocol.t)) *
Tezos_base__TzPervasives.RPC_context.stopper)) :=
make_streamed_call S.bootstrapped ctxt tt tt tt.
Definition valid_blocks {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
* (E * p * q * i * o)) * F) * F) (op_staroptstar : option (list variant))
: (option (list Tezos_base__TzPervasives.Protocol_hash.t)) ->
(option (list Tezos_base__TzPervasives.Protocol_hash.t)) ->
unit ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
((Lwt_stream.t
((Tezos_base__TzPervasives.Chain_id.t *
Tezos_base__TzPervasives.Block_hash.t) *
Tezos_base__TzPervasives.Block_header.t)) *
Tezos_base__TzPervasives.RPC_context.stopper)) :=
let chains :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
cons
(* ❌ Variants not supported *)
variant []
end in
fun op_staroptstar =>
let protocols :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun op_staroptstar =>
let next_protocols :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun function_parameter =>
let 'tt := function_parameter in
make_streamed_call S.valid_blocks ctxt tt
(* ❌ Creation of objects is not handled *)
object tt.
Definition heads {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
* (E * p * q * i * o)) * F) * F)
(op_staroptstar : option (list Tezos_base__TzPervasives.Protocol_hash.t))
: Tezos_shell_services.Chain_services.chain ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
((Lwt_stream.t
(Tezos_base__TzPervasives.Block_hash.t *
Tezos_base__TzPervasives.Block_header.t)) *
Tezos_base__TzPervasives.RPC_context.stopper)) :=
let next_protocols :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun chain =>
make_streamed_call S.heads ctxt (tt, chain)
(* ❌ Creation of objects is not handled *)
object tt.
Definition protocols {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
* (E * p * q * i * o)) * F) * F)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
((Lwt_stream.t Tezos_base__TzPervasives.Protocol_hash.t) *
Tezos_base__TzPervasives.RPC_context.stopper)) :=
make_streamed_call S.protocols ctxt tt tt tt.
Definition commit_hash {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult string) :=
make_call S.commit_hash ctxt tt tt tt.
Definition active_chains {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
* (E * p * q * i * o)) * F) * F)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
((Lwt_stream.t (list chain_status)) *
Tezos_base__TzPervasives.RPC_context.stopper)) :=
make_streamed_call S.active_chains ctxt tt tt tt.
src/lib_shell_services/p2p_services.ml 244 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let wait_query =
let open RPC_query in
query (fun wait ->
object
method wait = wait
end)
|+ flag "wait" (fun t -> t#wait)
|> seal
let monitor_query =
let open RPC_query in
query (fun monitor ->
object
method monitor = monitor
end)
|+ flag "monitor" (fun t -> t#monitor)
|> seal
let timeout_query =
let open RPC_query in
query (fun timeout ->
object
method timeout = timeout
end)
|+ field
"timeout"
Time.System.Span.rpc_arg
(Time.System.Span.of_seconds_exn 10.)
(fun t -> t#timeout)
|> seal
module S = struct
let self =
RPC_service.get_service
~description:"Return the node's peer id"
~query:RPC_query.empty
~output:P2p_peer.Id.encoding
RPC_path.(root / "network" / "self")
let version =
RPC_service.get_service
~description:"Supported network layer version."
~query:RPC_query.empty
~output:Network_version.encoding
RPC_path.(root / "network" / "version")
(* DEPRECATED: use [version] instead. *)
let versions =
RPC_service.get_service
~description:"DEPRECATED: use `version` instead."
~query:RPC_query.empty
~output:(Data_encoding.list Network_version.encoding)
RPC_path.(root / "network" / "versions")
let stat =
RPC_service.get_service
~description:"Global network bandwidth statistics in B/s."
~query:RPC_query.empty
~output:P2p_stat.encoding
RPC_path.(root / "network" / "stat")
let events =
RPC_service.get_service
~description:"Stream of all network events"
~query:RPC_query.empty
~output:P2p_connection.P2p_event.encoding
RPC_path.(root / "network" / "log")
let connect =
RPC_service.put_service
~description:"Connect to a peer"
~query:timeout_query
~input:Data_encoding.empty
~output:Data_encoding.empty
RPC_path.(root / "network" / "points" /: P2p_point.Id.rpc_arg)
end
open RPC_context
let self ctxt = make_call S.self ctxt () () ()
let stat ctxt = make_call S.stat ctxt () () ()
let version ctxt = make_call S.version ctxt () () ()
let versions ctxt = make_call S.versions ctxt () () ()
(* DEPRECATED: use [version] instead. *)
let events ctxt = make_streamed_call S.events ctxt () () ()
let connect ctxt ~timeout peer_id =
make_call1
S.connect
ctxt
peer_id
(object
method timeout = timeout
end)
()
module Connections = struct
type connection_info = Connection_metadata.t P2p_connection.Info.t
let connection_info_encoding =
P2p_connection.Info.encoding Connection_metadata.encoding
module S = struct
let list =
RPC_service.get_service
~description:"List the running P2P connection."
~query:RPC_query.empty
~output:(Data_encoding.list connection_info_encoding)
RPC_path.(root / "network" / "connections")
let info =
RPC_service.get_service
~query:RPC_query.empty
~output:connection_info_encoding
~description:
"Details about the current P2P connection to the given peer."
RPC_path.(root / "network" / "connections" /: P2p_peer.Id.rpc_arg)
let kick =
RPC_service.delete_service
~query:wait_query
~output:Data_encoding.empty
~description:
"Forced close of the current P2P connection to the given peer."
RPC_path.(root / "network" / "connections" /: P2p_peer.Id.rpc_arg)
end
let list ctxt = make_call S.list ctxt () () ()
let info ctxt peer_id = make_call1 S.info ctxt peer_id () ()
let kick ctxt ?(wait = false) peer_id =
make_call1
S.kick
ctxt
peer_id
(object
method wait = wait
end)
()
end
module Points = struct
module S = struct
let info =
RPC_service.get_service
~query:RPC_query.empty
~output:P2p_point.Info.encoding
~description:"Details about a given `IP:addr`."
RPC_path.(root / "network" / "points" /: P2p_point.Id.rpc_arg)
let events =
RPC_service.get_service
~query:monitor_query
~output:(Data_encoding.list P2p_point.Pool_event.encoding)
~description:"Monitor network events related to an `IP:addr`."
RPC_path.(root / "network" / "points" /: P2p_point.Id.rpc_arg / "log")
let list =
let filter_query =
let open RPC_query in
query (fun filters ->
object
method filters = filters
end)
|+ multi_field "filter" P2p_point.Filter.rpc_arg (fun t -> t#filters)
|> seal
in
RPC_service.get_service
~query:filter_query
~output:
Data_encoding.(
list (tup2 P2p_point.Id.encoding P2p_point.Info.encoding))
~description:
"List the pool of known `IP:port` used for establishing P2P \
connections."
RPC_path.(root / "network" / "points")
let ban =
RPC_service.get_service
~query:RPC_query.empty
~output:Data_encoding.empty
~description:
"Blacklist the given address and remove it from the whitelist if \
present."
RPC_path.(root / "network" / "points" /: P2p_point.Id.rpc_arg / "ban")
let unban =
RPC_service.get_service
~query:RPC_query.empty
~output:Data_encoding.empty
~description:"Remove an address from the blacklist."
RPC_path.(
root / "network" / "points" /: P2p_point.Id.rpc_arg / "unban")
let trust =
RPC_service.get_service
~query:RPC_query.empty
~output:Data_encoding.empty
~description:
"Trust a given address permanently and remove it from the blacklist \
if present. Connections from this address can still be closed on \
authentication if the peer is greylisted."
RPC_path.(
root / "network" / "points" /: P2p_point.Id.rpc_arg / "trust")
let untrust =
RPC_service.get_service
~query:RPC_query.empty
~output:Data_encoding.empty
~description:"Remove an address from the whitelist."
RPC_path.(
root / "network" / "points" /: P2p_point.Id.rpc_arg / "untrust")
let banned =
RPC_service.get_service
~query:RPC_query.empty
~output:Data_encoding.bool
~description:"Check is a given address is blacklisted or greylisted."
RPC_path.(
root / "network" / "points" /: P2p_point.Id.rpc_arg / "banned")
end
open RPC_context
let info ctxt peer_id = make_call1 S.info ctxt peer_id () ()
let events ctxt point =
make_streamed_call
S.events
ctxt
((), point)
(object
method monitor = true
end)
()
let list ?(filter = []) ctxt =
make_call
S.list
ctxt
()
(object
method filters = filter
end)
()
let ban ctxt peer_id = make_call1 S.ban ctxt peer_id () ()
let unban ctxt peer_id = make_call1 S.unban ctxt peer_id () ()
let trust ctxt peer_id = make_call1 S.trust ctxt peer_id () ()
let untrust ctxt peer_id = make_call1 S.untrust ctxt peer_id () ()
let banned ctxt peer_id = make_call1 S.banned ctxt peer_id () ()
end
module Peers = struct
module S = struct
let info =
RPC_service.get_service
~query:RPC_query.empty
~output:
(P2p_peer.Info.encoding
Peer_metadata.encoding
Connection_metadata.encoding)
~description:"Details about a given peer."
RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg)
let events =
RPC_service.get_service
~query:monitor_query
~output:(Data_encoding.list P2p_peer.Pool_event.encoding)
~description:"Monitor network events related to a given peer."
RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "log")
let list =
let filter =
let open RPC_query in
query (fun filters ->
object
method filters = filters
end)
|+ multi_field "filter" P2p_peer.Filter.rpc_arg (fun t -> t#filters)
|> seal
in
RPC_service.get_service
~query:filter
~output:
Data_encoding.(
list
(tup2
P2p_peer.Id.encoding
(P2p_peer.Info.encoding
Peer_metadata.encoding
Connection_metadata.encoding)))
~description:"List the peers the node ever met."
RPC_path.(root / "network" / "peers")
let ban =
RPC_service.get_service
~query:RPC_query.empty
~output:Data_encoding.empty
~description:
"Blacklist the given peer and remove it from the whitelist if \
present."
RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "ban")
let unban =
RPC_service.get_service
~query:RPC_query.empty
~output:Data_encoding.empty
~description:"Remove the given peer from the blacklist."
RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "unban")
let trust =
RPC_service.get_service
~query:RPC_query.empty
~output:Data_encoding.empty
~description:
"Whitelist a given peer permanently and remove it from the \
blacklist if present. The peer cannot be blocked (but its host IP \
still can)."
RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "trust")
let untrust =
RPC_service.get_service
~query:RPC_query.empty
~output:Data_encoding.empty
~description:"Remove a given peer from the whitelist."
RPC_path.(
root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "untrust")
let banned =
RPC_service.get_service
~query:RPC_query.empty
~output:Data_encoding.bool
~description:"Check if a given peer is blacklisted or greylisted."
RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "banned")
end
let info ctxt peer_id = make_call1 S.info ctxt peer_id () ()
let events ctxt point =
make_streamed_call
S.events
ctxt
((), point)
(object
method monitor = true
end)
()
let list ?(filter = []) ctxt =
make_call
S.list
ctxt
()
(object
method filters = filter
end)
()
let ban ctxt point_id = make_call1 S.ban ctxt point_id () ()
let unban ctxt point_id = make_call1 S.unban ctxt point_id () ()
let trust ctxt point_id = make_call1 S.trust ctxt point_id () ()
let untrust ctxt point_id = make_call1 S.untrust ctxt point_id () ()
let banned ctxt point_id = make_call1 S.banned ctxt point_id () ()
end
module ACL = struct
module S = struct
let clear =
RPC_service.get_service
~query:RPC_query.empty
~output:Data_encoding.empty
~description:"Clear all greylists tables."
RPC_path.(root / "network" / "greylist" / "clear")
end
let clear ctxt = make_call S.clear ctxt () ()
end
src/lib_shell_services/p2p_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition wait_query : Tezos_base__TzPervasives.RPC_query.t ((bool * nil)) :=
OCaml.Stdlib.reverse_apply
(op_pipeplus
(query
(fun wait =>
(* ❌ Creation of objects is not handled *)
object))
(flag None "wait" % string
(fun t =>
(* ❌ Sending method message is not handled *)
send))) seal.
Definition monitor_query
: Tezos_base__TzPervasives.RPC_query.t ((bool * nil)) :=
OCaml.Stdlib.reverse_apply
(op_pipeplus
(query
(fun monitor =>
(* ❌ Creation of objects is not handled *)
object))
(flag None "monitor" % string
(fun t =>
(* ❌ Sending method message is not handled *)
send))) seal.
Definition timeout_query
: Tezos_base__TzPervasives.RPC_query.t
((Tezos_base__TzPervasives.Time.System.Span.t * nil)) :=
OCaml.Stdlib.reverse_apply
(op_pipeplus
(query
(fun timeout =>
(* ❌ Creation of objects is not handled *)
object))
(field None "timeout" % string Time.System.Span.rpc_arg
(Time.System.Span.of_seconds_exn
(* ❌ Float constant 10. is approximated by the integer 10 *)
10)
(fun t =>
(* ❌ Sending method message is not handled *)
send))) seal.
Module S.
Definition self
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
Tezos_base__TzPervasives.P2p_peer.Id.t :=
RPC_service.get_service (Some "Return the node's peer id" % string)
RPC_query.empty P2p_peer.Id.encoding
(op_div (op_div root "network" % string) "self" % string).
Definition version
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
Tezos_base__TzPervasives.Network_version.t :=
RPC_service.get_service (Some "Supported network layer version." % string)
RPC_query.empty Network_version.encoding
(op_div (op_div root "network" % string) "version" % string).
Definition versions
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
(list Tezos_base__TzPervasives.Network_version.t) :=
RPC_service.get_service (Some "DEPRECATED: use `version` instead." % string)
RPC_query.empty (Data_encoding.list None Network_version.encoding)
(op_div (op_div root "network" % string) "versions" % string).
Definition stat
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
Tezos_base__TzPervasives.P2p_stat.t :=
RPC_service.get_service
(Some "Global network bandwidth statistics in B/s." % string)
RPC_query.empty P2p_stat.encoding
(op_div (op_div root "network" % string) "stat" % string).
Definition events
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
Tezos_base__TzPervasives.P2p_connection.P2p_event.t :=
RPC_service.get_service (Some "Stream of all network events" % string)
RPC_query.empty P2p_connection.P2p_event.encoding
(op_div (op_div root "network" % string) "log" % string).
Definition connect
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_point.Id.t)
((Tezos_base__TzPervasives.Time.System.Span.t * nil)) unit unit :=
RPC_service.put_service (Some "Connect to a peer" % string) timeout_query
Data_encoding.empty Data_encoding.empty
(op_divcolon (op_div (op_div root "network" % string) "points" % string)
P2p_point.Id.rpc_arg).
End S.
Import RPC_context.
Definition self {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
Tezos_base__TzPervasives.P2p_peer.Id.t) := make_call S.self ctxt tt tt tt.
Definition stat {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult Tezos_base__TzPervasives.P2p_stat.t) :=
make_call S.stat ctxt tt tt tt.
Definition version {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
Tezos_base__TzPervasives.Network_version.t) :=
make_call S.version ctxt tt tt tt.
Definition versions {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(list Tezos_base__TzPervasives.Network_version.t)) :=
make_call S.versions ctxt tt tt tt.
Definition events {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
* (E * p * q * i * o)) * F) * F)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
((Lwt_stream.t Tezos_base__TzPervasives.P2p_connection.P2p_event.t) *
Tezos_base__TzPervasives.RPC_context.stopper)) :=
make_streamed_call S.events ctxt tt tt tt.
Definition connect {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(timeout : Tezos_base__TzPervasives.Time.System.Span.t)
(peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
make_call1 S.connect ctxt peer_id
(* ❌ Creation of objects is not handled *)
object tt.
Module Connections.
Definition connection_info :=
Tezos_base__TzPervasives.P2p_connection.Info.t
Tezos_shell_services.Connection_metadata.t.
Definition connection_info_encoding
: Tezos_data_encoding.Data_encoding.t
(Tezos_base__TzPervasives.P2p_connection.Info.t
Tezos_shell_services.Connection_metadata.t) :=
P2p_connection.Info.encoding Connection_metadata.encoding.
Module S.
Definition list
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
(list
(Tezos_base__TzPervasives.P2p_connection.Info.t
Tezos_shell_services.Connection_metadata.t)) :=
RPC_service.get_service (Some "List the running P2P connection." % string)
RPC_query.empty (Data_encoding.list None connection_info_encoding)
(op_div (op_div root "network" % string) "connections" % string).
Definition info
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
(Tezos_base__TzPervasives.P2p_connection.Info.t
Tezos_shell_services.Connection_metadata.t) :=
RPC_service.get_service
(Some
"Details about the current P2P connection to the given peer." % string)
RPC_query.empty connection_info_encoding
(op_divcolon
(op_div (op_div root "network" % string) "connections" % string)
P2p_peer.Id.rpc_arg).
Definition kick
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_peer.Id.t) ((bool * nil)) unit unit :=
RPC_service.delete_service
(Some
"Forced close of the current P2P connection to the given peer." %
string) wait_query Data_encoding.empty
(op_divcolon
(op_div (op_div root "network" % string) "connections" % string)
P2p_peer.Id.rpc_arg).
End S.
Definition list {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(list
(Tezos_base__TzPervasives.P2p_connection.Info.t
Tezos_shell_services.Connection_metadata.t))) :=
make_call S.list ctxt tt tt tt.
Definition info {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(Tezos_base__TzPervasives.P2p_connection.Info.t
Tezos_shell_services.Connection_metadata.t)) :=
make_call1 S.info ctxt peer_id tt tt.
Definition kick {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F) (op_staroptstar : option bool)
: Tezos_base__TzPervasives.P2p_peer.Id.t ->
Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
let wait :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun peer_id =>
make_call1 S.kick ctxt peer_id
(* ❌ Creation of objects is not handled *)
object tt.
End Connections.
Module Points.
Module S.
Definition info
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit
Tezos_base__TzPervasives.P2p_point.Info.t :=
RPC_service.get_service (Some "Details about a given `IP:addr`." % string)
RPC_query.empty P2p_point.Info.encoding
(op_divcolon (op_div (op_div root "network" % string) "points" % string)
P2p_point.Id.rpc_arg).
Definition events
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_point.Id.t) ((bool * nil)) unit
(list Tezos_base__TzPervasives.P2p_point.Pool_event.t) :=
RPC_service.get_service
(Some "Monitor network events related to an `IP:addr`." % string)
monitor_query (Data_encoding.list None P2p_point.Pool_event.encoding)
(op_div
(op_divcolon
(op_div (op_div root "network" % string) "points" % string)
P2p_point.Id.rpc_arg) "log" % string).
Definition list
: Tezos_base__TzPervasives.RPC_service.service variant unit unit
(((list Tezos_base__TzPervasives.P2p_point.Filter.t) * nil)) unit
(list
(Tezos_base__TzPervasives.P2p_point.Id.t *
Tezos_base__TzPervasives.P2p_point.Info.t)) :=
let filter_query :=
OCaml.Stdlib.reverse_apply
(op_pipeplus
(query
(fun filters =>
(* ❌ Creation of objects is not handled *)
object))
(multi_field None "filter" % string P2p_point.Filter.rpc_arg
(fun t =>
(* ❌ Sending method message is not handled *)
send))) seal in
RPC_service.get_service
(Some
"List the pool of known `IP:port` used for establishing P2P connections."
% string) filter_query
(list None (tup2 P2p_point.Id.encoding P2p_point.Info.encoding))
(op_div (op_div root "network" % string) "points" % string).
Definition ban
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit unit :=
RPC_service.get_service
(Some
"Blacklist the given address and remove it from the whitelist if present."
% string) RPC_query.empty Data_encoding.empty
(op_div
(op_divcolon
(op_div (op_div root "network" % string) "points" % string)
P2p_point.Id.rpc_arg) "ban" % string).
Definition unban
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit unit :=
RPC_service.get_service
(Some "Remove an address from the blacklist." % string) RPC_query.empty
Data_encoding.empty
(op_div
(op_divcolon
(op_div (op_div root "network" % string) "points" % string)
P2p_point.Id.rpc_arg) "unban" % string).
Definition trust
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit unit :=
RPC_service.get_service
(Some
"Trust a given address permanently and remove it from the blacklist if present. Connections from this address can still be closed on authentication if the peer is greylisted."
% string) RPC_query.empty Data_encoding.empty
(op_div
(op_divcolon
(op_div (op_div root "network" % string) "points" % string)
P2p_point.Id.rpc_arg) "trust" % string).
Definition untrust
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit unit :=
RPC_service.get_service
(Some "Remove an address from the whitelist." % string) RPC_query.empty
Data_encoding.empty
(op_div
(op_divcolon
(op_div (op_div root "network" % string) "points" % string)
P2p_point.Id.rpc_arg) "untrust" % string).
Definition banned
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit bool :=
RPC_service.get_service
(Some "Check is a given address is blacklisted or greylisted." % string)
RPC_query.empty Data_encoding.bool
(op_div
(op_divcolon
(op_div (op_div root "network" % string) "points" % string)
P2p_point.Id.rpc_arg) "banned" % string).
End S.
Import RPC_context.
Definition info {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
Tezos_base__TzPervasives.P2p_point.Info.t) :=
make_call1 S.info ctxt peer_id tt tt.
Definition events {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
* (E * p * q * i * o)) * F) * F)
(point : Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
((Lwt_stream.t (list Tezos_base__TzPervasives.P2p_point.Pool_event.t)) *
Tezos_base__TzPervasives.RPC_context.stopper)) :=
make_streamed_call S.events ctxt (tt, point)
(* ❌ Creation of objects is not handled *)
object tt.
Definition list {E F i o p q : Type}
(op_staroptstar : option (list Tezos_base__TzPervasives.P2p_point.Filter.t))
: (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F) ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(list
(Tezos_base__TzPervasives.P2p_point.Id.t *
Tezos_base__TzPervasives.P2p_point.Info.t))) :=
let filter :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun ctxt =>
make_call S.list ctxt tt
(* ❌ Creation of objects is not handled *)
object tt.
Definition ban {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
make_call1 S.ban ctxt peer_id tt tt.
Definition unban {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
make_call1 S.unban ctxt peer_id tt tt.
Definition trust {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
make_call1 S.trust ctxt peer_id tt tt.
Definition untrust {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
make_call1 S.untrust ctxt peer_id tt tt.
Definition banned {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult bool) :=
make_call1 S.banned ctxt peer_id tt tt.
End Points.
Module Peers.
Module S.
Definition info
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
(Tezos_base__TzPervasives.P2p_peer.Info.t
Tezos_shell_services.Peer_metadata.t
Tezos_shell_services.Connection_metadata.t) :=
RPC_service.get_service (Some "Details about a given peer." % string)
RPC_query.empty
(P2p_peer.Info.encoding Peer_metadata.encoding
Connection_metadata.encoding)
(op_divcolon (op_div (op_div root "network" % string) "peers" % string)
P2p_peer.Id.rpc_arg).
Definition events
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_peer.Id.t) ((bool * nil)) unit
(list Tezos_base__TzPervasives.P2p_peer.Pool_event.t) :=
RPC_service.get_service
(Some "Monitor network events related to a given peer." % string)
monitor_query (Data_encoding.list None P2p_peer.Pool_event.encoding)
(op_div
(op_divcolon
(op_div (op_div root "network" % string) "peers" % string)
P2p_peer.Id.rpc_arg) "log" % string).
Definition list
: Tezos_base__TzPervasives.RPC_service.service variant unit unit
(((list Tezos_base__TzPervasives.P2p_peer.Filter.t) * nil)) unit
(list
(Tezos_base__TzPervasives.P2p_peer.Id.t *
(Tezos_base__TzPervasives.P2p_peer.Info.t
Tezos_shell_services.Peer_metadata.t
Tezos_shell_services.Connection_metadata.t))) :=
let filter :=
OCaml.Stdlib.reverse_apply
(op_pipeplus
(query
(fun filters =>
(* ❌ Creation of objects is not handled *)
object))
(multi_field None "filter" % string P2p_peer.Filter.rpc_arg
(fun t =>
(* ❌ Sending method message is not handled *)
send))) seal in
RPC_service.get_service
(Some "List the peers the node ever met." % string) filter
(list None
(tup2 P2p_peer.Id.encoding
(P2p_peer.Info.encoding Peer_metadata.encoding
Connection_metadata.encoding)))
(op_div (op_div root "network" % string) "peers" % string).
Definition ban
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit unit :=
RPC_service.get_service
(Some
"Blacklist the given peer and remove it from the whitelist if present."
% string) RPC_query.empty Data_encoding.empty
(op_div
(op_divcolon
(op_div (op_div root "network" % string) "peers" % string)
P2p_peer.Id.rpc_arg) "ban" % string).
Definition unban
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit unit :=
RPC_service.get_service
(Some "Remove the given peer from the blacklist." % string)
RPC_query.empty Data_encoding.empty
(op_div
(op_divcolon
(op_div (op_div root "network" % string) "peers" % string)
P2p_peer.Id.rpc_arg) "unban" % string).
Definition trust
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit unit :=
RPC_service.get_service
(Some
"Whitelist a given peer permanently and remove it from the blacklist if present. The peer cannot be blocked (but its host IP still can)."
% string) RPC_query.empty Data_encoding.empty
(op_div
(op_divcolon
(op_div (op_div root "network" % string) "peers" % string)
P2p_peer.Id.rpc_arg) "trust" % string).
Definition untrust
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit unit :=
RPC_service.get_service
(Some "Remove a given peer from the whitelist." % string)
RPC_query.empty Data_encoding.empty
(op_div
(op_divcolon
(op_div (op_div root "network" % string) "peers" % string)
P2p_peer.Id.rpc_arg) "untrust" % string).
Definition banned
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit bool :=
RPC_service.get_service
(Some "Check if a given peer is blacklisted or greylisted." % string)
RPC_query.empty Data_encoding.bool
(op_div
(op_divcolon
(op_div (op_div root "network" % string) "peers" % string)
P2p_peer.Id.rpc_arg) "banned" % string).
End S.
Definition info {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(Tezos_base__TzPervasives.P2p_peer.Info.t
Tezos_shell_services.Peer_metadata.t
Tezos_shell_services.Connection_metadata.t)) :=
make_call1 S.info ctxt peer_id tt tt.
Definition events {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
* (E * p * q * i * o)) * F) * F)
(point : Tezos_base__TzPervasives.P2p_peer.Id.t)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
((Lwt_stream.t (list Tezos_base__TzPervasives.P2p_peer.Pool_event.t)) *
Tezos_base__TzPervasives.RPC_context.stopper)) :=
make_streamed_call S.events ctxt (tt, point)
(* ❌ Creation of objects is not handled *)
object tt.
Definition list {E F i o p q : Type}
(op_staroptstar : option (list Tezos_base__TzPervasives.P2p_peer.Filter.t))
: (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F) ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(list
(Tezos_base__TzPervasives.P2p_peer.Id.t *
(Tezos_base__TzPervasives.P2p_peer.Info.t
Tezos_shell_services.Peer_metadata.t
Tezos_shell_services.Connection_metadata.t)))) :=
let filter :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun ctxt =>
make_call S.list ctxt tt
(* ❌ Creation of objects is not handled *)
object tt.
Definition ban {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
make_call1 S.ban ctxt point_id tt tt.
Definition unban {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
make_call1 S.unban ctxt point_id tt tt.
Definition trust {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
make_call1 S.trust ctxt point_id tt tt.
Definition untrust {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
make_call1 S.untrust ctxt point_id tt tt.
Definition banned {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult bool) :=
make_call1 S.banned ctxt point_id tt tt.
End Peers.
Module ACL.
Module S.
Definition clear
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
unit :=
RPC_service.get_service (Some "Clear all greylists tables." % string)
RPC_query.empty Data_encoding.empty
(op_div (op_div (op_div root "network" % string) "greylist" % string)
"clear" % string).
End S.
Definition clear {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
make_call S.clear ctxt tt tt.
End ACL.
src/lib_shell_services/peer_metadata.ml 43 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type counter = Z.t
let counter = Data_encoding.z
let (( + ) : counter -> counter -> counter) = Z.add
let zero : counter = Z.zero
let one : counter = Z.one
(* Distributed DB peer metadata *)
type messages = {
mutable branch : counter;
mutable head : counter;
mutable block_header : counter;
mutable operations : counter;
mutable protocols : counter;
mutable operation_hashes_for_block : counter;
mutable operations_for_block : counter;
mutable other : counter;
}
let sent_requests_encoding =
let open Data_encoding in
(conv
(fun { branch;
head;
block_header;
operations;
protocols;
operation_hashes_for_block;
operations_for_block;
other } ->
( branch,
head,
block_header,
operations,
protocols,
operation_hashes_for_block,
operations_for_block,
other ))
(fun ( branch,
head,
block_header,
operations,
protocols,
operation_hashes_for_block,
operations_for_block,
other ) ->
{
branch;
head;
block_header;
operations;
protocols;
operation_hashes_for_block;
operations_for_block;
other;
}))
(obj8
(req "branch" counter)
(req "head" counter)
(req "block_header" counter)
(req "operations" counter)
(req "protocols" counter)
(req "operation_hashes_for_block" counter)
(req "operations_for_block" counter)
(req "other" counter))
type requests_kind =
| Branch
| Head
| Block_header
| Operations
| Protocols
| Operation_hashes_for_block
| Operations_for_block
| Other
type requests = {
sent : messages; (** p2p sent messages of type requests *)
received : messages; (** p2p received messages of type requests *)
failed : messages;
(** p2p messages of type requests that we failed to send *)
scheduled : messages; (** p2p messages ent via request scheduler *)
}
let requests_encoding =
let open Data_encoding in
(conv
(fun {sent; received; failed; scheduled} ->
(sent, received, failed, scheduled))
(fun (sent, received, failed, scheduled) ->
{sent; received; failed; scheduled}))
(obj4
(req "sent" sent_requests_encoding)
(req "received" sent_requests_encoding)
(req "failed" sent_requests_encoding)
(req "scheduled" sent_requests_encoding))
(* Prevalidator peer metadata *)
type prevalidator_results = {
cannot_download : counter;
cannot_parse : counter;
refused_by_prefilter : counter;
refused_by_postfilter : counter;
(* prevalidation results *)
applied : counter;
branch_delayed : counter;
branch_refused : counter;
refused : counter;
duplicate : counter;
outdated : counter;
}
let prevalidator_results_encoding =
let open Data_encoding in
conv
(fun { cannot_download;
cannot_parse;
refused_by_prefilter;
refused_by_postfilter;
applied;
branch_delayed;
branch_refused;
refused;
duplicate;
outdated } ->
( cannot_download,
cannot_parse,
refused_by_prefilter,
refused_by_postfilter,
applied,
branch_delayed,
branch_refused,
refused,
duplicate,
outdated ))
(fun ( cannot_download,
cannot_parse,
refused_by_prefilter,
refused_by_postfilter,
applied,
branch_delayed,
branch_refused,
refused,
duplicate,
outdated ) ->
{
cannot_download;
cannot_parse;
refused_by_prefilter;
refused_by_postfilter;
applied;
branch_delayed;
branch_refused;
refused;
duplicate;
outdated;
})
(obj10
(req "cannot_download" counter)
(req "cannot_parse" counter)
(req "refused_by_prefilter" counter)
(req "refused_by_postfilter" counter)
(req "applied" counter)
(req "branch_delayed" counter)
(req "branch_refused" counter)
(req "refused" counter)
(req "duplicate" counter)
(req "outdated" counter))
type resource_kind = Block | Operations | Protocol
type advertisement = Head | Branch
type metadata =
(* Distributed_db *)
| Received_request of requests_kind
| Sent_request of requests_kind
| Failed_request of requests_kind
| Scheduled_request of requests_kind
| Received_response of requests_kind
| Sent_response of requests_kind
| Unexpected_response
| Unactivated_chain
| Inactive_chain
| Future_block
| Unadvertised of resource_kind
| Sent_advertisement of advertisement
| Received_advertisement of advertisement
| Outdated_response (* TODO : unused *)
(* Peer validator *)
| Valid_blocks
| Old_heads
(* Prevalidation *)
| Cannot_download
| Cannot_parse
| Refused_by_prefilter
| Refused_by_postfilter
| Applied
| Branch_delayed
| Branch_refused
| Refused
| Duplicate
| Outdated
type responses = {
mutable sent : messages; (** p2p sent messages of type responses *)
mutable failed : messages; (** p2p sent messages of type responses *)
mutable received : messages; (** p2p received responses *)
mutable unexpected : counter;
(** p2p received responses that were unexpected *)
mutable outdated : counter;
(** p2p received responses that are now outdated *)
}
let responses_encoding =
let open Data_encoding in
(conv
(fun {sent; failed; received; unexpected; outdated} ->
(sent, failed, received, unexpected, outdated))
(fun (sent, failed, received, unexpected, outdated) ->
{sent; failed; received; unexpected; outdated}))
(obj5
(req "sent" sent_requests_encoding)
(req "failed" sent_requests_encoding)
(req "received" sent_requests_encoding)
(req "unexpected" counter)
(req "outdated" counter))
type unadvertised = {
mutable block : counter; (** requests for unadvertised block *)
mutable operations : counter; (** requests for unadvertised operations *)
mutable protocol : counter; (** requests for unadvertised protocol *)
}
let unadvertised_encoding =
let open Data_encoding in
(conv
(fun {block; operations; protocol} -> (block, operations, protocol))
(fun (block, operations, protocol) -> {block; operations; protocol}))
(obj3
(req "block" counter)
(req "operations" counter)
(req "protocol" counter))
type advertisements_kind = {mutable head : counter; mutable branch : counter}
let advertisements_kind_encoding =
let open Data_encoding in
(conv
(fun {head; branch} -> (head, branch))
(fun (head, branch) -> {head; branch}))
(obj2 (req "head" counter) (req "branch" counter))
type advertisements = {
mutable sent : advertisements_kind;
mutable received : advertisements_kind;
}
let advertisements_encoding =
let open Data_encoding in
(conv
(fun {sent; received} -> (sent, received))
(fun (sent, received) -> {sent; received}))
(obj2
(req "sent" advertisements_kind_encoding)
(req "received" advertisements_kind_encoding))
type t = {
mutable responses : responses; (** responses sent/received *)
mutable requests : requests; (** requests sent/received *)
mutable valid_blocks : counter; (** new valid blocks advertized by a peer *)
mutable old_heads : counter; (** previously validated blocks from a peer *)
mutable prevalidator_results : prevalidator_results;
(** prevalidator metadata *)
mutable unactivated_chains : counter;
(** requests from unactivated chains *)
mutable inactive_chains : counter; (** advertise inactive chains *)
mutable future_blocks_advertised : counter; (** future blocks *)
mutable unadvertised : unadvertised;
(** requests for unadvertised resources *)
mutable advertisements : advertisements; (** advertisements sent *)
}
let empty () =
let empty_request () =
{
branch = zero;
head = zero;
block_header = zero;
operations = zero;
protocols = zero;
operation_hashes_for_block = zero;
operations_for_block = zero;
other = zero;
}
in
{
responses =
{
sent = empty_request ();
failed = empty_request ();
received = empty_request ();
unexpected = zero;
outdated = zero;
};
requests =
{
sent = empty_request ();
failed = empty_request ();
scheduled = empty_request ();
received = empty_request ();
};
valid_blocks = zero;
old_heads = zero;
prevalidator_results =
{
cannot_download = zero;
cannot_parse = zero;
refused_by_prefilter = zero;
refused_by_postfilter = zero;
applied = zero;
branch_delayed = zero;
branch_refused = zero;
refused = zero;
duplicate = zero;
outdated = zero;
};
unactivated_chains = zero;
inactive_chains = zero;
future_blocks_advertised = zero;
unadvertised = {block = zero; operations = zero; protocol = zero};
advertisements =
{
sent = {head = zero; branch = zero};
received = {head = zero; branch = zero};
};
}
let encoding =
let open Data_encoding in
(conv
(fun { responses;
requests;
valid_blocks;
old_heads;
prevalidator_results;
unactivated_chains;
inactive_chains;
future_blocks_advertised;
unadvertised;
advertisements } ->
( ( responses,
requests,
valid_blocks,
old_heads,
prevalidator_results,
unactivated_chains,
inactive_chains,
future_blocks_advertised ),
(unadvertised, advertisements) ))
(fun ( ( responses,
requests,
valid_blocks,
old_heads,
prevalidator_results,
unactivated_chains,
inactive_chains,
future_blocks_advertised ),
(unadvertised, advertisements) ) ->
{
responses;
requests;
valid_blocks;
old_heads;
prevalidator_results;
unactivated_chains;
inactive_chains;
future_blocks_advertised;
unadvertised;
advertisements;
}))
(merge_objs
(obj8
(req "responses" responses_encoding)
(req "requests" requests_encoding)
(req "valid_blocks" counter)
(req "old_heads" counter)
(req "prevalidator_results" prevalidator_results_encoding)
(req "unactivated_chains" counter)
(req "inactive_chains" counter)
(req "future_blocks_advertised" counter))
(obj2
(req "unadvertised" unadvertised_encoding)
(req "advertisements" advertisements_encoding)))
let incr_requests (msgs : messages) (req : requests_kind) =
match req with
| Branch ->
msgs.branch <- msgs.branch + one
| Head ->
msgs.head <- msgs.head + one
| Block_header ->
msgs.block_header <- msgs.block_header + one
| Operations ->
msgs.operations <- msgs.operations + one
| Protocols ->
msgs.protocols <- msgs.protocols + one
| Operation_hashes_for_block ->
msgs.operation_hashes_for_block <- msgs.operation_hashes_for_block + one
| Operations_for_block ->
msgs.operations_for_block <- msgs.operations_for_block + one
| Other ->
msgs.other <- msgs.other + one
let incr_unadvertised {unadvertised = u; _} = function
| Block ->
u.block <- u.block + one
| Operations ->
u.operations <- u.operations + one
| Protocol ->
u.protocol <- u.protocol + one
let incr ({responses = rsps; requests = rqst; _} as m) metadata =
match metadata with
(* requests *)
| Received_request req ->
incr_requests rqst.received req
| Sent_request req ->
incr_requests rqst.sent req
| Scheduled_request req ->
incr_requests rqst.scheduled req
| Failed_request req ->
incr_requests rqst.failed req
(* responses *)
| Received_response req ->
incr_requests rsps.received req
| Sent_response req ->
incr_requests rsps.sent req
| Unexpected_response ->
rsps.unexpected <- rsps.unexpected + one
| Outdated_response ->
rsps.outdated <- rsps.outdated + one
(* Advertisements *)
| Sent_advertisement ad -> (
match ad with
| Head ->
m.advertisements.sent.head <- m.advertisements.sent.head + one
| Branch ->
m.advertisements.sent.branch <- m.advertisements.sent.branch + one )
| Received_advertisement ad -> (
match ad with
| Head ->
m.advertisements.received.head <- m.advertisements.received.head + one
| Branch ->
m.advertisements.received.branch <-
m.advertisements.received.branch + one )
(* Unexpected erroneous msg *)
| Unactivated_chain ->
m.unactivated_chains <- m.unactivated_chains + one
| Inactive_chain ->
m.inactive_chains <- m.inactive_chains + one
| Future_block ->
m.future_blocks_advertised <- m.future_blocks_advertised + one
| Unadvertised u ->
incr_unadvertised m u
(* Peer validator *)
| Valid_blocks ->
m.valid_blocks <- m.valid_blocks + one
| Old_heads ->
m.old_heads <- m.old_heads + one
(* prevalidation *)
| Cannot_download ->
m.prevalidator_results <-
{
m.prevalidator_results with
cannot_download = m.prevalidator_results.cannot_download + one;
}
| Cannot_parse ->
m.prevalidator_results <-
{
m.prevalidator_results with
cannot_parse = m.prevalidator_results.cannot_parse + one;
}
| Refused_by_prefilter ->
m.prevalidator_results <-
{
m.prevalidator_results with
refused_by_prefilter =
m.prevalidator_results.refused_by_prefilter + one;
}
| Refused_by_postfilter ->
m.prevalidator_results <-
{
m.prevalidator_results with
refused_by_postfilter =
m.prevalidator_results.refused_by_postfilter + one;
}
| Applied ->
m.prevalidator_results <-
{
m.prevalidator_results with
applied = m.prevalidator_results.applied + one;
}
| Branch_delayed ->
m.prevalidator_results <-
{
m.prevalidator_results with
branch_delayed = m.prevalidator_results.branch_delayed + one;
}
| Branch_refused ->
m.prevalidator_results <-
{
m.prevalidator_results with
branch_refused = m.prevalidator_results.branch_refused + one;
}
| Refused ->
m.prevalidator_results <-
{
m.prevalidator_results with
refused = m.prevalidator_results.refused + one;
}
| Duplicate ->
m.prevalidator_results <-
{
m.prevalidator_results with
duplicate = m.prevalidator_results.duplicate + one;
}
| Outdated ->
m.prevalidator_results <-
{
m.prevalidator_results with
outdated = m.prevalidator_results.outdated + one;
}
(* shortcuts to update sent/failed requests/responses *)
let update_requests {requests = {sent; failed; _}; _} kind = function
| true ->
incr_requests sent kind
| false ->
incr_requests failed kind
let update_responses {responses = {sent; failed; _}; _} kind = function
| true ->
incr_requests sent kind
| false ->
incr_requests failed kind
(* Scores computation *)
(* TODO:
- scores cannot be kept as integers (use big numbers?)
- they scores should probably be reset frequently (at each block/cycle?)
- we might still need to keep some kind of score history
- store only best/worst/last_value/mean/variance... ?
- do we need to keep "good" scores ?
- maybe "bad" scores are enough to reduce resources
allocated to misbehaving peers *)
let distributed_db_score _ =
(* TODO *)
1.0
let prevalidation_score {prevalidator_results = _; _} =
(* TODO *)
1.0
let score _ =
(* TODO *)
1.0
src/lib_shell_services/peer_metadata.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition counter := Z.t.
Definition counter : Tezos_base__TzPervasives.Data_encoding.encoding Z.t :=
Data_encoding.z.
Definition zero : counter := Z.zero.
Definition one : counter := Z.one.
Record messages := {
branch : counter;
head : counter;
block_header : counter;
operations : counter;
protocols : counter;
operation_hashes_for_block : counter;
operations_for_block : counter;
other : counter }.
Definition sent_requests_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding messages :=
(conv
(fun function_parameter =>
let '{|
branch := branch;
head := head;
block_header := block_header;
operations := operations;
protocols := protocols;
operation_hashes_for_block := operation_hashes_for_block;
operations_for_block := operations_for_block;
other := other
|} := function_parameter in
(branch, head, block_header, operations, protocols,
operation_hashes_for_block, operations_for_block, other))
(fun function_parameter =>
let
'(branch, head, block_header, operations, protocols,
operation_hashes_for_block, operations_for_block, other) :=
function_parameter in
{| branch := branch; head := head; block_header := block_header;
operations := operations; protocols := protocols;
operation_hashes_for_block := operation_hashes_for_block;
operations_for_block := operations_for_block; other := other |})) None
(obj8 (req None None "branch" % string counter)
(req None None "head" % string counter)
(req None None "block_header" % string counter)
(req None None "operations" % string counter)
(req None None "protocols" % string counter)
(req None None "operation_hashes_for_block" % string counter)
(req None None "operations_for_block" % string counter)
(req None None "other" % string counter)).
Inductive requests_kind : Type :=
| Branch : requests_kind
| Head : requests_kind
| Block_header : requests_kind
| Operations : requests_kind
| Protocols : requests_kind
| Operation_hashes_for_block : requests_kind
| Operations_for_block : requests_kind
| Other : requests_kind.
Record requests := {
sent : messages;
received : messages;
failed : messages;
scheduled : messages }.
Definition requests_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding requests :=
(conv
(fun function_parameter =>
let '{|
sent := sent;
received := received;
failed := failed;
scheduled := scheduled
|} := function_parameter in
(sent, received, failed, scheduled))
(fun function_parameter =>
let '(sent, received, failed, scheduled) := function_parameter in
{| sent := sent; received := received; failed := failed;
scheduled := scheduled |})) None
(obj4 (req None None "sent" % string sent_requests_encoding)
(req None None "received" % string sent_requests_encoding)
(req None None "failed" % string sent_requests_encoding)
(req None None "scheduled" % string sent_requests_encoding)).
Record prevalidator_results := {
cannot_download : counter;
cannot_parse : counter;
refused_by_prefilter : counter;
refused_by_postfilter : counter;
applied : counter;
branch_delayed : counter;
branch_refused : counter;
refused : counter;
duplicate : counter;
outdated : counter }.
Definition prevalidator_results_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding prevalidator_results :=
conv
(fun function_parameter =>
let '{|
cannot_download := cannot_download;
cannot_parse := cannot_parse;
refused_by_prefilter := refused_by_prefilter;
refused_by_postfilter := refused_by_postfilter;
applied := applied;
branch_delayed := branch_delayed;
branch_refused := branch_refused;
refused := refused;
duplicate := duplicate;
outdated := outdated
|} := function_parameter in
(cannot_download, cannot_parse, refused_by_prefilter,
refused_by_postfilter, applied, branch_delayed, branch_refused, refused,
duplicate, outdated))
(fun function_parameter =>
let
'(cannot_download, cannot_parse, refused_by_prefilter,
refused_by_postfilter, applied, branch_delayed, branch_refused,
refused, duplicate, outdated) := function_parameter in
{| cannot_download := cannot_download; cannot_parse := cannot_parse;
refused_by_prefilter := refused_by_prefilter;
refused_by_postfilter := refused_by_postfilter; applied := applied;
branch_delayed := branch_delayed; branch_refused := branch_refused;
refused := refused; duplicate := duplicate; outdated := outdated |})
None
(obj10 (req None None "cannot_download" % string counter)
(req None None "cannot_parse" % string counter)
(req None None "refused_by_prefilter" % string counter)
(req None None "refused_by_postfilter" % string counter)
(req None None "applied" % string counter)
(req None None "branch_delayed" % string counter)
(req None None "branch_refused" % string counter)
(req None None "refused" % string counter)
(req None None "duplicate" % string counter)
(req None None "outdated" % string counter)).
Inductive resource_kind : Type :=
| Block : resource_kind
| Operations : resource_kind
| Protocol : resource_kind.
Inductive advertisement : Type :=
| Head : advertisement
| Branch : advertisement.
Inductive metadata : Type :=
| Received_request : requests_kind -> metadata
| Sent_request : requests_kind -> metadata
| Failed_request : requests_kind -> metadata
| Scheduled_request : requests_kind -> metadata
| Received_response : requests_kind -> metadata
| Sent_response : requests_kind -> metadata
| Unexpected_response : metadata
| Unactivated_chain : metadata
| Inactive_chain : metadata
| Future_block : metadata
| Unadvertised : resource_kind -> metadata
| Sent_advertisement : advertisement -> metadata
| Received_advertisement : advertisement -> metadata
| Outdated_response : metadata
| Valid_blocks : metadata
| Old_heads : metadata
| Cannot_download : metadata
| Cannot_parse : metadata
| Refused_by_prefilter : metadata
| Refused_by_postfilter : metadata
| Applied : metadata
| Branch_delayed : metadata
| Branch_refused : metadata
| Refused : metadata
| Duplicate : metadata
| Outdated : metadata.
Record responses := {
sent : messages;
failed : messages;
received : messages;
unexpected : counter;
outdated : counter }.
Definition responses_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding responses :=
(conv
(fun function_parameter =>
let '{|
sent := sent;
failed := failed;
received := received;
unexpected := unexpected;
outdated := outdated
|} := function_parameter in
(sent, failed, received, unexpected, outdated))
(fun function_parameter =>
let '(sent, failed, received, unexpected, outdated) := function_parameter
in
{| sent := sent; failed := failed; received := received;
unexpected := unexpected; outdated := outdated |})) None
(obj5 (req None None "sent" % string sent_requests_encoding)
(req None None "failed" % string sent_requests_encoding)
(req None None "received" % string sent_requests_encoding)
(req None None "unexpected" % string counter)
(req None None "outdated" % string counter)).
Record unadvertised := {
block : counter;
operations : counter;
protocol : counter }.
Definition unadvertised_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding unadvertised :=
(conv
(fun function_parameter =>
let '{|
block := block; operations := operations; protocol := protocol |} :=
function_parameter in
(block, operations, protocol))
(fun function_parameter =>
let '(block, operations, protocol) := function_parameter in
{| block := block; operations := operations; protocol := protocol |}))
None
(obj3 (req None None "block" % string counter)
(req None None "operations" % string counter)
(req None None "protocol" % string counter)).
Record advertisements_kind := {
head : counter;
branch : counter }.
Definition advertisements_kind_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding advertisements_kind :=
(conv
(fun function_parameter =>
let '{| head := head; branch := branch |} := function_parameter in
(head, branch))
(fun function_parameter =>
let '(head, branch) := function_parameter in
{| head := head; branch := branch |})) None
(obj2 (req None None "head" % string counter)
(req None None "branch" % string counter)).
Record advertisements := {
sent : advertisements_kind;
received : advertisements_kind }.
Definition advertisements_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding advertisements :=
(conv
(fun function_parameter =>
let '{| sent := sent; received := received |} := function_parameter in
(sent, received))
(fun function_parameter =>
let '(sent, received) := function_parameter in
{| sent := sent; received := received |})) None
(obj2 (req None None "sent" % string advertisements_kind_encoding)
(req None None "received" % string advertisements_kind_encoding)).
Record t := {
responses : responses;
requests : requests;
valid_blocks : counter;
old_heads : counter;
prevalidator_results : prevalidator_results;
unactivated_chains : counter;
inactive_chains : counter;
future_blocks_advertised : counter;
unadvertised : unadvertised;
advertisements : advertisements }.
Definition empty (function_parameter : unit) : t :=
let 'tt := function_parameter in
let empty_request (function_parameter : unit) : messages :=
let 'tt := function_parameter in
{| branch := zero; head := zero; block_header := zero; operations := zero;
protocols := zero; operation_hashes_for_block := zero;
operations_for_block := zero; other := zero |} in
{|
responses :=
{| sent := empty_request tt; failed := empty_request tt;
received := empty_request tt; unexpected := zero; outdated := zero |};
requests :=
{| sent := empty_request tt; received := empty_request tt;
failed := empty_request tt; scheduled := empty_request tt |};
valid_blocks := zero; old_heads := zero;
prevalidator_results :=
{| cannot_download := zero; cannot_parse := zero;
refused_by_prefilter := zero; refused_by_postfilter := zero;
applied := zero; branch_delayed := zero; branch_refused := zero;
refused := zero; duplicate := zero; outdated := zero |};
unactivated_chains := zero; inactive_chains := zero;
future_blocks_advertised := zero;
unadvertised := {| block := zero; operations := zero; protocol := zero |};
advertisements :=
{| sent := {| head := zero; branch := zero |};
received := {| head := zero; branch := zero |} |} |}.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
(conv
(fun function_parameter =>
let '{|
responses := responses;
requests := requests;
valid_blocks := valid_blocks;
old_heads := old_heads;
prevalidator_results := prevalidator_results;
unactivated_chains := unactivated_chains;
inactive_chains := inactive_chains;
future_blocks_advertised := future_blocks_advertised;
unadvertised := unadvertised;
advertisements := advertisements
|} := function_parameter in
((responses, requests, valid_blocks, old_heads, prevalidator_results,
unactivated_chains, inactive_chains, future_blocks_advertised),
(unadvertised, advertisements)))
(fun function_parameter =>
let
'((responses, requests, valid_blocks, old_heads, prevalidator_results,
unactivated_chains, inactive_chains, future_blocks_advertised),
(unadvertised, advertisements)) := function_parameter in
{| responses := responses; requests := requests;
valid_blocks := valid_blocks; old_heads := old_heads;
prevalidator_results := prevalidator_results;
unactivated_chains := unactivated_chains;
inactive_chains := inactive_chains;
future_blocks_advertised := future_blocks_advertised;
unadvertised := unadvertised; advertisements := advertisements |})) None
(merge_objs
(obj8 (req None None "responses" % string responses_encoding)
(req None None "requests" % string requests_encoding)
(req None None "valid_blocks" % string counter)
(req None None "old_heads" % string counter)
(req None None "prevalidator_results" % string
prevalidator_results_encoding)
(req None None "unactivated_chains" % string counter)
(req None None "inactive_chains" % string counter)
(req None None "future_blocks_advertised" % string counter))
(obj2 (req None None "unadvertised" % string unadvertised_encoding)
(req None None "advertisements" % string advertisements_encoding))).
Definition incr_requests (msgs : messages) (req : requests_kind) : unit :=
match req with
| Branch =>
(* ❌ Set record field not handled. *)
set_record_field msgs "branch" % string (op_plus (branch msgs) one)
| Head =>
(* ❌ Set record field not handled. *)
set_record_field msgs "head" % string (op_plus (head msgs) one)
| Block_header =>
(* ❌ Set record field not handled. *)
set_record_field msgs "block_header" % string
(op_plus (block_header msgs) one)
| Operations =>
(* ❌ Set record field not handled. *)
set_record_field msgs "operations" % string (op_plus (operations msgs) one)
| Protocols =>
(* ❌ Set record field not handled. *)
set_record_field msgs "protocols" % string (op_plus (protocols msgs) one)
| Operation_hashes_for_block =>
(* ❌ Set record field not handled. *)
set_record_field msgs "operation_hashes_for_block" % string
(op_plus (operation_hashes_for_block msgs) one)
| Operations_for_block =>
(* ❌ Set record field not handled. *)
set_record_field msgs "operations_for_block" % string
(op_plus (operations_for_block msgs) one)
| Other =>
(* ❌ Set record field not handled. *)
set_record_field msgs "other" % string (op_plus (other msgs) one)
end.
Definition incr_unadvertised (function_parameter : t) : resource_kind -> unit :=
let '{| unadvertised := u |} := function_parameter in
fun function_parameter =>
match function_parameter with
| Block =>
(* ❌ Set record field not handled. *)
set_record_field u "block" % string (op_plus (block u) one)
| Operations =>
(* ❌ Set record field not handled. *)
set_record_field u "operations" % string (op_plus (operations u) one)
| Protocol =>
(* ❌ Set record field not handled. *)
set_record_field u "protocol" % string (op_plus (protocol u) one)
end.
Definition incr (function_parameter : t) : metadata -> unit :=
let '{| responses := rsps; requests := rqst |} as m := function_parameter in
fun metadata =>
match metadata with
| Received_request req => incr_requests (received rqst) req
| Sent_request req => incr_requests (sent rqst) req
| Scheduled_request req => incr_requests (scheduled rqst) req
| Failed_request req => incr_requests (failed rqst) req
| Received_response req => incr_requests (received rsps) req
| Sent_response req => incr_requests (sent rsps) req
| Unexpected_response =>
(* ❌ Set record field not handled. *)
set_record_field rsps "unexpected" % string
(op_plus (unexpected rsps) one)
| Outdated_response =>
(* ❌ Set record field not handled. *)
set_record_field rsps "outdated" % string (op_plus (outdated rsps) one)
| Sent_advertisement ad =>
match ad with
| Head =>
(* ❌ Set record field not handled. *)
set_record_field (sent (advertisements m)) "head" % string
(op_plus (head (sent (advertisements m))) one)
| Branch =>
(* ❌ Set record field not handled. *)
set_record_field (sent (advertisements m)) "branch" % string
(op_plus (branch (sent (advertisements m))) one)
end
| Received_advertisement ad =>
match ad with
| Head =>
(* ❌ Set record field not handled. *)
set_record_field (received (advertisements m)) "head" % string
(op_plus (head (received (advertisements m))) one)
| Branch =>
(* ❌ Set record field not handled. *)
set_record_field (received (advertisements m)) "branch" % string
(op_plus (branch (received (advertisements m))) one)
end
| Unactivated_chain =>
(* ❌ Set record field not handled. *)
set_record_field m "unactivated_chains" % string
(op_plus (unactivated_chains m) one)
| Inactive_chain =>
(* ❌ Set record field not handled. *)
set_record_field m "inactive_chains" % string
(op_plus (inactive_chains m) one)
| Future_block =>
(* ❌ Set record field not handled. *)
set_record_field m "future_blocks_advertised" % string
(op_plus (future_blocks_advertised m) one)
| Unadvertised u => incr_unadvertised m u
| Valid_blocks =>
(* ❌ Set record field not handled. *)
set_record_field m "valid_blocks" % string (op_plus (valid_blocks m) one)
| Old_heads =>
(* ❌ Set record field not handled. *)
set_record_field m "old_heads" % string (op_plus (old_heads m) one)
| Cannot_download =>
(* ❌ Set record field not handled. *)
set_record_field m "prevalidator_results" % string
(* ❌ Record substitution not handled *)
record_substitution
| Cannot_parse =>
(* ❌ Set record field not handled. *)
set_record_field m "prevalidator_results" % string
(* ❌ Record substitution not handled *)
record_substitution
| Refused_by_prefilter =>
(* ❌ Set record field not handled. *)
set_record_field m "prevalidator_results" % string
(* ❌ Record substitution not handled *)
record_substitution
| Refused_by_postfilter =>
(* ❌ Set record field not handled. *)
set_record_field m "prevalidator_results" % string
(* ❌ Record substitution not handled *)
record_substitution
| Applied =>
(* ❌ Set record field not handled. *)
set_record_field m "prevalidator_results" % string
(* ❌ Record substitution not handled *)
record_substitution
| Branch_delayed =>
(* ❌ Set record field not handled. *)
set_record_field m "prevalidator_results" % string
(* ❌ Record substitution not handled *)
record_substitution
| Branch_refused =>
(* ❌ Set record field not handled. *)
set_record_field m "prevalidator_results" % string
(* ❌ Record substitution not handled *)
record_substitution
| Refused =>
(* ❌ Set record field not handled. *)
set_record_field m "prevalidator_results" % string
(* ❌ Record substitution not handled *)
record_substitution
| Duplicate =>
(* ❌ Set record field not handled. *)
set_record_field m "prevalidator_results" % string
(* ❌ Record substitution not handled *)
record_substitution
| Outdated =>
(* ❌ Set record field not handled. *)
set_record_field m "prevalidator_results" % string
(* ❌ Record substitution not handled *)
record_substitution
end.
Definition update_requests (function_parameter : t)
: requests_kind -> bool -> unit :=
let '{| requests := {| sent := sent; failed := failed |} |} :=
function_parameter in
fun kind =>
fun function_parameter =>
match function_parameter with
| true => incr_requests sent kind
| false => incr_requests failed kind
end.
Definition update_responses (function_parameter : t)
: requests_kind -> bool -> unit :=
let '{| responses := {| sent := sent; failed := failed |} |} :=
function_parameter in
fun kind =>
fun function_parameter =>
match function_parameter with
| true => incr_requests sent kind
| false => incr_requests failed kind
end.
Definition distributed_db_score {A : Type} (function_parameter : A) : Z :=
let '_ := function_parameter in
(* ❌ Float constant 1.0 is approximated by the integer 1 *)
1.
Definition prevalidation_score (function_parameter : t) : Z :=
let '{| prevalidator_results := _ |} := function_parameter in
(* ❌ Float constant 1.0 is approximated by the integer 1 *)
1.
Definition score {A : Type} (function_parameter : A) : Z :=
let '_ := function_parameter in
(* ❌ Float constant 1.0 is approximated by the integer 1 *)
1.
src/lib_shell_services/peer_validator_worker_state.ml success
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Request = struct
type view = New_head of Block_hash.t | New_branch of Block_hash.t * int
let encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"New_head"
(obj2
(req "request" (constant "new_head"))
(req "block" Block_hash.encoding))
(function New_head h -> Some ((), h) | _ -> None)
(fun ((), h) -> New_head h);
case
(Tag 1)
~title:"New_branch"
(obj3
(req "request" (constant "new_branch"))
(req "block" Block_hash.encoding)
(req "locators" int31))
(function New_branch (h, l) -> Some ((), h, l) | _ -> None)
(fun ((), h, l) -> New_branch (h, l)) ]
let pp ppf = function
| New_head hash ->
Format.fprintf ppf "New head %a" Block_hash.pp hash
| New_branch (hash, len) ->
Format.fprintf
ppf
"New branch %a, locator length %d"
Block_hash.pp
hash
len
end
module Event = struct
type t =
| Request of
(Request.view * Worker_types.request_status * error list option)
| Debug of string
let level req =
match req with
| Debug _ ->
Internal_event.Debug
| Request _ ->
Internal_event.Info
let encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Debug"
(obj1 (req "message" string))
(function Debug msg -> Some msg | _ -> None)
(fun msg -> Debug msg);
case
(Tag 1)
~title:"Request"
(obj2
(req "request" Request.encoding)
(req "status" Worker_types.request_status_encoding))
(function Request (req, t, None) -> Some (req, t) | _ -> None)
(fun (req, t) -> Request (req, t, None));
case
(Tag 2)
~title:"Failed request"
(obj3
(req "error" RPC_error.encoding)
(req "failed_request" Request.encoding)
(req "status" Worker_types.request_status_encoding))
(function
| Request (req, t, Some errs) -> Some (errs, req, t) | _ -> None)
(fun (errs, req, t) -> Request (req, t, Some errs)) ]
let pp ppf = function
| Debug msg ->
Format.fprintf ppf "%s" msg
| Request (view, {pushed; treated; completed}, None) ->
Format.fprintf
ppf
"@[<v 0>%a@, %a@]"
Request.pp
view
Worker_types.pp_status
{pushed; treated; completed}
| Request (view, {pushed; treated; completed}, Some errors) ->
Format.fprintf
ppf
"@[<v 0>%a@, %a, %a@]"
Request.pp
view
Worker_types.pp_status
{pushed; treated; completed}
(Format.pp_print_list Error_monad.pp)
errors
end
module Worker_state = struct
type pipeline_length = {
fetched_header_length : int;
fetched_block_length : int;
}
let pipeline_length_encoding =
let open Data_encoding in
conv
(function
| {fetched_header_length; fetched_block_length} ->
(fetched_header_length, fetched_block_length))
(function
| (fetched_header_length, fetched_block_length) ->
{fetched_header_length; fetched_block_length})
(obj2 (req "fetched_headers" int31) (req "fetched_blocks" int31))
type view = {
bootstrapped : bool;
pipeline_length : pipeline_length;
mutable last_validated_head : Block_hash.t;
mutable last_advertised_head : Block_hash.t;
}
let encoding =
let open Data_encoding in
conv
(function
| { bootstrapped;
pipeline_length;
last_validated_head;
last_advertised_head } ->
( bootstrapped,
pipeline_length,
last_validated_head,
last_advertised_head ))
(function
| ( bootstrapped,
pipeline_length,
last_validated_head,
last_advertised_head ) ->
{
bootstrapped;
pipeline_length;
last_validated_head;
last_advertised_head;
})
(obj4
(req "bootstrapped" bool)
(req "pipelines" pipeline_length_encoding)
(req "last_validated_head" Block_hash.encoding)
(req "last_advertised_head" Block_hash.encoding))
let pp ppf state =
Format.fprintf
ppf
"@[<v 0>Bootstrapped: %s@,\
Pipeline_length: %d - %d @,\
Last validated head: %a@,\
Last advertised head: %a@]"
(if state.bootstrapped then "yes" else "no")
state.pipeline_length.fetched_header_length
state.pipeline_length.fetched_block_length
Block_hash.pp
state.last_validated_head
Block_hash.pp
state.last_advertised_head
end
src/lib_shell_services/peer_validator_worker_state.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Request.
Inductive view : Type :=
| New_head : Tezos_base__TzPervasives.Block_hash.t -> view
| New_branch : Tezos_base__TzPervasives.Block_hash.t -> Z -> view.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
union None
(cons
(case "New_head" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(obj2
(req None None "request" % string (constant "new_head" % string))
(req None None "block" % string Block_hash.encoding))
(fun function_parameter =>
match function_parameter with
| New_head h => Some (tt, h)
| _ => None
end)
(fun function_parameter =>
let '(tt, h) := function_parameter in
New_head h))
(cons
(case "New_branch" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj3
(req None None "request" % string (constant "new_branch" % string))
(req None None "block" % string Block_hash.encoding)
(req None None "locators" % string int31))
(fun function_parameter =>
match function_parameter with
| New_branch h l => Some (tt, h, l)
| _ => None
end)
(fun function_parameter =>
let '(tt, h, l) := function_parameter in
New_branch h l)) [])).
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : view)
: unit :=
match function_parameter with
| New_head hash =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "New head " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "New head %a" % string)
Block_hash.pp hash
| New_branch hash len =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "New branch " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", locator length " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))))
"New branch %a, locator length %d" % string) Block_hash.pp hash len
end.
End Request.
Module Event.
Inductive t : Type :=
| Request :
(Request.view * Tezos_shell_services.Worker_types.request_status *
(option (list Tezos_base__TzPervasives.error))) -> t
| Debug : string -> t.
Definition level (req : t) : Tezos_base__TzPervasives.Internal_event.level :=
match req with
| Debug _ => Tezos_base__TzPervasives.Internal_event.Debug
| Request _ => Tezos_base__TzPervasives.Internal_event.Info
end.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
union None
(cons
(case "Debug" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(obj1 (req None None "message" % string string))
(fun function_parameter =>
match function_parameter with
| Debug msg => Some msg
| _ => None
end) (fun msg => Debug msg))
(cons
(case "Request" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj2 (req None None "request" % string Request.encoding)
(req None None "status" % string
Worker_types.request_status_encoding))
(fun function_parameter =>
match function_parameter with
| Request (req, t, None) => Some (req, t)
| _ => None
end)
(fun function_parameter =>
let '(req, t) := function_parameter in
Request (req, t, None)))
(cons
(case "Failed request" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 2)
(obj3 (req None None "error" % string RPC_error.encoding)
(req None None "failed_request" % string Request.encoding)
(req None None "status" % string
Worker_types.request_status_encoding))
(fun function_parameter =>
match function_parameter with
| Request (req, t, Some errs) => Some (errs, req, t)
| _ => None
end)
(fun function_parameter =>
let '(errs, req, t) := function_parameter in
Request (req, t, (Some errs)))) []))).
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
match function_parameter with
| Debug msg =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) msg
|
Request
(view, {|
pushed := pushed; treated := treated; completed := completed |},
None) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@[<v 0>%a@, %a@]" % string) Request.pp view Worker_types.pp_status
{| pushed := pushed; treated := treated; completed := completed |}
|
Request
(view, {|
pushed := pushed; treated := treated; completed := completed |},
Some errors) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ", " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"@[<v 0>%a@, %a, %a@]" % string) Request.pp view
Worker_types.pp_status
{| pushed := pushed; treated := treated; completed := completed |}
(Format.pp_print_list None Error_monad.pp) errors
end.
End Event.
Module Worker_state.
Record pipeline_length := {
fetched_header_length : Z;
fetched_block_length : Z }.
Definition pipeline_length_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding pipeline_length :=
conv
(fun function_parameter =>
let '{|
fetched_header_length := fetched_header_length;
fetched_block_length := fetched_block_length
|} := function_parameter in
(fetched_header_length, fetched_block_length))
(fun function_parameter =>
let '(fetched_header_length, fetched_block_length) := function_parameter
in
{| fetched_header_length := fetched_header_length;
fetched_block_length := fetched_block_length |}) None
(obj2 (req None None "fetched_headers" % string int31)
(req None None "fetched_blocks" % string int31)).
Record view := {
bootstrapped : bool;
pipeline_length : pipeline_length;
last_validated_head : Tezos_base__TzPervasives.Block_hash.t;
last_advertised_head : Tezos_base__TzPervasives.Block_hash.t }.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
conv
(fun function_parameter =>
let '{|
bootstrapped := bootstrapped;
pipeline_length := pipeline_length;
last_validated_head := last_validated_head;
last_advertised_head := last_advertised_head
|} := function_parameter in
(bootstrapped, pipeline_length, last_validated_head,
last_advertised_head))
(fun function_parameter =>
let
'(bootstrapped, pipeline_length, last_validated_head,
last_advertised_head) := function_parameter in
{| bootstrapped := bootstrapped; pipeline_length := pipeline_length;
last_validated_head := last_validated_head;
last_advertised_head := last_advertised_head |}) None
(obj4 (req None None "bootstrapped" % string bool)
(req None None "pipelines" % string pipeline_length_encoding)
(req None None "last_validated_head" % string Block_hash.encoding)
(req None None "last_advertised_head" % string Block_hash.encoding)).
Definition pp (ppf : Stdlib.Format.formatter) (state : view) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal "Bootstrapped: " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Pipeline_length: " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " - " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Last validated head: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string
0 0)
(CamlinternalFormatBasics.String_literal
"Last advertised head: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))))
"@[<v 0>Bootstrapped: %s@,Pipeline_length: %d - %d @,Last validated head: %a@,Last advertised head: %a@]"
% string)
(if bootstrapped state then
"yes" % string
else
"no" % string) (fetched_header_length (pipeline_length state))
(fetched_block_length (pipeline_length state)) Block_hash.pp
(last_validated_head state) Block_hash.pp (last_advertised_head state).
End Worker_state.
src/lib_shell_services/prevalidator_worker_state.ml 16 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Request = struct
type 'a t =
| Flush : Block_hash.t -> unit t
| Notify : P2p_peer.Id.t * Mempool.t -> unit t
| Leftover : unit t
| Inject : Operation.t -> unit t
| Arrived : Operation_hash.t * Operation.t -> unit t
| Advertise : unit t
type view = View : _ t -> view
let view req = View req
let encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Flush"
(obj2
(req "request" (constant "flush"))
(req "block" Block_hash.encoding))
(function View (Flush hash) -> Some ((), hash) | _ -> None)
(fun ((), hash) -> View (Flush hash));
case
(Tag 1)
~title:"Notify"
(obj3
(req "request" (constant "notify"))
(req "peer" P2p_peer.Id.encoding)
(req "mempool" Mempool.encoding))
(function
| View (Notify (peer, mempool)) ->
Some ((), peer, mempool)
| _ ->
None)
(fun ((), peer, mempool) -> View (Notify (peer, mempool)));
case
(Tag 2)
~title:"Inject"
(obj2
(req "request" (constant "inject"))
(req "operation" Operation.encoding))
(function View (Inject op) -> Some ((), op) | _ -> None)
(fun ((), op) -> View (Inject op));
case
(Tag 3)
~title:"Arrived"
(obj3
(req "request" (constant "arrived"))
(req "operation_hash" Operation_hash.encoding)
(req "operation" Operation.encoding))
(function
| View (Arrived (oph, op)) -> Some ((), oph, op) | _ -> None)
(fun ((), oph, op) -> View (Arrived (oph, op)));
case
(Tag 4)
~title:"Advertise"
(obj1 (req "request" (constant "advertise")))
(function View Advertise -> Some () | _ -> None)
(fun () -> View Advertise) ]
let pp ppf (View r) =
match r with
| Flush hash ->
Format.fprintf ppf "switching to new head %a" Block_hash.pp hash
| Notify (id, {Mempool.known_valid; pending}) ->
Format.fprintf
ppf
"@[<v 2>notified by %a of operations"
P2p_peer.Id.pp
id ;
List.iter
(fun oph ->
Format.fprintf ppf "@,%a (applied)" Operation_hash.pp oph)
known_valid ;
List.iter
(fun oph ->
Format.fprintf ppf "@,%a (pending)" Operation_hash.pp oph)
(Operation_hash.Set.elements pending) ;
Format.fprintf ppf "@]"
| Leftover ->
Format.fprintf ppf "process next batch of operation"
| Inject op ->
Format.fprintf
ppf
"injecting operation %a"
Operation_hash.pp
(Operation.hash op)
| Arrived (oph, _) ->
Format.fprintf ppf "operation %a arrived" Operation_hash.pp oph
| Advertise ->
Format.fprintf ppf "advertising pending operations"
end
module Event = struct
type t =
| Request of
(Request.view * Worker_types.request_status * error list option)
| Debug of string
let level req =
let open Request in
match req with
| Debug _ ->
Internal_event.Debug
| Request (View (Flush _), _, _) ->
Internal_event.Notice
| Request (View (Notify _), _, _) ->
Internal_event.Debug
| Request (View Leftover, _, _) ->
Internal_event.Debug
| Request (View (Inject _), _, _) ->
Internal_event.Notice
| Request (View (Arrived _), _, _) ->
Internal_event.Debug
| Request (View Advertise, _, _) ->
Internal_event.Debug
let encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Debug"
(obj1 (req "message" string))
(function Debug msg -> Some msg | _ -> None)
(fun msg -> Debug msg);
case
(Tag 1)
~title:"Request"
(obj2
(req "request" Request.encoding)
(req "status" Worker_types.request_status_encoding))
(function Request (req, t, None) -> Some (req, t) | _ -> None)
(fun (req, t) -> Request (req, t, None));
case
(Tag 2)
~title:"Failed request"
(obj3
(req "error" RPC_error.encoding)
(req "failed_request" Request.encoding)
(req "status" Worker_types.request_status_encoding))
(function
| Request (req, t, Some errs) -> Some (errs, req, t) | _ -> None)
(fun (errs, req, t) -> Request (req, t, Some errs)) ]
let pp ppf = function
| Debug msg ->
Format.fprintf ppf "%s" msg
| Request (view, {pushed; treated; completed}, None) ->
Format.fprintf
ppf
"@[<v 0>%a@, %a@]"
Request.pp
view
Worker_types.pp_status
{pushed; treated; completed}
| Request (view, {pushed; treated; completed}, Some errors) ->
Format.fprintf
ppf
"@[<v 0>%a@, %a, %a@]"
Request.pp
view
Worker_types.pp_status
{pushed; treated; completed}
(Format.pp_print_list Error_monad.pp)
errors
end
module Worker_state = struct
type view = {
head : Block_hash.t;
timestamp : Time.System.t;
fetching : Operation_hash.Set.t;
pending : Operation_hash.Set.t;
applied : Operation_hash.t list;
delayed : Operation_hash.Set.t;
}
let encoding =
let open Data_encoding in
conv
(fun {head; timestamp; fetching; pending; applied; delayed} ->
(head, timestamp, fetching, pending, applied, delayed))
(fun (head, timestamp, fetching, pending, applied, delayed) ->
{head; timestamp; fetching; pending; applied; delayed})
(obj6
(req "head" Block_hash.encoding)
(req "timestamp" Time.System.encoding)
(req "fetching" Operation_hash.Set.encoding)
(req "pending" Operation_hash.Set.encoding)
(req "applied" (list Operation_hash.encoding))
(req "delayed" Operation_hash.Set.encoding))
let pp ppf view =
Format.fprintf
ppf
"@[<v 0>Head: %a@,\
Timestamp: %a@,\n\
\ @[<v 2>Fetching: %a@]@,\n\
\ @[<v 2>Pending: %a@]@,\n\
\ @[<v 2>Applied: %a@]@,\n\
\ @[<v 2>Delayed: %a@]@]"
Block_hash.pp
view.head
Time.System.pp_hum
view.timestamp
(Format.pp_print_list Operation_hash.pp)
(Operation_hash.Set.elements view.fetching)
(Format.pp_print_list Operation_hash.pp)
(Operation_hash.Set.elements view.pending)
(Format.pp_print_list Operation_hash.pp)
view.applied
(Format.pp_print_list Operation_hash.pp)
(Operation_hash.Set.elements view.delayed)
end
src/lib_shell_services/prevalidator_worker_state.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Request.
Inductive t : forall (a : Type), Type :=
| Flush : Tezos_base__TzPervasives.Block_hash.t -> t unit
| Notify : Tezos_base__TzPervasives.P2p_peer.Id.t ->
Tezos_base__TzPervasives.Mempool.t -> t unit
| Leftover : t unit
| Inject : Tezos_base__TzPervasives.Operation.t -> t unit
| Arrived : Tezos_base__TzPervasives.Operation_hash.t ->
Tezos_base__TzPervasives.Operation.t -> t unit
| Advertise : t unit.
Inductive view : Type :=
| View : forall {A : Type}, (t A) -> view.
Definition view {A : Type} (req : t A) : view := View req.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
union None
(cons
(case "Flush" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(obj2 (req None None "request" % string (constant "flush" % string))
(req None None "block" % string Block_hash.encoding))
(fun function_parameter =>
match function_parameter with
| View (Flush hash) => Some (tt, hash)
| _ => None
end)
(fun function_parameter =>
let '(tt, hash) := function_parameter in
View (Flush hash)))
(cons
(case "Notify" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj3
(req None None "request" % string (constant "notify" % string))
(req None None "peer" % string P2p_peer.Id.encoding)
(req None None "mempool" % string Mempool.encoding))
(fun function_parameter =>
match function_parameter with
| View (Notify peer mempool) => Some (tt, peer, mempool)
| _ => None
end)
(fun function_parameter =>
let '(tt, peer, mempool) := function_parameter in
View (Notify peer mempool)))
(cons
(case "Inject" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 2)
(obj2
(req None None "request" % string (constant "inject" % string))
(req None None "operation" % string Operation.encoding))
(fun function_parameter =>
match function_parameter with
| View (Inject op) => Some (tt, op)
| _ => None
end)
(fun function_parameter =>
let '(tt, op) := function_parameter in
View (Inject op)))
(cons
(case "Arrived" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 3)
(obj3
(req None None "request" % string
(constant "arrived" % string))
(req None None "operation_hash" % string
Operation_hash.encoding)
(req None None "operation" % string Operation.encoding))
(fun function_parameter =>
match function_parameter with
| View (Arrived oph op) => Some (tt, oph, op)
| _ => None
end)
(fun function_parameter =>
let '(tt, oph, op) := function_parameter in
View (Arrived oph op)))
(cons
(case "Advertise" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 4)
(obj1
(req None None "request" % string
(constant "advertise" % string)))
(fun function_parameter =>
match function_parameter with
| View Advertise => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
View Advertise)) []))))).
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : view)
: unit :=
let 'View r := function_parameter in
match r with
| Flush hash =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"switching to new head " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"switching to new head %a" % string) Block_hash.pp hash
|
Notify id {|
Mempool.known_valid := known_valid; Mempool.pending := pending |} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "notified by " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" of operations" % string
CamlinternalFormatBasics.End_of_format))))
"@[<v 2>notified by %a of operations" % string) P2p_peer.Id.pp id in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun oph =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (applied)" % string
CamlinternalFormatBasics.End_of_format)))
"@,%a (applied)" % string) Operation_hash.pp oph) known_valid in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun oph =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (pending)" % string
CamlinternalFormatBasics.End_of_format)))
"@,%a (pending)" % string) Operation_hash.pp oph)
(Operation_hash.Set.elements pending) in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format) "@]" % string)
| Leftover =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"process next batch of operation" % string
CamlinternalFormatBasics.End_of_format)
"process next batch of operation" % string)
| Inject op =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"injecting operation " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"injecting operation %a" % string) Operation_hash.pp
(Operation.hash op)
| Arrived oph _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "operation " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " arrived" % string
CamlinternalFormatBasics.End_of_format)))
"operation %a arrived" % string) Operation_hash.pp oph
| Advertise =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"advertising pending operations" % string
CamlinternalFormatBasics.End_of_format)
"advertising pending operations" % string)
end.
End Request.
Module Event.
Inductive t : Type :=
| Request :
(Request.view * Tezos_shell_services.Worker_types.request_status *
(option (list Tezos_base__TzPervasives.error))) -> t
| Debug : string -> t.
Definition level (req : t) : Tezos_base__TzPervasives.Internal_event.level :=
match req with
| Debug _ => Tezos_base__TzPervasives.Internal_event.Debug
| Request (Request.View (Request.Flush _), _, _) =>
Tezos_base__TzPervasives.Internal_event.Notice
| Request (Request.View (Request.Notify _ _), _, _) =>
Tezos_base__TzPervasives.Internal_event.Debug
| Request (Request.View Request.Leftover, _, _) =>
Tezos_base__TzPervasives.Internal_event.Debug
| Request (Request.View (Request.Inject _), _, _) =>
Tezos_base__TzPervasives.Internal_event.Notice
| Request (Request.View (Request.Arrived _ _), _, _) =>
Tezos_base__TzPervasives.Internal_event.Debug
| Request (Request.View Request.Advertise, _, _) =>
Tezos_base__TzPervasives.Internal_event.Debug
end.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
union None
(cons
(case "Debug" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(obj1 (req None None "message" % string string))
(fun function_parameter =>
match function_parameter with
| Debug msg => Some msg
| _ => None
end) (fun msg => Debug msg))
(cons
(case "Request" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj2 (req None None "request" % string Request.encoding)
(req None None "status" % string
Worker_types.request_status_encoding))
(fun function_parameter =>
match function_parameter with
| Request (req, t, None) => Some (req, t)
| _ => None
end)
(fun function_parameter =>
let '(req, t) := function_parameter in
Request (req, t, None)))
(cons
(case "Failed request" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 2)
(obj3 (req None None "error" % string RPC_error.encoding)
(req None None "failed_request" % string Request.encoding)
(req None None "status" % string
Worker_types.request_status_encoding))
(fun function_parameter =>
match function_parameter with
| Request (req, t, Some errs) => Some (errs, req, t)
| _ => None
end)
(fun function_parameter =>
let '(errs, req, t) := function_parameter in
Request (req, t, (Some errs)))) []))).
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
match function_parameter with
| Debug msg =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) msg
|
Request
(view, {|
pushed := pushed; treated := treated; completed := completed |},
None) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@[<v 0>%a@, %a@]" % string) Request.pp view Worker_types.pp_status
{| pushed := pushed; treated := treated; completed := completed |}
|
Request
(view, {|
pushed := pushed; treated := treated; completed := completed |},
Some errors) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ", " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"@[<v 0>%a@, %a, %a@]" % string) Request.pp view
Worker_types.pp_status
{| pushed := pushed; treated := treated; completed := completed |}
(Format.pp_print_list None Error_monad.pp) errors
end.
End Event.
Module Worker_state.
Record view := {
head : Tezos_base__TzPervasives.Block_hash.t;
timestamp : Tezos_base__TzPervasives.Time.System.t;
fetching : Tezos_base__TzPervasives.Operation_hash.Set.t;
pending : Tezos_base__TzPervasives.Operation_hash.Set.t;
applied : list Tezos_base__TzPervasives.Operation_hash.t;
delayed : Tezos_base__TzPervasives.Operation_hash.Set.t }.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
conv
(fun function_parameter =>
let '{|
head := head;
timestamp := timestamp;
fetching := fetching;
pending := pending;
applied := applied;
delayed := delayed
|} := function_parameter in
(head, timestamp, fetching, pending, applied, delayed))
(fun function_parameter =>
let '(head, timestamp, fetching, pending, applied, delayed) :=
function_parameter in
{| head := head; timestamp := timestamp; fetching := fetching;
pending := pending; applied := applied; delayed := delayed |}) None
(obj6 (req None None "head" % string Block_hash.encoding)
(req None None "timestamp" % string Time.System.encoding)
(req None None "fetching" % string Operation_hash.Set.encoding)
(req None None "pending" % string Operation_hash.Set.encoding)
(req None None "applied" % string (list None Operation_hash.encoding))
(req None None "delayed" % string Operation_hash.Set.encoding)).
Definition pp (ppf : Stdlib.Format.formatter) (view : view) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal "Head: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Timestamp: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"
" % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Fetching: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string
0 0)
(CamlinternalFormatBasics.String_literal
"
" % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Pending: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"
" % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Applied: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"
" % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" %
string
CamlinternalFormatBasics.End_of_format)
"<v 2>" %
string))
(CamlinternalFormatBasics.String_literal
"Delayed: " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))))))))))))))))))))
"@[<v 0>Head: %a@,Timestamp: %a@,
@[<v 2>Fetching: %a@]@,
@[<v 2>Pending: %a@]@,
@[<v 2>Applied: %a@]@,
@[<v 2>Delayed: %a@]@]"
% string) Block_hash.pp (head view) Time.System.pp_hum
(timestamp view) (Format.pp_print_list None Operation_hash.pp)
(Operation_hash.Set.elements (fetching view))
(Format.pp_print_list None Operation_hash.pp)
(Operation_hash.Set.elements (pending view))
(Format.pp_print_list None Operation_hash.pp) (applied view)
(Format.pp_print_list None Operation_hash.pp)
(Operation_hash.Set.elements (delayed view)).
End Worker_state.
src/lib_shell_services/protocol_services.ml 15 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Data_encoding
module S = struct
let protocols_arg = Protocol_hash.rpc_arg
let contents =
RPC_service.get_service
~query:RPC_query.empty
~output:Protocol.encoding
RPC_path.(root / "protocols" /: protocols_arg)
let list =
RPC_service.get_service
~query:RPC_query.empty
~output:(list Protocol_hash.encoding)
RPC_path.(root / "protocols")
let fetch =
RPC_service.get_service
~description:"Fetch a protocol from the network."
~query:RPC_query.empty
~output:unit
RPC_path.(root / "fetch_protocol" /: protocols_arg)
end
open RPC_context
let contents ctxt h = make_call1 S.contents ctxt h () ()
let list ctxt = make_call S.list ctxt () () ()
let fetch ctxt h = make_call1 S.fetch ctxt h () ()
src/lib_shell_services/protocol_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Data_encoding.
Module S.
Definition protocols_arg
: Tezos_rpc.RPC_arg.t Tezos_base__TzPervasives.Protocol_hash.t :=
Protocol_hash.rpc_arg.
Definition contents
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.Protocol_hash.t) unit unit
Tezos_base__TzPervasives.Protocol.t :=
RPC_service.get_service None RPC_query.empty Protocol.encoding
(op_divcolon (op_div root "protocols" % string) protocols_arg).
Definition list
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
(list Tezos_base__TzPervasives.Protocol_hash.t) :=
RPC_service.get_service None RPC_query.empty
(list None Protocol_hash.encoding) (op_div root "protocols" % string).
Definition fetch
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.Protocol_hash.t) unit unit unit :=
RPC_service.get_service (Some "Fetch a protocol from the network." % string)
RPC_query.empty unit
(op_divcolon (op_div root "fetch_protocol" % string) protocols_arg).
End S.
Import RPC_context.
Definition contents {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(h : Tezos_base__TzPervasives.Protocol_hash.t)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult Tezos_base__TzPervasives.Protocol.t) :=
make_call1 S.contents ctxt h tt tt.
Definition list {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(list Tezos_base__TzPervasives.Protocol_hash.t)) :=
make_call S.list ctxt tt tt tt.
Definition fetch {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(h : Tezos_base__TzPervasives.Protocol_hash.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
make_call1 S.fetch ctxt h tt tt.
src/lib_shell_services/shell_services.ml 9 errors
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) type chain = Chain_services.chain type block = Block_services.block module Chain = Chain_services module Blocks = Chain.Blocks module Invalid_blocks = Chain.Invalid_blocks module Mempool = Chain.Mempool module Protocol = Protocol_services module Monitor = Monitor_services module Injection = Injection_services module P2p = P2p_services module Worker = Worker_services
src/lib_shell_services/shell_services.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. Definition chain := Tezos_shell_services.Chain_services.chain. Definition block := Tezos_shell_services.Block_services.block. (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module (* ❌ This kind of module is not handled. *) unhandled_module
src/lib_shell_services/stat_services.ml 11 errors
(*****************************************************************************)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Gc
let gc_stat_encoding =
let open Data_encoding in
conv
(fun { minor_words;
promoted_words;
major_words;
minor_collections;
major_collections;
heap_words;
heap_chunks;
live_words;
live_blocks;
free_words;
free_blocks;
largest_free;
fragments;
compactions;
top_heap_words;
stack_size } ->
( ( minor_words,
promoted_words,
major_words,
minor_collections,
major_collections ),
( (heap_words, heap_chunks, live_words, live_blocks, free_words),
( free_blocks,
largest_free,
fragments,
compactions,
top_heap_words,
stack_size ) ) ))
(fun ( ( minor_words,
promoted_words,
major_words,
minor_collections,
major_collections ),
( (heap_words, heap_chunks, live_words, live_blocks, free_words),
( free_blocks,
largest_free,
fragments,
compactions,
top_heap_words,
stack_size ) ) ) ->
{
minor_words;
promoted_words;
major_words;
minor_collections;
major_collections;
heap_words;
heap_chunks;
live_words;
live_blocks;
free_words;
free_blocks;
largest_free;
fragments;
compactions;
top_heap_words;
stack_size;
})
(merge_objs
(obj5
(req "minor_words" float)
(req "promoted_words" float)
(req "major_words" float)
(req "minor_collections" int31)
(req "major_collections" int31))
(merge_objs
(obj5
(req "heap_words" int31)
(req "heap_chunks" int31)
(req "live_words" int31)
(req "live_blocks" int31)
(req "free_words" int31))
(obj6
(req "free_blocks" int31)
(req "largest_free" int31)
(req "fragments" int31)
(req "compactions" int31)
(req "top_heap_words" int31)
(req "stack_size" int31))))
let proc_stat_encoding =
let open Memory in
let open Data_encoding in
union
~tag_size:`Uint8
[ case
(Tag 0)
(conv
(fun {page_size; size; resident; shared; text; lib; data; dt} ->
(page_size, size, resident, shared, text, lib, data, dt))
(fun (page_size, size, resident, shared, text, lib, data, dt) ->
{page_size; size; resident; shared; text; lib; data; dt})
(obj8
(req "page_size" int31)
(req "size" int64)
(req "resident" int64)
(req "shared" int64)
(req "text" int64)
(req "lib" int64)
(req "data" int64)
(req "dt" int64)))
~title:"Linux_proc_statm"
(function Statm x -> Some x | _ -> None)
(function res -> Statm res);
case
(Tag 1)
(conv
(fun {page_size; mem; resident} -> (page_size, mem, resident))
(fun (page_size, mem, resident) -> {page_size; mem; resident})
(obj3
(req "page_size" int31)
(req "mem" float)
(req "resident" int64)))
~title:"Darwin_ps"
(function Ps x -> Some x | _ -> None)
(function res -> Ps res) ]
module S = struct
let gc =
RPC_service.get_service
~description:"Gets stats from the OCaml Garbage Collector"
~query:RPC_query.empty
~output:gc_stat_encoding
RPC_path.(root / "stats" / "gc")
let memory =
RPC_service.get_service
~description:"Gets memory usage stats"
~query:RPC_query.empty
~output:proc_stat_encoding
RPC_path.(root / "stats" / "memory")
end
let gc ctxt = RPC_context.make_call S.gc ctxt () () ()
let memory ctxt = RPC_context.make_call S.memory ctxt () () ()
src/lib_shell_services/stat_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Gc.
Definition gc_stat_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Gc.stat :=
conv
(fun function_parameter =>
let '{|
minor_words := minor_words;
promoted_words := promoted_words;
major_words := major_words;
minor_collections := minor_collections;
major_collections := major_collections;
heap_words := heap_words;
heap_chunks := heap_chunks;
live_words := live_words;
live_blocks := live_blocks;
free_words := free_words;
free_blocks := free_blocks;
largest_free := largest_free;
fragments := fragments;
compactions := compactions;
top_heap_words := top_heap_words;
stack_size := stack_size
|} := function_parameter in
((minor_words, promoted_words, major_words, minor_collections,
major_collections),
((heap_words, heap_chunks, live_words, live_blocks, free_words),
(free_blocks, largest_free, fragments, compactions, top_heap_words,
stack_size))))
(fun function_parameter =>
let
'((minor_words, promoted_words, major_words, minor_collections,
major_collections),
((heap_words, heap_chunks, live_words, live_blocks, free_words),
(free_blocks, largest_free, fragments, compactions, top_heap_words,
stack_size))) := function_parameter in
{| minor_words := minor_words; promoted_words := promoted_words;
major_words := major_words; minor_collections := minor_collections;
major_collections := major_collections; heap_words := heap_words;
heap_chunks := heap_chunks; live_words := live_words;
live_blocks := live_blocks; free_words := free_words;
free_blocks := free_blocks; largest_free := largest_free;
fragments := fragments; compactions := compactions;
top_heap_words := top_heap_words; stack_size := stack_size |}) None
(merge_objs
(obj5 (req None None "minor_words" % string float)
(req None None "promoted_words" % string float)
(req None None "major_words" % string float)
(req None None "minor_collections" % string int31)
(req None None "major_collections" % string int31))
(merge_objs
(obj5 (req None None "heap_words" % string int31)
(req None None "heap_chunks" % string int31)
(req None None "live_words" % string int31)
(req None None "live_blocks" % string int31)
(req None None "free_words" % string int31))
(obj6 (req None None "free_blocks" % string int31)
(req None None "largest_free" % string int31)
(req None None "fragments" % string int31)
(req None None "compactions" % string int31)
(req None None "top_heap_words" % string int31)
(req None None "stack_size" % string int31)))).
Definition proc_stat_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_base__TzPervasives.Memory.mem_stats :=
union
(Some
(* ❌ Variants not supported *)
variant)
(cons
(case "Linux_proc_statm" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(conv
(fun function_parameter =>
let '{|
page_size := page_size;
size := size;
resident := resident;
shared := shared;
text := text;
lib := lib;
data := data;
dt := dt
|} := function_parameter in
(page_size, size, resident, shared, text, lib, data, dt))
(fun function_parameter =>
let '(page_size, size, resident, shared, text, lib, data, dt) :=
function_parameter in
{| page_size := page_size; size := size; resident := resident;
shared := shared; text := text; lib := lib; data := data; dt := dt
|}) None
(obj8 (req None None "page_size" % string int31)
(req None None "size" % string int64)
(req None None "resident" % string int64)
(req None None "shared" % string int64)
(req None None "text" % string int64)
(req None None "lib" % string int64)
(req None None "data" % string int64)
(req None None "dt" % string int64)))
(fun function_parameter =>
match function_parameter with
| Tezos_base__TzPervasives.Memory.Statm x => Some x
| _ => None
end) (fun res => Tezos_base__TzPervasives.Memory.Statm res))
(cons
(case "Darwin_ps" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(conv
(fun function_parameter =>
let '{|
page_size := page_size; mem := mem; resident := resident |} :=
function_parameter in
(page_size, mem, resident))
(fun function_parameter =>
let '(page_size, mem, resident) := function_parameter in
{| page_size := page_size; mem := mem; resident := resident |})
None
(obj3 (req None None "page_size" % string int31)
(req None None "mem" % string float)
(req None None "resident" % string int64)))
(fun function_parameter =>
match function_parameter with
| Tezos_base__TzPervasives.Memory.Ps x => Some x
| _ => None
end) (fun res => Tezos_base__TzPervasives.Memory.Ps res)) [])).
Module S.
Definition gc
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
Stdlib.Gc.stat :=
RPC_service.get_service
(Some "Gets stats from the OCaml Garbage Collector" % string)
RPC_query.empty gc_stat_encoding
(op_div (op_div root "stats" % string) "gc" % string).
Definition memory
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
Tezos_base__TzPervasives.Memory.mem_stats :=
RPC_service.get_service (Some "Gets memory usage stats" % string)
RPC_query.empty proc_stat_encoding
(op_div (op_div root "stats" % string) "memory" % string).
End S.
Definition gc {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult Stdlib.Gc.stat) :=
RPC_context.make_call S.gc ctxt tt tt tt.
Definition memory {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
Tezos_base__TzPervasives.Memory.mem_stats) :=
RPC_context.make_call S.memory ctxt tt tt tt.
src/lib_shell_services/state_logging.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Internal_event.Legacy_logging.Make_semantic (struct let name = "node.state" end) let chain_id = Tag.def ~doc:"Chain ID" "chain_id" Chain_id.pp
src/lib_shell_services/state_logging.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include Definition chain_id : Tag.def Tezos_base__TzPervasives.Chain_id.t := Tag.def (Some "Chain ID" % string) "chain_id" % string Chain_id.pp.
src/lib_shell_services/validation_errors.ml 21 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(***************** Prevalidation errors ***********************************)
type error += Parse_error
type error += Too_many_operations
type error += Oversized_operation of {size : int; max : int}
type error +=
| Future_block_header of {
block : Block_hash.t;
block_time : Time.Protocol.t;
time : Time.System.t;
}
let () =
(* Parse error *)
register_error_kind
`Permanent
~id:"node.prevalidation.parse_error"
~title:"Parsing error in prevalidation"
~description:
"Raised when an operation has not been parsed correctly during \
prevalidation."
~pp:(fun ppf () ->
Format.fprintf ppf "Operation parsing error in prevalidation.")
Data_encoding.empty
(function Parse_error -> Some () | _ -> None)
(fun () -> Parse_error) ;
(* Too many operations *)
register_error_kind
`Temporary
~id:"node.prevalidation.too_many_operations"
~title:"Too many pending operations in prevalidation"
~description:"The prevalidation context is full."
~pp:(fun ppf () ->
Format.fprintf ppf "Too many operations in prevalidation context.")
Data_encoding.empty
(function Too_many_operations -> Some () | _ -> None)
(fun () -> Too_many_operations) ;
(* Oversized operation *)
register_error_kind
`Permanent
~id:"node.prevalidation.oversized_operation"
~title:"Oversized operation"
~description:"The operation size is bigger than allowed."
~pp:(fun ppf (size, max) ->
Format.fprintf ppf "Oversized operation (size: %d, max: %d)" size max)
Data_encoding.(obj2 (req "size" int31) (req "max_size" int31))
(function
| Oversized_operation {size; max} -> Some (size, max) | _ -> None)
(fun (size, max) -> Oversized_operation {size; max}) ;
(* Block from the future *)
register_error_kind
`Temporary
~id:"node.prevalidation.future_block_header"
~title:"Future block header"
~description:"The block was annotated with a time too far in the future."
~pp:(fun ppf (block, block_time, time) ->
Format.fprintf
ppf
"Future block header (block: %a, block_time: %a, time: %a)"
Block_hash.pp
block
Time.System.pp_hum
(Time.System.of_protocol_exn block_time)
Time.System.pp_hum
time)
Data_encoding.(
obj3
(req "block" Block_hash.encoding)
(req "block_time" Time.Protocol.encoding)
(req "time" Time.System.encoding))
(function
| Future_block_header {block; block_time; time} ->
Some (block, block_time, time)
| _ ->
None)
(fun (block, block_time, time) ->
Future_block_header {block; block_time; time})
(************************* State errors ***********************************)
type error += Unknown_chain of Chain_id.t
type error += Bad_data_dir
type error += Block_not_invalid of Block_hash.t
let () =
(* Unknown network *)
register_error_kind
`Permanent
~id:"node.state.unknown_chain"
~title:"Unknown chain"
~description:
"The chain identifier could not be found in the chain identifiers table."
~pp:(fun ppf id -> Format.fprintf ppf "Unknown chain %a" Chain_id.pp id)
Data_encoding.(obj1 (req "chain" Chain_id.encoding))
(function Unknown_chain x -> Some x | _ -> None)
(fun x -> Unknown_chain x) ;
register_error_kind
`Permanent
~id:"node.state.bad_data_dir"
~title:"Bad data directory"
~description:
"The data directory could not be read. This could be because it was \
generated with an old version of the tezos-node program. Deleting and \
regenerating this directory may fix the problem."
~pp:(fun ppf () -> Format.fprintf ppf "Bad data directory.")
Data_encoding.empty
(function Bad_data_dir -> Some () | _ -> None)
(fun () -> Bad_data_dir) ;
(* Block not invalid *)
register_error_kind
`Permanent
~id:"node.state.block_not_invalid"
~title:"Block not invalid"
~description:"The invalid block to be unmarked was not actually invalid."
~pp:(fun ppf block ->
Format.fprintf
ppf
"Block %a was expected to be invalid, but was not actually invalid."
Block_hash.pp
block)
Data_encoding.(obj1 (req "block" Block_hash.encoding))
(function Block_not_invalid block -> Some block | _ -> None)
(fun block -> Block_not_invalid block)
(* Block database error *)
type error += Inconsistent_hash of Context_hash.t * Context_hash.t
let () =
(* Inconsistent hash *)
register_error_kind
`Permanent
~id:"node.state.block.inconsistent_context_hash"
~title:"Inconsistent commit hash"
~description:
"When commiting the context of a block, the announced context hash was \
not the one computed at commit time."
~pp:(fun ppf (got, exp) ->
Format.fprintf
ppf
"@[<v 2>Inconsistent hash:@ got: %a@ expected: %a"
Context_hash.pp
got
Context_hash.pp
exp)
Data_encoding.(
obj2
(req "wrong_context_hash" Context_hash.encoding)
(req "expected_context_hash" Context_hash.encoding))
(function Inconsistent_hash (got, exp) -> Some (got, exp) | _ -> None)
(fun (got, exp) -> Inconsistent_hash (got, exp))
(******************* Bootstrap pipeline errors ****************************)
type error += Invalid_locator of P2p_peer.Id.t * Block_locator.t
type error += Too_short_locator of P2p_peer.Id.t * Block_locator.t
let () =
(* Invalid locator *)
register_error_kind
`Permanent
~id:"node.bootstrap_pipeline.invalid_locator"
~title:"Invalid block locator"
~description:"Block locator is invalid."
~pp:(fun ppf (id, locator) ->
Format.fprintf
ppf
"Invalid block locator on peer %a:\n%a"
P2p_peer.Id.pp
id
Block_locator.pp
locator)
Data_encoding.(
obj2
(req "id" P2p_peer.Id.encoding)
(req "locator" Block_locator.encoding))
(function Invalid_locator (id, loc) -> Some (id, loc) | _ -> None)
(fun (id, loc) -> Invalid_locator (id, loc)) ;
(* Too short locator *)
register_error_kind
`Permanent
~id:"node.bootstrap_pipeline.too_short_locator"
~title:"Too short locator"
~description:"Block locator is too short."
~pp:(fun ppf (id, locator) ->
Format.fprintf
ppf
"Too short locator on peer %a:\n%a"
P2p_peer.Id.pp
id
Block_locator.pp
locator)
Data_encoding.(
obj2
(req "id" P2p_peer.Id.encoding)
(req "locator" Block_locator.encoding))
(function Too_short_locator (id, loc) -> Some (id, loc) | _ -> None)
(fun (id, loc) -> Too_short_locator (id, loc))
(******************* Protocol validator errors ****************************)
type protocol_error = Compilation_failed | Dynlinking_failed
type error +=
| Invalid_protocol of {hash : Protocol_hash.t; error : protocol_error}
let protocol_error_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Compilation failed"
(obj1 (req "error" (constant "compilation_failed")))
(function Compilation_failed -> Some () | _ -> None)
(fun () -> Compilation_failed);
case
(Tag 1)
~title:"Dynlinking failed"
(obj1 (req "error" (constant "dynlinking_failed")))
(function Dynlinking_failed -> Some () | _ -> None)
(fun () -> Dynlinking_failed) ]
let pp_protocol_error ppf = function
| Compilation_failed ->
Format.fprintf ppf "compilation error"
| Dynlinking_failed ->
Format.fprintf ppf "dynlinking error"
let () =
(* Invalid protocol *)
register_error_kind
`Permanent
~id:"node.protocol_validator.invalid_protocol"
~title:"Invalid protocol"
~description:"Invalid protocol."
~pp:(fun ppf (protocol, error) ->
Format.fprintf
ppf
"@[<v 2>Invalid protocol %a@ %a@]"
Protocol_hash.pp_short
protocol
pp_protocol_error
error)
Data_encoding.(
merge_objs
(obj1 (req "invalid_protocol" Protocol_hash.encoding))
protocol_error_encoding)
(function
| Invalid_protocol {hash; error} -> Some (hash, error) | _ -> None)
(fun (hash, error) -> Invalid_protocol {hash; error})
(********************* Peer validator errors ******************************)
type error += Unknown_ancestor | Known_invalid
let () =
(* Unknown ancestor *)
register_error_kind
`Permanent
~id:"node.peer_validator.unknown_ancestor"
~title:"Unknown ancestor"
~description:"Unknown ancestor block found in the peer's chain"
~pp:(fun ppf () -> Format.fprintf ppf "Unknown ancestor")
Data_encoding.empty
(function Unknown_ancestor -> Some () | _ -> None)
(fun () -> Unknown_ancestor) ;
(* Known invalid *)
register_error_kind
`Permanent
~id:"node.peer_validator.known_invalid"
~title:"Known invalid"
~description:"Known invalid block found in the peer's chain"
~pp:(fun ppf () -> Format.fprintf ppf "Known invalid")
Data_encoding.empty
(function Known_invalid -> Some () | _ -> None)
(fun () -> Known_invalid)
(************************ Validator errors ********************************)
type error += Inactive_chain of Chain_id.t
type error += Checkpoint_error of Block_hash.t * P2p_peer.Id.t option
let () =
(* Inactive network *)
register_error_kind
`Branch
~id:"node.validator.inactive_chain"
~title:"Inactive chain"
~description:"Attempted validation of a block from an inactive chain."
~pp:(fun ppf chain ->
Format.fprintf
ppf
"Tried to validate a block from chain %a, that is not currently \
considered active."
Chain_id.pp
chain)
Data_encoding.(obj1 (req "inactive_chain" Chain_id.encoding))
(function Inactive_chain chain -> Some chain | _ -> None)
(fun chain -> Inactive_chain chain) ;
register_error_kind
`Branch
~id:"node.validator.checkpoint_error"
~title:"Block incompatible with the current checkpoint."
~description:
"The block belongs to a branch that is not compatible with the current \
checkpoint."
~pp:(fun ppf (block, peer) ->
match peer with
| None ->
Format.fprintf
ppf
"The block %a is incompatible with the current checkpoint."
Block_hash.pp_short
block
| Some peer ->
Format.fprintf
ppf
"The peer %a send us a block which is a sibling of the configured \
checkpoint (%a)."
P2p_peer.Id.pp
peer
Block_hash.pp_short
block)
Data_encoding.(
obj2 (req "block" Block_hash.encoding) (opt "peer" P2p_peer.Id.encoding))
(function
| Checkpoint_error (block, peer) -> Some (block, peer) | _ -> None)
(fun (block, peer) -> Checkpoint_error (block, peer))
src/lib_shell_services/validation_errors.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Inductive protocol_error : Type :=
| Compilation_failed : protocol_error
| Dynlinking_failed : protocol_error.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition protocol_error_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding protocol_error :=
union None
(cons
(case "Compilation failed" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(obj1
(req None None "error" % string
(constant "compilation_failed" % string)))
(fun function_parameter =>
match function_parameter with
| Compilation_failed => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Compilation_failed))
(cons
(case "Dynlinking failed" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj1
(req None None "error" % string
(constant "dynlinking_failed" % string)))
(fun function_parameter =>
match function_parameter with
| Dynlinking_failed => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Dynlinking_failed)) [])).
Definition pp_protocol_error
(ppf : Stdlib.Format.formatter) (function_parameter : protocol_error)
: unit :=
match function_parameter with
| Compilation_failed =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "compilation error" % string
CamlinternalFormatBasics.End_of_format) "compilation error" % string)
| Dynlinking_failed =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "dynlinking error" % string
CamlinternalFormatBasics.End_of_format) "dynlinking error" % string)
end.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
src/lib_shell_services/worker_services.ml 70 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Data_encoding
module Prevalidators = struct
module S = struct
let list =
RPC_service.get_service
~description:"Lists the Prevalidator workers and their status."
~query:RPC_query.empty
~output:
(list
(obj4
(req "chain_id" Chain_id.encoding)
(req
"status"
(Worker_types.worker_status_encoding RPC_error.encoding))
(req
"information"
(Worker_types.worker_information_encoding RPC_error.encoding))
(req "pipelines" int8)))
RPC_path.(root / "workers" / "prevalidators")
let state =
RPC_service.get_service
~description:"Introspect the state of prevalidator workers."
~query:RPC_query.empty
~output:
(Worker_types.full_status_encoding
Prevalidator_worker_state.Request.encoding
Prevalidator_worker_state.Event.encoding
RPC_error.encoding)
RPC_path.(
root / "workers" / "prevalidators" /: Chain_services.chain_arg)
end
open RPC_context
let list ctxt = make_call S.list ctxt () () ()
let state ctxt h = make_call1 S.state ctxt h () ()
end
module Block_validator = struct
module S = struct
let state =
RPC_service.get_service
~description:"Introspect the state of the block_validator worker."
~query:RPC_query.empty
~output:
(Worker_types.full_status_encoding
Block_validator_worker_state.Request.encoding
Block_validator_worker_state.Event.encoding
RPC_error.encoding)
RPC_path.(root / "workers" / "block_validator")
end
open RPC_context
let state ctxt = make_call S.state ctxt () () ()
end
module Peer_validators = struct
module S = struct
let list =
RPC_service.get_service
~description:"Lists the peer validator workers and their status."
~query:RPC_query.empty
~output:
(list
(obj4
(req "peer_id" P2p_peer.Id.encoding)
(req
"status"
(Worker_types.worker_status_encoding RPC_error.encoding))
(req
"information"
(Worker_types.worker_information_encoding RPC_error.encoding))
(req
"pipelines"
Peer_validator_worker_state.Worker_state
.pipeline_length_encoding)))
RPC_path.(
root / "workers" / "chain_validators" /: Chain_services.chain_arg
/ "peers_validators")
let state =
RPC_service.get_service
~description:"Introspect the state of a peer validator worker."
~query:RPC_query.empty
~output:
(Worker_types.full_status_encoding
Peer_validator_worker_state.Request.encoding
Peer_validator_worker_state.Event.encoding
RPC_error.encoding)
RPC_path.(
root / "workers" / "chain_validators" /: Chain_services.chain_arg
/ "peers_validators" /: P2p_peer.Id.rpc_arg)
end
open RPC_context
let list ctxt n = make_call1 S.list ctxt n () ()
let state ctxt n h = make_call2 S.state ctxt n h () ()
end
module Chain_validators = struct
module S = struct
let list =
RPC_service.get_service
~description:"Lists the chain validator workers and their status."
~query:RPC_query.empty
~output:
(list
(obj4
(req "chain_id" Chain_id.encoding)
(req
"status"
(Worker_types.worker_status_encoding RPC_error.encoding))
(req
"information"
(Worker_types.worker_information_encoding RPC_error.encoding))
(req "pipelines" int8)))
RPC_path.(root / "workers" / "chain_validators")
let state =
RPC_service.get_service
~description:"Introspect the state of a chain validator worker."
~query:RPC_query.empty
~output:
(Worker_types.full_status_encoding
Chain_validator_worker_state.Request.encoding
Chain_validator_worker_state.Event.encoding
RPC_error.encoding)
RPC_path.(
root / "workers" / "chain_validators" /: Chain_services.chain_arg)
let ddb_state =
RPC_service.get_service
~description:
"Introspect the state of the DDB attached to a chain validator \
worker."
~query:RPC_query.empty
~output:Chain_validator_worker_state.Distributed_db_state.encoding
RPC_path.(
root / "workers" / "chain_validators" /: Chain_services.chain_arg
/ "ddb")
end
open RPC_context
let list ctxt = make_call S.list ctxt () () ()
let state ctxt h = make_call1 S.state ctxt h () ()
let ddb_state ctxt h = make_call1 S.ddb_state ctxt h () ()
end
src/lib_shell_services/worker_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Data_encoding.
Module Prevalidators.
Module S.
Definition list
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
(list
(Tezos_base__TzPervasives.Chain_id.t *
Tezos_shell_services.Worker_types.worker_status *
Tezos_shell_services.Worker_types.worker_information * Z)) :=
RPC_service.get_service
(Some "Lists the Prevalidator workers and their status." % string)
RPC_query.empty
(list None
(obj4 (req None None "chain_id" % string Chain_id.encoding)
(req None None "status" % string
(Worker_types.worker_status_encoding RPC_error.encoding))
(req None None "information" % string
(Worker_types.worker_information_encoding RPC_error.encoding))
(req None None "pipelines" % string int8)))
(op_div (op_div root "workers" % string) "prevalidators" % string).
Definition state
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_shell_services.Chain_services.chain) unit unit
(Tezos_shell_services.Worker_types.full_status
Tezos_shell_services.Prevalidator_worker_state.Request.view
Tezos_shell_services.Prevalidator_worker_state.Event.t) :=
RPC_service.get_service
(Some "Introspect the state of prevalidator workers." % string)
RPC_query.empty
(Worker_types.full_status_encoding
Prevalidator_worker_state.Request.encoding
Prevalidator_worker_state.Event.encoding RPC_error.encoding)
(op_divcolon
(op_div (op_div root "workers" % string) "prevalidators" % string)
Chain_services.chain_arg).
End S.
Import RPC_context.
Definition list {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(list
(Tezos_base__TzPervasives.Chain_id.t *
Tezos_shell_services.Worker_types.worker_status *
Tezos_shell_services.Worker_types.worker_information * Z))) :=
make_call S.list ctxt tt tt tt.
Definition state {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(h : Tezos_shell_services.Chain_services.chain)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(Tezos_shell_services.Worker_types.full_status
Tezos_shell_services.Prevalidator_worker_state.Request.view
Tezos_shell_services.Prevalidator_worker_state.Event.t)) :=
make_call1 S.state ctxt h tt tt.
End Prevalidators.
Module Block_validator.
Module S.
Definition state
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
(Tezos_shell_services.Worker_types.full_status
Tezos_shell_services.Block_validator_worker_state.Request.view
Tezos_shell_services.Block_validator_worker_state.Event.t) :=
RPC_service.get_service
(Some "Introspect the state of the block_validator worker." % string)
RPC_query.empty
(Worker_types.full_status_encoding
Block_validator_worker_state.Request.encoding
Block_validator_worker_state.Event.encoding RPC_error.encoding)
(op_div (op_div root "workers" % string) "block_validator" % string).
End S.
Import RPC_context.
Definition state {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(Tezos_shell_services.Worker_types.full_status
Tezos_shell_services.Block_validator_worker_state.Request.view
Tezos_shell_services.Block_validator_worker_state.Event.t)) :=
make_call S.state ctxt tt tt tt.
End Block_validator.
Module Peer_validators.
Module S.
Definition list
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_shell_services.Chain_services.chain) unit unit
(list
(Tezos_base__TzPervasives.P2p_peer.Id.t *
Tezos_shell_services.Worker_types.worker_status *
Tezos_shell_services.Worker_types.worker_information *
Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length)) :=
RPC_service.get_service
(Some "Lists the peer validator workers and their status." % string)
RPC_query.empty
(list None
(obj4 (req None None "peer_id" % string P2p_peer.Id.encoding)
(req None None "status" % string
(Worker_types.worker_status_encoding RPC_error.encoding))
(req None None "information" % string
(Worker_types.worker_information_encoding RPC_error.encoding))
(req None None "pipelines" % string
Peer_validator_worker_state.Worker_state.pipeline_length_encoding)))
(op_div
(op_divcolon
(op_div (op_div root "workers" % string) "chain_validators" % string)
Chain_services.chain_arg) "peers_validators" % string).
Definition state
: Tezos_base__TzPervasives.RPC_service.service variant unit
((unit * Tezos_shell_services.Chain_services.chain) *
Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
(Tezos_shell_services.Worker_types.full_status
Tezos_shell_services.Peer_validator_worker_state.Request.view
Tezos_shell_services.Peer_validator_worker_state.Event.t) :=
RPC_service.get_service
(Some "Introspect the state of a peer validator worker." % string)
RPC_query.empty
(Worker_types.full_status_encoding
Peer_validator_worker_state.Request.encoding
Peer_validator_worker_state.Event.encoding RPC_error.encoding)
(op_divcolon
(op_div
(op_divcolon
(op_div (op_div root "workers" % string)
"chain_validators" % string) Chain_services.chain_arg)
"peers_validators" % string) P2p_peer.Id.rpc_arg).
End S.
Import RPC_context.
Definition list {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(n : Tezos_shell_services.Chain_services.chain)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(list
(Tezos_base__TzPervasives.P2p_peer.Id.t *
Tezos_shell_services.Worker_types.worker_status *
Tezos_shell_services.Worker_types.worker_information *
Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length))) :=
make_call1 S.list ctxt n tt tt.
Definition state {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(n : Tezos_shell_services.Chain_services.chain)
(h : Tezos_base__TzPervasives.P2p_peer.Id.t)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(Tezos_shell_services.Worker_types.full_status
Tezos_shell_services.Peer_validator_worker_state.Request.view
Tezos_shell_services.Peer_validator_worker_state.Event.t)) :=
make_call2 S.state ctxt n h tt tt.
End Peer_validators.
Module Chain_validators.
Module S.
Definition list
: Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
(list
(Tezos_base__TzPervasives.Chain_id.t *
Tezos_shell_services.Worker_types.worker_status *
Tezos_shell_services.Worker_types.worker_information * Z)) :=
RPC_service.get_service
(Some "Lists the chain validator workers and their status." % string)
RPC_query.empty
(list None
(obj4 (req None None "chain_id" % string Chain_id.encoding)
(req None None "status" % string
(Worker_types.worker_status_encoding RPC_error.encoding))
(req None None "information" % string
(Worker_types.worker_information_encoding RPC_error.encoding))
(req None None "pipelines" % string int8)))
(op_div (op_div root "workers" % string) "chain_validators" % string).
Definition state
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_shell_services.Chain_services.chain) unit unit
(Tezos_shell_services.Worker_types.full_status
Tezos_shell_services.Chain_validator_worker_state.Request.view
Tezos_shell_services.Chain_validator_worker_state.Event.t) :=
RPC_service.get_service
(Some "Introspect the state of a chain validator worker." % string)
RPC_query.empty
(Worker_types.full_status_encoding
Chain_validator_worker_state.Request.encoding
Chain_validator_worker_state.Event.encoding RPC_error.encoding)
(op_divcolon
(op_div (op_div root "workers" % string) "chain_validators" % string)
Chain_services.chain_arg).
Definition ddb_state
: Tezos_base__TzPervasives.RPC_service.service variant unit
(unit * Tezos_shell_services.Chain_services.chain) unit unit
Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view :=
RPC_service.get_service
(Some
"Introspect the state of the DDB attached to a chain validator worker."
% string) RPC_query.empty
Chain_validator_worker_state.Distributed_db_state.encoding
(op_div
(op_divcolon
(op_div (op_div root "workers" % string) "chain_validators" % string)
Chain_services.chain_arg) "ddb" % string).
End S.
Import RPC_context.
Definition list {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(list
(Tezos_base__TzPervasives.Chain_id.t *
Tezos_shell_services.Worker_types.worker_status *
Tezos_shell_services.Worker_types.worker_information * Z))) :=
make_call S.list ctxt tt tt tt.
Definition state {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(h : Tezos_shell_services.Chain_services.chain)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(Tezos_shell_services.Worker_types.full_status
Tezos_shell_services.Chain_validator_worker_state.Request.view
Tezos_shell_services.Chain_validator_worker_state.Event.t)) :=
make_call1 S.state ctxt h tt tt.
Definition ddb_state {E F i o p q : Type}
(ctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(h : Tezos_shell_services.Chain_services.chain)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view) :=
make_call1 S.ddb_state ctxt h tt tt.
End Chain_validators.
src/lib_shell_services/worker_types.ml 28 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type limits = {backlog_size : int; backlog_level : Internal_event.level}
type worker_status =
| Launching of Time.System.t
| Running of Time.System.t
| Closing of Time.System.t * Time.System.t
| Closed of Time.System.t * Time.System.t * error list option
let worker_status_encoding error_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Launching"
(obj2
(req "phase" (constant "launching"))
(req "since" Time.System.encoding))
(function Launching t -> Some ((), t) | _ -> None)
(fun ((), t) -> Launching t);
case
(Tag 1)
~title:"Running"
(obj2
(req "phase" (constant "running"))
(req "since" Time.System.encoding))
(function Running t -> Some ((), t) | _ -> None)
(fun ((), t) -> Running t);
case
(Tag 2)
~title:"Closing"
(obj3
(req "phase" (constant "closing"))
(req "birth" Time.System.encoding)
(req "since" Time.System.encoding))
(function Closing (t0, t) -> Some ((), t0, t) | _ -> None)
(fun ((), t0, t) -> Closing (t0, t));
case
(Tag 3)
~title:"Closed"
(obj3
(req "phase" (constant "closed"))
(req "birth" Time.System.encoding)
(req "since" Time.System.encoding))
(function Closed (t0, t, None) -> Some ((), t0, t) | _ -> None)
(fun ((), t0, t) -> Closed (t0, t, None));
case
(Tag 4)
~title:"Crashed"
(obj4
(req "phase" (constant "crashed"))
(req "birth" Time.System.encoding)
(req "since" Time.System.encoding)
(req "errors" error_encoding))
(function
| Closed (t0, t, Some errs) -> Some ((), t0, t, errs) | _ -> None)
(fun ((), t0, t, errs) -> Closed (t0, t, Some errs)) ]
type worker_information = {
instances_number : int;
wstatus : worker_status;
queue_length : int;
}
let worker_information_encoding error_encoding =
Data_encoding.(
conv
(fun {instances_number; wstatus; queue_length} ->
(instances_number, wstatus, queue_length))
(fun (instances_number, wstatus, queue_length) ->
{instances_number; wstatus; queue_length})
(obj3
(req "instances" int31)
(req "status" (worker_status_encoding error_encoding))
(req "queue_length" int31)))
type request_status = {
pushed : Time.System.t;
treated : Time.System.t;
completed : Time.System.t;
}
let request_status_encoding =
let open Data_encoding in
conv
(fun {pushed; treated; completed} -> (pushed, treated, completed))
(fun (pushed, treated, completed) -> {pushed; treated; completed})
(obj3
(req "pushed" Time.System.encoding)
(req "treated" Time.System.encoding)
(req "completed" Time.System.encoding))
type ('req, 'evt) full_status = {
status : worker_status;
pending_requests : (Time.System.t * 'req) list;
backlog : (Internal_event.level * 'evt list) list;
current_request : (Time.System.t * Time.System.t * 'req) option;
}
let full_status_encoding req_encoding evt_encoding error_encoding =
let open Data_encoding in
let requests_encoding =
list
(obj2
(req "pushed" Time.System.encoding)
(req "request" (dynamic_size req_encoding)))
in
let events_encoding =
list
(obj2
(req "level" Internal_event.Level.encoding)
(req "events" (dynamic_size (list (dynamic_size evt_encoding)))))
in
let current_request_encoding =
obj3
(req "pushed" Time.System.encoding)
(req "treated" Time.System.encoding)
(req "request" req_encoding)
in
conv
(fun {status; pending_requests; backlog; current_request} ->
(status, pending_requests, backlog, current_request))
(fun (status, pending_requests, backlog, current_request) ->
{status; pending_requests; backlog; current_request})
(obj4
(req "status" (worker_status_encoding error_encoding))
(req "pending_requests" requests_encoding)
(req "backlog" events_encoding)
(opt "current_request" current_request_encoding))
let pp_status ppf {pushed; treated; completed} =
let completed = Ptime.diff completed treated
and treated = Ptime.diff treated pushed in
Format.fprintf
ppf
"Request pushed on %a, treated in %a, completed in %a "
Time.System.pp_hum
pushed
Ptime.Span.pp
treated
Ptime.Span.pp
completed
src/lib_shell_services/worker_types.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record limits := {
backlog_size : Z;
backlog_level : Tezos_base__TzPervasives.Internal_event.level }.
Inductive worker_status : Type :=
| Launching : Tezos_base__TzPervasives.Time.System.t -> worker_status
| Running : Tezos_base__TzPervasives.Time.System.t -> worker_status
| Closing : Tezos_base__TzPervasives.Time.System.t ->
Tezos_base__TzPervasives.Time.System.t -> worker_status
| Closed : Tezos_base__TzPervasives.Time.System.t ->
Tezos_base__TzPervasives.Time.System.t ->
(option (list Tezos_base__TzPervasives.error)) -> worker_status.
Definition worker_status_encoding
(error_encoding :
Tezos_base__TzPervasives.Data_encoding.encoding
(list Tezos_base__TzPervasives.error))
: Tezos_base__TzPervasives.Data_encoding.encoding worker_status :=
union None
(cons
(case "Launching" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(obj2 (req None None "phase" % string (constant "launching" % string))
(req None None "since" % string Time.System.encoding))
(fun function_parameter =>
match function_parameter with
| Launching t => Some (tt, t)
| _ => None
end)
(fun function_parameter =>
let '(tt, t) := function_parameter in
Launching t))
(cons
(case "Running" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj2 (req None None "phase" % string (constant "running" % string))
(req None None "since" % string Time.System.encoding))
(fun function_parameter =>
match function_parameter with
| Running t => Some (tt, t)
| _ => None
end)
(fun function_parameter =>
let '(tt, t) := function_parameter in
Running t))
(cons
(case "Closing" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 2)
(obj3 (req None None "phase" % string (constant "closing" % string))
(req None None "birth" % string Time.System.encoding)
(req None None "since" % string Time.System.encoding))
(fun function_parameter =>
match function_parameter with
| Closing t0 t => Some (tt, t0, t)
| _ => None
end)
(fun function_parameter =>
let '(tt, t0, t) := function_parameter in
Closing t0 t))
(cons
(case "Closed" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 3)
(obj3
(req None None "phase" % string (constant "closed" % string))
(req None None "birth" % string Time.System.encoding)
(req None None "since" % string Time.System.encoding))
(fun function_parameter =>
match function_parameter with
| Closed t0 t None => Some (tt, t0, t)
| _ => None
end)
(fun function_parameter =>
let '(tt, t0, t) := function_parameter in
Closed t0 t None))
(cons
(case "Crashed" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 4)
(obj4
(req None None "phase" % string (constant "crashed" % string))
(req None None "birth" % string Time.System.encoding)
(req None None "since" % string Time.System.encoding)
(req None None "errors" % string error_encoding))
(fun function_parameter =>
match function_parameter with
| Closed t0 t (Some errs) => Some (tt, t0, t, errs)
| _ => None
end)
(fun function_parameter =>
let '(tt, t0, t, errs) := function_parameter in
Closed t0 t (Some errs))) []))))).
Record worker_information := {
instances_number : Z;
wstatus : worker_status;
queue_length : Z }.
Definition worker_information_encoding
(error_encoding :
Tezos_base__TzPervasives.Data_encoding.encoding
(list Tezos_base__TzPervasives.error))
: Tezos_base__TzPervasives.Data_encoding.encoding worker_information :=
conv
(fun function_parameter =>
let '{|
instances_number := instances_number;
wstatus := wstatus;
queue_length := queue_length
|} := function_parameter in
(instances_number, wstatus, queue_length))
(fun function_parameter =>
let '(instances_number, wstatus, queue_length) := function_parameter in
{| instances_number := instances_number; wstatus := wstatus;
queue_length := queue_length |}) None
(obj3 (req None None "instances" % string int31)
(req None None "status" % string (worker_status_encoding error_encoding))
(req None None "queue_length" % string int31)).
Record request_status := {
pushed : Tezos_base__TzPervasives.Time.System.t;
treated : Tezos_base__TzPervasives.Time.System.t;
completed : Tezos_base__TzPervasives.Time.System.t }.
Definition request_status_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding request_status :=
conv
(fun function_parameter =>
let '{| pushed := pushed; treated := treated; completed := completed |} :=
function_parameter in
(pushed, treated, completed))
(fun function_parameter =>
let '(pushed, treated, completed) := function_parameter in
{| pushed := pushed; treated := treated; completed := completed |}) None
(obj3 (req None None "pushed" % string Time.System.encoding)
(req None None "treated" % string Time.System.encoding)
(req None None "completed" % string Time.System.encoding)).
Record full_status {req evt : Type} := {
status : worker_status;
pending_requests : list (Tezos_base__TzPervasives.Time.System.t * req);
backlog : list (Tezos_base__TzPervasives.Internal_event.level * (list evt));
current_request :
option
(Tezos_base__TzPervasives.Time.System.t *
Tezos_base__TzPervasives.Time.System.t * req) }.
Arguments full_status : clear implicits.
Definition full_status_encoding {A B : Type}
(req_encoding : Tezos_base__TzPervasives.Data_encoding.encoding A)
(evt_encoding : Tezos_base__TzPervasives.Data_encoding.encoding B)
(error_encoding :
Tezos_base__TzPervasives.Data_encoding.encoding
(list Tezos_base__TzPervasives.error))
: Tezos_base__TzPervasives.Data_encoding.encoding (full_status A B) :=
let requests_encoding :=
list None
(obj2 (req None None "pushed" % string Time.System.encoding)
(req None None "request" % string (dynamic_size None req_encoding))) in
let events_encoding :=
list None
(obj2 (req None None "level" % string Internal_event.Level.encoding)
(req None None "events" % string
(dynamic_size None (list None (dynamic_size None evt_encoding))))) in
let current_request_encoding :=
obj3 (req None None "pushed" % string Time.System.encoding)
(req None None "treated" % string Time.System.encoding)
(req None None "request" % string req_encoding) in
conv
(fun function_parameter =>
let '{|
status := status;
pending_requests := pending_requests;
backlog := backlog;
current_request := current_request
|} := function_parameter in
(status, pending_requests, backlog, current_request))
(fun function_parameter =>
let '(status, pending_requests, backlog, current_request) :=
function_parameter in
{| status := status; pending_requests := pending_requests;
backlog := backlog; current_request := current_request |}) None
(obj4
(req None None "status" % string (worker_status_encoding error_encoding))
(req None None "pending_requests" % string requests_encoding)
(req None None "backlog" % string events_encoding)
(opt None None "current_request" % string current_request_encoding)).
Definition pp_status
(ppf : Stdlib.Format.formatter) (function_parameter : request_status)
: unit :=
let '{| pushed := pushed; treated := treated; completed := completed |} :=
function_parameter in
let completed : Ptime.span :=
Ptime.diff completed treated
with treated : Ptime.span :=
Ptime.diff treated pushed in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Request pushed on " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ", treated in " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", completed in " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal " " % char
CamlinternalFormatBasics.End_of_format)))))))
"Request pushed on %a, treated in %a, completed in %a " % string)
Time.System.pp_hum pushed Ptime.Span.pp treated Ptime.Span.pp completed.
src/lib_signer_backends/encrypted.ml 135 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type Base58.data += Encrypted_ed25519 of Bytes.t
type Base58.data += Encrypted_secp256k1 of Bytes.t
type Base58.data += Encrypted_p256 of Bytes.t
open Client_keys
let scheme = "encrypted"
module Raw = struct
(* https://tools.ietf.org/html/rfc2898#section-4.1 *)
let salt_len = 8
(* Fixed zero nonce *)
let nonce = Crypto_box.zero_nonce
(* Secret keys for Ed25519, secp256k1, P256 are 32 bytes long. *)
let encrypted_size = Crypto_box.boxzerobytes + 32
let pbkdf ~salt ~password =
Pbkdf.SHA512.pbkdf2 ~count:32768 ~dk_len:32l ~salt ~password
let encrypt ~password sk =
let salt = Hacl.Rand.gen salt_len in
let key = Crypto_box.Secretbox.unsafe_of_bytes (pbkdf ~salt ~password) in
let msg =
match (sk : Signature.secret_key) with
| Ed25519 sk ->
Data_encoding.Binary.to_bytes_exn Ed25519.Secret_key.encoding sk
| Secp256k1 sk ->
Data_encoding.Binary.to_bytes_exn Secp256k1.Secret_key.encoding sk
| P256 sk ->
Data_encoding.Binary.to_bytes_exn P256.Secret_key.encoding sk
in
Bigstring.concat "" [salt; Crypto_box.Secretbox.box key msg nonce]
let decrypt algo ~password ~encrypted_sk =
let salt = Bigstring.sub encrypted_sk 0 salt_len in
let encrypted_sk = Bigstring.sub encrypted_sk salt_len encrypted_size in
let key = Crypto_box.Secretbox.unsafe_of_bytes (pbkdf ~salt ~password) in
match (Crypto_box.Secretbox.box_open key encrypted_sk nonce, algo) with
| (None, _) ->
return_none
| (Some bytes, Signature.Ed25519) -> (
match
Data_encoding.Binary.of_bytes Ed25519.Secret_key.encoding bytes
with
| Some sk ->
return_some (Ed25519 sk : Signature.Secret_key.t)
| None ->
failwith
"Corrupted wallet, deciphered key is not a valid Ed25519 secret key"
)
| (Some bytes, Signature.Secp256k1) -> (
match
Data_encoding.Binary.of_bytes Secp256k1.Secret_key.encoding bytes
with
| Some sk ->
return_some (Secp256k1 sk : Signature.Secret_key.t)
| None ->
failwith
"Corrupted wallet, deciphered key is not a valid Secp256k1 secret \
key" )
| (Some bytes, Signature.P256) -> (
match Data_encoding.Binary.of_bytes P256.Secret_key.encoding bytes with
| Some sk ->
return_some (P256 sk : Signature.Secret_key.t)
| None ->
failwith
"Corrupted wallet, deciphered key is not a valid P256 secret key" )
end
module Encodings = struct
let ed25519 =
let length = Hacl.Sign.skbytes + Crypto_box.boxzerobytes + Raw.salt_len in
Base58.register_encoding
~prefix:Base58.Prefix.ed25519_encrypted_seed
~length
~to_raw:(fun sk -> Bytes.to_string sk)
~of_raw:(fun buf ->
if String.length buf <> length then None
else Some (Bytes.of_string buf))
~wrap:(fun sk -> Encrypted_ed25519 sk)
let secp256k1 =
let open Libsecp256k1.External in
let length = Key.secret_bytes + Crypto_box.boxzerobytes + Raw.salt_len in
Base58.register_encoding
~prefix:Base58.Prefix.secp256k1_encrypted_secret_key
~length
~to_raw:(fun sk -> Bytes.to_string sk)
~of_raw:(fun buf ->
if String.length buf <> length then None
else Some (Bytes.of_string buf))
~wrap:(fun sk -> Encrypted_secp256k1 sk)
let p256 =
let length =
Uecc.(sk_size secp256r1) + Crypto_box.boxzerobytes + Raw.salt_len
in
Base58.register_encoding
~prefix:Base58.Prefix.p256_encrypted_secret_key
~length
~to_raw:(fun sk -> Bytes.to_string sk)
~of_raw:(fun buf ->
if String.length buf <> length then None
else Some (Bytes.of_string buf))
~wrap:(fun sk -> Encrypted_p256 sk)
let () =
Base58.check_encoded_prefix ed25519 "edesk" 88 ;
Base58.check_encoded_prefix secp256k1 "spesk" 88 ;
Base58.check_encoded_prefix p256 "p2esk" 88
end
let decrypted = Hashtbl.create 13
(* we cache the password in this list to avoid
asking the user all the time *)
let passwords = ref []
let rec interactive_decrypt_loop (cctxt : #Client_context.prompter) ?name
~encrypted_sk algo =
( match name with
| None ->
cctxt#prompt_password "Enter password for encrypted key: "
| Some name ->
cctxt#prompt_password "Enter password for encrypted key \"%s\": " name )
>>=? fun password ->
Raw.decrypt algo ~password ~encrypted_sk
>>=? function
| Some sk ->
passwords := password :: !passwords ;
return sk
| None ->
interactive_decrypt_loop cctxt ?name ~encrypted_sk algo
(* add all passwords obtained by [ctxt#load_passwords] to the list of known passwords *)
let password_file_load ctxt =
match ctxt#load_passwords with
| Some stream ->
Lwt_stream.iter
(fun p -> passwords := Bigstring.of_string p :: !passwords)
stream
>>= fun () -> return_unit
| None ->
return_unit
let rec noninteractive_decrypt_loop algo ~encrypted_sk = function
| [] ->
return_none
| password :: passwords -> (
Raw.decrypt algo ~password ~encrypted_sk
>>=? function
| None ->
noninteractive_decrypt_loop algo ~encrypted_sk passwords
| Some sk ->
return_some sk )
let decrypt_payload cctxt ?name encrypted_sk =
( match Base58.decode encrypted_sk with
| Some (Encrypted_ed25519 encrypted_sk) ->
return (Signature.Ed25519, encrypted_sk)
| Some (Encrypted_secp256k1 encrypted_sk) ->
return (Signature.Secp256k1, encrypted_sk)
| Some (Encrypted_p256 encrypted_sk) ->
return (Signature.P256, encrypted_sk)
| _ ->
failwith "Not a Base58Check-encoded encrypted key" )
>>=? fun (algo, encrypted_sk) ->
let encrypted_sk = Bigstring.of_bytes encrypted_sk in
noninteractive_decrypt_loop algo ~encrypted_sk !passwords
>>=? function
| Some sk ->
return sk
| None ->
interactive_decrypt_loop cctxt ?name ~encrypted_sk algo
let decrypt (cctxt : #Client_context.prompter) ?name sk_uri =
let payload = Uri.path (sk_uri : sk_uri :> Uri.t) in
decrypt_payload cctxt ?name payload
>>=? fun sk ->
Hashtbl.replace decrypted sk_uri sk ;
return sk
let decrypt_all (cctxt : #Client_context.io_wallet) =
Secret_key.load cctxt
>>=? fun sks ->
password_file_load cctxt
>>=? fun () ->
iter_s
(fun (name, sk_uri) ->
if Uri.scheme (sk_uri : sk_uri :> Uri.t) <> Some scheme then return_unit
else decrypt cctxt ~name sk_uri >>=? fun _ -> return_unit)
sks
let decrypt_list (cctxt : #Client_context.io_wallet) keys =
Secret_key.load cctxt
>>=? fun sks ->
password_file_load cctxt
>>=? fun () ->
iter_s
(fun (name, sk_uri) ->
if
Uri.scheme (sk_uri : sk_uri :> Uri.t) = Some scheme
&& (keys = [] || List.mem name keys)
then decrypt cctxt ~name sk_uri >>=? fun _ -> return_unit
else return_unit)
sks
let rec read_password (cctxt : #Client_context.io) =
cctxt#prompt_password "Enter password to encrypt your key: "
>>=? fun password ->
cctxt#prompt_password "Confirm password: "
>>=? fun confirm ->
if not (Bigstring.equal password confirm) then
cctxt#message "Passwords do not match." >>= fun () -> read_password cctxt
else return password
let encrypt cctxt sk =
read_password cctxt
>>=? fun password ->
let payload = Raw.encrypt ~password sk in
let encoding =
match sk with
| Ed25519 _ ->
Encodings.ed25519
| Secp256k1 _ ->
Encodings.secp256k1
| P256 _ ->
Encodings.p256
in
let payload = Bigstring.to_bytes payload in
let path = Base58.simple_encode encoding payload in
let sk_uri = Client_keys.make_sk_uri (Uri.make ~scheme ~path ()) in
Hashtbl.replace decrypted sk_uri sk ;
return sk_uri
module Make (C : sig
val cctxt : Client_context.prompter
end) =
struct
let scheme = "encrypted"
let title = "Built-in signer using encrypted keys."
let description =
"Valid secret key URIs are of the form\n\
\ - encrypted:<encrypted_key>\n\
where <encrypted_key> is the encrypted (password protected using Nacl's \
cryptobox and pbkdf) secret key, formatted in unprefixed Base58.\n\
Valid public key URIs are of the form\n\
\ - encrypted:<public_key>\n\
where <public_key> is the public key in Base58."
let public_key = Unencrypted.public_key
let public_key_hash = Unencrypted.public_key_hash
let import_secret_key = Unencrypted.import_secret_key
let neuterize sk_uri =
decrypt C.cctxt sk_uri
>>=? fun sk ->
return (Unencrypted.make_pk (Signature.Secret_key.to_public_key sk))
let sign ?watermark sk_uri buf =
decrypt C.cctxt sk_uri
>>=? fun sk -> return (Signature.sign ?watermark sk buf)
let deterministic_nonce sk_uri buf =
decrypt C.cctxt sk_uri
>>=? fun sk -> return (Signature.deterministic_nonce sk buf)
let deterministic_nonce_hash sk_uri buf =
decrypt C.cctxt sk_uri
>>=? fun sk -> return (Signature.deterministic_nonce_hash sk buf)
let supports_deterministic_nonces _ = return_true
end
src/lib_signer_backends/encrypted.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Import Client_keys.
Definition scheme : string := "encrypted" % string.
Module Raw.
Definition salt_len : Z := 8.
Definition nonce : Tezos_base__TzPervasives.Crypto_box.nonce :=
Crypto_box.zero_nonce.
Definition encrypted_size : Z := Z.add Crypto_box.boxzerobytes 32.
Definition pbkdf (salt : Bigstring.t) (password : Bigstring.t)
: Bigstring.t :=
Pbkdf.SHA512.(Pbkdf.S.pbkdf2) password salt 32768
(* ❌ Constant of type int32 is converted to int *)
32.
Definition encrypt
(password : Bigstring.t)
(sk : Tezos_base__TzPervasives.Signature.secret_key) : Bigstring.t :=
let salt := Hacl.Rand.gen salt_len in
let key := Crypto_box.Secretbox.unsafe_of_bytes (pbkdf salt password) in
let msg :=
match sk with
| Tezos_base__TzPervasives.Signature.Ed25519 sk =>
Data_encoding.Binary.to_bytes_exn Ed25519.Secret_key.encoding sk
| Tezos_base__TzPervasives.Signature.Secp256k1 sk =>
Data_encoding.Binary.to_bytes_exn Secp256k1.Secret_key.encoding sk
| Tezos_base__TzPervasives.Signature.P256 sk =>
Data_encoding.Binary.to_bytes_exn P256.Secret_key.encoding sk
end in
Bigstring.concat "" % string
(cons salt (cons (Crypto_box.Secretbox.box key msg nonce) [])).
Definition decrypt
(algo : Tezos_base__TzPervasives.Signature.algo) (password : Bigstring.t)
(encrypted_sk : Bigstring.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option Tezos_base__TzPervasives.Signature.Secret_key.t)) :=
let salt := Bigstring.sub encrypted_sk 0 salt_len in
let encrypted_sk := Bigstring.sub encrypted_sk salt_len encrypted_size in
let key := Crypto_box.Secretbox.unsafe_of_bytes (pbkdf salt password) in
match ((Crypto_box.Secretbox.box_open key encrypted_sk nonce), algo) with
| (None, _) => return_none
| (Some bytes, Tezos_base__TzPervasives.Signature.Ed25519) =>
match Data_encoding.Binary.of_bytes Ed25519.Secret_key.encoding string
with
| Some sk => return_some (Tezos_crypto__Signature.Ed25519 sk)
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Corrupted wallet, deciphered key is not a valid Ed25519 secret key"
% string CamlinternalFormatBasics.End_of_format)
"Corrupted wallet, deciphered key is not a valid Ed25519 secret key"
% string)
end
| (Some bytes, Tezos_base__TzPervasives.Signature.Secp256k1) =>
match Data_encoding.Binary.of_bytes Secp256k1.Secret_key.encoding string
with
| Some sk => return_some (Tezos_crypto__Signature.Secp256k1 sk)
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Corrupted wallet, deciphered key is not a valid Secp256k1 secret key"
% string CamlinternalFormatBasics.End_of_format)
"Corrupted wallet, deciphered key is not a valid Secp256k1 secret key"
% string)
end
| (Some bytes, Tezos_base__TzPervasives.Signature.P256) =>
match Data_encoding.Binary.of_bytes P256.Secret_key.encoding string with
| Some sk => return_some (Tezos_crypto__Signature.P256 sk)
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Corrupted wallet, deciphered key is not a valid P256 secret key"
% string CamlinternalFormatBasics.End_of_format)
"Corrupted wallet, deciphered key is not a valid P256 secret key" %
string)
end
end.
End Raw.
Module Encodings.
Definition ed25519
: Tezos_base__TzPervasives.Base58.encoding Stdlib.Bytes.t :=
let length :=
Z.add (Z.add Hacl.Sign.skbytes Crypto_box.boxzerobytes) Raw.salt_len in
Base58.register_encoding Base58.Prefix.ed25519_encrypted_seed length
(fun sk => Stdlib.Bytes.to_string sk)
(fun buf =>
if nequiv_decb (String.length buf) length then
None
else
Some (Stdlib.Bytes.of_string buf))
(fun sk => Tezos_base__TzPervasives.Base58.Encrypted_ed25519 sk).
Definition secp256k1
: Tezos_base__TzPervasives.Base58.encoding Stdlib.Bytes.t :=
let length :=
Z.add (Z.add Key.secret_bytes Crypto_box.boxzerobytes) Raw.salt_len in
Base58.register_encoding Base58.Prefix.secp256k1_encrypted_secret_key length
(fun sk => Stdlib.Bytes.to_string sk)
(fun buf =>
if nequiv_decb (String.length buf) length then
None
else
Some (Stdlib.Bytes.of_string buf))
(fun sk => Tezos_base__TzPervasives.Base58.Encrypted_secp256k1 sk).
Definition p256 : Tezos_base__TzPervasives.Base58.encoding Stdlib.Bytes.t :=
let length :=
Z.add (Z.add (sk_size secp256r1) Crypto_box.boxzerobytes) Raw.salt_len in
Base58.register_encoding Base58.Prefix.p256_encrypted_secret_key length
(fun sk => Stdlib.Bytes.to_string sk)
(fun buf =>
if nequiv_decb (String.length buf) length then
None
else
Some (Stdlib.Bytes.of_string buf))
(fun sk => Tezos_base__TzPervasives.Base58.Encrypted_p256 sk).
End Encodings.
Definition decrypted
: Stdlib.Hashtbl.t Tezos_client_base.Client_keys.sk_uri
Tezos_base__TzPervasives.Signature.Secret_key.t := Hashtbl.create None 13.
Definition passwords : Stdlib.ref (list Bigstring.t) := Stdlib.ref [].
Fixpoint interactive_decrypt_loop {B a : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) * B)) * B)
(name : option string) (encrypted_sk : Bigstring.t)
(algo : Tezos_base__TzPervasives.Signature.algo)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.Secret_key.t) :=
op_gtgteqquestion
match name with
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Enter password for encrypted key: " % string
CamlinternalFormatBasics.End_of_format)
"Enter password for encrypted key: " % string)
| Some name =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Enter password for encrypted key """ % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal """: " % string
CamlinternalFormatBasics.End_of_format)))
"Enter password for encrypted key ""%s"": " % string) name
end
(fun password =>
op_gtgteqquestion (Raw.decrypt algo password encrypted_sk)
(fun function_parameter =>
match function_parameter with
| Some sk =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq passwords
(cons password (Stdlib.op_exclamation passwords)) in
_return sk
| None => interactive_decrypt_loop cctxt name encrypted_sk algo
end)).
Definition password_file_load {A : Type}
(ctxt : ((option (Lwt_stream.t string)) * A))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match
(* ❌ Sending method message is not handled *)
send with
| Some stream =>
op_gtgteq
(Lwt_stream.iter
(fun p =>
Stdlib.op_coloneq passwords
(cons (Bigstring.of_string p) (Stdlib.op_exclamation passwords)))
stream)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| None => return_unit
end.
Fixpoint noninteractive_decrypt_loop
(algo : Tezos_base__TzPervasives.Signature.algo) (encrypted_sk : Bigstring.t)
(function_parameter : list Bigstring.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option Tezos_base__TzPervasives.Signature.Secret_key.t)) :=
match function_parameter with
| [] => return_none
| cons password passwords =>
op_gtgteqquestion (Raw.decrypt algo password encrypted_sk)
(fun function_parameter =>
match function_parameter with
| None => noninteractive_decrypt_loop algo encrypted_sk passwords
| Some sk => return_some sk
end)
end.
Definition decrypt_payload {B a : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) * B)) * B)
(name : option string) (encrypted_sk : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.Secret_key.t) :=
op_gtgteqquestion
match Base58.decode None encrypted_sk with
| Some (Tezos_base__TzPervasives.Base58.Encrypted_ed25519 encrypted_sk) =>
_return (Tezos_base__TzPervasives.Signature.Ed25519, encrypted_sk)
| Some (Tezos_base__TzPervasives.Base58.Encrypted_secp256k1 encrypted_sk) =>
_return (Tezos_base__TzPervasives.Signature.Secp256k1, encrypted_sk)
| Some (Tezos_base__TzPervasives.Base58.Encrypted_p256 encrypted_sk) =>
_return (Tezos_base__TzPervasives.Signature.P256, encrypted_sk)
| _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Not a Base58Check-encoded encrypted key" % string
CamlinternalFormatBasics.End_of_format)
"Not a Base58Check-encoded encrypted key" % string)
end
(fun function_parameter =>
let '(algo, encrypted_sk) := function_parameter in
let encrypted_sk := Bigstring.of_bytes encrypted_sk in
op_gtgteqquestion
(noninteractive_decrypt_loop algo encrypted_sk
(Stdlib.op_exclamation passwords))
(fun function_parameter =>
match function_parameter with
| Some sk => _return sk
| None => interactive_decrypt_loop cctxt name encrypted_sk algo
end)).
Definition decrypt {B a : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) * B)) * B)
(name : option string) (sk_uri : Tezos_client_base.Client_keys.sk_uri)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.Secret_key.t) :=
let payload := Uri.path sk_uri in
op_gtgteqquestion (decrypt_payload cctxt name payload)
(fun sk =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Hashtbl.replace decrypted sk_uri sk in
_return sk).
Definition decrypt_all {C a b : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
(a * b)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a) * (a))
*
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit)
-> a) * (a)) * C)))))))))))) * C)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (Secret_key.load cctxt)
(fun sks =>
op_gtgteqquestion (password_file_load cctxt)
(fun function_parameter =>
let 'tt := function_parameter in
iter_s
(fun function_parameter =>
let '(name, sk_uri) := function_parameter in
if nequiv_decb (Uri.scheme sk_uri) (Some scheme) then
return_unit
else
op_gtgteqquestion (decrypt cctxt (Some name) sk_uri)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)) sks)).
Definition decrypt_list {C a b : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
(a * b)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a) * (a))
*
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit)
-> a) * (a)) * C)))))))))))) * C)
(keys : list string) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (Secret_key.load cctxt)
(fun sks =>
op_gtgteqquestion (password_file_load cctxt)
(fun function_parameter =>
let 'tt := function_parameter in
iter_s
(fun function_parameter =>
let '(name, sk_uri) := function_parameter in
if
andb (equiv_decb (Uri.scheme sk_uri) (Some scheme))
(orb (equiv_decb keys []) (List.mem name keys)) then
op_gtgteqquestion (decrypt cctxt (Some name) sk_uri)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)
else
return_unit) sks)).
Fixpoint read_password {C a b : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b))
*
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) * C))))))) * C)
: Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Enter password to encrypt your key: " % string
CamlinternalFormatBasics.End_of_format)
"Enter password to encrypt your key: " % string))
(fun password =>
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Confirm password: " % string
CamlinternalFormatBasics.End_of_format)
"Confirm password: " % string))
(fun confirm =>
if negb (Bigstring.equal password confirm) then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Passwords do not match." % string
CamlinternalFormatBasics.End_of_format)
"Passwords do not match." % string))
(fun function_parameter =>
let 'tt := function_parameter in
read_password cctxt)
else
_return password)).
Definition encrypt {C a b : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b))
*
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) * C))))))) * C)
(sk : Tezos_base__TzPervasives.Signature.secret_key)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_client_base.Client_keys.sk_uri) :=
op_gtgteqquestion (read_password cctxt)
(fun password =>
let payload := Raw.encrypt password sk in
let encoding :=
match sk with
| Tezos_base__TzPervasives.Signature.Ed25519 _ => Encodings.ed25519
| Tezos_base__TzPervasives.Signature.Secp256k1 _ => Encodings.secp256k1
| Tezos_base__TzPervasives.Signature.P256 _ => Encodings.p256
end in
let payload := Bigstring.to_bytes payload in
let path := Base58.simple_encode None encoding payload in
let sk_uri :=
Client_keys.make_sk_uri
(Uri.make (Some scheme) None None None (Some path) None None tt) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Hashtbl.replace decrypted sk_uri sk in
_return sk_uri).
(* ❌ Functors are not handled. *)
functor
src/lib_signer_backends/http.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Http_gen.Make (struct let scheme = "http" end)
src/lib_signer_backends/http.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/lib_signer_backends/http_gen.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Make (N : sig
val scheme : string
end) =
struct
open Client_keys
let scheme = N.scheme
module Make
(RPC_client : RPC_client.S) (P : sig
val authenticate :
Signature.Public_key_hash.t list ->
Bytes.t ->
Signature.t tzresult Lwt.t
val logger : RPC_client.logger
end) =
struct
let scheme = scheme
let title =
"Built-in tezos-signer using remote signer through hardcoded " ^ scheme
^ " requests."
let description =
"Valid locators are of this form:\n" ^ " - " ^ scheme
^ "://host/tz1...\n" ^ " - " ^ scheme
^ "://host:port/path/to/service/tz1...\n"
^ "Environment variable TEZOS_SIGNER_HTTP_HEADERS can be specified to \
add headers to the requests (only 'host' and custom 'x-...' headers \
are supported)."
let headers =
match Sys.getenv_opt "TEZOS_SIGNER_HTTP_HEADERS" with
| None ->
None
| Some contents ->
let lines = String.split_on_char '\n' contents in
Some
(List.fold_left
(fun acc line ->
match String.index_opt line ':' with
| None ->
Pervasives.failwith
"Http signer: invalid TEZOS_SIGNER_HTTP_HEADERS \
environment variable, missing colon"
| Some pos ->
let header = String.trim (String.sub line 0 pos) in
let header = String.lowercase_ascii header in
if
header <> "host"
&& ( String.length header < 2
|| String.sub header 0 2 <> "x-" )
then
Pervasives.failwith
"Http signer: invalid TEZOS_SIGNER_HTTP_HEADERS \
environment variable, only 'host' or 'x-' headers \
are supported" ;
let value =
String.trim
(String.sub
line
(pos + 1)
(String.length line - pos - 1))
in
(header, value) :: acc)
[]
lines)
let parse uri =
(* extract `tz1..` from the last component of the path *)
assert (Uri.scheme uri = Some scheme) ;
let path = Uri.path uri in
( match String.rindex_opt path '/' with
| None ->
failwith "Invalid locator %a" Uri.pp_hum uri
| Some i ->
let pkh =
try String.sub path (i + 1) (String.length path - i - 1)
with _ -> ""
in
let path = String.sub path 0 i in
return (Uri.with_path uri path, pkh) )
>>=? fun (base, pkh) ->
Lwt.return (Signature.Public_key_hash.of_b58check pkh)
>>=? fun pkh -> return (base, pkh)
let public_key uri =
parse (uri : pk_uri :> Uri.t)
>>=? fun (base, pkh) ->
RPC_client.call_service
~logger:P.logger
?headers
Media_type.all_media_types
~base
Signer_services.public_key
((), pkh)
()
()
let neuterize uri =
return (Client_keys.make_pk_uri (uri : sk_uri :> Uri.t))
let public_key_hash uri =
public_key uri
>>=? fun pk -> return (Signature.Public_key.hash pk, Some pk)
let import_secret_key ~io:_ = public_key_hash
let get_signature base pkh msg =
RPC_client.call_service
~logger:P.logger
?headers
Media_type.all_media_types
~base
Signer_services.authorized_keys
()
()
()
>>=? function
| Some authorized_keys ->
P.authenticate
authorized_keys
(Signer_messages.Sign.Request.to_sign ~pkh ~data:msg)
>>=? fun signature -> return_some signature
| None ->
return_none
let sign ?watermark uri msg =
parse (uri : sk_uri :> Uri.t)
>>=? fun (base, pkh) ->
let msg =
match watermark with
| None ->
msg
| Some watermark ->
Bytes.cat (Signature.bytes_of_watermark watermark) msg
in
get_signature base pkh msg
>>=? fun signature ->
RPC_client.call_service
~logger:P.logger
?headers
Media_type.all_media_types
~base
Signer_services.sign
((), pkh)
signature
msg
let deterministic_nonce uri msg =
parse (uri : sk_uri :> Uri.t)
>>=? fun (base, pkh) ->
get_signature base pkh msg
>>=? fun signature ->
RPC_client.call_service
~logger:P.logger
?headers
Media_type.all_media_types
~base
Signer_services.deterministic_nonce
((), pkh)
signature
msg
let deterministic_nonce_hash uri msg =
parse (uri : sk_uri :> Uri.t)
>>=? fun (base, pkh) ->
get_signature base pkh msg
>>=? fun signature ->
RPC_client.call_service
~logger:P.logger
?headers
Media_type.all_media_types
~base
Signer_services.deterministic_nonce_hash
((), pkh)
signature
msg
let supports_deterministic_nonces uri =
parse (uri : sk_uri :> Uri.t)
>>=? fun (base, pkh) ->
RPC_client.call_service
~logger:P.logger
?headers
Media_type.all_media_types
~base
Signer_services.supports_deterministic_nonces
((), pkh)
()
()
>>= function
| Ok ans ->
return ans
| Error (RPC_context.Not_found _ :: _) ->
return_false
| Error _ as res ->
Lwt.return res
end
let make_base host port = Uri.make ~scheme ~host ~port ()
end
src/lib_signer_backends/http_gen.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Functors are not handled. *) functor
src/lib_signer_backends/https.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Http_gen.Make (struct let scheme = "https" end)
src/lib_signer_backends/https.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/lib_signer_backends/test/test_encrypted.ml 31 errors
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2018. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Error_monad
let loops = 10
let passwords =
List.map
Bigstring.of_string
[ "ahThie5H";
"aVah7eid";
"Hihohh1n";
"mui0Hoox";
"Piu7pual";
"paik6aiW";
"caeS5me5";
"boh5dauL";
"zaiK1Oht";
"Oogh4hah";
"kiY5ohlo";
"booth0Ei";
"xa2Aidao";
"aju6oXu4";
"gooruGh9";
"ahy4Daih";
"chosh0Wu";
"Cheij6za";
"quee9ooL";
"Sohs9are";
"Pae3gay7";
"Naif5iel";
" eir6Aed1";
"aa6Aesai";
"" ]
let nb_passwds = List.length passwords
let fake_ctx () =
object
val mutable i = 0
val mutable distributed = false
inherit Client_context.simple_printer (fun _ _ -> Lwt.return_unit)
method prompt : type a. (a, string tzresult) Client_context.lwt_format -> a
=
Format.kasprintf (fun _ -> return "")
method prompt_password : type a.
(a, Bigstring.t tzresult) Client_context.lwt_format -> a =
Format.kasprintf (fun _ ->
(* return Bigstring.empty *)
match distributed with
| false ->
distributed <- true ;
return (List.nth passwords 0)
| true ->
i <- (if i = nb_passwds - 1 then 0 else succ i) ;
distributed <- false ;
return (List.nth passwords i))
end
let make_sk_uris =
List.map (fun path ->
Client_keys.make_sk_uri (Uri.make ~scheme:"encrypted" ~path ()))
let ed25519_sks =
[ "edsk3kMNLNdzLPbbABASDLARft8JRZ3Wpwibn8SMAb4KmuWSMJmAFd";
"edsk3Kqr8VHRx9kmR8Pj5qRGcmvQH34cForiMaMz1Ahhq5DkZp7FxJ";
"edsk2mBu4w9sMGhryvvXK53dXgpcNdZWi8pJQ1QL2rAgRPrE5y12az" ]
let ed25519_sks_encrypted =
make_sk_uris
[ "edesk1oGXxunJ5FTGpQ6o1xdop8VGKdT36Fj7LwWF9HLjzEqaCC4V6tdRVN1jaeJTfCHS8bYf7U2YhMK2yW6jSUy";
"edesk1s4xEifbUdUkghHHimbNUuyQ4eidDVJdc8JtPRUon758hBqZNZsQxadUDFRSRiUdLoFqBG35HAiLKafyczw";
"edesk1zY5jEs4QXrF9tXxFq1mfW9PkatdRxCKQ2Q598y5LLz65nQj4eWxefYFp8YLerya1haRdGe5NWckHDb5ApM"
]
let secp256k1_sks =
[ "spsk24attf9uuQ7PUKFHxTm6E3TMqB6SPkFiMbXPBur7JNrvupW2xg";
"spsk2H32XfWL7MkW58r76q6Yu5tJg77YGgVyjwq7EvLUHhn4JmAtEG";
"spsk3KQ56REAUGc6Gn87xCRnWyPwR2Un667vegQVuU16ZcgNyLCooh" ]
let secp256k1_sks_encrypted =
make_sk_uris
[ "spesk2CXQHDbzrcNatRzmg83Dto6kX6BWwpP2zGs4Zks9LDsXzaX6mAYRj5ZrrdgyZQap4DS9YRRLNSpaVC2TSsk";
"spesk1upiFp23osWSUTgHcx8DCVpTrMr9xtdqVQkQDWj5sFG7vqcWLDaNv9AKKcF27Nb266YfuAGF2hEbcyAxHmK";
"spesk1w7d68hzTWJusk5Xn5oz8EgDXbotDW9BXb5ksFjr8Jd94Kxnu5yKAhgRszojhMUoJ1EEt5BtPpGpkgCjELq"
]
let p256_sks =
[ "p2sk2YQcwF5h7qgRztocEMrfizUwZaM41f4v7zWneiig2Y5AxajqYC";
"p2sk2XiSoQC9tvejVBDJyvkbHUq2kvcQHdJJ2wM8rii228DkjKV2b5";
"p2sk3ZsfsEaxDNn74orv91Ruu35fomzF373aT9ForA4fDo54c47o6H" ]
let p256_sks_encrypted =
make_sk_uris
[ "p2esk2JMFpR9yaSpgsaKQYLqFnv16t4gowJ4cgjj7D7iMfoaJz2vZuH7Tdi11MrX6FC2yhfs2nvy5VRxAvzH1STE";
"p2esk1nfobVL73mY5Y18W8Ltb3Vm6Nf5Th7trN3yA3ucyyP4AH93XfyRatkh9AxxaDtnju1EtArykjroEQHDT97k";
"p2esk2Ge1jrVak7NhxksimzaQjRCTLx5vxUZ4Akgq3spGQLx6N41h6aKXeEYDgxN5eztnPwD6QiCHCfVAKXLPNm8"
]
let sk_testable =
Alcotest.testable Signature.Secret_key.pp Signature.Secret_key.equal
let test_vectors () =
let open Encrypted in
iter_s
(fun (sks, encrypted_sks) ->
let ctx = fake_ctx () in
let sks = List.map Signature.Secret_key.of_b58check_exn sks in
map_s (decrypt ctx) encrypted_sks
>>=? fun decs ->
assert (decs = sks) ;
return_unit)
[ (ed25519_sks, ed25519_sks_encrypted);
(secp256k1_sks, secp256k1_sks_encrypted);
(p256_sks, p256_sks_encrypted) ]
let test_random algo =
let open Encrypted in
let ctx = fake_ctx () in
let decrypt_ctx = (ctx :> Client_context.prompter) in
let rec inner i =
if i >= loops then return_unit
else
let (_, _, sk) = Signature.generate_key ~algo () in
encrypt ctx sk
>>=? fun sk_uri ->
decrypt decrypt_ctx sk_uri
>>=? fun decrypted_sk ->
Alcotest.check sk_testable "test_encrypt: decrypt" sk decrypted_sk ;
inner (succ i)
in
inner 0
let test_random _switch () =
iter_s test_random Signature.[Ed25519; Secp256k1; P256]
>>= function
| Ok _ -> Lwt.return_unit | Error _ -> Lwt.fail_with "test_random"
let test_vectors _switch () =
test_vectors ()
>>= function
| Ok _ -> Lwt.return_unit | Error _ -> Lwt.fail_with "test_vectors"
let tests =
[ Alcotest_lwt.test_case "random_roundtrip" `Quick test_random;
Alcotest_lwt.test_case "vectors_decrypt" `Quick test_vectors ]
let () = Alcotest.run "tezos-signer-backends" [("encrypted", tests)]
src/lib_signer_backends/test/test_encrypted.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Definition loops : Z := 10.
Definition passwords : list Bigstring.t :=
List.map Bigstring.of_string
(cons "ahThie5H" % string
(cons "aVah7eid" % string
(cons "Hihohh1n" % string
(cons "mui0Hoox" % string
(cons "Piu7pual" % string
(cons "paik6aiW" % string
(cons "caeS5me5" % string
(cons "boh5dauL" % string
(cons "zaiK1Oht" % string
(cons "Oogh4hah" % string
(cons "kiY5ohlo" % string
(cons "booth0Ei" % string
(cons "xa2Aidao" % string
(cons "aju6oXu4" % string
(cons "gooruGh9" % string
(cons "ahy4Daih" % string
(cons "chosh0Wu" % string
(cons "Cheij6za" % string
(cons "quee9ooL" % string
(cons "Sohs9are" % string
(cons "Pae3gay7" % string
(cons "Naif5iel" % string
(cons " eir6Aed1" % string
(cons "aa6Aesai" % string
(cons "" % string []))))))))))))))))))))))))).
Definition nb_passwds : Z := List.length passwords.
Definition fake_ctx {a b : Type} (function_parameter : unit)
: ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string -> (Tezos_client_base.Client_context.lwt_format a unit) -> a)
* (a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.Error_monad.tzresult string)) -> a) *
(a)) *
((((Tezos_client_base.Client_context.lwt_format a
(Tezos_base__TzPervasives.Error_monad.tzresult Bigstring.t)) ->
a) * (a)) * nil))))))) :=
let 'tt := function_parameter in
(* ❌ Creation of objects is not handled *)
object.
Definition make_sk_uris
: (list string) -> list Tezos_client_base.Client_keys.sk_uri :=
List.map
(fun path =>
Client_keys.make_sk_uri
(Uri.make (Some "encrypted" % string) None None None (Some path) None
None tt)).
Definition ed25519_sks : list string :=
cons "edsk3kMNLNdzLPbbABASDLARft8JRZ3Wpwibn8SMAb4KmuWSMJmAFd" % string
(cons "edsk3Kqr8VHRx9kmR8Pj5qRGcmvQH34cForiMaMz1Ahhq5DkZp7FxJ" % string
(cons "edsk2mBu4w9sMGhryvvXK53dXgpcNdZWi8pJQ1QL2rAgRPrE5y12az" % string [])).
Definition ed25519_sks_encrypted : list Tezos_client_base.Client_keys.sk_uri :=
make_sk_uris
(cons
"edesk1oGXxunJ5FTGpQ6o1xdop8VGKdT36Fj7LwWF9HLjzEqaCC4V6tdRVN1jaeJTfCHS8bYf7U2YhMK2yW6jSUy"
% string
(cons
"edesk1s4xEifbUdUkghHHimbNUuyQ4eidDVJdc8JtPRUon758hBqZNZsQxadUDFRSRiUdLoFqBG35HAiLKafyczw"
% string
(cons
"edesk1zY5jEs4QXrF9tXxFq1mfW9PkatdRxCKQ2Q598y5LLz65nQj4eWxefYFp8YLerya1haRdGe5NWckHDb5ApM"
% string []))).
Definition secp256k1_sks : list string :=
cons "spsk24attf9uuQ7PUKFHxTm6E3TMqB6SPkFiMbXPBur7JNrvupW2xg" % string
(cons "spsk2H32XfWL7MkW58r76q6Yu5tJg77YGgVyjwq7EvLUHhn4JmAtEG" % string
(cons "spsk3KQ56REAUGc6Gn87xCRnWyPwR2Un667vegQVuU16ZcgNyLCooh" % string [])).
Definition secp256k1_sks_encrypted
: list Tezos_client_base.Client_keys.sk_uri :=
make_sk_uris
(cons
"spesk2CXQHDbzrcNatRzmg83Dto6kX6BWwpP2zGs4Zks9LDsXzaX6mAYRj5ZrrdgyZQap4DS9YRRLNSpaVC2TSsk"
% string
(cons
"spesk1upiFp23osWSUTgHcx8DCVpTrMr9xtdqVQkQDWj5sFG7vqcWLDaNv9AKKcF27Nb266YfuAGF2hEbcyAxHmK"
% string
(cons
"spesk1w7d68hzTWJusk5Xn5oz8EgDXbotDW9BXb5ksFjr8Jd94Kxnu5yKAhgRszojhMUoJ1EEt5BtPpGpkgCjELq"
% string []))).
Definition p256_sks : list string :=
cons "p2sk2YQcwF5h7qgRztocEMrfizUwZaM41f4v7zWneiig2Y5AxajqYC" % string
(cons "p2sk2XiSoQC9tvejVBDJyvkbHUq2kvcQHdJJ2wM8rii228DkjKV2b5" % string
(cons "p2sk3ZsfsEaxDNn74orv91Ruu35fomzF373aT9ForA4fDo54c47o6H" % string [])).
Definition p256_sks_encrypted : list Tezos_client_base.Client_keys.sk_uri :=
make_sk_uris
(cons
"p2esk2JMFpR9yaSpgsaKQYLqFnv16t4gowJ4cgjj7D7iMfoaJz2vZuH7Tdi11MrX6FC2yhfs2nvy5VRxAvzH1STE"
% string
(cons
"p2esk1nfobVL73mY5Y18W8Ltb3Vm6Nf5Th7trN3yA3ucyyP4AH93XfyRatkh9AxxaDtnju1EtArykjroEQHDT97k"
% string
(cons
"p2esk2Ge1jrVak7NhxksimzaQjRCTLx5vxUZ4Akgq3spGQLx6N41h6aKXeEYDgxN5eztnPwD6QiCHCfVAKXLPNm8"
% string []))).
Definition sk_testable {A : Type} : A :=
op_startypeminuserrorstar Signature.Secret_key.pp Signature.Secret_key.equal.
Definition test_vectors (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
iter_s
(fun function_parameter =>
let '(sks, encrypted_sks) := function_parameter in
let ctx := fake_ctx tt in
let sks := List.map Signature.Secret_key.of_b58check_exn sks in
op_gtgteqquestion
(map_s
(let arg := decrypt ctx in
fun eta => arg None eta) encrypted_sks)
(fun decs =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb decs sks) in
return_unit))
(cons (ed25519_sks, ed25519_sks_encrypted)
(cons (secp256k1_sks, secp256k1_sks_encrypted)
(cons (p256_sks, p256_sks_encrypted) []))).
Definition test_random (algo : Tezos_base__TzPervasives.Signature.algo)
: Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit) :=
let ctx := fake_ctx tt in
let decrypt_ctx := ctx in
let fix inner (i : Z)
: Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit) :=
if OCaml.Stdlib.ge i loops then
return_unit
else
let '(_, _, sk) := Signature.generate_key (Some algo) None tt in
op_gtgteqquestion (encrypt ctx sk)
(fun sk_uri =>
op_gtgteqquestion (decrypt decrypt_ctx None sk_uri)
(fun decrypted_sk =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar sk_testable
"test_encrypt: decrypt" % string sk decrypted_sk in
inner (Z.succ i))) in
inner 0.
Definition test_random {A : Type} (_switch : A) (function_parameter : unit)
: Lwt.t unit :=
let 'tt := function_parameter in
op_gtgteq
(iter_s test_random
(cons Tezos_base__TzPervasives.Signature.Ed25519
(cons Tezos_base__TzPervasives.Signature.Secp256k1
(cons Tezos_base__TzPervasives.Signature.P256 []))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok _ => Lwt.return_unit
| Stdlib.Error _ => Lwt.fail_with "test_random" % string
end).
Definition test_vectors {A : Type} (_switch : A) (function_parameter : unit)
: Lwt.t unit :=
let 'tt := function_parameter in
op_gtgteq (test_vectors tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok _ => Lwt.return_unit
| Stdlib.Error _ => Lwt.fail_with "test_vectors" % string
end).
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "random_roundtrip" % string
(* ❌ Variants not supported *)
variant test_random)
(cons
(op_startypeminuserrorstar "vectors_decrypt" % string
(* ❌ Variants not supported *)
variant test_vectors) []).
src/lib_signer_backends/unencrypted.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Client_keys
let scheme = "unencrypted"
let title = "Built-in signer using raw unencrypted keys."
let description =
"Please DO NOT USE this signer outside of test environments.\n\
Valid secret key URIs are of the form\n\
\ - unencrypted:<key>\n\
where <key> is the secret key in Base58.\n\
Valid public key URIs are of the form\n\
\ - unencrypted:<public_key>\n\
where <public_key> is the public key in Base58."
let secret_key sk_uri =
Lwt.return
(Signature.Secret_key.of_b58check (Uri.path (sk_uri : sk_uri :> Uri.t)))
let make_sk sk =
Client_keys.make_sk_uri
(Uri.make ~scheme ~path:(Signature.Secret_key.to_b58check sk) ())
let public_key pk_uri =
Lwt.return
(Signature.Public_key.of_b58check (Uri.path (pk_uri : pk_uri :> Uri.t)))
let make_pk pk =
Client_keys.make_pk_uri
(Uri.make ~scheme ~path:(Signature.Public_key.to_b58check pk) ())
let neuterize sk_uri =
secret_key sk_uri
>>=? fun sk -> return (make_pk (Signature.Secret_key.to_public_key sk))
let public_key_hash pk_uri =
public_key pk_uri
>>=? fun pk -> return (Signature.Public_key.hash pk, Some pk)
let import_secret_key ~io:_ = public_key_hash
let sign ?watermark sk_uri buf =
secret_key sk_uri >>=? fun sk -> return (Signature.sign ?watermark sk buf)
let deterministic_nonce sk_uri buf =
secret_key sk_uri
>>=? fun sk -> return (Signature.deterministic_nonce sk buf)
let deterministic_nonce_hash sk_uri buf =
secret_key sk_uri
>>=? fun sk -> return (Signature.deterministic_nonce_hash sk buf)
let supports_deterministic_nonces _ = return_true
src/lib_signer_backends/unencrypted.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Client_keys.
Definition scheme : string := "unencrypted" % string.
Definition title : string :=
"Built-in signer using raw unencrypted keys." % string.
Definition description : string :=
"Please DO NOT USE this signer outside of test environments.
Valid secret key URIs are of the form
- unencrypted:<key>
where <key> is the secret key in Base58.
Valid public key URIs are of the form
- unencrypted:<public_key>
where <public_key> is the public key in Base58."
% string.
Definition secret_key (sk_uri : Tezos_client_base.Client_keys.sk_uri)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
Tezos_base__TzPervasives.Signature.Secret_key.t) :=
Lwt._return (Signature.Secret_key.of_b58check (Uri.path sk_uri)).
Definition make_sk (sk : Tezos_base__TzPervasives.Signature.Secret_key.t)
: Tezos_client_base.Client_keys.sk_uri :=
Client_keys.make_sk_uri
(Uri.make (Some scheme) None None None
(Some (Signature.Secret_key.to_b58check sk)) None None tt).
Definition public_key (pk_uri : Tezos_client_base.Client_keys.pk_uri)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
Tezos_base__TzPervasives.Signature.Public_key.t) :=
Lwt._return (Signature.Public_key.of_b58check (Uri.path pk_uri)).
Definition make_pk (pk : Tezos_base__TzPervasives.Signature.Public_key.t)
: Tezos_client_base.Client_keys.pk_uri :=
Client_keys.make_pk_uri
(Uri.make (Some scheme) None None None
(Some (Signature.Public_key.to_b58check pk)) None None tt).
Definition neuterize (sk_uri : Tezos_client_base.Client_keys.sk_uri)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_client_base.Client_keys.pk_uri) :=
op_gtgteqquestion (secret_key sk_uri)
(fun sk => _return (make_pk (Signature.Secret_key.to_public_key sk))).
Definition public_key_hash (pk_uri : Tezos_client_base.Client_keys.pk_uri)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_crypto__Signature.Public_key_hash.t *
(option Tezos_base__TzPervasives.Signature.Public_key.t))) :=
op_gtgteqquestion (public_key pk_uri)
(fun pk => _return ((Signature.Public_key.hash pk), (Some pk))).
Definition import_secret_key {A : Type} (function_parameter : A)
: Tezos_client_base.Client_keys.pk_uri ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_crypto__Signature.Public_key_hash.t *
(option Tezos_base__TzPervasives.Signature.Public_key.t))) :=
let '_ := function_parameter in
public_key_hash.
Definition sign
(watermark : option Tezos_base__TzPervasives.Signature.watermark)
(sk_uri : Tezos_client_base.Client_keys.sk_uri) (buf : Stdlib.Bytes.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
op_gtgteqquestion (secret_key sk_uri)
(fun sk => _return (Signature.sign watermark sk buf)).
Definition deterministic_nonce
(sk_uri : Tezos_client_base.Client_keys.sk_uri) (buf : Stdlib.Bytes.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
op_gtgteqquestion (secret_key sk_uri)
(fun sk => _return (Signature.deterministic_nonce sk buf)).
Definition deterministic_nonce_hash
(sk_uri : Tezos_client_base.Client_keys.sk_uri) (buf : Stdlib.Bytes.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
op_gtgteqquestion (secret_key sk_uri)
(fun sk => _return (Signature.deterministic_nonce_hash sk buf)).
Definition supports_deterministic_nonces {A : Type} (function_parameter : A)
: Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
let '_ := function_parameter in
return_true.
src/lib_signer_backends/unix/ledger.ml 186 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Client_keys
include Internal_event.Legacy_logging.Make (struct
let name = "client.signer.ledger"
end)
module Bip32_path = struct
let hard = Int32.logor 0x8000_0000l
let unhard = Int32.logand 0x7fff_ffffl
let is_hard n = Int32.logand 0x8000_0000l n <> 0l
let tezos_root = [hard 44l; hard 1729l]
let node_of_string str =
match Int32.of_string_opt str with
| Some node ->
Some node
| None -> (
match Int32.of_string_opt String.(sub str 0 (length str - 1)) with
| None ->
None
| Some node ->
Some (hard node) )
let node_of_string_exn str =
match node_of_string str with
| None ->
invalid_arg (Printf.sprintf "node_of_string_exn: got %S" str)
| Some str ->
str
let pp_node ppf node =
match is_hard node with
| true ->
Fmt.pf ppf "%ldh" (unhard node)
| false ->
Fmt.pf ppf "%ld" node
let string_of_node = Fmt.to_to_string pp_node
let path_of_string_exn s =
match String.split_on_char '/' s with
| [""] ->
[]
| nodes ->
List.map node_of_string_exn nodes
let path_of_string s = try Some (path_of_string_exn s) with _ -> None
let pp_path = Fmt.(list ~sep:(const char '/') pp_node)
let string_of_path = Fmt.to_to_string pp_path
end
type error +=
| LedgerError of Ledgerwallet.Transport.error
| Ledger_signing_hash_mismatch of string * string
let error_encoding =
let open Data_encoding in
conv
(fun e -> Format.asprintf "%a" Ledgerwallet.Transport.pp_error e)
(fun _ -> invalid_arg "Ledger error is not deserializable")
(obj1 (req "ledger-error" string))
let () =
register_error_kind
`Permanent
~id:"signer.ledger"
~title:"Ledger error"
~description:"Error communicating with a Ledger Nano device"
~pp:(fun ppf e ->
Format.fprintf ppf "@[Ledger %a@]" Ledgerwallet.Transport.pp_error e)
error_encoding
(function LedgerError e -> Some e | _ -> None)
(fun e -> LedgerError e)
let () =
let description ledger_hash computed_hash =
let paren fmt hash_opt =
match Base.Option.bind ~f:Blake2B.of_string_opt hash_opt with
| None ->
()
| Some hash ->
Format.fprintf fmt " (%a)" Blake2B.pp_short hash
in
Format.asprintf
"The ledger returned a hash%a which doesn't match the independently \
computed hash%a."
paren
ledger_hash
paren
computed_hash
in
register_error_kind
`Permanent
~id:"signer.ledger.signing-hash-mismatch"
~title:"Ledger signing-hash mismatch"
~description:(description None None)
~pp:(fun ppf (lh, ch) ->
Format.pp_print_string ppf (description (Some lh) (Some ch)))
Data_encoding.(
obj2 (req "ledger-hash" string) (req "computed-hash" string))
(function
| Ledger_signing_hash_mismatch (lh, ch) -> Some (lh, ch) | _ -> None)
(fun (lh, ch) -> Ledger_signing_hash_mismatch (lh, ch))
(** Wrappers around Ledger APDUs. *)
module Ledger_commands = struct
let wrap_ledger_cmd f =
let buf = Buffer.create 100 in
let pp =
Format.make_formatter
(fun s ofs lgth -> Buffer.add_substring buf s ofs lgth)
(fun () ->
debug "%s%!" (Buffer.contents buf) ;
Buffer.clear buf)
in
let res = f pp in
lwt_debug "%!"
>>= fun () ->
match res with Error err -> fail (LedgerError err) | Ok v -> return v
let get_version ~device_info h =
let buf = Buffer.create 100 in
let pp = Format.formatter_of_buffer buf in
let version = Ledgerwallet_tezos.get_version ~pp h in
debug "%s" (Buffer.contents buf) ;
match version with
| Error e ->
warn
"WARNING:@ The device at [%s] is not a Tezos application@ %a"
device_info.Hidapi.path
Ledgerwallet.Transport.pp_error
e ;
return_none
| Ok version ->
( if (version.major, version.minor) < (1, 4) then
failwith
"Version %a of the ledger apps is not supported by this client"
Ledgerwallet_tezos.Version.pp
version
else return_unit )
>>=? fun () ->
wrap_ledger_cmd (fun pp -> Ledgerwallet_tezos.get_git_commit ~pp h)
>>=? fun git_commit ->
log_info
"Found a %a application at [%s] (git-description: %S)"
Ledgerwallet_tezos.Version.pp
version
device_info.path
git_commit ;
let cleaned_up =
(* The ledger sends a NUL-terminated C-String: *)
if git_commit.[String.length git_commit - 1] = '\x00' then
String.sub git_commit 0 (String.length git_commit - 1)
else git_commit
in
return_some (version, cleaned_up)
let secp256k1_ctx =
Libsecp256k1.External.Context.create ~sign:false ~verify:false ()
let public_key_returning_instruction which ?(prompt = false) hidapi curve
path =
let path = Bip32_path.tezos_root @ path in
( match which with
| `Get_public_key ->
wrap_ledger_cmd (fun pp ->
Ledgerwallet_tezos.get_public_key ~prompt ~pp hidapi curve path)
| `Authorize_baking ->
wrap_ledger_cmd (fun pp ->
Ledgerwallet_tezos.authorize_baking ~pp hidapi curve path)
| `Setup (main_chain_id, main_hwm, test_hwm) ->
wrap_ledger_cmd (fun pp ->
Ledgerwallet_tezos.setup_baking
~pp
hidapi
curve
path
~main_chain_id
~main_hwm
~test_hwm) )
>>|? fun pk ->
match curve with
| Ed25519 | Bip32_ed25519 ->
let pk = Cstruct.to_bytes pk in
TzEndian.set_int8 pk 0 0 ;
(* hackish, but works. *)
Data_encoding.Binary.of_bytes_exn Signature.Public_key.encoding pk
| Secp256k1 ->
let open Libsecp256k1.External in
let buf = Bigstring.create (Key.compressed_pk_bytes + 1) in
let pk = Key.read_pk_exn secp256k1_ctx (Cstruct.to_bigarray pk) in
EndianBigstring.BigEndian.set_int8 buf 0 1 ;
let _nb_written = Key.write secp256k1_ctx ~pos:1 buf pk in
Data_encoding.Binary.of_bytes_exn
Signature.Public_key.encoding
(Bigstring.to_bytes buf)
| Secp256r1 -> (
let open Uecc in
let pklen = compressed_size secp256r1 in
let buf = Bigstring.create (pklen + 1) in
match pk_of_bytes secp256r1 (Cstruct.to_bigarray pk) with
| None ->
Pervasives.failwith
"Impossible to read P256 public key from Ledger"
| Some pk ->
EndianBigstring.BigEndian.set_int8 buf 0 2 ;
let _nb_written =
write_key ~compress:true (Bigstring.sub buf 1 pklen) pk
in
Data_encoding.Binary.of_bytes_exn
Signature.Public_key.encoding
(Bigstring.to_bytes buf) )
let get_public_key = public_key_returning_instruction `Get_public_key
let pkh_of_pk = Signature.Public_key.hash
let public_key ?(first_import : Client_context.io_wallet option) hid curve
path =
match first_import with
| Some cctxt ->
get_public_key ~prompt:false hid curve path
>>=? fun pk ->
let pkh = pkh_of_pk pk in
cctxt#message
"Please validate@ (and write down)@ the public key hash@ displayed@ \
on the Ledger,@ it should be equal@ to `%a`:"
Signature.Public_key_hash.pp
pkh
>>= fun () -> get_public_key ~prompt:true hid curve path
| None ->
get_public_key ~prompt:false hid curve path
let public_key_hash ?first_import hid curve path =
public_key ?first_import hid curve path
>>=? fun pk -> return (pkh_of_pk pk, pk)
let get_authorized_path hid version =
let open Ledgerwallet_tezos.Version in
if version.major < 2 then
wrap_ledger_cmd (fun pp -> Ledgerwallet_tezos.get_authorized_key ~pp hid)
>>|? fun path -> `Legacy_path path
else
wrap_ledger_cmd (fun pp ->
Ledgerwallet_tezos.get_authorized_path_and_curve ~pp hid)
>>= function
| Error
(LedgerError
(AppError
{ status =
Ledgerwallet.Transport.Status.Referenced_data_not_found;
_ })
:: _) ->
return `No_baking_authorized
| Error _ as e ->
Lwt.return e
| Ok (path, curve) ->
return (`Path_curve (path, curve))
let sign ?watermark ~version hid curve path (base_msg : Bytes.t) =
let msg =
Option.unopt_map watermark ~default:base_msg ~f:(fun watermark ->
Bytes.cat (Signature.bytes_of_watermark watermark) base_msg)
in
let path = Bip32_path.tezos_root @ path in
wrap_ledger_cmd (fun pp ->
let {Ledgerwallet_tezos.Version.major; minor; patch; _} = version in
let open Rresult.R.Infix in
if (major, minor, patch) <= (2, 0, 0) then
Ledgerwallet_tezos.sign ~pp hid curve path (Cstruct.of_bytes msg)
>>= fun s -> Ok (None, s)
else
Ledgerwallet_tezos.sign_and_hash
~pp
hid
curve
path
(Cstruct.of_bytes msg)
>>= fun (h, s) -> Ok (Some h, s))
>>=? fun (hash_opt, signature) ->
( match hash_opt with
| None ->
return_unit
| Some hsh ->
let hash_msg = Blake2B.hash_bytes [msg] in
let ledger_one = Blake2B.of_bytes_exn (Cstruct.to_bytes hsh) in
if Blake2B.equal hash_msg ledger_one then return_unit
else
fail
(Ledger_signing_hash_mismatch
(Blake2B.to_string ledger_one, Blake2B.to_string hash_msg)) )
>>=? fun () ->
match curve with
| Ed25519 | Bip32_ed25519 ->
let signature = Ed25519.of_bytes_exn (Cstruct.to_bytes signature) in
return (Signature.of_ed25519 signature)
| Secp256k1 ->
(* Remove parity info *)
Cstruct.(set_uint8 signature 0 (get_uint8 signature 0 land 0xfe)) ;
let signature = Cstruct.to_bigarray signature in
let open Libsecp256k1.External in
let signature = Sign.read_der_exn secp256k1_ctx signature in
let bytes = Sign.to_bytes secp256k1_ctx signature in
let signature = Secp256k1.of_bytes_exn (Bigstring.to_bytes bytes) in
return (Signature.of_secp256k1 signature)
| Secp256r1 ->
(* Remove parity info *)
Cstruct.(set_uint8 signature 0 (get_uint8 signature 0 land 0xfe)) ;
let signature = Cstruct.to_bigarray signature in
let open Libsecp256k1.External in
(* We use secp256r1 library to extract P256 DER signature. *)
let signature = Sign.read_der_exn secp256k1_ctx signature in
let buf = Sign.to_bytes secp256k1_ctx signature in
let signature = P256.of_bytes_exn (Bigstring.to_bytes buf) in
return (Signature.of_p256 signature)
let get_deterministic_nonce hid curve path msg =
let path = Bip32_path.tezos_root @ path in
wrap_ledger_cmd (fun pp ->
Ledgerwallet_tezos.get_deterministic_nonce
~pp
hid
curve
path
(Cstruct.of_bytes msg))
>>=? fun nonce -> return (Bigstring.of_bytes (Cstruct.to_bytes nonce))
end
(** Identification of a ledger's root key through crouching-tigers
(not the keys used for an account). *)
module Ledger_id = struct
(**
The âIDâ of the ledger is the animals (or pkh) corresponding to
["/ed25519/"] (first curve, no path).
*)
type t = Animals of Ledger_names.t | Pkh of Signature.public_key_hash
let animals_of_pkh pkh =
pkh |> Signature.Public_key_hash.to_string |> Ledger_names.crouching_tiger
let curve = Ledgerwallet_tezos.Ed25519
let get hidapi =
Ledger_commands.get_public_key hidapi curve []
>>=? fun pk ->
let pkh = Signature.Public_key.hash pk in
let animals = animals_of_pkh pkh in
return (Animals animals)
let pp ppf = function
| Animals a ->
Ledger_names.pp ppf a
| Pkh pkh ->
Signature.Public_key_hash.pp ppf pkh
let to_animals = function Animals a -> a | Pkh pkh -> animals_of_pkh pkh
let equal a b = to_animals a = to_animals b
end
(** An account is a given key-pair corresponding to a
[ledger + curve + derivation-path]. *)
module Ledger_account = struct
type t = {
ledger : Ledger_id.t;
curve : Ledgerwallet_tezos.curve;
path : int32 list;
}
end
(** {!Ledger_uri.t} represents a parsed ["ledger://..."] URI which may
refer to a {!Ledger_id.t} or a full blown {!Ledger_account.t}. *)
module Ledger_uri = struct
type t = [`Ledger of Ledger_id.t | `Ledger_account of Ledger_account.t]
let int32_of_path_element_exn ~allow_weak x =
let failf ppf = Printf.ksprintf Pervasives.failwith ppf in
let len = String.length x in
match x.[len - 1] with
| exception _ ->
failf "Empty path element"
| '\'' | 'h' -> (
let intpart = String.sub x 0 (len - 1) in
match Int32.of_string_opt intpart with
| Some i ->
Bip32_path.hard i
| None ->
failf "Path is not an integer: %S" intpart )
| _ when allow_weak -> (
match Int32.of_string_opt x with
| Some i ->
i
| None ->
failf "Path is not a non-hardened integer: %S" x )
| _ ->
failf
"Non-hardened paths are not allowed for this derivation scheme (%S)"
x
let parse_animals animals =
match String.split '-' animals with
| [c; t; h; d] ->
Some {Ledger_names.c; t; h; d}
| _ ->
None
let derivation_supports_weak_paths = function
| Ledgerwallet_tezos.Ed25519 ->
false
| Ledgerwallet_tezos.Secp256k1 ->
true
| Ledgerwallet_tezos.Secp256r1 ->
true
| Ledgerwallet_tezos.Bip32_ed25519 ->
true
let parse ?allow_weak uri : t tzresult Lwt.t =
let host = Uri.host uri in
( match Option.apply host ~f:Signature.Public_key_hash.of_b58check_opt with
| Some pkh ->
return (Ledger_id.Pkh pkh)
| None -> (
match Option.apply host ~f:parse_animals with
| Some animals ->
return (Ledger_id.Animals animals)
| None ->
failwith "Cannot parse host of URI: %s" (Uri.to_string uri) ) )
>>=? fun ledger ->
let components = String.split '/' (Uri.path uri) in
match components with
| s :: tl ->
let (curve, more_path) =
match Ledgerwallet_tezos.curve_of_string s with
| Some curve ->
(curve, tl)
| None ->
(Ledger_id.curve, s :: tl)
in
let actually_allow_weak =
match allow_weak with
| None ->
derivation_supports_weak_paths curve
| Some x ->
x
in
( try
return
(List.map
(int32_of_path_element_exn ~allow_weak:actually_allow_weak)
more_path)
with Failure s ->
failwith
"Failed to parse Curve/BIP32 path from %s (%s): %s"
(Uri.path uri)
(Uri.to_string uri)
s )
>>=? fun bip32 ->
return (`Ledger_account Ledger_account.{ledger; curve; path = bip32})
| [] ->
return (`Ledger ledger)
let ledger_uri_or_alias_param next =
let name = "account-alias-or-ledger-uri" in
let desc =
"An imported ledger alias or a ledger URI (e.g. \
\"ledger://animal/curve/path\")."
in
let open Clic in
param
~name
~desc
(parameter (fun cctxt str ->
Public_key.find_opt cctxt str
>>=? (function
| Some ((x : pk_uri), _) ->
return (x :> Uri.t)
| None -> (
try return (Uri.of_string str)
with e ->
failwith
"Error while parsing URI: %s"
(Printexc.to_string e) ))
>>=? fun uri -> parse uri))
next
let pp : _ -> t -> unit =
fun ppf ->
Format.(
function
| `Ledger lid ->
fprintf ppf "ledger://%a" Ledger_id.pp lid
| `Ledger_account {Ledger_account.ledger; curve; path} ->
fprintf
ppf
"ledger://%a/%a/%a"
Ledger_id.pp
ledger
Ledgerwallet_tezos.pp_curve
curve
Bip32_path.pp_path
path)
let if_matches (meta_uri : t) ledger_id cont =
match meta_uri with
| `Ledger l ->
if Ledger_id.equal l ledger_id then cont () else return_none
| `Ledger_account {Ledger_account.ledger; _} ->
if Ledger_id.equal ledger ledger_id then cont () else return_none
let full_account (ledger_uri : t) =
match ledger_uri with
| `Ledger_account acc ->
return acc
| `Ledger ledger_id ->
failwith
"Insufficient information: you need to provide a curve & BIP32 path \
(%a)."
Ledger_id.pp
ledger_id
end
(** Filters allow early dismissal of HID devices/ledgers which
searching for a ledger. *)
module Filter = struct
type version_filter = Ledgerwallet_tezos.Version.t * string -> bool
type t = [`None | `Hid_path of string | `Version of string * version_filter]
let version_matches (t : t) version_commit =
match t with `Version (_, f) -> f version_commit | _ -> true
let is_app : _ -> _ -> t =
fun msg app ->
`Version
( msg,
fun ({Ledgerwallet_tezos.Version.app_class; _}, _) -> app = app_class
)
let is_baking = is_app "App = Baking" Ledgerwallet_tezos.Version.TezBake
let pp ppf (f : t) =
let open Format in
match f with
| `None ->
fprintf ppf "None"
| `Hid_path s ->
fprintf ppf "HID-path: %s" s
| `Version (s, _) ->
fprintf ppf "%s" s
end
(* Those constants are provided by the vendor (e.g. check the udev
rules they provide): *)
let vendor_id = 0x2c97
let product_id_nano_s = 0x0001
let product_id_nano_x = 0x0004
let use_ledger ?(filter : Filter.t = `None) f =
let ledgers =
Hidapi.enumerate ~vendor_id ~product_id:product_id_nano_s ()
@ Hidapi.enumerate ~vendor_id ~product_id:product_id_nano_x ()
in
debug
"Found %d Ledger(s) %s"
(List.length ledgers)
(String.concat
" -- "
(List.map
Hidapi.(
fun l -> Printf.sprintf "(%04x, %04x)" l.vendor_id l.product_id)
ledgers)) ;
let process_device device_info f =
log_info "Processing Ledger at path [%s]" device_info.Hidapi.path ;
(* HID interfaces get the number 0
(cf. https://github.com/LedgerHQ/ledger-nano-s/issues/48)
*BUT* on MacOSX the Hidapi library does not report the interface-number
so we look at the usage-page (which is even more unspecified but used by
prominent Ledger users:
https://github.com/LedgerHQ/ledgerjs/commit/333ade0d55dc9c59bcc4b451cf7c976e78629681).
*)
if
device_info.Hidapi.interface_number = 0
|| device_info.Hidapi.interface_number = -1
&& device_info.Hidapi.usage_page = 0xffa0
then
match filter with
| `Hid_path hp when device_info.path <> hp ->
return_none
| _ -> (
match Hidapi.(open_path device_info.path) with
| None ->
return_none
| Some h ->
Lwt.finalize
(fun () ->
Ledger_commands.get_version ~device_info h
>>=? function
| Some version_git
when Filter.version_matches filter version_git ->
Ledger_id.get h
>>=? fun ledger_id -> f h version_git device_info ledger_id
| None | Some _ ->
return_none)
(fun () -> Hidapi.close h ; Lwt.return_unit) )
else return_none
in
let rec go = function
| [] ->
return_none
| h :: t -> (
process_device h f
>>=? function Some x -> return_some x | None -> go t )
in
go ledgers
let min_version_of_derivation_scheme = function
| Ledgerwallet_tezos.Ed25519 ->
(1, 3, 0)
| Ledgerwallet_tezos.Secp256k1 ->
(1, 3, 0)
| Ledgerwallet_tezos.Secp256r1 ->
(1, 3, 0)
| Ledgerwallet_tezos.Bip32_ed25519 ->
(2, 1, 0)
let is_derivation_scheme_supported version curve =
Ledgerwallet_tezos.Version.(
let {major; minor; patch; _} = version in
(major, minor, patch) >= min_version_of_derivation_scheme curve)
let use_ledger_or_fail ~ledger_uri ?filter ?msg f =
use_ledger ?filter (fun hidapi (version, git_commit) device_info ledger_id ->
Ledger_uri.if_matches ledger_uri ledger_id (fun () ->
let go () = f hidapi (version, git_commit) device_info ledger_id in
match ledger_uri with
| `Ledger_account {curve; _} ->
if is_derivation_scheme_supported version curve then go ()
else
Ledgerwallet_tezos.(
failwith
"To use derivation scheme %a you need %a or later but \
you're using %a."
pp_curve
curve
Version.pp
(let (a, b, c) = min_version_of_derivation_scheme curve in
{version with major = a; minor = b; patch = c})
Version.pp
version)
| _ ->
go ()))
>>=? function
| Some o ->
return o
| None ->
failwith
"%sFound no ledger corresponding to %a%t."
(Option.unopt_map ~default:"" ~f:(Printf.sprintf "%s: ") msg)
Ledger_uri.pp
ledger_uri
(fun ppf ->
match filter with
| Some f ->
Format.fprintf ppf " with filter \"%a\"" Filter.pp f
| None ->
())
(** A global {!Hashtbl.t} which allows us to avoid calling
{!Signer_implementation.get_public_key} too often. *)
module Global_cache : sig
val record :
pk_uri -> pk:Signature.public_key -> pkh:Signature.public_key_hash -> unit
val get : pk_uri -> (Signature.public_key_hash * Signature.public_key) option
end = struct
let _cache :
(pk_uri, Signature.Public_key_hash.t * Signature.Public_key.t) Hashtbl.t
=
Hashtbl.create 13
let record pk_uri ~pk ~pkh = Hashtbl.replace _cache pk_uri (pkh, pk)
let get pk_uri = Hashtbl.find_opt _cache pk_uri
end
(** The implementation of the âsigner-plugin.â *)
module Signer_implementation : Client_keys.SIGNER = struct
let scheme = "ledger"
let title = "Built-in signer using a Ledger Nano device."
let description =
Printf.sprintf
"Valid URIs are of the form\n\
\ - ledger://<animals>/<curve>[/<path>]\n\
where:\n\
\ - <animals> is the identifier of the ledger of the form \
'crouching-tiger-hidden-dragon' and can be obtained with the command \
`tezos-client list connected ledgers` (which also provides full \
examples).\n\
- <curve> is the signing curve, e.g. `ed1551`\n\
- <path> is a BIP32 path anchored at m/%s. The ledger does not yet \
support non-hardened paths, so each node of the path must be hardened."
Bip32_path.(string_of_path tezos_root)
let neuterize (sk : sk_uri) = return (make_pk_uri (sk :> Uri.t))
let pkh_of_pk = Signature.Public_key.hash
let public_key_maybe_prompt ?(first_import : Client_context.io_wallet option)
(pk_uri : pk_uri) =
match Global_cache.get pk_uri with
| Some (_, pk) ->
return pk
| None -> (
Ledger_uri.parse (pk_uri :> Uri.t)
>>=? (fun ledger_uri ->
Ledger_uri.full_account ledger_uri
>>=? fun {curve; path; _} ->
use_ledger_or_fail
~ledger_uri
(fun hidapi (_version, _git_commit) _device_info _ledger_id ->
Ledger_commands.public_key ?first_import hidapi curve path
>>=? fun pk ->
let pkh = pkh_of_pk pk in
Global_cache.record pk_uri ~pkh ~pk ;
return_some pk))
>>= function
| Error err -> failwith "%a" pp_print_error err | Ok v -> return v )
let public_key_hash_maybe_prompt ?first_import pk_uri =
match Global_cache.get pk_uri with
| Some (pkh, pk) ->
return (pkh, Some pk)
| None ->
public_key_maybe_prompt ?first_import pk_uri
>>=? fun pk -> return (pkh_of_pk pk, Some pk)
let public_key = public_key_maybe_prompt ?first_import:None
let public_key_hash = public_key_hash_maybe_prompt ?first_import:None
let import_secret_key ~io pk_uri =
public_key_hash_maybe_prompt ~first_import:io pk_uri
let sign ?watermark (sk_uri : sk_uri) msg =
Ledger_uri.parse (sk_uri :> Uri.t)
>>=? fun ledger_uri ->
Ledger_uri.full_account ledger_uri
>>=? fun {curve; path; _} ->
use_ledger_or_fail
~ledger_uri
(fun hidapi (version, _git_commit) _device_info _ledger_id ->
Ledger_commands.sign ?watermark ~version hidapi curve path msg
>>=? fun bytes -> return_some bytes)
let deterministic_nonce (sk_uri : sk_uri) msg =
Ledger_uri.parse (sk_uri :> Uri.t)
>>=? fun ledger_uri ->
Ledger_uri.full_account ledger_uri
>>=? fun {curve; path; _} ->
use_ledger_or_fail
~ledger_uri
(fun hidapi (_version, _git_commit) _device_info _ledger_id ->
Ledger_commands.get_deterministic_nonce hidapi curve path msg
>>=? fun bytes -> return_some bytes)
let deterministic_nonce_hash (sk : sk_uri) msg =
deterministic_nonce sk msg
>>=? fun nonce ->
return (Blake2B.to_bytes (Blake2B.hash_bytes [Bigstring.to_bytes nonce]))
let supports_deterministic_nonces _ = return_true
end
(* The Ledger uses a special value 0x00000000 for the âanyâ chain-id: *)
let pp_ledger_chain_id fmt s =
match s with
| "\x00\x00\x00\x00" ->
Format.fprintf fmt "'Unspecified'"
| other ->
Format.fprintf fmt "%a" Chain_id.pp (Chain_id.of_string_exn other)
(** Commands for both ledger applications. *)
let generic_commands group =
Clic.
[ command
~group
~desc:"List supported Ledger Nano devices connected."
no_options
(fixed ["list"; "connected"; "ledgers"])
(fun () (cctxt : Client_context.full) ->
use_ledger
(fun _hidapi (version, git_commit) device_info ledger_id ->
let open Hidapi in
cctxt#message
"%t"
Format.(
fun ppf ->
let intro =
asprintf
"Found a %a (git-description: %S) application running \
on %s %s at [%s]."
Ledgerwallet_tezos.Version.pp
version
git_commit
( device_info.manufacturer_string
|> Option.unopt ~default:"NO-MANUFACTURER" )
( device_info.product_string
|> Option.unopt ~default:"NO-PRODUCT" )
device_info.path
in
pp_open_vbox ppf 0 ;
fprintf ppf "## Ledger `%a`@," Ledger_id.pp ledger_id ;
pp_open_hovbox ppf 0 ;
pp_print_text ppf intro ;
pp_close_box ppf () ;
pp_print_cut ppf () ;
pp_print_cut ppf () ;
pp_open_hovbox ppf 0 ;
pp_print_text
ppf
"To use keys at BIP32 path m/44'/1729'/0'/0' (default \
Tezos key path), use one of:" ;
pp_close_box ppf () ;
pp_print_cut ppf () ;
List.iter
(fun curve ->
fprintf
ppf
" tezos-client import secret key ledger_%s \
\"ledger://%a/%a/0h/0h\""
( Sys.getenv_opt "USER"
|> Option.unopt ~default:"user" )
Ledger_id.pp
ledger_id
Ledgerwallet_tezos.pp_curve
curve ;
pp_print_cut ppf ())
(List.filter
(is_derivation_scheme_supported version)
[Bip32_ed25519; Ed25519; Secp256k1; Secp256r1]) ;
pp_close_box ppf () ;
pp_print_newline ppf ())
>>= fun () -> return_none)
>>=? fun _ -> return_unit);
Clic.command
~group
~desc:"Display version/public-key/address information for a Ledger URI"
(args1 (switch ~doc:"Test signing operation" ~long:"test-sign" ()))
( prefixes ["show"; "ledger"]
@@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
(fun test_sign ledger_uri (cctxt : Client_context.full) ->
use_ledger_or_fail
~ledger_uri
(fun hidapi (version, git_commit) device_info _ledger_id ->
cctxt#message
"Found ledger corresponding to %a:"
Ledger_uri.pp
ledger_uri
>>= fun () ->
cctxt#message
"* Manufacturer: %s"
(Option.unopt device_info.manufacturer_string ~default:"NONE")
>>= fun () ->
cctxt#message
"* Product: %s"
(Option.unopt device_info.product_string ~default:"NONE")
>>= fun () ->
cctxt#message
"* Application: %a (git-description: %S)"
Ledgerwallet_tezos.Version.pp
version
git_commit
>>= fun () ->
( match ledger_uri with
| `Ledger_account {curve; path; _} -> (
cctxt#message
"* Curve: `%a`"
Ledgerwallet_tezos.pp_curve
curve
>>= fun () ->
let full_path = Bip32_path.tezos_root @ path in
cctxt#message
"* Path: `%s` [%s]"
(Bip32_path.string_of_path full_path)
(String.concat
"; "
(List.map (Printf.sprintf "0x%lX") full_path))
>>= fun () ->
Ledger_commands.public_key_hash hidapi curve path
>>=? fun (pkh, pk) ->
cctxt#message "* Public Key: %a" Signature.Public_key.pp pk
>>= fun () ->
cctxt#message
"* Public Key Hash: %a@\n"
Signature.Public_key_hash.pp
pkh
>>= fun () ->
match (test_sign, version.app_class) with
| (true, Tezos) -> (
let pkh_bytes = Signature.Public_key_hash.to_bytes pkh in
(* Signing requires validation on the device. *)
cctxt#message
"@[Attempting a signature@ (of `%a`),@ please@ \
validate on@ the ledger.@]"
Hex.pp
(Hex.of_bytes pkh_bytes)
>>= fun () ->
Ledger_commands.sign
~version
~watermark:Generic_operation
hidapi
curve
path
pkh_bytes
>>=? fun signature ->
match
Signature.check
~watermark:Generic_operation
pk
signature
pkh_bytes
with
| false ->
failwith
"Fatal: Ledger cannot sign with %a"
Signature.Public_key_hash.pp
pkh
| true ->
cctxt#message
"Tezos Wallet successfully signed:@ %a."
Signature.pp
signature
>>= fun () -> return_unit )
| (true, TezBake) ->
failwith
"Option --test-sign only works for the Tezos Wallet \
app."
| (false, _) ->
return_unit )
| `Ledger _ when test_sign ->
failwith
"Option --test-sign only works with a full ledger \
URI/account (with curve/path)."
| `Ledger _ ->
cctxt#message "* This is just a ledger URI."
>>= fun () -> return_unit )
>>=? fun () -> return_some ())) ]
(** Commands specific to the Baking app minus the high-water-mark ones
which get a specific treatment in {!high_water_mark_commands}. *)
let baking_commands group =
Clic.
[ Clic.command
~group
~desc:"Query the path of the authorized key"
no_options
( prefixes ["get"; "ledger"; "authorized"; "path"; "for"]
@@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
(fun () ledger_uri (cctxt : Client_context.full) ->
use_ledger_or_fail
~ledger_uri
~filter:Filter.is_baking
(fun hidapi (version, _git_commit) _device_info _ledger_id ->
Ledger_commands.get_authorized_path hidapi version
>>=? fun authorized ->
match authorized with
| `Legacy_path p ->
cctxt#message
"@[<v 0>Authorized baking path (Legacy < 2.x.y): %a@]"
Bip32_path.pp_path
p
>>= fun () -> return_some ()
| `No_baking_authorized ->
cctxt#message "No baking key authorized at all."
>>= fun () -> return_some ()
| `Path_curve (ledger_path, ledger_curve) -> (
cctxt#message
"@[<v 0>Authorized baking path: %a@]"
Bip32_path.pp_path
ledger_path
>>= fun () ->
cctxt#message
"@[<v 0>Authorized baking curve: %a@]"
Ledgerwallet_tezos.pp_curve
ledger_curve
>>= fun () ->
match ledger_uri with
| `Ledger _ ->
return_some ()
| `Ledger_account {curve; path; _}
when curve = ledger_curve
&& Bip32_path.tezos_root @ path = ledger_path ->
cctxt#message
"@[<v 0>Authorized baking URI: %a@]"
Ledger_uri.pp
ledger_uri
>>= fun () -> return_some ()
| `Ledger_account {curve; path; _} ->
failwith
"Path and curve do not match the ones specified in \
the command line: %a & %a"
Ledgerwallet_tezos.pp_curve
curve
Bip32_path.pp_path
(Bip32_path.tezos_root @ path) )));
Clic.command
~group
~desc:
"Authorize a Ledger to bake for a key (deprecated, use `setup \
ledger ...` with recent versions of the Baking app)"
no_options
( prefixes ["authorize"; "ledger"; "to"; "bake"; "for"]
@@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
(fun () ledger_uri (cctxt : Client_context.full) ->
use_ledger_or_fail
~ledger_uri
~filter:Filter.is_baking
(fun hidapi (version, _git_commit) _device_info _ledger_id ->
( match version with
| {Ledgerwallet_tezos.Version.app_class = Tezos; _} ->
failwith
"This command (`authorize ledger ...`) only works with \
the Tezos Baking app"
| {Ledgerwallet_tezos.Version.app_class = TezBake; major; _}
when major >= 2 ->
failwith
"This command (`authorize ledger ...`) is@ not compatible \
with@ this version of the Ledger@ Baking app (%a >= \
2.0.0),@ please use the command@ `setup ledger to bake \
for ...`@ from now on."
Ledgerwallet_tezos.Version.pp
version
| _ ->
cctxt#message
"This Ledger Baking app is outdated (%a)@ running@ in \
backwards@ compatibility mode."
Ledgerwallet_tezos.Version.pp
version
>>= fun () -> return_unit )
>>=? fun () ->
Ledger_uri.full_account ledger_uri
>>=? fun {Ledger_account.curve; path; _} ->
Ledger_commands.public_key_returning_instruction
`Authorize_baking
hidapi
curve
path
>>=? fun pk ->
let pkh = Signature.Public_key.hash pk in
cctxt#message
"@[<v 0>Authorized baking for address: %a@,\
Corresponding full public key: %a@]"
Signature.Public_key_hash.pp
pkh
Signature.Public_key.pp
pk
>>= fun () -> return_some ()));
Clic.command
~group
~desc:"Setup a Ledger to bake for a key"
(let hwm_arg kind =
let doc =
Printf.sprintf
"Use <HWM> as %s chain high watermark instead of asking the \
ledger."
kind
in
let long = kind ^ "-hwm" in
default_arg
~doc
~long
~placeholder:"HWM"
~default:"ASK-LEDGER"
(parameter (fun _ ->
function
| "ASK-LEDGER" ->
return_none
| s -> (
try return_some (Int32.of_string s)
with _ ->
failwith "Parameter %S should be a 32-bits integer" s )))
in
args3
(default_arg
~doc:"Use <ID> as main chain-id instead of asking the node."
~long:"main-chain-id"
~placeholder:"ID"
~default:"ASK-NODE"
(parameter (fun _ ->
function
| "ASK-NODE" ->
return `Ask_node
| s -> (
try return (`Int32 (Int32.of_string s))
with _ -> (
try return (`Chain_id (Chain_id.of_b58check_exn s))
with _ ->
failwith
"Parameter %S should be a 32-bits integer or a \
Base58 chain-id"
s ) ))))
(hwm_arg "main")
(hwm_arg "test"))
( prefixes ["setup"; "ledger"; "to"; "bake"; "for"]
@@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
(fun (chain_id_opt, main_hwm_opt, test_hwm_opt)
ledger_uri
(cctxt : Client_context.full) ->
use_ledger_or_fail
~ledger_uri
~filter:Filter.is_baking
(fun hidapi (version, _git_commit) _device_info _ledger_id ->
(let open Ledgerwallet_tezos.Version in
match version with
| {app_class = Tezos; _} ->
failwith
"This command (`setup ledger ...`) only works with the \
Tezos Baking app"
| {app_class = TezBake; major; _} when major < 2 ->
failwith
"This command (`setup ledger ...`)@ is not@ compatible@ \
with this version@ of the Ledger Baking app@ (%a < \
2.0.0),@ please upgrade@ your ledger@ or use the \
command@ `authorize ledger to bake for ...`"
pp
version
| _ ->
return_unit)
>>=? fun () ->
Ledger_uri.full_account ledger_uri
>>=? fun {Ledger_account.curve; path; _} ->
let chain_id_of_int32 i32 =
let open Int32 in
let byte n =
logand 0xFFl (shift_right i32 (n * 8))
|> Int32.to_int |> char_of_int
in
Chain_id.of_string_exn
(Stringext.of_array (Array.init 4 (fun i -> byte (3 - i))))
in
( match chain_id_opt with
| `Ask_node ->
Chain_services.chain_id cctxt ()
| `Int32 s ->
return (chain_id_of_int32 s)
| `Chain_id chid ->
return chid )
>>=? fun main_chain_id ->
Ledger_commands.wrap_ledger_cmd (fun pp ->
Ledgerwallet_tezos.get_all_high_watermarks ~pp hidapi)
>>=? fun ( `Main_hwm current_mh,
`Test_hwm current_th,
`Chain_id current_ci ) ->
let main_hwm = Option.unopt main_hwm_opt ~default:current_mh in
let test_hwm = Option.unopt test_hwm_opt ~default:current_th in
cctxt#message
"Setting up the ledger:@.* Main chain ID: %a -> %a@.* Main \
chain High Watermark: %ld -> %ld@.* Test chain High \
Watermark: %ld -> %ld"
pp_ledger_chain_id
current_ci
Chain_id.pp
main_chain_id
current_mh
main_hwm
current_th
test_hwm
>>= fun () ->
Ledger_commands.public_key_returning_instruction
(`Setup (Chain_id.to_string main_chain_id, main_hwm, test_hwm))
hidapi
curve
path
>>=? fun pk ->
let pkh = Signature.Public_key.hash pk in
cctxt#message
"@[<v 0>Authorized baking for address: %a@,\
Corresponding full public key: %a@]"
Signature.Public_key_hash.pp
pkh
Signature.Public_key.pp
pk
>>= fun () -> return_some ()));
Clic.command
~group
~desc:"Deauthorize Ledger from baking"
no_options
( prefixes ["deauthorize"; "ledger"; "baking"; "for"]
@@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
(fun () ledger_uri (_cctxt : Client_context.full) ->
use_ledger_or_fail
~ledger_uri
~filter:Filter.is_baking
(fun hidapi (_version, _git_commit) _device_info _ledger_id ->
Ledger_commands.wrap_ledger_cmd (fun pp ->
Ledgerwallet_tezos.deauthorize_baking ~pp hidapi)
>>=? fun () -> return_some ())) ]
(** Commands for high water mark of the Baking app. The
[watermark_spelling] argument is used to make 2 sets of commands: with
the old/wrong spelling âwatermarkâ for backwards compatibility and
with the correct one âhigh water markâ (it's a mark of the highest
water level). *)
let high_water_mark_commands group watermark_spelling =
let make_desc desc =
if List.length watermark_spelling = 1 then
desc ^ " (legacy/deprecated spelling)"
else desc
in
Clic.
[ Clic.command
~group
~desc:(make_desc "Get high water mark of a Ledger")
(args1
(switch
~doc:
"Prevent the fallback to the (deprecated) Ledger instructions \
(for 1.x.y versions of the Baking app)"
~long:"no-legacy-instructions"
()))
( prefixes (["get"; "ledger"; "high"] @ watermark_spelling @ ["for"])
@@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
(fun no_legacy_apdu ledger_uri (cctxt : Client_context.full) ->
use_ledger_or_fail
~ledger_uri
~filter:Filter.is_baking
(fun hidapi (version, _git_commit) _device_info _ledger_id ->
match version.app_class with
| Tezos ->
failwith
"Fatal: this operation is only valid with the Tezos \
Baking application"
| TezBake when (not no_legacy_apdu) && version.major < 2 ->
Ledger_commands.wrap_ledger_cmd (fun pp ->
Ledgerwallet_tezos.get_high_watermark ~pp hidapi)
>>=? fun hwm ->
cctxt#message
"The high water mark for@ %a@ is %ld."
Ledger_uri.pp
ledger_uri
hwm
>>= fun () -> return_some ()
| TezBake when no_legacy_apdu && version.major < 2 ->
failwith
"Cannot get the high water mark with@ \
`--no-legacy-instructions` and version %a"
Ledgerwallet_tezos.Version.pp
version
| TezBake ->
Ledger_commands.wrap_ledger_cmd (fun pp ->
Ledgerwallet_tezos.get_all_high_watermarks ~pp hidapi)
>>=? fun (`Main_hwm mh, `Test_hwm th, `Chain_id ci) ->
cctxt#message
"The high water mark values for@ %a@ are@ %ld for the \
main-chain@ (%a)@ and@ %ld for the test-chain."
Ledger_uri.pp
ledger_uri
mh
pp_ledger_chain_id
ci
th
>>= fun () -> return_some ()));
Clic.command
~group
~desc:(make_desc "Set high water mark of a Ledger")
no_options
( prefixes (["set"; "ledger"; "high"] @ watermark_spelling @ ["for"])
@@ Ledger_uri.ledger_uri_or_alias_param @@ prefix "to"
@@ param
~name:"high watermark"
~desc:"High watermark"
(parameter (fun _ctx s ->
try return (Int32.of_string s)
with _ -> failwith "%s is not an int32 value" s))
@@ stop )
(fun () ledger_uri hwm (cctxt : Client_context.full) ->
use_ledger_or_fail
~ledger_uri
~filter:Filter.is_baking
(fun hidapi (version, _git_commit) _device_info _ledger_id ->
match version.app_class with
| Tezos ->
failwith "Fatal: this operation is only valid with TezBake"
| TezBake ->
Ledger_commands.wrap_ledger_cmd (fun pp ->
Ledgerwallet_tezos.set_high_watermark ~pp hidapi hwm)
>>=? fun () ->
Ledger_commands.wrap_ledger_cmd (fun pp ->
Ledgerwallet_tezos.get_high_watermark ~pp hidapi)
>>=? fun new_hwm ->
cctxt#message
"@[<v 0>%a has now high water mark: %ld@]"
Ledger_uri.pp
ledger_uri
new_hwm
>>= fun () -> return_some ())) ]
let commands =
let group =
{
Clic.name = "ledger";
title = "Commands for managing the connected Ledger Nano devices";
}
in
fun () ->
generic_commands group @ baking_commands group
@ high_water_mark_commands group ["water"; "mark"]
@ high_water_mark_commands group ["watermark"]
src/lib_signer_backends/unix/ledger.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Client_keys.
(* ❌ Structure item `include` not handled. *)
include
Module Bip32_path.
Definition hard : int32 -> int32 :=
Int32.logor
(* ❌ Constant of type int32 is converted to int *)
(-2147483648).
Definition unhard : int32 -> int32 :=
Int32.logand
(* ❌ Constant of type int32 is converted to int *)
2147483647.
Definition is_hard (n : int32) : bool :=
nequiv_decb
(Int32.logand
(* ❌ Constant of type int32 is converted to int *)
(-2147483648) n)
(* ❌ Constant of type int32 is converted to int *)
0.
Definition tezos_root : list int32 :=
cons
(hard
(* ❌ Constant of type int32 is converted to int *)
44)
(cons
(hard
(* ❌ Constant of type int32 is converted to int *)
1729) []).
Definition node_of_string (str : string) : option int32 :=
match Int32.of_string_opt str with
| Some node => Some node
| None =>
match Int32.of_string_opt (sub str 0 (Z.sub (length str) 1)) with
| None => None
| Some node => Some (hard node)
end
end.
Definition node_of_string_exn (str : string) : int32 :=
match node_of_string str with
| None =>
OCaml.Stdlib.invalid_arg
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"node_of_string_exn: got " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"node_of_string_exn: got %S" % string) str)
| Some str => str
end.
Definition pp_node (ppf : Stdlib.Format.formatter) (node : int32) : unit :=
match is_hard node with
| true =>
Fmt.pf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal "h" % char
CamlinternalFormatBasics.End_of_format)) "%ldh" % string)
(unhard node)
| false =>
Fmt.pf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format) "%ld" % string) node
end.
Definition string_of_node : int32 -> string := Fmt.to_to_string pp_node.
Definition path_of_string_exn (s : string) : list int32 :=
match String.split_on_char "/" % char s with
| cons "" % string [] => []
| nodes => List.map node_of_string_exn nodes
end.
Definition path_of_string (s : string) : option (list int32) :=
(* ❌ Try-with are not handled *)
try (Some (path_of_string_exn s)).
Definition pp_path : Fmt.t (list int32) :=
list (Some (const char "/" % char)) pp_node.
Definition string_of_path : (list int32) -> string := Fmt.to_to_string pp_path.
End Bip32_path.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition error_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Ledgerwallet.Transport.error :=
conv
(fun e =>
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) Ledgerwallet.Transport.pp_error e)
(fun function_parameter =>
let '_ := function_parameter in
OCaml.Stdlib.invalid_arg "Ledger error is not deserializable" % string)
None (obj1 (req None None "ledger-error" % string string)).
Module Ledger_commands.
Definition wrap_ledger_cmd {A : Type}
(f : Stdlib.Format.formatter -> sum A Ledgerwallet.Transport.error)
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
let buf := Buffer.create 100 in
let pp :=
Format.make_formatter
(fun s => fun ofs => fun lgth => Buffer.add_substring buf s ofs lgth)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format)) "%s%!" % string)
(Buffer.contents buf) in
Buffer.clear buf) in
let res := f pp in
op_gtgteq
(lwt_debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format)
"%!" % string))
(fun function_parameter =>
let 'tt := function_parameter in
match res with
| Stdlib.Error err => fail (Tezos_base__TzPervasives.LedgerError err)
| Stdlib.Ok v => _return v
end).
Definition get_version (device_info : Hidapi.device_info) (h : Hidapi.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option (Ledgerwallet_tezos.Version.t * string))) :=
let buf := Buffer.create 100 in
let pp := Format.formatter_of_buffer buf in
let version := Ledgerwallet_tezos.get_version (Some pp) None h in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
(Buffer.contents buf) in
match version with
| Stdlib.Error e =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
warn
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "WARNING:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"The device at [" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"] is not a Tezos application" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))))))
"WARNING:@ The device at [%s] is not a Tezos application@ %a" %
string) (Hidapi.path device_info) Ledgerwallet.Transport.pp_error
e in
return_none
| Stdlib.Ok version =>
op_gtgteqquestion
(if OCaml.Stdlib.lt ((major version), (minor version)) (1, 4) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Version " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" of the ledger apps is not supported by this client" %
string CamlinternalFormatBasics.End_of_format)))
"Version %a of the ledger apps is not supported by this client" %
string) Ledgerwallet_tezos.Version.pp version
else
return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(wrap_ledger_cmd
(fun pp => Ledgerwallet_tezos.get_git_commit (Some pp) None h))
(fun git_commit =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Found a " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" application at [" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"] (git-description: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))))))
"Found a %a application at [%s] (git-description: %S)" %
string) Ledgerwallet_tezos.Version.pp version
(path device_info) git_commit in
let cleaned_up :=
if
equiv_decb
(String.get git_commit (Z.sub (String.length git_commit) 1))
"000" % char then
String.sub git_commit 0 (Z.sub (String.length git_commit) 1)
else
git_commit in
return_some (version, cleaned_up)))
end.
Definition secp256k1_ctx : Libsecp256k1.External.Context.t :=
Libsecp256k1.External.Context.create (Some false) (Some false) tt.
Definition public_key_returning_instruction
(which : variant) (op_staroptstar : option bool)
: Hidapi.t ->
Ledgerwallet_tezos.curve ->
(list int32) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.Public_key.t) :=
let prompt :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun hidapi =>
fun curve =>
fun path =>
let path := OCaml.Stdlib.app Bip32_path.tezos_root path in
op_gtgtpipequestion
match which with
| Get_public_key =>
wrap_ledger_cmd
(fun pp =>
Ledgerwallet_tezos.get_public_key (Some prompt) (Some pp) None
hidapi curve path)
| Authorize_baking =>
wrap_ledger_cmd
(fun pp =>
Ledgerwallet_tezos.authorize_baking (Some pp) None hidapi
curve path)
| Setup (main_chain_id, main_hwm, test_hwm) =>
wrap_ledger_cmd
(fun pp =>
Ledgerwallet_tezos.setup_baking (Some pp) None hidapi
main_chain_id main_hwm test_hwm curve path)
end
(fun pk =>
match curve with
| Ledgerwallet_tezos.Ed25519 | Ledgerwallet_tezos.Bip32_ed25519 =>
let pk := Cstruct.to_bytes pk in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := TzEndian.set_int8 pk 0 0 in
Data_encoding.Binary.of_bytes_exn Signature.Public_key.encoding
pk
| Ledgerwallet_tezos.Secp256k1 =>
let buf := Bigstring.create (Z.add Key.compressed_pk_bytes 1) in
let pk := Key.read_pk_exn secp256k1_ctx (Cstruct.to_bigarray pk)
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
EndianBigstring.BigEndian.(EndianBigstring.EndianBigstringSig.set_int8)
buf 0 1 in
let _nb_written := Key.write None secp256k1_ctx (Some 1) buf pk
in
Data_encoding.Binary.of_bytes_exn Signature.Public_key.encoding
(Bigstring.to_bytes buf)
| Ledgerwallet_tezos.Secp256r1 =>
let pklen := compressed_size secp256r1 in
let buf := Bigstring.create (Z.add pklen 1) in
match pk_of_bytes secp256r1 (Cstruct.to_bigarray pk) with
| None =>
Pervasives.failwith
"Impossible to read P256 public key from Ledger" % string
| Some pk =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
EndianBigstring.BigEndian.(EndianBigstring.EndianBigstringSig.set_int8)
buf 0 2 in
let _nb_written :=
write_key (Some true) (Bigstring.sub buf 1 pklen) pk in
Data_encoding.Binary.of_bytes_exn
Signature.Public_key.encoding (Bigstring.to_bytes buf)
end
end).
Definition get_public_key
: (option bool) ->
Hidapi.t ->
Ledgerwallet_tezos.curve ->
(list int32) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.Public_key.t) :=
public_key_returning_instruction
(* ❌ Variants not supported *)
variant.
Definition pkh_of_pk
: Tezos_base__TzPervasives.Signature.Public_key.t ->
Tezos_crypto__Signature.Public_key_hash.t := Signature.Public_key.hash.
Definition public_key
(first_import : option Tezos_client_base.Client_context.io_wallet)
(hid : Hidapi.t) (curve : Ledgerwallet_tezos.curve) (path : list int32)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.Public_key.t) :=
match first_import with
| Some cctxt =>
op_gtgteqquestion (get_public_key (Some false) hid curve path)
(fun pk =>
let pkh := pkh_of_pk pk in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Please validate" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"(and write down)" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"the public key hash" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"displayed" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1
0)
(CamlinternalFormatBasics.String_literal
"on the Ledger," % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"it should be equal" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"to `" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"`:" % string
CamlinternalFormatBasics.End_of_format)))))))))))))))
"Please validate@ (and write down)@ the public key hash@ displayed@ on the Ledger,@ it should be equal@ to `%a`:"
% string) Signature.Public_key_hash.pp pkh)
(fun function_parameter =>
let 'tt := function_parameter in
get_public_key (Some true) hid curve path))
| None => get_public_key (Some false) hid curve path
end.
Definition public_key_hash
(first_import : option Tezos_client_base.Client_context.io_wallet)
(hid : Hidapi.t) (curve : Ledgerwallet_tezos.curve) (path : list int32)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_crypto__Signature.Public_key_hash.t *
Tezos_base__TzPervasives.Signature.Public_key.t)) :=
op_gtgteqquestion (public_key first_import hid curve path)
(fun pk => _return ((pkh_of_pk pk), pk)).
Definition get_authorized_path
(hid : Hidapi.t) (version : Ledgerwallet_tezos.Version.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult variant) :=
if OCaml.Stdlib.lt (major version) 2 then
op_gtgtpipequestion
(wrap_ledger_cmd
(fun pp => Ledgerwallet_tezos.get_authorized_key (Some pp) None hid))
(fun path =>
(* ❌ Variants not supported *)
variant)
else
op_gtgteq
(wrap_ledger_cmd
(fun pp =>
Ledgerwallet_tezos.get_authorized_path_and_curve (Some pp) None hid))
(fun function_parameter =>
match function_parameter with
|
Stdlib.Error
(cons
(Tezos_base__TzPervasives.LedgerError
(Ledgerwallet.Transport.AppError {|
status := Ledgerwallet.Transport.Status.Referenced_data_not_found
|})) _) =>
_return
(* ❌ Variants not supported *)
variant
| (Stdlib.Error _) as e => Lwt._return e
| Stdlib.Ok (path, curve) =>
_return
(* ❌ Variants not supported *)
variant
end).
Definition sign
(watermark : option Tezos_base__TzPervasives.Signature.watermark)
(version : Ledgerwallet_tezos.Version.t) (hid : Hidapi.t)
(curve : Ledgerwallet_tezos.curve) (path : list int32)
(base_msg : Stdlib.Bytes.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
let msg :=
Option.unopt_map
(fun watermark =>
String.append (Signature.bytes_of_watermark watermark) base_msg)
base_msg watermark in
let path := OCaml.Stdlib.app Bip32_path.tezos_root path in
op_gtgteqquestion
(wrap_ledger_cmd
(fun pp =>
let '{|
Ledgerwallet_tezos.Version.major := major;
Ledgerwallet_tezos.Version.minor := minor;
Ledgerwallet_tezos.Version.patch := patch
|} := version in
if OCaml.Stdlib.le (major, minor, patch) (2, 0, 0) then
op_gtgteq
(Ledgerwallet_tezos.sign (Some pp) None None hid curve path
(Cstruct.of_bytes None None None msg))
(fun s => Stdlib.Ok (None, s))
else
op_gtgteq
(Ledgerwallet_tezos.sign_and_hash (Some pp) None hid curve path
(Cstruct.of_bytes None None None msg))
(fun function_parameter =>
let '(h, s) := function_parameter in
Stdlib.Ok ((Some h), s))))
(fun function_parameter =>
let '(hash_opt, signature) := function_parameter in
op_gtgteqquestion
match hash_opt with
| None => return_unit
| Some hsh =>
let hash_msg := Blake2B.hash_bytes None (cons msg []) in
let ledger_one := Blake2B.of_bytes_exn (Cstruct.to_bytes hsh) in
if Blake2B.equal hash_msg ledger_one then
return_unit
else
fail
(Tezos_base__TzPervasives.Ledger_signing_hash_mismatch
(Blake2B.to_string ledger_one) (Blake2B.to_string hash_msg))
end
(fun function_parameter =>
let 'tt := function_parameter in
match curve with
| Ledgerwallet_tezos.Ed25519 | Ledgerwallet_tezos.Bip32_ed25519 =>
let signature := Ed25519.of_bytes_exn (Cstruct.to_bytes signature)
in
_return (Signature.of_ed25519 signature)
| Ledgerwallet_tezos.Secp256k1 =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
set_uint8 signature 0 (Z.land (get_uint8 signature 0) 254) in
let signature := Cstruct.to_bigarray signature in
let signature := Sign.read_der_exn secp256k1_ctx signature in
let bytes := Sign.to_bytes None secp256k1_ctx signature in
let signature :=
Secp256k1.of_bytes_exn (Bigstring.to_bytes string) in
_return (Signature.of_secp256k1 signature)
| Ledgerwallet_tezos.Secp256r1 =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
set_uint8 signature 0 (Z.land (get_uint8 signature 0) 254) in
let signature := Cstruct.to_bigarray signature in
let signature := Sign.read_der_exn secp256k1_ctx signature in
let buf := Sign.to_bytes None secp256k1_ctx signature in
let signature := P256.of_bytes_exn (Bigstring.to_bytes buf) in
_return (Signature.of_p256 signature)
end)).
Definition get_deterministic_nonce
(hid : Hidapi.t) (curve : Ledgerwallet_tezos.curve) (path : list int32)
(msg : string) : Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
let path := OCaml.Stdlib.app Bip32_path.tezos_root path in
op_gtgteqquestion
(wrap_ledger_cmd
(fun pp =>
Ledgerwallet_tezos.get_deterministic_nonce (Some pp) None hid curve
path (Cstruct.of_bytes None None None msg)))
(fun nonce => _return (Bigstring.of_bytes (Cstruct.to_bytes nonce))).
End Ledger_commands.
Module Ledger_id.
Inductive t : Type :=
| Animals : Tezos_signer_backends_unix.Ledger_names.t -> t
| Pkh : Tezos_base__TzPervasives.Signature.public_key_hash -> t.
Definition animals_of_pkh
(pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
: Tezos_signer_backends_unix.Ledger_names.t :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply pkh Signature.Public_key_hash.to_string)
Ledger_names.crouching_tiger.
Definition curve : Ledgerwallet_tezos.curve := Ledgerwallet_tezos.Ed25519.
Definition get (hidapi : Hidapi.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
op_gtgteqquestion (Ledger_commands.get_public_key None hidapi curve [])
(fun pk =>
let pkh := Signature.Public_key.hash pk in
let animals := animals_of_pkh pkh in
_return (Animals animals)).
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
match function_parameter with
| Animals a => Ledger_names.pp ppf a
| Pkh pkh => Signature.Public_key_hash.pp ppf pkh
end.
Definition to_animals (function_parameter : t)
: Tezos_signer_backends_unix.Ledger_names.t :=
match function_parameter with
| Animals a => a
| Pkh pkh => animals_of_pkh pkh
end.
Definition equal (a : t) (b : t) : bool :=
equiv_decb (to_animals a) (to_animals b).
End Ledger_id.
Module Ledger_account.
Record t := {
ledger : Ledger_id.t;
curve : Ledgerwallet_tezos.curve;
path : list int32 }.
End Ledger_account.
Module Ledger_uri.
Definition t := variant.
Definition int32_of_path_element_exn (allow_weak : bool) (x : string)
: int32 :=
let failf {A B : Type} (ppf : Stdlib.format4 A unit string B) : A :=
Printf.ksprintf Pervasives.failwith ppf in
let len := String.length x in
match String.get x (Z.sub len 1) with
| "'" % char | "h" % char =>
let intpart := String.sub x 0 (Z.sub len 1) in
match Int32.of_string_opt intpart with
| Some i => Bip32_path.hard i
| None =>
failf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Path is not an integer: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Path is not an integer: %S" % string) intpart
end
| _ =>
match Int32.of_string_opt x with
| Some i => i
| None =>
failf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Path is not a non-hardened integer: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Path is not a non-hardened integer: %S" % string) x
end
| _ =>
failf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Non-hardened paths are not allowed for this derivation scheme (" %
string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"Non-hardened paths are not allowed for this derivation scheme (%S)" %
string) x
end.
Definition parse_animals (animals : string)
: option Tezos_signer_backends_unix.Ledger_names.t :=
match String.split "-" % char None None animals with
| cons c (cons t (cons h (cons d []))) =>
Some
{| Ledger_names.c := c; Ledger_names.t := t; Ledger_names.h := h;
Ledger_names.d := d |}
| _ => None
end.
Definition derivation_supports_weak_paths
(function_parameter : Ledgerwallet_tezos.curve) : bool :=
match function_parameter with
| Ledgerwallet_tezos.Ed25519 => false
| Ledgerwallet_tezos.Secp256k1 => true
| Ledgerwallet_tezos.Secp256r1 => true
| Ledgerwallet_tezos.Bip32_ed25519 => true
end.
Definition parse (allow_weak : option bool) (uri : Uri.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
let host := Uri.host uri in
op_gtgteqquestion
match Option.apply Signature.Public_key_hash.of_b58check_opt host with
| Some pkh => _return (Ledger_id.Pkh pkh)
| None =>
match Option.apply parse_animals host with
| Some animals => _return (Ledger_id.Animals animals)
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot parse host of URI: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Cannot parse host of URI: %s" % string) (Uri.to_string uri)
end
end
(fun ledger =>
let components := String.split "/" % char None None (Uri.path uri) in
match components with
| cons s tl =>
let '(curve, more_path) :=
match Ledgerwallet_tezos.curve_of_string s with
| Some curve => (curve, tl)
| None => (Ledger_id.curve, (cons s tl))
end in
let actually_allow_weak :=
match allow_weak with
| None => derivation_supports_weak_paths curve
| Some x => x
end in
op_gtgteqquestion
(* ❌ Try-with are not handled *)
(try
(_return
(List.map (int32_of_path_element_exn actually_allow_weak)
more_path)))
(fun bip32 =>
_return
(* ❌ Variants not supported *)
variant)
| [] =>
_return
(* ❌ Variants not supported *)
variant
end).
Definition ledger_uri_or_alias_param {A C a : Type}
(next :
Tezos_base__TzPervasives.Clic.params A
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
* C))
: Tezos_base__TzPervasives.Clic.params (t -> A)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
* C) :=
let name := "account-alias-or-ledger-uri" % string in
let desc :=
"An imported ledger alias or a ledger URI (e.g. ""ledger://animal/curve/path"")."
% string in
param name desc
(parameter None
(fun cctxt =>
fun str =>
op_gtgteqquestion
(op_gtgteqquestion (Public_key.find_opt cctxt str)
(fun function_parameter =>
match function_parameter with
| Some (_ as x, _) => _return x
| None =>
(* ❌ Try-with are not handled *)
try (_return (Uri.of_string str))
end)) (fun uri => parse None uri))) next.
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
match function_parameter with
| Ledger lid =>
fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "ledger://" % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "ledger://%a" % string)
Ledger_id.pp lid
|
Ledger_account {|
Ledger_account.ledger := ledger;
Ledger_account.curve := curve;
Ledger_account.path := path
|} =>
fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "ledger://" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "/" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "/" % char
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))))
"ledger://%a/%a/%a" % string) Ledger_id.pp ledger
Ledgerwallet_tezos.pp_curve curve Bip32_path.pp_path path
end.
Definition if_matches {A : Type}
(meta_uri : t) (ledger_id : Ledger_id.t)
(cont : unit -> Lwt.t (Tezos_base__TzPervasives.tzresult (option A)))
: Lwt.t (Tezos_base__TzPervasives.tzresult (option A)) :=
match meta_uri with
| Ledger l =>
if Ledger_id.equal l ledger_id then
cont tt
else
return_none
| Ledger_account {| Ledger_account.ledger := ledger |} =>
if Ledger_id.equal ledger ledger_id then
cont tt
else
return_none
end.
Definition full_account (ledger_uri : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Ledger_account.(Base.T.t)) :=
match ledger_uri with
| Ledger_account acc => _return acc
| Ledger ledger_id =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Insufficient information: you need to provide a curve & BIP32 path ("
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ")." % string
CamlinternalFormatBasics.End_of_format)))
"Insufficient information: you need to provide a curve & BIP32 path (%a)."
% string) Ledger_id.pp ledger_id
end.
End Ledger_uri.
Module Filter.
Definition version_filter := (Ledgerwallet_tezos.Version.t * string) -> bool.
Definition t := variant.
Definition version_matches
(t : t) (version_commit : Ledgerwallet_tezos.Version.t * string) : bool :=
match t with
| Version (_, f) => f version_commit
| _ => true
end.
Definition is_app (msg : string) (app : Ledgerwallet_tezos.Version.app_class)
: t :=
(* ❌ Variants not supported *)
variant.
Definition is_baking : t :=
is_app "App = Baking" % string Ledgerwallet_tezos.Version.TezBake.
Definition pp (ppf : Stdlib.Format.formatter) (f : t) : unit :=
match f with
| None =>
fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "None" % string
CamlinternalFormatBasics.End_of_format) "None" % string)
| Hid_path s =>
fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "HID-path: " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "HID-path: %s" % string)
s
| Version (s, _) =>
fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) s
end.
End Filter.
Definition vendor_id : Z := 11415.
Definition product_id_nano_s : Z := 1.
Definition product_id_nano_x : Z := 4.
Definition use_ledger {A : Type} (op_staroptstar : option Filter.t)
: (Hidapi.t ->
(Ledgerwallet_tezos.Version.t * string) ->
Hidapi.device_info ->
Ledger_id.t -> Lwt.t (Tezos_base__TzPervasives.tzresult (option A))) ->
Lwt.t (Tezos_base__TzPervasives.tzresult (option A)) :=
let '_ as filter :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun f =>
let ledgers :=
OCaml.Stdlib.app
(Hidapi.enumerate (Some vendor_id) (Some product_id_nano_s) tt)
(Hidapi.enumerate (Some vendor_id) (Some product_id_nano_x) tt) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
debug
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Found " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal " Ledger(s) " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"Found %d Ledger(s) %s" % string) (List.length ledgers)
(String.concat " -- " % string
(List.map
(fun l =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_x
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 4)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ", " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_x
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 4)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"(%04x, %04x)" % string) (vendor_id l) (product_id l)) ledgers))
in
let process_device {B : Type}
(device_info : Hidapi.device_info) (f :
Hidapi.t ->
(Ledgerwallet_tezos.Version.t * string) ->
Hidapi.device_info ->
Ledger_id.t -> Lwt.t (Tezos_base__TzPervasives.tzresult (option B)))
: Lwt.t (Tezos_base__TzPervasives.tzresult (option B)) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
log_info
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Processing Ledger at path [" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "]" % char
CamlinternalFormatBasics.End_of_format)))
"Processing Ledger at path [%s]" % string) (Hidapi.path device_info)
in
if
orb (equiv_decb (Hidapi.interface_number device_info) 0)
(andb (equiv_decb (Hidapi.interface_number device_info) (-1))
(equiv_decb (Hidapi.usage_page device_info) 65440)) then
match filter with
| Hid_path hp => return_none
| _ =>
match open_path (path device_info) with
| None => return_none
| Some h =>
Lwt.finalize
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Ledger_commands.get_version device_info h)
(fun function_parameter =>
match function_parameter with
| Some version_git =>
op_gtgteqquestion (Ledger_id.get h)
(fun ledger_id => f h version_git device_info ledger_id)
| None | Some _ => return_none
end))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Hidapi.close h in
Lwt.return_unit)
end
end
else
return_none in
let fix go (function_parameter : list Hidapi.device_info)
: Lwt.t (Tezos_base__TzPervasives.tzresult (option A)) :=
match function_parameter with
| [] => return_none
| cons h t =>
op_gtgteqquestion (process_device h f)
(fun function_parameter =>
match function_parameter with
| Some x => return_some x
| None => go t
end)
end in
go ledgers.
Definition min_version_of_derivation_scheme
(function_parameter : Ledgerwallet_tezos.curve) : Z * Z * Z :=
match function_parameter with
| Ledgerwallet_tezos.Ed25519 => (1, 3, 0)
| Ledgerwallet_tezos.Secp256k1 => (1, 3, 0)
| Ledgerwallet_tezos.Secp256r1 => (1, 3, 0)
| Ledgerwallet_tezos.Bip32_ed25519 => (2, 1, 0)
end.
Definition is_derivation_scheme_supported
(version : Ledgerwallet_tezos.Version.t) (curve : Ledgerwallet_tezos.curve)
: bool :=
let '{| major := major; minor := minor; patch := patch |} := version in
OCaml.Stdlib.ge (major, minor, patch) (min_version_of_derivation_scheme curve).
Definition use_ledger_or_fail {A : Type}
(ledger_uri : Ledger_uri.t) (filter : option Filter.t) (msg : option string)
(f :
Hidapi.t ->
(Ledgerwallet_tezos.Version.t * string) ->
Hidapi.device_info ->
Ledger_id.t -> Lwt.t (Tezos_base__TzPervasives.tzresult (option A)))
: Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
op_gtgteqquestion
(use_ledger filter
(fun hidapi =>
fun function_parameter =>
let '(version, git_commit) := function_parameter in
fun device_info =>
fun ledger_id =>
Ledger_uri.if_matches ledger_uri ledger_id
(fun function_parameter =>
let 'tt := function_parameter in
let go (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult (option A)) :=
let 'tt := function_parameter in
f hidapi (version, git_commit) device_info ledger_id in
match ledger_uri with
| Ledger_account {| curve := curve |} =>
if is_derivation_scheme_supported version curve then
go tt
else
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"To use derivation scheme " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" you need " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" or later but you're using " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format)))))))
"To use derivation scheme %a you need %a or later but you're using %a."
% string) pp_curve curve Version.pp
(let '(a, b, c) :=
min_version_of_derivation_scheme curve in
(* ❌ Record substitution not handled *)
record_substitution) Version.pp version
| _ => go tt
end)))
(fun function_parameter =>
match function_parameter with
| Some o => _return o
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"Found no ledger corresponding to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Theta
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))))
"%sFound no ledger corresponding to %a%t." % string)
(Option.unopt_map
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ": " % string
CamlinternalFormatBasics.End_of_format)) "%s: " % string))
"" % string msg) Ledger_uri.pp ledger_uri
(fun ppf =>
match filter with
| Some f =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" with filter """ % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal """" % char
CamlinternalFormatBasics.End_of_format)))
" with filter ""%a""" % string) Filter.pp f
| None => tt
end)
end).
Module Global_cache.
Definition _cache
: Stdlib.Hashtbl.t Tezos_client_base.Client_keys.pk_uri
(Tezos_base__TzPervasives.Signature.Public_key_hash.t *
Tezos_base__TzPervasives.Signature.Public_key.t) :=
Hashtbl.create None 13.
Definition record
(pk_uri : Tezos_client_base.Client_keys.pk_uri)
(pk : Tezos_base__TzPervasives.Signature.Public_key.t)
(pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t) : unit :=
Hashtbl.replace _cache pk_uri (pkh, pk).
Definition get (pk_uri : Tezos_client_base.Client_keys.pk_uri)
: option
(Tezos_base__TzPervasives.Signature.Public_key_hash.t *
Tezos_base__TzPervasives.Signature.Public_key.t) :=
Hashtbl.find_opt _cache pk_uri.
End Global_cache.
Module Signer_implementation.
Definition scheme : string := "ledger" % string.
Definition title : string :=
"Built-in signer using a Ledger Nano device." % string.
Definition description : string :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Valid URIs are of the form
- ledger://<animals>/<curve>[/<path>]
where:
- <animals> is the identifier of the ledger of the form 'crouching-tiger-hidden-dragon' and can be obtained with the command `tezos-client list connected ledgers` (which also provides full examples).
- <curve> is the signing curve, e.g. `ed1551`
- <path> is a BIP32 path anchored at m/"
% string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
". The ledger does not yet support non-hardened paths, so each node of the path must be hardened."
% string CamlinternalFormatBasics.End_of_format)))
"Valid URIs are of the form
- ledger://<animals>/<curve>[/<path>]
where:
- <animals> is the identifier of the ledger of the form 'crouching-tiger-hidden-dragon' and can be obtained with the command `tezos-client list connected ledgers` (which also provides full examples).
- <curve> is the signing curve, e.g. `ed1551`
- <path> is a BIP32 path anchored at m/%s. The ledger does not yet support non-hardened paths, so each node of the path must be hardened."
% string) (string_of_path tezos_root).
Definition neuterize (sk : Tezos_client_base.Client_keys.sk_uri)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_client_base.Client_keys.pk_uri) :=
_return (make_pk_uri sk).
Definition pkh_of_pk
: Tezos_base__TzPervasives.Signature.Public_key.t ->
Tezos_crypto__Signature.Public_key_hash.t := Signature.Public_key.hash.
Definition public_key_maybe_prompt
(first_import : option Tezos_client_base.Client_context.io_wallet)
(pk_uri : Tezos_client_base.Client_keys.pk_uri)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.public_key) :=
match Global_cache.get pk_uri with
| Some (_, pk) => _return pk
| None =>
op_gtgteq
(op_gtgteqquestion (Ledger_uri.parse None pk_uri)
(fun ledger_uri =>
op_gtgteqquestion (Ledger_uri.full_account ledger_uri)
(fun function_parameter =>
let '{| curve := curve; path := path |} := function_parameter in
use_ledger_or_fail ledger_uri None None
(fun hidapi =>
fun function_parameter =>
let '(_version, _git_commit) := function_parameter in
fun _device_info =>
fun _ledger_id =>
op_gtgteqquestion
(Ledger_commands.public_key first_import hidapi
curve path)
(fun pk =>
let pkh := pkh_of_pk pk in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Global_cache.record pk_uri pk pkh in
return_some pk)))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Error err =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
pp_print_error err
| Stdlib.Ok v => _return v
end)
end.
Definition public_key_hash_maybe_prompt
(first_import : option Tezos_client_base.Client_context.io_wallet)
(pk_uri : Tezos_client_base.Client_keys.pk_uri)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Signature.public_key_hash *
(option Tezos_base__TzPervasives.Signature.public_key))) :=
match Global_cache.get pk_uri with
| Some (pkh, pk) => _return (pkh, (Some pk))
| None =>
op_gtgteqquestion (public_key_maybe_prompt first_import pk_uri)
(fun pk => _return ((pkh_of_pk pk), (Some pk)))
end.
Definition public_key
: Tezos_client_base.Client_keys.pk_uri ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.public_key) :=
public_key_maybe_prompt None.
Definition public_key_hash
: Tezos_client_base.Client_keys.pk_uri ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Signature.public_key_hash *
(option Tezos_base__TzPervasives.Signature.public_key))) :=
public_key_hash_maybe_prompt None.
Definition import_secret_key
(io : Tezos_client_base.Client_context.io_wallet)
(pk_uri : Tezos_client_base.Client_keys.pk_uri)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Signature.public_key_hash *
(option Tezos_base__TzPervasives.Signature.public_key))) :=
public_key_hash_maybe_prompt (Some io) pk_uri.
Definition sign
(watermark : option Tezos_base__TzPervasives.Signature.watermark)
(sk_uri : Tezos_client_base.Client_keys.sk_uri) (msg : Stdlib.Bytes.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
op_gtgteqquestion (Ledger_uri.parse None sk_uri)
(fun ledger_uri =>
op_gtgteqquestion (Ledger_uri.full_account ledger_uri)
(fun function_parameter =>
let '{| curve := curve; path := path |} := function_parameter in
use_ledger_or_fail ledger_uri None None
(fun hidapi =>
fun function_parameter =>
let '(version, _git_commit) := function_parameter in
fun _device_info =>
fun _ledger_id =>
op_gtgteqquestion
(Ledger_commands.sign watermark version hidapi curve
path msg) (fun bytes => return_some string)))).
Definition deterministic_nonce
(sk_uri : Tezos_client_base.Client_keys.sk_uri) (msg : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
op_gtgteqquestion (Ledger_uri.parse None sk_uri)
(fun ledger_uri =>
op_gtgteqquestion (Ledger_uri.full_account ledger_uri)
(fun function_parameter =>
let '{| curve := curve; path := path |} := function_parameter in
use_ledger_or_fail ledger_uri None None
(fun hidapi =>
fun function_parameter =>
let '(_version, _git_commit) := function_parameter in
fun _device_info =>
fun _ledger_id =>
op_gtgteqquestion
(Ledger_commands.get_deterministic_nonce hidapi curve
path msg) (fun bytes => return_some string)))).
Definition deterministic_nonce_hash
(sk : Tezos_client_base.Client_keys.sk_uri) (msg : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
op_gtgteqquestion (deterministic_nonce sk msg)
(fun nonce =>
_return
(Blake2B.to_bytes
(Blake2B.hash_bytes None (cons (Bigstring.to_bytes nonce) [])))).
Definition supports_deterministic_nonces {A : Type} (function_parameter : A)
: Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
let '_ := function_parameter in
return_true.
End Signer_implementation.
Definition pp_ledger_chain_id (fmt : Stdlib.Format.formatter) (s : string)
: unit :=
match s with
| " " % string =>
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "'Unspecified'" % string
CamlinternalFormatBasics.End_of_format) "'Unspecified'" % string)
| other =>
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) Chain_id.pp (Chain_id.of_string_exn other)
end.
Definition generic_commands (group : Tezos_base__TzPervasives.Clic.group)
: list
(Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
cons
(command (Some group)
"List supported Ledger Nano devices connected." % string no_options
(fixed
(cons "list" % string
(cons "connected" % string (cons "ledgers" % string []))))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion
(use_ledger None
(fun _hidapi =>
fun function_parameter =>
let '(version, git_commit) := function_parameter in
fun device_info =>
fun ledger_id =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Theta
CamlinternalFormatBasics.End_of_format)
"%t" % string)
(fun ppf =>
let intro :=
asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Found a " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (git-description: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
") application running on " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
" " % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" at [" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"]." % string
CamlinternalFormatBasics.End_of_format)))))))))))
"Found a %a (git-description: %S) application running on %s %s at [%s]."
% string) Ledgerwallet_tezos.Version.pp
version git_commit
(OCaml.Stdlib.reverse_apply
(manufacturer_string device_info)
(Option.unopt "NO-MANUFACTURER" % string))
(OCaml.Stdlib.reverse_apply
(product_string device_info)
(Option.unopt "NO-PRODUCT" % string))
(path device_info) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_open_vbox ppf 0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"## Ledger `" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"`" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
CamlinternalFormatBasics.End_of_format))))
"## Ledger `%a`@," % string) Ledger_id.pp
ledger_id in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_open_hovbox ppf 0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_print_text ppf intro in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_close_box ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_print_cut ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_print_cut ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_open_hovbox ppf 0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
pp_print_text ppf
"To use keys at BIP32 path m/44'/1729'/0'/0' (default Tezos key path), use one of:"
% string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_close_box ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_print_cut ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun curve =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" tezos-client import secret key ledger_"
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" ""ledger://" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"/" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"/0h/0h""" % string
CamlinternalFormatBasics.End_of_format)))))))
" tezos-client import secret key ledger_%s ""ledger://%a/%a/0h/0h"""
% string)
(OCaml.Stdlib.reverse_apply
(Sys.getenv_opt "USER" % string)
(Option.unopt "user" % string))
Ledger_id.pp ledger_id
Ledgerwallet_tezos.pp_curve curve in
pp_print_cut ppf tt)
(List.filter
(is_derivation_scheme_supported version)
(cons Ledgerwallet_tezos.Bip32_ed25519
(cons Ledgerwallet_tezos.Ed25519
(cons Ledgerwallet_tezos.Secp256k1
(cons Ledgerwallet_tezos.Secp256r1 [])))))
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_close_box ppf tt in
pp_print_newline ppf tt))
(fun function_parameter =>
let 'tt := function_parameter in
return_none)))
(fun function_parameter =>
let '_ := function_parameter in
return_unit)))
(cons
(Clic.command (Some group)
"Display version/public-key/address information for a Ledger URI" %
string
(args1
(switch "Test signing operation" % string None "test-sign" % string tt))
(apply (prefixes (cons "show" % string (cons "ledger" % string [])))
(apply Ledger_uri.ledger_uri_or_alias_param stop))
(fun test_sign =>
fun ledger_uri =>
fun cctxt =>
use_ledger_or_fail ledger_uri None None
(fun hidapi =>
fun function_parameter =>
let '(version, git_commit) := function_parameter in
fun device_info =>
fun _ledger_id =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Found ledger corresponding to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
":" % char
CamlinternalFormatBasics.End_of_format)))
"Found ledger corresponding to %a:" % string)
Ledger_uri.pp ledger_uri)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"* Manufacturer: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"* Manufacturer: %s" % string)
(Option.unopt "NONE" % string
(manufacturer_string device_info)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"* Product: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"* Product: %s" % string)
(Option.unopt "NONE" % string
(product_string device_info)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"* Application: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (git-description: " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))))
"* Application: %a (git-description: %S)"
% string)
Ledgerwallet_tezos.Version.pp version
git_commit)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
match ledger_uri with
|
Ledger_account {|
curve := curve;
path := path
|} =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"* Curve: `" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"`" % char
CamlinternalFormatBasics.End_of_format)))
"* Curve: `%a`" % string)
Ledgerwallet_tezos.pp_curve
curve)
(fun function_parameter =>
let 'tt := function_parameter in
let full_path :=
OCaml.Stdlib.app
Bip32_path.tezos_root path
in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"* Path: `" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"` [" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"]" % char
CamlinternalFormatBasics.End_of_format)))))
"* Path: `%s` [%s]" %
string)
(Bip32_path.string_of_path
full_path)
(String.concat "; " % string
(List.map
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"0x" % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_X
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"0x%lX" % string))
full_path)))
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteqquestion
(Ledger_commands.public_key_hash
None hidapi curve path)
(fun function_parameter =>
let '(pkh, pk) :=
function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"* Public Key: "
% string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"* Public Key: %a"
% string)
Signature.Public_key.pp
pk)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"* Public Key Hash: "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
CamlinternalFormatBasics.End_of_format)))
"* Public Key Hash: %a@
"
% string)
Signature.Public_key_hash.pp
pkh)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
match
(test_sign,
(app_class
version))
with
|
(true,
Ledgerwallet_tezos.Version.Tezos)
=>
let
pkh_bytes :=
Signature.Public_key_hash.to_bytes
pkh in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
""
%
string))
(CamlinternalFormatBasics.String_literal
"Attempting a signature"
%
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ "
%
string
1
0)
(CamlinternalFormatBasics.String_literal
"(of `"
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"`),"
%
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ "
%
string
1
0)
(CamlinternalFormatBasics.String_literal
"please"
%
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ "
%
string
1
0)
(CamlinternalFormatBasics.String_literal
"validate on"
%
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ "
%
string
1
0)
(CamlinternalFormatBasics.String_literal
"the ledger."
%
string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))
"@[Attempting a signature@ (of `%a`),@ please@ validate on@ the ledger.@]"
%
string)
Hex.pp
(Hex.of_bytes
None
pkh_bytes))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteqquestion
(Ledger_commands.sign
(Some
Tezos_base__TzPervasives.Signature.Generic_operation)
version
hidapi
curve
path
pkh_bytes)
(fun
signature
=>
match
Signature.check
(Some
Tezos_base__TzPervasives.Signature.Generic_operation)
pk
signature
pkh_bytes
with
|
false
=>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Fatal: Ledger cannot sign with "
%
string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Fatal: Ledger cannot sign with %a"
%
string)
Signature.Public_key_hash.pp
pkh
| true
=>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Tezos Wallet successfully signed:"
%
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ "
%
string
1
0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"."
%
char
CamlinternalFormatBasics.End_of_format))))
"Tezos Wallet successfully signed:@ %a."
%
string)
Signature.pp
signature)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
return_unit)
end))
|
(true,
Ledgerwallet_tezos.Version.TezBake)
=>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Option --test-sign only works for the Tezos Wallet app."
%
string
CamlinternalFormatBasics.End_of_format)
"Option --test-sign only works for the Tezos Wallet app."
% string)
| (false, _) =>
return_unit
end)))))
| Ledger _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Option --test-sign only works with a full ledger URI/account (with curve/path)."
% string
CamlinternalFormatBasics.End_of_format)
"Option --test-sign only works with a full ledger URI/account (with curve/path)."
% string)
| Ledger _ =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"* This is just a ledger URI."
% string
CamlinternalFormatBasics.End_of_format)
"* This is just a ledger URI."
% string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end
(fun function_parameter =>
let 'tt := function_parameter in
return_some tt)))))))) []).
Definition baking_commands (group : Tezos_base__TzPervasives.Clic.group)
: list
(Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
cons
(Clic.command (Some group) "Query the path of the authorized key" % string
no_options
(apply
(prefixes
(cons "get" % string
(cons "ledger" % string
(cons "authorized" % string
(cons "path" % string (cons "for" % string []))))))
(apply Ledger_uri.ledger_uri_or_alias_param stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun ledger_uri =>
fun cctxt =>
use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
(fun hidapi =>
fun function_parameter =>
let '(version, _git_commit) := function_parameter in
fun _device_info =>
fun _ledger_id =>
op_gtgteqquestion
(Ledger_commands.get_authorized_path hidapi version)
(fun authorized =>
match authorized with
| Legacy_path p =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Authorized baking path (Legacy < 2.x.y): "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))
"@[<v 0>Authorized baking path (Legacy < 2.x.y): %a@]"
% string) Bip32_path.pp_path p)
(fun function_parameter =>
let 'tt := function_parameter in
return_some tt)
| No_baking_authorized =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No baking key authorized at all." % string
CamlinternalFormatBasics.End_of_format)
"No baking key authorized at all." % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_some tt)
| Path_curve (ledger_path, ledger_curve) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Authorized baking path: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))
"@[<v 0>Authorized baking path: %a@]" % string)
Bip32_path.pp_path ledger_path)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Authorized baking curve: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))
"@[<v 0>Authorized baking curve: %a@]" %
string) Ledgerwallet_tezos.pp_curve
ledger_curve)
(fun function_parameter =>
let 'tt := function_parameter in
match ledger_uri with
| Ledger _ => return_some tt
|
Ledger_account {|
curve := curve; path := path |} =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Authorized baking URI: " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))
"@[<v 0>Authorized baking URI: %a@]"
% string) Ledger_uri.pp ledger_uri)
(fun function_parameter =>
let 'tt := function_parameter in
return_some tt)
|
Ledger_account {|
curve := curve; path := path |} =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Path and curve do not match the ones specified in the command line: "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" & " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Path and curve do not match the ones specified in the command line: %a & %a"
% string)
Ledgerwallet_tezos.pp_curve curve
Bip32_path.pp_path
(OCaml.Stdlib.app Bip32_path.tezos_root
path)
end))
end))))
(cons
(Clic.command (Some group)
"Authorize a Ledger to bake for a key (deprecated, use `setup ledger ...` with recent versions of the Baking app)"
% string no_options
(apply
(prefixes
(cons "authorize" % string
(cons "ledger" % string
(cons "to" % string
(cons "bake" % string (cons "for" % string []))))))
(apply Ledger_uri.ledger_uri_or_alias_param stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun ledger_uri =>
fun cctxt =>
use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
(fun hidapi =>
fun function_parameter =>
let '(version, _git_commit) := function_parameter in
fun _device_info =>
fun _ledger_id =>
op_gtgteqquestion
match version with
| {|
Ledgerwallet_tezos.Version.app_class := Ledgerwallet_tezos.Version.Tezos
|} =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This command (`authorize ledger ...`) only works with the Tezos Baking app"
% string
CamlinternalFormatBasics.End_of_format)
"This command (`authorize ledger ...`) only works with the Tezos Baking app"
% string)
| {|
Ledgerwallet_tezos.Version.app_class := Ledgerwallet_tezos.Version.TezBake;
Ledgerwallet_tezos.Version.major := major
|} =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This command (`authorize ledger ...`) is" %
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"not compatible with" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"this version of the Ledger" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"Baking app (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" >= 2.0.0)," % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"please use the command" %
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"`setup ledger to bake for ...`"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"from now on." %
string
CamlinternalFormatBasics.End_of_format)))))))))))))))
"This command (`authorize ledger ...`) is@ not compatible with@ this version of the Ledger@ Baking app (%a >= 2.0.0),@ please use the command@ `setup ledger to bake for ...`@ from now on."
% string) Ledgerwallet_tezos.Version.pp
version
| _ =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This Ledger Baking app is outdated (" %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"running" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"in backwards" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"compatibility mode." %
string
CamlinternalFormatBasics.End_of_format)))))))))
"This Ledger Baking app is outdated (%a)@ running@ in backwards@ compatibility mode."
% string) Ledgerwallet_tezos.Version.pp
version)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Ledger_uri.full_account ledger_uri)
(fun function_parameter =>
let '{|
Ledger_account.curve := curve;
Ledger_account.path := path
|} := function_parameter in
op_gtgteqquestion
(Ledger_commands.public_key_returning_instruction
(* ❌ Variants not supported *)
variant None hidapi curve path)
(fun pk =>
let pkh := Signature.Public_key.hash pk in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Authorized baking for address: "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Corresponding full public key: "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 0>Authorized baking for address: %a@,Corresponding full public key: %a@]"
% string)
Signature.Public_key_hash.pp pkh
Signature.Public_key.pp pk)
(fun function_parameter =>
let 'tt := function_parameter in
return_some tt)))))))
(cons
(Clic.command (Some group) "Setup a Ledger to bake for a key" % string
(let hwm_arg {A : Type} (kind : string)
: Tezos_base__TzPervasives.Clic.arg (option int32) A :=
let doc :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Use <HWM> as " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" chain high watermark instead of asking the ledger." %
string CamlinternalFormatBasics.End_of_format)))
"Use <HWM> as %s chain high watermark instead of asking the ledger."
% string) kind in
let long := String.append kind "-hwm" % string in
default_arg doc None long "HWM" % string "ASK-LEDGER" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
match function_parameter with
| "ASK-LEDGER" % string => return_none
| s =>
(* ❌ Try-with are not handled *)
try (return_some (Int32.of_string s))
end)) in
args3
(default_arg
"Use <ID> as main chain-id instead of asking the node." % string
None "main-chain-id" % string "ID" % string "ASK-NODE" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
match function_parameter with
| "ASK-NODE" % string =>
_return
(* ❌ Variants not supported *)
variant
| s =>
(* ❌ Try-with are not handled *)
try
(_return
(* ❌ Variants not supported *)
variant)
end))) (hwm_arg "main" % string) (hwm_arg "test" % string))
(apply
(prefixes
(cons "setup" % string
(cons "ledger" % string
(cons "to" % string
(cons "bake" % string (cons "for" % string []))))))
(apply Ledger_uri.ledger_uri_or_alias_param stop))
(fun function_parameter =>
let '(chain_id_opt, main_hwm_opt, test_hwm_opt) :=
function_parameter in
fun ledger_uri =>
fun cctxt =>
use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
(fun hidapi =>
fun function_parameter =>
let '(version, _git_commit) := function_parameter in
fun _device_info =>
fun _ledger_id =>
op_gtgteqquestion
match version with
| {|
app_class := Ledgerwallet_tezos.Version.Tezos
|} =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This command (`setup ledger ...`) only works with the Tezos Baking app"
% string
CamlinternalFormatBasics.End_of_format)
"This command (`setup ledger ...`) only works with the Tezos Baking app"
% string)
| {|
app_class := Ledgerwallet_tezos.Version.TezBake;
major := major
|} =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This command (`setup ledger ...`)" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"is not" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"compatible" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"with this version" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"of the Ledger Baking app" %
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Char_literal
"(" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" < 2.0.0)," %
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1
0)
(CamlinternalFormatBasics.String_literal
"please upgrade"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " %
string 1 0)
(CamlinternalFormatBasics.String_literal
"your ledger"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " %
string
1 0)
(CamlinternalFormatBasics.String_literal
"or use the command"
%
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ "
%
string
1 0)
(CamlinternalFormatBasics.String_literal
"`authorize ledger to bake for ...`"
%
string
CamlinternalFormatBasics.End_of_format)))))))))))))))))))))
"This command (`setup ledger ...`)@ is not@ compatible@ with this version@ of the Ledger Baking app@ (%a < 2.0.0),@ please upgrade@ your ledger@ or use the command@ `authorize ledger to bake for ...`"
% string) pp version
| _ => return_unit
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Ledger_uri.full_account ledger_uri)
(fun function_parameter =>
let '{|
Ledger_account.curve := curve;
Ledger_account.path := path
|} := function_parameter in
let chain_id_of_int32 (i32 : int32)
: Tezos_base__TzPervasives.Chain_id.t :=
let byte (n : Z) : ascii :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(logand
(* ❌ Constant of type int32 is converted to int *)
255 (shift_right i32 (Z.mul n 8)))
Int32.to_int) OCaml.Stdlib.char_of_int
in
Chain_id.of_string_exn
(Stringext.of_array
(Array.init 4
(fun i => byte (Z.sub 3 i)))) in
op_gtgteqquestion
match chain_id_opt with
| Ask_node =>
Chain_services.chain_id cctxt None tt
| Int32 s => _return (chain_id_of_int32 s)
| Chain_id chid => _return chid
end
(fun main_chain_id =>
op_gtgteqquestion
(Ledger_commands.wrap_ledger_cmd
(fun pp =>
Ledgerwallet_tezos.get_all_high_watermarks
(Some pp) None hidapi))
(fun function_parameter =>
let
'(Main_hwm current_mh,
Test_hwm current_th,
Chain_id current_ci) :=
function_parameter in
let main_hwm :=
Option.unopt current_mh main_hwm_opt
in
let test_hwm :=
Option.unopt current_th test_hwm_opt
in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Setting up the ledger:" %
string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
"* Main chain ID: " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" -> " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
"* Main chain High Watermark: "
% string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" -> " %
string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.String_literal
"* Test chain High Watermark: "
%
string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" -> "
%
string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))))))))))))))))
"Setting up the ledger:@.* Main chain ID: %a -> %a@.* Main chain High Watermark: %ld -> %ld@.* Test chain High Watermark: %ld -> %ld"
% string) pp_ledger_chain_id
current_ci Chain_id.pp
main_chain_id current_mh main_hwm
current_th test_hwm)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Ledger_commands.public_key_returning_instruction
(* ❌ Variants not supported *)
variant None hidapi curve path)
(fun pk =>
let pkh :=
Signature.Public_key.hash pk
in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Authorized baking for address: "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string
0 0)
(CamlinternalFormatBasics.String_literal
"Corresponding full public key: "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 0>Authorized baking for address: %a@,Corresponding full public key: %a@]"
% string)
Signature.Public_key_hash.pp
pkh
Signature.Public_key.pp pk)
(fun function_parameter =>
let 'tt :=
function_parameter in
return_some tt))))))))))
(cons
(Clic.command (Some group) "Deauthorize Ledger from baking" % string
no_options
(apply
(prefixes
(cons "deauthorize" % string
(cons "ledger" % string
(cons "baking" % string (cons "for" % string [])))))
(apply Ledger_uri.ledger_uri_or_alias_param stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun ledger_uri =>
fun _cctxt =>
use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
(fun hidapi =>
fun function_parameter =>
let '(_version, _git_commit) := function_parameter in
fun _device_info =>
fun _ledger_id =>
op_gtgteqquestion
(Ledger_commands.wrap_ledger_cmd
(fun pp =>
Ledgerwallet_tezos.deauthorize_baking
(Some pp) None hidapi))
(fun function_parameter =>
let 'tt := function_parameter in
return_some tt)))) []))).
Definition high_water_mark_commands
(group : Tezos_base__TzPervasives.Clic.group)
(watermark_spelling : list string)
: list
(Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
let make_desc (desc : string) : string :=
if equiv_decb (List.length watermark_spelling) 1 then
String.append desc " (legacy/deprecated spelling)" % string
else
desc in
cons
(Clic.command (Some group)
(make_desc "Get high water mark of a Ledger" % string)
(args1
(switch
"Prevent the fallback to the (deprecated) Ledger instructions (for 1.x.y versions of the Baking app)"
% string None "no-legacy-instructions" % string tt))
(apply
(prefixes
(OCaml.Stdlib.app
(cons "get" % string
(cons "ledger" % string (cons "high" % string [])))
(OCaml.Stdlib.app watermark_spelling (cons "for" % string []))))
(apply Ledger_uri.ledger_uri_or_alias_param stop))
(fun no_legacy_apdu =>
fun ledger_uri =>
fun cctxt =>
use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
(fun hidapi =>
fun function_parameter =>
let '(version, _git_commit) := function_parameter in
fun _device_info =>
fun _ledger_id =>
match app_class version with
| Ledgerwallet_tezos.Version.Tezos =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Fatal: this operation is only valid with the Tezos Baking application"
% string CamlinternalFormatBasics.End_of_format)
"Fatal: this operation is only valid with the Tezos Baking application"
% string)
| Ledgerwallet_tezos.Version.TezBake =>
op_gtgteqquestion
(Ledger_commands.wrap_ledger_cmd
(fun pp =>
Ledgerwallet_tezos.get_high_watermark (Some pp)
None hidapi))
(fun hwm =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The high water mark for" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"is " % string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format)))))))
"The high water mark for@ %a@ is %ld." %
string) Ledger_uri.pp ledger_uri hwm)
(fun function_parameter =>
let 'tt := function_parameter in
return_some tt))
| Ledgerwallet_tezos.Version.TezBake =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot get the high water mark with" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1
0)
(CamlinternalFormatBasics.String_literal
"`--no-legacy-instructions` and version " %
string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Cannot get the high water mark with@ `--no-legacy-instructions` and version %a"
% string) Ledgerwallet_tezos.Version.pp version
| Ledgerwallet_tezos.Version.TezBake =>
op_gtgteqquestion
(Ledger_commands.wrap_ledger_cmd
(fun pp =>
Ledgerwallet_tezos.get_all_high_watermarks
(Some pp) None hidapi))
(fun function_parameter =>
let '(Main_hwm mh, Test_hwm th, Chain_id ci) :=
function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The high water mark values for" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"are" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" for the main-chain" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Char_literal
"(" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"and" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string
1 0)
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" for the test-chain."
% string
CamlinternalFormatBasics.End_of_format)))))))))))))))))
"The high water mark values for@ %a@ are@ %ld for the main-chain@ (%a)@ and@ %ld for the test-chain."
% string) Ledger_uri.pp ledger_uri mh
pp_ledger_chain_id ci th)
(fun function_parameter =>
let 'tt := function_parameter in
return_some tt))
end)))
(cons
(Clic.command (Some group)
(make_desc "Set high water mark of a Ledger" % string) no_options
(apply
(prefixes
(OCaml.Stdlib.app
(cons "set" % string
(cons "ledger" % string (cons "high" % string [])))
(OCaml.Stdlib.app watermark_spelling (cons "for" % string []))))
(apply Ledger_uri.ledger_uri_or_alias_param
(apply (prefix "to" % string)
(apply
(param "high watermark" % string "High watermark" % string
(parameter None
(fun _ctx =>
fun s =>
(* ❌ Try-with are not handled *)
try (_return (Int32.of_string s))))) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun ledger_uri =>
fun hwm =>
fun cctxt =>
use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
(fun hidapi =>
fun function_parameter =>
let '(version, _git_commit) := function_parameter in
fun _device_info =>
fun _ledger_id =>
match app_class version with
| Ledgerwallet_tezos.Version.Tezos =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Fatal: this operation is only valid with TezBake"
% string
CamlinternalFormatBasics.End_of_format)
"Fatal: this operation is only valid with TezBake"
% string)
| Ledgerwallet_tezos.Version.TezBake =>
op_gtgteqquestion
(Ledger_commands.wrap_ledger_cmd
(fun pp =>
Ledgerwallet_tezos.set_high_watermark
(Some pp) None hidapi hwm))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Ledger_commands.wrap_ledger_cmd
(fun pp =>
Ledgerwallet_tezos.get_high_watermark
(Some pp) None hidapi))
(fun new_hwm =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" has now high water mark: " %
string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 0>%a has now high water mark: %ld@]"
% string) Ledger_uri.pp ledger_uri
new_hwm)
(fun function_parameter =>
let 'tt := function_parameter in
return_some tt)))
end))) []).
Definition commands
: unit ->
list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full) :=
let group :=
{| Clic.name := "ledger" % string;
Clic.title :=
"Commands for managing the connected Ledger Nano devices" % string |} in
fun function_parameter =>
let 'tt := function_parameter in
OCaml.Stdlib.app (generic_commands group)
(OCaml.Stdlib.app (baking_commands group)
(OCaml.Stdlib.app
(high_water_mark_commands group
(cons "water" % string (cons "mark" % string [])))
(high_water_mark_commands group (cons "watermark" % string [])))).
src/lib_signer_backends/unix/ledger_names.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let adjectives =
[| "abandoned";
"able";
"absolute";
"adorable";
"adventurous";
"academic";
"acceptable";
"acclaimed";
"accomplished";
"accurate";
"aching";
"acidic";
"acrobatic";
"active";
"actual";
"adept";
"admirable";
"admired";
"adolescent";
"adorable";
"adored";
"advanced";
"afraid";
"affectionate";
"aged";
"aggravating";
"aggressive";
"agile";
"agitated";
"agonizing";
"agreeable";
"ajar";
"alarmed";
"alarming";
"alert";
"alienated";
"alive";
"all";
"altruistic";
"amazing";
"ambitious";
"ample";
"amused";
"amusing";
"anchored";
"ancient";
"angelic";
"angry";
"anguished";
"animated";
"annual";
"another";
"antique";
"anxious";
"any";
"apprehensive";
"appropriate";
"apt";
"arctic";
"arid";
"aromatic";
"artistic";
"ashamed";
"assured";
"astonishing";
"athletic";
"attached";
"attentive";
"attractive";
"austere";
"authentic";
"authorized";
"automatic";
"avaricious";
"average";
"aware";
"awesome";
"awful";
"awkward";
"babyish";
"bad";
"back";
"baggy";
"bare";
"barren";
"basic";
"beautiful";
"belated";
"beloved";
"beneficial";
"better";
"best";
"bewitched";
"big";
"biodegradable";
"bitter";
"black";
"bland";
"blank";
"blaring";
"bleak";
"blind";
"blissful";
"blond";
"blue";
"blushing";
"bogus";
"boiling";
"bold";
"bony";
"boring";
"bossy";
"both";
"bouncy";
"bountiful";
"bowed";
"brave";
"breakable";
"brief";
"bright";
"brilliant";
"brisk";
"broken";
"bronze";
"brown";
"bruised";
"bubbly";
"bulky";
"bumpy";
"buoyant";
"burdensome";
"burly";
"bustling";
"busy";
"buttery";
"buzzing";
"calculating";
"calm";
"candid";
"canine";
"capital";
"carefree";
"careful";
"careless";
"caring";
"cautious";
"cavernous";
"celebrated";
"charming";
"cheap";
"cheerful";
"cheery";
"chief";
"chilly";
"chubby";
"circular";
"classic";
"clean";
"clear";
"clever";
"close";
"closed";
"cloudy";
"clueless";
"clumsy";
"cluttered";
"coarse";
"cold";
"colorful";
"colorless";
"colossal";
"comfortable";
"common";
"compassionate";
"competent";
"complete";
"complex";
"complicated";
"composed";
"concerned";
"concrete";
"confused";
"conscious";
"considerate";
"constant";
"content";
"conventional";
"cooked";
"cool";
"cooperative";
"coordinated";
"corny";
"corrupt";
"costly";
"courageous";
"courteous";
"crafty";
"crazy";
"creamy";
"creative";
"creepy";
"criminal";
"crisp";
"critical";
"crooked";
"crowded";
"cruel";
"crushing";
"cuddly";
"cultivated";
"cultured";
"cumbersome";
"curly";
"curvy";
"cute";
"cylindrical";
"damaged";
"damp";
"dangerous";
"dapper";
"daring";
"darling";
"dark";
"dazzling";
"dead";
"deadly";
"deafening";
"dear";
"dearest";
"decent";
"decimal";
"decisive";
"deep";
"defenseless";
"defensive";
"defiant";
"deficient";
"definite";
"definitive";
"delayed";
"delectable";
"delicious";
"delightful";
"delirious";
"demanding";
"dense";
"dental";
"dependable";
"dependent";
"descriptive";
"deserted";
"detailed";
"determined";
"devoted";
"different";
"difficult";
"digital";
"diligent";
"dim";
"dimpled";
"dimwitted";
"direct";
"disastrous";
"discrete";
"disfigured";
"disgusting";
"disloyal";
"dismal";
"distant";
"downright";
"dreary";
"dirty";
"disguised";
"dishonest";
"dismal";
"distant";
"distinct";
"distorted";
"dizzy";
"dopey";
"doting";
"double";
"downright";
"drab";
"drafty";
"dramatic";
"dreary";
"droopy";
"dry";
"dual";
"dull";
"dutiful";
"eager";
"earnest";
"early";
"easy";
"ecstatic";
"edible";
"educated";
"elaborate";
"elastic";
"elated";
"elderly";
"electric";
"elegant";
"elementary";
"elliptical";
"embarrassed";
"embellished";
"eminent";
"emotional";
"empty";
"enchanted";
"enchanting";
"energetic";
"enlightened";
"enormous";
"enraged";
"entire";
"envious";
"equal";
"equatorial";
"essential";
"esteemed";
"ethical";
"euphoric";
"even";
"evergreen";
"everlasting";
"every";
"evil";
"exalted";
"excellent";
"exemplary";
"exhausted";
"excitable";
"excited";
"exciting";
"exotic";
"expensive";
"experienced";
"expert";
"extraneous";
"extroverted";
"fabulous";
"failing";
"faint";
"fair";
"faithful";
"fake";
"false";
"familiar";
"famous";
"fancy";
"fantastic";
"far";
"faraway";
"fast";
"fat";
"fatal";
"fatherly";
"favorable";
"favorite";
"fearful";
"fearless";
"feisty";
"feline";
"female";
"feminine";
"few";
"fickle";
"filthy";
"fine";
"finished";
"firm";
"first";
"firsthand";
"fitting";
"fixed";
"flaky";
"flamboyant";
"flashy";
"flat";
"flawed";
"flawless";
"flickering";
"flimsy";
"flippant";
"flowery";
"fluffy";
"fluid";
"flustered";
"focused";
"fond";
"foolhardy";
"foolish";
"forceful";
"forked";
"formal";
"forsaken";
"forthright";
"fortunate";
"fragrant";
"frail";
"frank";
"frayed";
"free";
"french";
"fresh";
"frequent";
"friendly";
"frightened";
"frightening";
"frigid";
"frilly";
"frizzy";
"frivolous";
"front";
"frosty";
"frozen";
"frugal";
"fruitful";
"full";
"fumbling";
"functional";
"funny";
"fussy";
"fuzzy";
"gargantuan";
"gaseous";
"general";
"generous";
"gentle";
"genuine";
"giant";
"giddy";
"gigantic";
"gifted";
"giving";
"glamorous";
"glaring";
"glass";
"gleaming";
"gleeful";
"glistening";
"glittering";
"gloomy";
"glorious";
"glossy";
"glum";
"golden";
"good";
"gorgeous";
"graceful";
"gracious";
"grand";
"grandiose";
"granular";
"grateful";
"grave";
"gray";
"great";
"greedy";
"green";
"gregarious";
"grim";
"grimy";
"gripping";
"grizzled";
"gross";
"grotesque";
"grouchy";
"grounded";
"growing";
"growling";
"grown";
"grubby";
"gruesome";
"grumpy";
"guilty";
"gullible";
"gummy";
"hairy";
"half";
"handmade";
"handsome";
"handy";
"happy";
"hard";
"harmful";
"harmless";
"harmonious";
"harsh";
"hasty";
"hateful";
"haunting";
"healthy";
"heartfelt";
"hearty";
"heavenly";
"heavy";
"hefty";
"helpful";
"helpless";
"hidden";
"hideous";
"high";
"hilarious";
"hoarse";
"hollow";
"homely";
"honest";
"honorable";
"honored";
"hopeful";
"horrible";
"hospitable";
"hot";
"huge";
"humble";
"humiliating";
"humming";
"humongous";
"hungry";
"hurtful";
"husky";
"icky";
"icy";
"ideal";
"idealistic";
"identical";
"idle";
"idiotic";
"idolized";
"ignorant";
"ill";
"illegal";
"illiterate";
"illustrious";
"imaginary";
"imaginative";
"immaculate";
"immaterial";
"immediate";
"immense";
"impassioned";
"impeccable";
"impartial";
"imperfect";
"imperturbable";
"impish";
"impolite";
"important";
"impossible";
"impractical";
"impressionable";
"impressive";
"improbable";
"impure";
"inborn";
"incomparable";
"incompatible";
"incomplete";
"inconsequential";
"incredible";
"indelible";
"inexperienced";
"indolent";
"infamous";
"infantile";
"infatuated";
"inferior";
"infinite";
"informal";
"innocent";
"insecure";
"insidious";
"insignificant";
"insistent";
"instructive";
"insubstantial";
"intelligent";
"intent";
"intentional";
"interesting";
"internal";
"international";
"intrepid";
"ironclad";
"irresponsible";
"irritating";
"itchy";
"jaded";
"jagged";
"jaunty";
"jealous";
"jittery";
"joint";
"jolly";
"jovial";
"joyful";
"joyous";
"jubilant";
"judicious";
"juicy";
"jumbo";
"junior";
"jumpy";
"juvenile";
"kaleidoscopic";
"keen";
"key";
"kind";
"kindhearted";
"kindly";
"klutzy";
"knobby";
"knotty";
"knowledgeable";
"knowing";
"known";
"kooky";
"lame";
"lanky";
"large";
"last";
"lasting";
"late";
"lavish";
"lawful";
"lazy";
"leading";
"lean";
"leafy";
"left";
"legal";
"legitimate";
"light";
"lighthearted";
"likable";
"likely";
"limited";
"limp";
"limping";
"linear";
"lined";
"liquid";
"little";
"live";
"lively";
"livid";
"loathsome";
"lone";
"lonely";
"long";
"loose";
"lopsided";
"lost";
"loud";
"lovable";
"lovely";
"loving";
"low";
"loyal";
"lucky";
"lumbering";
"luminous";
"lumpy";
"lustrous";
"luxurious";
"mad";
"magnificent";
"majestic";
"major";
"male";
"mammoth";
"married";
"marvelous";
"masculine";
"massive";
"mature";
"meager";
"mealy";
"mean";
"measly";
"meaty";
"medical";
"mediocre";
"medium";
"meek";
"mellow";
"melodic";
"memorable";
"menacing";
"merry";
"messy";
"metallic";
"mild";
"milky";
"mindless";
"miniature";
"minor";
"minty";
"miserable";
"miserly";
"misguided";
"misty";
"mixed";
"modern";
"modest";
"moist";
"monstrous";
"monthly";
"monumental";
"moral";
"mortified";
"motherly";
"motionless";
"mountainous";
"muddy";
"muffled";
"multicolored";
"mundane";
"murky";
"mushy";
"musty";
"muted";
"mysterious";
"naive";
"narrow";
"nasty";
"natural";
"naughty";
"nautical";
"near";
"neat";
"necessary";
"needy";
"negative";
"neglected";
"negligible";
"neighboring";
"nervous";
"new";
"nice";
"nifty";
"nimble";
"nippy";
"nocturnal";
"noisy";
"nonstop";
"normal";
"notable";
"noted";
"noteworthy";
"novel";
"noxious";
"numb";
"nutritious";
"nutty";
"obedient";
"obese";
"oblong";
"oily";
"oblong";
"obvious";
"occasional";
"odd";
"oddball";
"offbeat";
"offensive";
"official";
"old";
"only";
"open";
"optimal";
"optimistic";
"opulent";
"orange";
"orderly";
"organic";
"ornate";
"ornery";
"ordinary";
"original";
"other";
"our";
"outlying";
"outgoing";
"outlandish";
"outrageous";
"outstanding";
"oval";
"overcooked";
"overdue";
"overjoyed";
"overlooked";
"palatable";
"pale";
"paltry";
"parallel";
"parched";
"partial";
"passionate";
"past";
"pastel";
"peaceful";
"peppery";
"perfect";
"perfumed";
"periodic";
"perky";
"personal";
"pertinent";
"pesky";
"pessimistic";
"petty";
"phony";
"physical";
"piercing";
"pink";
"pitiful";
"plain";
"plaintive";
"plastic";
"playful";
"pleasant";
"pleased";
"pleasing";
"plump";
"plush";
"polished";
"polite";
"political";
"pointed";
"pointless";
"poised";
"poor";
"popular";
"portly";
"posh";
"positive";
"possible";
"potable";
"powerful";
"powerless";
"practical";
"precious";
"present";
"prestigious";
"pretty";
"precious";
"previous";
"pricey";
"prickly";
"primary";
"prime";
"pristine";
"private";
"prize";
"probable";
"productive";
"profitable";
"profuse";
"proper";
"proud";
"prudent";
"punctual";
"pungent";
"puny";
"pure";
"purple";
"pushy";
"putrid";
"puzzled";
"puzzling";
"quaint";
"qualified";
"quarrelsome";
"quarterly";
"queasy";
"querulous";
"questionable";
"quick";
"quiet";
"quintessential";
"quirky";
"quixotic";
"quizzical";
"radiant";
"ragged";
"rapid";
"rare";
"rash";
"raw";
"recent";
"reckless";
"rectangular";
"ready";
"real";
"realistic";
"reasonable";
"red";
"reflecting";
"regal";
"regular";
"reliable";
"relieved";
"remarkable";
"remorseful";
"remote";
"repentant";
"required";
"respectful";
"responsible";
"repulsive";
"revolving";
"rewarding";
"rich";
"rigid";
"right";
"ringed";
"ripe";
"roasted";
"robust";
"rosy";
"rotating";
"rotten";
"rough";
"round";
"rowdy";
"royal";
"rubbery";
"rundown";
"ruddy";
"rude";
"runny";
"rural";
"rusty";
"sad";
"safe";
"salty";
"same";
"sandy";
"sane";
"sarcastic";
"sardonic";
"satisfied";
"scaly";
"scarce";
"scared";
"scary";
"scented";
"scholarly";
"scientific";
"scornful";
"scratchy";
"scrawny";
"second";
"secondary";
"secret";
"selfish";
"sentimental";
"separate";
"serene";
"serious";
"serpentine";
"several";
"severe";
"shabby";
"shadowy";
"shady";
"shallow";
"shameful";
"shameless";
"sharp";
"shimmering";
"shiny";
"shocked";
"shocking";
"shoddy";
"short";
"showy";
"shrill";
"shy";
"sick";
"silent";
"silky";
"silly";
"silver";
"similar";
"simple";
"simplistic";
"sinful";
"single";
"sizzling";
"skeletal";
"skinny";
"sleepy";
"slight";
"slim";
"slimy";
"slippery";
"slow";
"slushy";
"small";
"smart";
"smoggy";
"smooth";
"smug";
"snappy";
"snarling";
"sneaky";
"sniveling";
"snoopy";
"sociable";
"soft";
"soggy";
"solid";
"somber";
"some";
"spherical";
"sophisticated";
"sore";
"sorrowful";
"soulful";
"soupy";
"sour";
"spanish";
"sparkling";
"sparse";
"specific";
"spectacular";
"speedy";
"spicy";
"spiffy";
"spirited";
"spiteful";
"splendid";
"spotless";
"spotted";
"spry";
"square";
"squeaky";
"squiggly";
"stable";
"staid";
"stained";
"stale";
"standard";
"starchy";
"stark";
"starry";
"steep";
"sticky";
"stiff";
"stimulating";
"stingy";
"stormy";
"straight";
"strange";
"steel";
"strict";
"strident";
"striking";
"striped";
"strong";
"studious";
"stunning";
"stupendous";
"stupid";
"sturdy";
"stylish";
"subdued";
"submissive";
"substantial";
"subtle";
"suburban";
"sudden";
"sugary";
"sunny";
"super";
"superb";
"superficial";
"superior";
"supportive";
"surprised";
"suspicious";
"svelte";
"sweaty";
"sweet";
"sweltering";
"swift";
"sympathetic";
"tall";
"talkative";
"tame";
"tan";
"tangible";
"tart";
"tasty";
"tattered";
"taut";
"tedious";
"teeming";
"tempting";
"tender";
"tense";
"tepid";
"terrible";
"terrific";
"testy";
"thankful";
"that";
"these";
"thick";
"thin";
"third";
"thirsty";
"this";
"thorough";
"thorny";
"those";
"thoughtful";
"threadbare";
"thrifty";
"thunderous";
"tidy";
"tight";
"timely";
"tinted";
"tiny";
"tired";
"torn";
"total";
"tough";
"traumatic";
"treasured";
"tremendous";
"tragic";
"trained";
"tremendous";
"triangular";
"tricky";
"trifling";
"trim";
"trivial";
"troubled";
"true";
"trusting";
"trustworthy";
"trusty";
"truthful";
"tubby";
"turbulent";
"twin";
"ugly";
"ultimate";
"unacceptable";
"unaware";
"uncomfortable";
"uncommon";
"unconscious";
"understated";
"unequaled";
"uneven";
"unfinished";
"unfit";
"unfolded";
"unfortunate";
"unhappy";
"unhealthy";
"uniform";
"unimportant";
"unique";
"united";
"unkempt";
"unknown";
"unlawful";
"unlined";
"unlucky";
"unnatural";
"unpleasant";
"unrealistic";
"unripe";
"unruly";
"unselfish";
"unsightly";
"unsteady";
"unsung";
"untidy";
"untimely";
"untried";
"untrue";
"unused";
"unusual";
"unwelcome";
"unwieldy";
"unwilling";
"unwitting";
"unwritten";
"upbeat";
"upright";
"upset";
"urban";
"usable";
"used";
"useful";
"useless";
"utilized";
"utter";
"vacant";
"vague";
"vain";
"valid";
"valuable";
"vapid";
"variable";
"vast";
"velvety";
"venerated";
"vengeful";
"verifiable";
"vibrant";
"vicious";
"victorious";
"vigilant";
"vigorous";
"villainous";
"violet";
"violent";
"virtual";
"virtuous";
"visible";
"vital";
"vivacious";
"vivid";
"voluminous";
"warlike";
"warm";
"warmhearted";
"warped";
"wary";
"wasteful";
"watchful";
"waterlogged";
"watery";
"wavy";
"wealthy";
"weak";
"weary";
"webbed";
"wee";
"weekly";
"weepy";
"weighty";
"weird";
"welcome";
"wet";
"which";
"whimsical";
"whirlwind";
"whispered";
"white";
"whole";
"whopping";
"wicked";
"wide";
"wiggly";
"wild";
"willing";
"wilted";
"winding";
"windy";
"winged";
"wiry";
"wise";
"witty";
"wobbly";
"woeful";
"wonderful";
"wooden";
"woozy";
"wordy";
"worldly";
"worn";
"worried";
"worrisome";
"worse";
"worst";
"worthless";
"worthwhile";
"worthy";
"wrathful";
"wretched";
"writhing";
"wrong";
"wry";
"yawning";
"yearly";
"yellow";
"yellowish";
"young";
"youthful";
"yummy";
"zany";
"zealous";
"zesty" |]
let animals =
[| "aardvark";
"abyssinian";
"affenpinscher";
"akbash";
"akita";
"albatross";
"alligator";
"angelfish";
"ant";
"anteater";
"antelope";
"armadillo";
"avocet";
"axolotl";
"baboon";
"badger";
"balinese";
"bandicoot";
"barb";
"barnacle";
"barracuda";
"bat";
"beagle";
"bear";
"beaver";
"beetle";
"binturong";
"birman";
"bison";
"bloodhound";
"bobcat";
"bombay";
"bongo";
"bonobo";
"booby";
"budgerigar";
"buffalo";
"bulldog";
"bullfrog";
"burmese";
"butterfly";
"caiman";
"camel";
"capybara";
"caracal";
"cassowary";
"cat";
"caterpillar";
"catfish";
"centipede";
"chameleon";
"chamois";
"cheetah";
"chicken";
"chihuahua";
"chimpanzee";
"chinchilla";
"chinook";
"chipmunk";
"cichlid";
"coati";
"cockroach";
"collie";
"coral";
"cougar";
"cow";
"coyote";
"crab";
"crane";
"crocodile";
"cuscus";
"cuttlefish";
"dachshund";
"dalmatian";
"deer";
"dhole";
"dingo";
"discus";
"dodo";
"dog";
"dolphin";
"donkey";
"dormouse";
"dragonfly";
"drever";
"duck";
"dugong";
"dunker";
"eagle";
"earwig";
"echidna";
"elephant";
"emu";
"falcon";
"fennec";
"ferret";
"fish";
"flamingo";
"flounder";
"fly";
"fossa";
"fox";
"frigatebird";
"frog";
"gar";
"gecko";
"gerbil";
"gharial";
"gibbon";
"giraffe";
"goat";
"goose";
"gopher";
"gorilla";
"grasshopper";
"greyhound";
"grouse";
"guppy";
"hamster";
"hare";
"harrier";
"havanese";
"hedgehog";
"heron";
"himalayan";
"hippopotamus";
"horse";
"human";
"hummingbird";
"hyena";
"ibis";
"iguana";
"impala";
"indri";
"insect";
"jackal";
"jaguar";
"javanese";
"jellyfish";
"kakapo";
"kangaroo";
"kingfisher";
"kiwi";
"koala";
"kudu";
"labradoodle";
"ladybird";
"lemming";
"lemur";
"leopard";
"liger";
"lion";
"lionfish";
"lizard";
"llama";
"lobster";
"lynx";
"macaw";
"magpie";
"maltese";
"manatee";
"mandrill";
"markhor";
"mastiff";
"mayfly";
"meerkat";
"millipede";
"mole";
"molly";
"mongoose";
"mongrel";
"monkey";
"moorhen";
"moose";
"moth";
"mouse";
"mule";
"neanderthal";
"newfoundland";
"newt";
"nightingale";
"numbat";
"ocelot";
"octopus";
"okapi";
"olm";
"opossum";
"ostrich";
"otter";
"oyster";
"pademelon";
"panther";
"parrot";
"peacock";
"pekingese";
"pelican";
"penguin";
"persian";
"pheasant";
"pig";
"pika";
"pike";
"piranha";
"platypus";
"pointer";
"poodle";
"porcupine";
"possum";
"prawn";
"puffin";
"pug";
"puma";
"quail";
"quetzal";
"quokka";
"quoll";
"rabbit";
"raccoon";
"ragdoll";
"rat";
"rattlesnake";
"reindeer";
"rhinoceros";
"robin";
"rottweiler";
"salamander";
"saola";
"scorpion";
"seahorse";
"seal";
"serval";
"sheep";
"shrimp";
"siamese";
"siberian";
"skunk";
"sloth";
"snail";
"snake";
"snowshoe";
"somali";
"sparrow";
"sponge";
"squid";
"squirrel";
"starfish";
"stingray";
"stoat";
"swan";
"tang";
"tapir";
"tarsier";
"termite";
"tetra";
"tiffany";
"tiger";
"tortoise";
"toucan";
"tropicbird";
"tuatara";
"turkey";
"uakari";
"uguisu";
"umbrellabird";
"vulture";
"wallaby";
"walrus";
"warthog";
"wasp";
"weasel";
"whippet";
"wildebeest";
"wolf";
"wolverine";
"wombat";
"woodlouse";
"woodpecker";
"wrasse";
"yak";
"zebra";
"zebu";
"zonkey";
"zorse" |]
let pick a z = a.(Z.rem z (Array.length a |> Z.of_int) |> Z.to_int)
let hash a = Blake2B.hash_string [a] |> Blake2B.to_string
type t = {c : string; t : string; h : string; d : string}
let pp ppf {c; t; h; d} = Format.fprintf ppf "%s-%s-%s-%s" c t h d
let crouching_tiger string =
let c = pick adjectives (string |> hash |> Z.of_bits) in
let t = pick animals (string |> hash |> hash |> Z.of_bits) in
let h = pick adjectives (string |> hash |> hash |> hash |> Z.of_bits) in
let d = pick animals (string |> hash |> hash |> hash |> hash |> Z.of_bits) in
{c; t; h; d}
src/lib_signer_backends/unix/ledger_names.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition adjectives : array string :=
(* ❌ Arrays not handled. *)
[
"abandoned" % string;
"able" % string;
"absolute" % string;
"adorable" % string;
"adventurous" % string;
"academic" % string;
"acceptable" % string;
"acclaimed" % string;
"accomplished" % string;
"accurate" % string;
"aching" % string;
"acidic" % string;
"acrobatic" % string;
"active" % string;
"actual" % string;
"adept" % string;
"admirable" % string;
"admired" % string;
"adolescent" % string;
"adorable" % string;
"adored" % string;
"advanced" % string;
"afraid" % string;
"affectionate" % string;
"aged" % string;
"aggravating" % string;
"aggressive" % string;
"agile" % string;
"agitated" % string;
"agonizing" % string;
"agreeable" % string;
"ajar" % string;
"alarmed" % string;
"alarming" % string;
"alert" % string;
"alienated" % string;
"alive" % string;
"all" % string;
"altruistic" % string;
"amazing" % string;
"ambitious" % string;
"ample" % string;
"amused" % string;
"amusing" % string;
"anchored" % string;
"ancient" % string;
"angelic" % string;
"angry" % string;
"anguished" % string;
"animated" % string;
"annual" % string;
"another" % string;
"antique" % string;
"anxious" % string;
"any" % string;
"apprehensive" % string;
"appropriate" % string;
"apt" % string;
"arctic" % string;
"arid" % string;
"aromatic" % string;
"artistic" % string;
"ashamed" % string;
"assured" % string;
"astonishing" % string;
"athletic" % string;
"attached" % string;
"attentive" % string;
"attractive" % string;
"austere" % string;
"authentic" % string;
"authorized" % string;
"automatic" % string;
"avaricious" % string;
"average" % string;
"aware" % string;
"awesome" % string;
"awful" % string;
"awkward" % string;
"babyish" % string;
"bad" % string;
"back" % string;
"baggy" % string;
"bare" % string;
"barren" % string;
"basic" % string;
"beautiful" % string;
"belated" % string;
"beloved" % string;
"beneficial" % string;
"better" % string;
"best" % string;
"bewitched" % string;
"big" % string;
"biodegradable" % string;
"bitter" % string;
"black" % string;
"bland" % string;
"blank" % string;
"blaring" % string;
"bleak" % string;
"blind" % string;
"blissful" % string;
"blond" % string;
"blue" % string;
"blushing" % string;
"bogus" % string;
"boiling" % string;
"bold" % string;
"bony" % string;
"boring" % string;
"bossy" % string;
"both" % string;
"bouncy" % string;
"bountiful" % string;
"bowed" % string;
"brave" % string;
"breakable" % string;
"brief" % string;
"bright" % string;
"brilliant" % string;
"brisk" % string;
"broken" % string;
"bronze" % string;
"brown" % string;
"bruised" % string;
"bubbly" % string;
"bulky" % string;
"bumpy" % string;
"buoyant" % string;
"burdensome" % string;
"burly" % string;
"bustling" % string;
"busy" % string;
"buttery" % string;
"buzzing" % string;
"calculating" % string;
"calm" % string;
"candid" % string;
"canine" % string;
"capital" % string;
"carefree" % string;
"careful" % string;
"careless" % string;
"caring" % string;
"cautious" % string;
"cavernous" % string;
"celebrated" % string;
"charming" % string;
"cheap" % string;
"cheerful" % string;
"cheery" % string;
"chief" % string;
"chilly" % string;
"chubby" % string;
"circular" % string;
"classic" % string;
"clean" % string;
"clear" % string;
"clever" % string;
"close" % string;
"closed" % string;
"cloudy" % string;
"clueless" % string;
"clumsy" % string;
"cluttered" % string;
"coarse" % string;
"cold" % string;
"colorful" % string;
"colorless" % string;
"colossal" % string;
"comfortable" % string;
"common" % string;
"compassionate" % string;
"competent" % string;
"complete" % string;
"complex" % string;
"complicated" % string;
"composed" % string;
"concerned" % string;
"concrete" % string;
"confused" % string;
"conscious" % string;
"considerate" % string;
"constant" % string;
"content" % string;
"conventional" % string;
"cooked" % string;
"cool" % string;
"cooperative" % string;
"coordinated" % string;
"corny" % string;
"corrupt" % string;
"costly" % string;
"courageous" % string;
"courteous" % string;
"crafty" % string;
"crazy" % string;
"creamy" % string;
"creative" % string;
"creepy" % string;
"criminal" % string;
"crisp" % string;
"critical" % string;
"crooked" % string;
"crowded" % string;
"cruel" % string;
"crushing" % string;
"cuddly" % string;
"cultivated" % string;
"cultured" % string;
"cumbersome" % string;
"curly" % string;
"curvy" % string;
"cute" % string;
"cylindrical" % string;
"damaged" % string;
"damp" % string;
"dangerous" % string;
"dapper" % string;
"daring" % string;
"darling" % string;
"dark" % string;
"dazzling" % string;
"dead" % string;
"deadly" % string;
"deafening" % string;
"dear" % string;
"dearest" % string;
"decent" % string;
"decimal" % string;
"decisive" % string;
"deep" % string;
"defenseless" % string;
"defensive" % string;
"defiant" % string;
"deficient" % string;
"definite" % string;
"definitive" % string;
"delayed" % string;
"delectable" % string;
"delicious" % string;
"delightful" % string;
"delirious" % string;
"demanding" % string;
"dense" % string;
"dental" % string;
"dependable" % string;
"dependent" % string;
"descriptive" % string;
"deserted" % string;
"detailed" % string;
"determined" % string;
"devoted" % string;
"different" % string;
"difficult" % string;
"digital" % string;
"diligent" % string;
"dim" % string;
"dimpled" % string;
"dimwitted" % string;
"direct" % string;
"disastrous" % string;
"discrete" % string;
"disfigured" % string;
"disgusting" % string;
"disloyal" % string;
"dismal" % string;
"distant" % string;
"downright" % string;
"dreary" % string;
"dirty" % string;
"disguised" % string;
"dishonest" % string;
"dismal" % string;
"distant" % string;
"distinct" % string;
"distorted" % string;
"dizzy" % string;
"dopey" % string;
"doting" % string;
"double" % string;
"downright" % string;
"drab" % string;
"drafty" % string;
"dramatic" % string;
"dreary" % string;
"droopy" % string;
"dry" % string;
"dual" % string;
"dull" % string;
"dutiful" % string;
"eager" % string;
"earnest" % string;
"early" % string;
"easy" % string;
"ecstatic" % string;
"edible" % string;
"educated" % string;
"elaborate" % string;
"elastic" % string;
"elated" % string;
"elderly" % string;
"electric" % string;
"elegant" % string;
"elementary" % string;
"elliptical" % string;
"embarrassed" % string;
"embellished" % string;
"eminent" % string;
"emotional" % string;
"empty" % string;
"enchanted" % string;
"enchanting" % string;
"energetic" % string;
"enlightened" % string;
"enormous" % string;
"enraged" % string;
"entire" % string;
"envious" % string;
"equal" % string;
"equatorial" % string;
"essential" % string;
"esteemed" % string;
"ethical" % string;
"euphoric" % string;
"even" % string;
"evergreen" % string;
"everlasting" % string;
"every" % string;
"evil" % string;
"exalted" % string;
"excellent" % string;
"exemplary" % string;
"exhausted" % string;
"excitable" % string;
"excited" % string;
"exciting" % string;
"exotic" % string;
"expensive" % string;
"experienced" % string;
"expert" % string;
"extraneous" % string;
"extroverted" % string;
"fabulous" % string;
"failing" % string;
"faint" % string;
"fair" % string;
"faithful" % string;
"fake" % string;
"false" % string;
"familiar" % string;
"famous" % string;
"fancy" % string;
"fantastic" % string;
"far" % string;
"faraway" % string;
"fast" % string;
"fat" % string;
"fatal" % string;
"fatherly" % string;
"favorable" % string;
"favorite" % string;
"fearful" % string;
"fearless" % string;
"feisty" % string;
"feline" % string;
"female" % string;
"feminine" % string;
"few" % string;
"fickle" % string;
"filthy" % string;
"fine" % string;
"finished" % string;
"firm" % string;
"first" % string;
"firsthand" % string;
"fitting" % string;
"fixed" % string;
"flaky" % string;
"flamboyant" % string;
"flashy" % string;
"flat" % string;
"flawed" % string;
"flawless" % string;
"flickering" % string;
"flimsy" % string;
"flippant" % string;
"flowery" % string;
"fluffy" % string;
"fluid" % string;
"flustered" % string;
"focused" % string;
"fond" % string;
"foolhardy" % string;
"foolish" % string;
"forceful" % string;
"forked" % string;
"formal" % string;
"forsaken" % string;
"forthright" % string;
"fortunate" % string;
"fragrant" % string;
"frail" % string;
"frank" % string;
"frayed" % string;
"free" % string;
"french" % string;
"fresh" % string;
"frequent" % string;
"friendly" % string;
"frightened" % string;
"frightening" % string;
"frigid" % string;
"frilly" % string;
"frizzy" % string;
"frivolous" % string;
"front" % string;
"frosty" % string;
"frozen" % string;
"frugal" % string;
"fruitful" % string;
"full" % string;
"fumbling" % string;
"functional" % string;
"funny" % string;
"fussy" % string;
"fuzzy" % string;
"gargantuan" % string;
"gaseous" % string;
"general" % string;
"generous" % string;
"gentle" % string;
"genuine" % string;
"giant" % string;
"giddy" % string;
"gigantic" % string;
"gifted" % string;
"giving" % string;
"glamorous" % string;
"glaring" % string;
"glass" % string;
"gleaming" % string;
"gleeful" % string;
"glistening" % string;
"glittering" % string;
"gloomy" % string;
"glorious" % string;
"glossy" % string;
"glum" % string;
"golden" % string;
"good" % string;
"gorgeous" % string;
"graceful" % string;
"gracious" % string;
"grand" % string;
"grandiose" % string;
"granular" % string;
"grateful" % string;
"grave" % string;
"gray" % string;
"great" % string;
"greedy" % string;
"green" % string;
"gregarious" % string;
"grim" % string;
"grimy" % string;
"gripping" % string;
"grizzled" % string;
"gross" % string;
"grotesque" % string;
"grouchy" % string;
"grounded" % string;
"growing" % string;
"growling" % string;
"grown" % string;
"grubby" % string;
"gruesome" % string;
"grumpy" % string;
"guilty" % string;
"gullible" % string;
"gummy" % string;
"hairy" % string;
"half" % string;
"handmade" % string;
"handsome" % string;
"handy" % string;
"happy" % string;
"hard" % string;
"harmful" % string;
"harmless" % string;
"harmonious" % string;
"harsh" % string;
"hasty" % string;
"hateful" % string;
"haunting" % string;
"healthy" % string;
"heartfelt" % string;
"hearty" % string;
"heavenly" % string;
"heavy" % string;
"hefty" % string;
"helpful" % string;
"helpless" % string;
"hidden" % string;
"hideous" % string;
"high" % string;
"hilarious" % string;
"hoarse" % string;
"hollow" % string;
"homely" % string;
"honest" % string;
"honorable" % string;
"honored" % string;
"hopeful" % string;
"horrible" % string;
"hospitable" % string;
"hot" % string;
"huge" % string;
"humble" % string;
"humiliating" % string;
"humming" % string;
"humongous" % string;
"hungry" % string;
"hurtful" % string;
"husky" % string;
"icky" % string;
"icy" % string;
"ideal" % string;
"idealistic" % string;
"identical" % string;
"idle" % string;
"idiotic" % string;
"idolized" % string;
"ignorant" % string;
"ill" % string;
"illegal" % string;
"illiterate" % string;
"illustrious" % string;
"imaginary" % string;
"imaginative" % string;
"immaculate" % string;
"immaterial" % string;
"immediate" % string;
"immense" % string;
"impassioned" % string;
"impeccable" % string;
"impartial" % string;
"imperfect" % string;
"imperturbable" % string;
"impish" % string;
"impolite" % string;
"important" % string;
"impossible" % string;
"impractical" % string;
"impressionable" % string;
"impressive" % string;
"improbable" % string;
"impure" % string;
"inborn" % string;
"incomparable" % string;
"incompatible" % string;
"incomplete" % string;
"inconsequential" % string;
"incredible" % string;
"indelible" % string;
"inexperienced" % string;
"indolent" % string;
"infamous" % string;
"infantile" % string;
"infatuated" % string;
"inferior" % string;
"infinite" % string;
"informal" % string;
"innocent" % string;
"insecure" % string;
"insidious" % string;
"insignificant" % string;
"insistent" % string;
"instructive" % string;
"insubstantial" % string;
"intelligent" % string;
"intent" % string;
"intentional" % string;
"interesting" % string;
"internal" % string;
"international" % string;
"intrepid" % string;
"ironclad" % string;
"irresponsible" % string;
"irritating" % string;
"itchy" % string;
"jaded" % string;
"jagged" % string;
"jaunty" % string;
"jealous" % string;
"jittery" % string;
"joint" % string;
"jolly" % string;
"jovial" % string;
"joyful" % string;
"joyous" % string;
"jubilant" % string;
"judicious" % string;
"juicy" % string;
"jumbo" % string;
"junior" % string;
"jumpy" % string;
"juvenile" % string;
"kaleidoscopic" % string;
"keen" % string;
"key" % string;
"kind" % string;
"kindhearted" % string;
"kindly" % string;
"klutzy" % string;
"knobby" % string;
"knotty" % string;
"knowledgeable" % string;
"knowing" % string;
"known" % string;
"kooky" % string;
"lame" % string;
"lanky" % string;
"large" % string;
"last" % string;
"lasting" % string;
"late" % string;
"lavish" % string;
"lawful" % string;
"lazy" % string;
"leading" % string;
"lean" % string;
"leafy" % string;
"left" % string;
"legal" % string;
"legitimate" % string;
"light" % string;
"lighthearted" % string;
"likable" % string;
"likely" % string;
"limited" % string;
"limp" % string;
"limping" % string;
"linear" % string;
"lined" % string;
"liquid" % string;
"little" % string;
"live" % string;
"lively" % string;
"livid" % string;
"loathsome" % string;
"lone" % string;
"lonely" % string;
"long" % string;
"loose" % string;
"lopsided" % string;
"lost" % string;
"loud" % string;
"lovable" % string;
"lovely" % string;
"loving" % string;
"low" % string;
"loyal" % string;
"lucky" % string;
"lumbering" % string;
"luminous" % string;
"lumpy" % string;
"lustrous" % string;
"luxurious" % string;
"mad" % string;
"magnificent" % string;
"majestic" % string;
"major" % string;
"male" % string;
"mammoth" % string;
"married" % string;
"marvelous" % string;
"masculine" % string;
"massive" % string;
"mature" % string;
"meager" % string;
"mealy" % string;
"mean" % string;
"measly" % string;
"meaty" % string;
"medical" % string;
"mediocre" % string;
"medium" % string;
"meek" % string;
"mellow" % string;
"melodic" % string;
"memorable" % string;
"menacing" % string;
"merry" % string;
"messy" % string;
"metallic" % string;
"mild" % string;
"milky" % string;
"mindless" % string;
"miniature" % string;
"minor" % string;
"minty" % string;
"miserable" % string;
"miserly" % string;
"misguided" % string;
"misty" % string;
"mixed" % string;
"modern" % string;
"modest" % string;
"moist" % string;
"monstrous" % string;
"monthly" % string;
"monumental" % string;
"moral" % string;
"mortified" % string;
"motherly" % string;
"motionless" % string;
"mountainous" % string;
"muddy" % string;
"muffled" % string;
"multicolored" % string;
"mundane" % string;
"murky" % string;
"mushy" % string;
"musty" % string;
"muted" % string;
"mysterious" % string;
"naive" % string;
"narrow" % string;
"nasty" % string;
"natural" % string;
"naughty" % string;
"nautical" % string;
"near" % string;
"neat" % string;
"necessary" % string;
"needy" % string;
"negative" % string;
"neglected" % string;
"negligible" % string;
"neighboring" % string;
"nervous" % string;
"new" % string;
"nice" % string;
"nifty" % string;
"nimble" % string;
"nippy" % string;
"nocturnal" % string;
"noisy" % string;
"nonstop" % string;
"normal" % string;
"notable" % string;
"noted" % string;
"noteworthy" % string;
"novel" % string;
"noxious" % string;
"numb" % string;
"nutritious" % string;
"nutty" % string;
"obedient" % string;
"obese" % string;
"oblong" % string;
"oily" % string;
"oblong" % string;
"obvious" % string;
"occasional" % string;
"odd" % string;
"oddball" % string;
"offbeat" % string;
"offensive" % string;
"official" % string;
"old" % string;
"only" % string;
"open" % string;
"optimal" % string;
"optimistic" % string;
"opulent" % string;
"orange" % string;
"orderly" % string;
"organic" % string;
"ornate" % string;
"ornery" % string;
"ordinary" % string;
"original" % string;
"other" % string;
"our" % string;
"outlying" % string;
"outgoing" % string;
"outlandish" % string;
"outrageous" % string;
"outstanding" % string;
"oval" % string;
"overcooked" % string;
"overdue" % string;
"overjoyed" % string;
"overlooked" % string;
"palatable" % string;
"pale" % string;
"paltry" % string;
"parallel" % string;
"parched" % string;
"partial" % string;
"passionate" % string;
"past" % string;
"pastel" % string;
"peaceful" % string;
"peppery" % string;
"perfect" % string;
"perfumed" % string;
"periodic" % string;
"perky" % string;
"personal" % string;
"pertinent" % string;
"pesky" % string;
"pessimistic" % string;
"petty" % string;
"phony" % string;
"physical" % string;
"piercing" % string;
"pink" % string;
"pitiful" % string;
"plain" % string;
"plaintive" % string;
"plastic" % string;
"playful" % string;
"pleasant" % string;
"pleased" % string;
"pleasing" % string;
"plump" % string;
"plush" % string;
"polished" % string;
"polite" % string;
"political" % string;
"pointed" % string;
"pointless" % string;
"poised" % string;
"poor" % string;
"popular" % string;
"portly" % string;
"posh" % string;
"positive" % string;
"possible" % string;
"potable" % string;
"powerful" % string;
"powerless" % string;
"practical" % string;
"precious" % string;
"present" % string;
"prestigious" % string;
"pretty" % string;
"precious" % string;
"previous" % string;
"pricey" % string;
"prickly" % string;
"primary" % string;
"prime" % string;
"pristine" % string;
"private" % string;
"prize" % string;
"probable" % string;
"productive" % string;
"profitable" % string;
"profuse" % string;
"proper" % string;
"proud" % string;
"prudent" % string;
"punctual" % string;
"pungent" % string;
"puny" % string;
"pure" % string;
"purple" % string;
"pushy" % string;
"putrid" % string;
"puzzled" % string;
"puzzling" % string;
"quaint" % string;
"qualified" % string;
"quarrelsome" % string;
"quarterly" % string;
"queasy" % string;
"querulous" % string;
"questionable" % string;
"quick" % string;
"quiet" % string;
"quintessential" % string;
"quirky" % string;
"quixotic" % string;
"quizzical" % string;
"radiant" % string;
"ragged" % string;
"rapid" % string;
"rare" % string;
"rash" % string;
"raw" % string;
"recent" % string;
"reckless" % string;
"rectangular" % string;
"ready" % string;
"real" % string;
"realistic" % string;
"reasonable" % string;
"red" % string;
"reflecting" % string;
"regal" % string;
"regular" % string;
"reliable" % string;
"relieved" % string;
"remarkable" % string;
"remorseful" % string;
"remote" % string;
"repentant" % string;
"required" % string;
"respectful" % string;
"responsible" % string;
"repulsive" % string;
"revolving" % string;
"rewarding" % string;
"rich" % string;
"rigid" % string;
"right" % string;
"ringed" % string;
"ripe" % string;
"roasted" % string;
"robust" % string;
"rosy" % string;
"rotating" % string;
"rotten" % string;
"rough" % string;
"round" % string;
"rowdy" % string;
"royal" % string;
"rubbery" % string;
"rundown" % string;
"ruddy" % string;
"rude" % string;
"runny" % string;
"rural" % string;
"rusty" % string;
"sad" % string;
"safe" % string;
"salty" % string;
"same" % string;
"sandy" % string;
"sane" % string;
"sarcastic" % string;
"sardonic" % string;
"satisfied" % string;
"scaly" % string;
"scarce" % string;
"scared" % string;
"scary" % string;
"scented" % string;
"scholarly" % string;
"scientific" % string;
"scornful" % string;
"scratchy" % string;
"scrawny" % string;
"second" % string;
"secondary" % string;
"secret" % string;
"selfish" % string;
"sentimental" % string;
"separate" % string;
"serene" % string;
"serious" % string;
"serpentine" % string;
"several" % string;
"severe" % string;
"shabby" % string;
"shadowy" % string;
"shady" % string;
"shallow" % string;
"shameful" % string;
"shameless" % string;
"sharp" % string;
"shimmering" % string;
"shiny" % string;
"shocked" % string;
"shocking" % string;
"shoddy" % string;
"short" % string;
"showy" % string;
"shrill" % string;
"shy" % string;
"sick" % string;
"silent" % string;
"silky" % string;
"silly" % string;
"silver" % string;
"similar" % string;
"simple" % string;
"simplistic" % string;
"sinful" % string;
"single" % string;
"sizzling" % string;
"skeletal" % string;
"skinny" % string;
"sleepy" % string;
"slight" % string;
"slim" % string;
"slimy" % string;
"slippery" % string;
"slow" % string;
"slushy" % string;
"small" % string;
"smart" % string;
"smoggy" % string;
"smooth" % string;
"smug" % string;
"snappy" % string;
"snarling" % string;
"sneaky" % string;
"sniveling" % string;
"snoopy" % string;
"sociable" % string;
"soft" % string;
"soggy" % string;
"solid" % string;
"somber" % string;
"some" % string;
"spherical" % string;
"sophisticated" % string;
"sore" % string;
"sorrowful" % string;
"soulful" % string;
"soupy" % string;
"sour" % string;
"spanish" % string;
"sparkling" % string;
"sparse" % string;
"specific" % string;
"spectacular" % string;
"speedy" % string;
"spicy" % string;
"spiffy" % string;
"spirited" % string;
"spiteful" % string;
"splendid" % string;
"spotless" % string;
"spotted" % string;
"spry" % string;
"square" % string;
"squeaky" % string;
"squiggly" % string;
"stable" % string;
"staid" % string;
"stained" % string;
"stale" % string;
"standard" % string;
"starchy" % string;
"stark" % string;
"starry" % string;
"steep" % string;
"sticky" % string;
"stiff" % string;
"stimulating" % string;
"stingy" % string;
"stormy" % string;
"straight" % string;
"strange" % string;
"steel" % string;
"strict" % string;
"strident" % string;
"striking" % string;
"striped" % string;
"strong" % string;
"studious" % string;
"stunning" % string;
"stupendous" % string;
"stupid" % string;
"sturdy" % string;
"stylish" % string;
"subdued" % string;
"submissive" % string;
"substantial" % string;
"subtle" % string;
"suburban" % string;
"sudden" % string;
"sugary" % string;
"sunny" % string;
"super" % string;
"superb" % string;
"superficial" % string;
"superior" % string;
"supportive" % string;
"surprised" % string;
"suspicious" % string;
"svelte" % string;
"sweaty" % string;
"sweet" % string;
"sweltering" % string;
"swift" % string;
"sympathetic" % string;
"tall" % string;
"talkative" % string;
"tame" % string;
"tan" % string;
"tangible" % string;
"tart" % string;
"tasty" % string;
"tattered" % string;
"taut" % string;
"tedious" % string;
"teeming" % string;
"tempting" % string;
"tender" % string;
"tense" % string;
"tepid" % string;
"terrible" % string;
"terrific" % string;
"testy" % string;
"thankful" % string;
"that" % string;
"these" % string;
"thick" % string;
"thin" % string;
"third" % string;
"thirsty" % string;
"this" % string;
"thorough" % string;
"thorny" % string;
"those" % string;
"thoughtful" % string;
"threadbare" % string;
"thrifty" % string;
"thunderous" % string;
"tidy" % string;
"tight" % string;
"timely" % string;
"tinted" % string;
"tiny" % string;
"tired" % string;
"torn" % string;
"total" % string;
"tough" % string;
"traumatic" % string;
"treasured" % string;
"tremendous" % string;
"tragic" % string;
"trained" % string;
"tremendous" % string;
"triangular" % string;
"tricky" % string;
"trifling" % string;
"trim" % string;
"trivial" % string;
"troubled" % string;
"true" % string;
"trusting" % string;
"trustworthy" % string;
"trusty" % string;
"truthful" % string;
"tubby" % string;
"turbulent" % string;
"twin" % string;
"ugly" % string;
"ultimate" % string;
"unacceptable" % string;
"unaware" % string;
"uncomfortable" % string;
"uncommon" % string;
"unconscious" % string;
"understated" % string;
"unequaled" % string;
"uneven" % string;
"unfinished" % string;
"unfit" % string;
"unfolded" % string;
"unfortunate" % string;
"unhappy" % string;
"unhealthy" % string;
"uniform" % string;
"unimportant" % string;
"unique" % string;
"united" % string;
"unkempt" % string;
"unknown" % string;
"unlawful" % string;
"unlined" % string;
"unlucky" % string;
"unnatural" % string;
"unpleasant" % string;
"unrealistic" % string;
"unripe" % string;
"unruly" % string;
"unselfish" % string;
"unsightly" % string;
"unsteady" % string;
"unsung" % string;
"untidy" % string;
"untimely" % string;
"untried" % string;
"untrue" % string;
"unused" % string;
"unusual" % string;
"unwelcome" % string;
"unwieldy" % string;
"unwilling" % string;
"unwitting" % string;
"unwritten" % string;
"upbeat" % string;
"upright" % string;
"upset" % string;
"urban" % string;
"usable" % string;
"used" % string;
"useful" % string;
"useless" % string;
"utilized" % string;
"utter" % string;
"vacant" % string;
"vague" % string;
"vain" % string;
"valid" % string;
"valuable" % string;
"vapid" % string;
"variable" % string;
"vast" % string;
"velvety" % string;
"venerated" % string;
"vengeful" % string;
"verifiable" % string;
"vibrant" % string;
"vicious" % string;
"victorious" % string;
"vigilant" % string;
"vigorous" % string;
"villainous" % string;
"violet" % string;
"violent" % string;
"virtual" % string;
"virtuous" % string;
"visible" % string;
"vital" % string;
"vivacious" % string;
"vivid" % string;
"voluminous" % string;
"warlike" % string;
"warm" % string;
"warmhearted" % string;
"warped" % string;
"wary" % string;
"wasteful" % string;
"watchful" % string;
"waterlogged" % string;
"watery" % string;
"wavy" % string;
"wealthy" % string;
"weak" % string;
"weary" % string;
"webbed" % string;
"wee" % string;
"weekly" % string;
"weepy" % string;
"weighty" % string;
"weird" % string;
"welcome" % string;
"wet" % string;
"which" % string;
"whimsical" % string;
"whirlwind" % string;
"whispered" % string;
"white" % string;
"whole" % string;
"whopping" % string;
"wicked" % string;
"wide" % string;
"wiggly" % string;
"wild" % string;
"willing" % string;
"wilted" % string;
"winding" % string;
"windy" % string;
"winged" % string;
"wiry" % string;
"wise" % string;
"witty" % string;
"wobbly" % string;
"woeful" % string;
"wonderful" % string;
"wooden" % string;
"woozy" % string;
"wordy" % string;
"worldly" % string;
"worn" % string;
"worried" % string;
"worrisome" % string;
"worse" % string;
"worst" % string;
"worthless" % string;
"worthwhile" % string;
"worthy" % string;
"wrathful" % string;
"wretched" % string;
"writhing" % string;
"wrong" % string;
"wry" % string;
"yawning" % string;
"yearly" % string;
"yellow" % string;
"yellowish" % string;
"young" % string;
"youthful" % string;
"yummy" % string;
"zany" % string;
"zealous" % string;
"zesty" % string
].
Definition animals : array string :=
(* ❌ Arrays not handled. *)
[
"aardvark" % string;
"abyssinian" % string;
"affenpinscher" % string;
"akbash" % string;
"akita" % string;
"albatross" % string;
"alligator" % string;
"angelfish" % string;
"ant" % string;
"anteater" % string;
"antelope" % string;
"armadillo" % string;
"avocet" % string;
"axolotl" % string;
"baboon" % string;
"badger" % string;
"balinese" % string;
"bandicoot" % string;
"barb" % string;
"barnacle" % string;
"barracuda" % string;
"bat" % string;
"beagle" % string;
"bear" % string;
"beaver" % string;
"beetle" % string;
"binturong" % string;
"birman" % string;
"bison" % string;
"bloodhound" % string;
"bobcat" % string;
"bombay" % string;
"bongo" % string;
"bonobo" % string;
"booby" % string;
"budgerigar" % string;
"buffalo" % string;
"bulldog" % string;
"bullfrog" % string;
"burmese" % string;
"butterfly" % string;
"caiman" % string;
"camel" % string;
"capybara" % string;
"caracal" % string;
"cassowary" % string;
"cat" % string;
"caterpillar" % string;
"catfish" % string;
"centipede" % string;
"chameleon" % string;
"chamois" % string;
"cheetah" % string;
"chicken" % string;
"chihuahua" % string;
"chimpanzee" % string;
"chinchilla" % string;
"chinook" % string;
"chipmunk" % string;
"cichlid" % string;
"coati" % string;
"cockroach" % string;
"collie" % string;
"coral" % string;
"cougar" % string;
"cow" % string;
"coyote" % string;
"crab" % string;
"crane" % string;
"crocodile" % string;
"cuscus" % string;
"cuttlefish" % string;
"dachshund" % string;
"dalmatian" % string;
"deer" % string;
"dhole" % string;
"dingo" % string;
"discus" % string;
"dodo" % string;
"dog" % string;
"dolphin" % string;
"donkey" % string;
"dormouse" % string;
"dragonfly" % string;
"drever" % string;
"duck" % string;
"dugong" % string;
"dunker" % string;
"eagle" % string;
"earwig" % string;
"echidna" % string;
"elephant" % string;
"emu" % string;
"falcon" % string;
"fennec" % string;
"ferret" % string;
"fish" % string;
"flamingo" % string;
"flounder" % string;
"fly" % string;
"fossa" % string;
"fox" % string;
"frigatebird" % string;
"frog" % string;
"gar" % string;
"gecko" % string;
"gerbil" % string;
"gharial" % string;
"gibbon" % string;
"giraffe" % string;
"goat" % string;
"goose" % string;
"gopher" % string;
"gorilla" % string;
"grasshopper" % string;
"greyhound" % string;
"grouse" % string;
"guppy" % string;
"hamster" % string;
"hare" % string;
"harrier" % string;
"havanese" % string;
"hedgehog" % string;
"heron" % string;
"himalayan" % string;
"hippopotamus" % string;
"horse" % string;
"human" % string;
"hummingbird" % string;
"hyena" % string;
"ibis" % string;
"iguana" % string;
"impala" % string;
"indri" % string;
"insect" % string;
"jackal" % string;
"jaguar" % string;
"javanese" % string;
"jellyfish" % string;
"kakapo" % string;
"kangaroo" % string;
"kingfisher" % string;
"kiwi" % string;
"koala" % string;
"kudu" % string;
"labradoodle" % string;
"ladybird" % string;
"lemming" % string;
"lemur" % string;
"leopard" % string;
"liger" % string;
"lion" % string;
"lionfish" % string;
"lizard" % string;
"llama" % string;
"lobster" % string;
"lynx" % string;
"macaw" % string;
"magpie" % string;
"maltese" % string;
"manatee" % string;
"mandrill" % string;
"markhor" % string;
"mastiff" % string;
"mayfly" % string;
"meerkat" % string;
"millipede" % string;
"mole" % string;
"molly" % string;
"mongoose" % string;
"mongrel" % string;
"monkey" % string;
"moorhen" % string;
"moose" % string;
"moth" % string;
"mouse" % string;
"mule" % string;
"neanderthal" % string;
"newfoundland" % string;
"newt" % string;
"nightingale" % string;
"numbat" % string;
"ocelot" % string;
"octopus" % string;
"okapi" % string;
"olm" % string;
"opossum" % string;
"ostrich" % string;
"otter" % string;
"oyster" % string;
"pademelon" % string;
"panther" % string;
"parrot" % string;
"peacock" % string;
"pekingese" % string;
"pelican" % string;
"penguin" % string;
"persian" % string;
"pheasant" % string;
"pig" % string;
"pika" % string;
"pike" % string;
"piranha" % string;
"platypus" % string;
"pointer" % string;
"poodle" % string;
"porcupine" % string;
"possum" % string;
"prawn" % string;
"puffin" % string;
"pug" % string;
"puma" % string;
"quail" % string;
"quetzal" % string;
"quokka" % string;
"quoll" % string;
"rabbit" % string;
"raccoon" % string;
"ragdoll" % string;
"rat" % string;
"rattlesnake" % string;
"reindeer" % string;
"rhinoceros" % string;
"robin" % string;
"rottweiler" % string;
"salamander" % string;
"saola" % string;
"scorpion" % string;
"seahorse" % string;
"seal" % string;
"serval" % string;
"sheep" % string;
"shrimp" % string;
"siamese" % string;
"siberian" % string;
"skunk" % string;
"sloth" % string;
"snail" % string;
"snake" % string;
"snowshoe" % string;
"somali" % string;
"sparrow" % string;
"sponge" % string;
"squid" % string;
"squirrel" % string;
"starfish" % string;
"stingray" % string;
"stoat" % string;
"swan" % string;
"tang" % string;
"tapir" % string;
"tarsier" % string;
"termite" % string;
"tetra" % string;
"tiffany" % string;
"tiger" % string;
"tortoise" % string;
"toucan" % string;
"tropicbird" % string;
"tuatara" % string;
"turkey" % string;
"uakari" % string;
"uguisu" % string;
"umbrellabird" % string;
"vulture" % string;
"wallaby" % string;
"walrus" % string;
"warthog" % string;
"wasp" % string;
"weasel" % string;
"whippet" % string;
"wildebeest" % string;
"wolf" % string;
"wolverine" % string;
"wombat" % string;
"woodlouse" % string;
"woodpecker" % string;
"wrasse" % string;
"yak" % string;
"zebra" % string;
"zebu" % string;
"zonkey" % string;
"zorse" % string
].
Definition pick {A : Type} (a : array A) (z : Z.t) : A :=
Array.get a
(OCaml.Stdlib.reverse_apply
(Z.rem z (OCaml.Stdlib.reverse_apply (Array.length a) Z.of_int)) Z.to_int).
Definition hash (a : string) : string :=
OCaml.Stdlib.reverse_apply (Blake2B.hash_string None (cons a []))
Blake2B.to_string.
Record t := {
c : string;
t : string;
h : string;
d : string }.
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
let '{| c := c; t := t; h := h; d := d |} := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "-" % char
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "-" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "-" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))))))
"%s-%s-%s-%s" % string) c t h d.
Definition crouching_tiger (string : string) : t :=
let c :=
pick adjectives
(OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply string hash)
Z.of_bits) in
let t :=
pick animals
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply string hash)
hash) Z.of_bits) in
let h :=
pick adjectives
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply string hash)
hash) hash) Z.of_bits) in
let d :=
pick animals
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply string hash)
hash) hash) hash) Z.of_bits) in
{| c := c; t := t; h := h; d := d |}.
src/lib_signer_backends/unix/remote.ml 11 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Client_keys
let scheme = "remote"
module Make
(RPC_client : RPC_client.S) (S : sig
val default : Uri.t
val authenticate :
Signature.Public_key_hash.t list ->
Bytes.t ->
Signature.t tzresult Lwt.t
val logger : RPC_client.logger
end) =
struct
let scheme = scheme
let title = "Built-in tezos-signer using remote wallet."
let description =
"Valid locators are of the form\n\
\ - remote://tz1...\n\
The key will be queried to current remote signer, which can be \
configured with the `--remote-signer` or `-R` options, or by defining \
the following environment variables:\n\
\ - $TEZOS_SIGNER_UNIX_PATH,\n\
\ - $TEZOS_SIGNER_TCP_HOST and $TEZOS_SIGNER_TCP_PORT (default: 7732),\n\
\ - $TEZOS_SIGNER_HTTP_HOST and $TEZOS_SIGNER_HTTP_PORT (default: 6732),\n\
\ - $TEZOS_SIGNER_HTTPS_HOST and $TEZOS_SIGNER_HTTPS_PORT (default: 443)."
module Socket = Socket.Make (S)
module Http = Http.Make (RPC_client) (S)
module Https = Https.Make (RPC_client) (S)
let get_remote () =
match Uri.scheme S.default with
| Some "unix" ->
(module Socket.Unix : SIGNER)
| Some "tcp" ->
(module Socket.Tcp : SIGNER)
| Some "http" ->
(module Http : SIGNER)
| Some "https" ->
(module Https : SIGNER)
| _ ->
assert false
module Remote = (val get_remote () : SIGNER)
let key =
match Uri.scheme S.default with
| Some "unix" ->
fun uri ->
let key = Uri.path uri in
Uri.add_query_param' S.default ("pkh", key)
| Some "tcp" ->
fun uri ->
let key = Uri.path uri in
Uri.with_path S.default key
| Some ("https" | "http") -> (
fun uri ->
let key = Uri.path uri in
match Uri.path S.default with
| "" ->
Uri.with_path S.default key
| path ->
Uri.with_path S.default (path ^ "/" ^ key) )
| _ ->
assert false
let public_key pk_uri =
Remote.public_key
(Client_keys.make_pk_uri (key (pk_uri : pk_uri :> Uri.t)))
let public_key_hash pk_uri =
Remote.public_key_hash
(Client_keys.make_pk_uri (key (pk_uri : pk_uri :> Uri.t)))
let import_secret_key ~io:_ = public_key_hash
let neuterize sk_uri =
return (Client_keys.make_pk_uri (sk_uri : sk_uri :> Uri.t))
let sign ?watermark sk_uri msg =
Remote.sign
?watermark
(Client_keys.make_sk_uri (key (sk_uri : sk_uri :> Uri.t)))
msg
let deterministic_nonce sk_uri msg =
Remote.deterministic_nonce
(Client_keys.make_sk_uri (key (sk_uri : sk_uri :> Uri.t)))
msg
let deterministic_nonce_hash sk_uri msg =
Remote.deterministic_nonce_hash
(Client_keys.make_sk_uri (key (sk_uri : sk_uri :> Uri.t)))
msg
let supports_deterministic_nonces sk_uri =
Remote.supports_deterministic_nonces
(Client_keys.make_sk_uri (key (sk_uri : sk_uri :> Uri.t)))
end
let make_sk sk =
Client_keys.make_sk_uri
(Uri.make ~scheme ~path:(Signature.Secret_key.to_b58check sk) ())
let make_pk pk =
Client_keys.make_pk_uri
(Uri.make ~scheme ~path:(Signature.Public_key.to_b58check pk) ())
let read_base_uri_from_env () =
match
( Sys.getenv_opt "TEZOS_SIGNER_UNIX_PATH",
Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST",
Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST",
Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" )
with
| (None, None, None, None) ->
return_none
| (Some path, None, None, None) ->
return_some (Socket.make_unix_base path)
| (None, Some host, None, None) -> (
try
let port =
match Sys.getenv_opt "TEZOS_SIGNER_TCP_PORT" with
| None ->
7732
| Some port ->
int_of_string port
in
return_some (Socket.make_tcp_base host port)
with Invalid_argument _ ->
failwith "Failed to parse TEZOS_SIGNER_TCP_PORT.@." )
| (None, None, Some host, None) -> (
try
let port =
match Sys.getenv_opt "TEZOS_SIGNER_HTTP_PORT" with
| None ->
6732
| Some port ->
int_of_string port
in
return_some (Http.make_base host port)
with Invalid_argument _ ->
failwith "Failed to parse TEZOS_SIGNER_HTTP_PORT.@." )
| (None, None, None, Some host) -> (
try
let port =
match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_PORT" with
| None ->
443
| Some port ->
int_of_string port
in
return_some (Https.make_base host port)
with Invalid_argument _ ->
failwith "Failed to parse TEZOS_SIGNER_HTTPS_PORT.@." )
| (_, _, _, _) ->
failwith
"Only one the following environment variable must be defined: \
TEZOS_SIGNER_UNIX_PATH, TEZOS_SIGNER_TCP_HOST, \
TEZOS_SIGNER_HTTP_HOST, TEZOS_SIGNER_HTTPS_HOST@."
type error += Invalid_remote_signer of string
let () =
register_error_kind
`Branch
~id:"invalid_remote_signer"
~title:"Unexpected URI fot remote signer"
~description:"The provided remote signer is invalid."
~pp:(fun ppf s ->
Format.fprintf
ppf
"@[<v 0>Value '%s' is not a valid URI for a remote signer.@,\
Supported URIs for remote signers are of the form:@,\
\ - unix:///path/to/socket/file@,\
\ - tcp://host:port@,\
\ - http://host[:port][/prefix]@,\
\ - https://host[:port][/prefix]@]"
s)
Data_encoding.(obj1 (req "uri" string))
(function Invalid_remote_signer s -> Some s | _ -> None)
(fun s -> Invalid_remote_signer s)
let parse_base_uri s =
trace (Invalid_remote_signer s)
@@
try
let uri = Uri.of_string s in
match Uri.scheme uri with
| Some "http" ->
return uri
| Some "https" ->
return uri
| Some "tcp" ->
return uri
| Some "unix" ->
return uri
| Some scheme ->
failwith "Unknown scheme: %s" scheme
| None ->
failwith "Unknown scheme: <empty>"
with Invalid_argument msg -> failwith "Malformed URI: %s" msg
src/lib_signer_backends/unix/remote.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Client_keys.
Definition scheme : string := "remote" % string.
(* ❌ Functors are not handled. *)
functor
Definition make_sk (sk : Tezos_base__TzPervasives.Signature.Secret_key.t)
: Tezos_client_base.Client_keys.sk_uri :=
Client_keys.make_sk_uri
(Uri.make (Some scheme) None None None
(Some (Signature.Secret_key.to_b58check sk)) None None tt).
Definition make_pk (pk : Tezos_base__TzPervasives.Signature.Public_key.t)
: Tezos_client_base.Client_keys.pk_uri :=
Client_keys.make_pk_uri
(Uri.make (Some scheme) None None None
(Some (Signature.Public_key.to_b58check pk)) None None tt).
Definition read_base_uri_from_env (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult (option Uri.t)) :=
let 'tt := function_parameter in
match
((Sys.getenv_opt "TEZOS_SIGNER_UNIX_PATH" % string),
(Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST" % string),
(Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST" % string),
(Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" % string)) with
| (None, None, None, None) => return_none
| (Some path, None, None, None) => return_some (Socket.make_unix_base path)
| (None, Some host, None, None) =>
(* ❌ Try-with are not handled *)
try
(let port :=
match Sys.getenv_opt "TEZOS_SIGNER_TCP_PORT" % string with
| None => 7732
| Some port => OCaml.Stdlib.int_of_string port
end in
return_some (Socket.make_tcp_base host port))
| (None, None, Some host, None) =>
(* ❌ Try-with are not handled *)
try
(let port :=
match Sys.getenv_opt "TEZOS_SIGNER_HTTP_PORT" % string with
| None => 6732
| Some port => OCaml.Stdlib.int_of_string port
end in
return_some (Http.make_base host port))
| (None, None, None, Some host) =>
(* ❌ Try-with are not handled *)
try
(let port :=
match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_PORT" % string with
| None => 443
| Some port => OCaml.Stdlib.int_of_string port
end in
return_some (Https.make_base host port))
| (_, _, _, _) =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Only one the following environment variable must be defined: TEZOS_SIGNER_UNIX_PATH, TEZOS_SIGNER_TCP_HOST, TEZOS_SIGNER_HTTP_HOST, TEZOS_SIGNER_HTTPS_HOST"
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))
"Only one the following environment variable must be defined: TEZOS_SIGNER_UNIX_PATH, TEZOS_SIGNER_TCP_HOST, TEZOS_SIGNER_HTTP_HOST, TEZOS_SIGNER_HTTPS_HOST@."
% string)
end.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition parse_base_uri (s : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult Uri.t) :=
apply (trace (Tezos_base__TzPervasives.Invalid_remote_signer s))
(* ❌ Try-with are not handled *)
(try
(let uri := Uri.of_string s in
match Uri.scheme uri with
| Some "http" % string => _return uri
| Some "https" % string => _return uri
| Some "tcp" % string => _return uri
| Some "unix" % string => _return uri
| Some scheme =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Unknown scheme: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Unknown scheme: %s" % string) scheme
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown scheme: <empty>" % string
CamlinternalFormatBasics.End_of_format)
"Unknown scheme: <empty>" % string)
end)).
src/lib_signer_backends/unix/socket.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Client_keys
open Signer_messages
let tcp_scheme = "tcp"
let unix_scheme = "unix"
module Make (P : sig
val authenticate :
Signature.Public_key_hash.t list -> Bytes.t -> Signature.t tzresult Lwt.t
end) =
struct
type request_type =
| Sign_request
| Deterministic_nonce_request
| Deterministic_nonce_hash_request
let build_request pkh data signature = function
| Sign_request ->
Request.Sign {Sign.Request.pkh; data; signature}
| Deterministic_nonce_request ->
Request.Deterministic_nonce
{Deterministic_nonce.Request.pkh; data; signature}
| Deterministic_nonce_hash_request ->
Request.Deterministic_nonce_hash
{Deterministic_nonce_hash.Request.pkh; data; signature}
let signer_operation path pkh msg request_type =
Lwt_utils_unix.Socket.connect path
>>=? (fun conn ->
Lwt_utils_unix.Socket.send
conn
Request.encoding
Request.Authorized_keys
>>=? fun () ->
Lwt_utils_unix.Socket.recv
conn
(result_encoding Authorized_keys.Response.encoding)
>>=? fun authorized_keys ->
Lwt.return authorized_keys
>>=? fun authorized_keys ->
Lwt_unix.close conn
>>= fun () ->
match authorized_keys with
| No_authentication ->
return_none
| Authorized_keys authorized_keys ->
P.authenticate
authorized_keys
(Sign.Request.to_sign ~pkh ~data:msg)
>>=? fun signature -> return_some signature)
>>=? fun signature ->
Lwt_utils_unix.Socket.connect path
>>=? fun conn ->
let req = build_request pkh msg signature request_type in
Lwt_utils_unix.Socket.send conn Request.encoding req
>>=? fun () -> return conn
let sign ?watermark path pkh msg =
let msg =
match watermark with
| None ->
msg
| Some watermark ->
Bytes.cat (Signature.bytes_of_watermark watermark) msg
in
signer_operation path pkh msg Sign_request
>>=? fun conn ->
Lwt_utils_unix.Socket.recv conn (result_encoding Sign.Response.encoding)
>>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res
let deterministic_nonce path pkh msg =
signer_operation path pkh msg Deterministic_nonce_request
>>=? fun conn ->
Lwt_utils_unix.Socket.recv
conn
(result_encoding Deterministic_nonce.Response.encoding)
>>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res
let deterministic_nonce_hash path pkh msg =
signer_operation path pkh msg Deterministic_nonce_hash_request
>>=? fun conn ->
Lwt_utils_unix.Socket.recv
conn
(result_encoding Deterministic_nonce_hash.Response.encoding)
>>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res
let supports_deterministic_nonces path pkh =
Lwt_utils_unix.Socket.connect path
>>=? fun conn ->
Lwt_utils_unix.Socket.send
conn
Request.encoding
(Request.Supports_deterministic_nonces pkh)
>>=? fun () ->
Lwt_utils_unix.Socket.recv
conn
(result_encoding Supports_deterministic_nonces.Response.encoding)
>>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res
let public_key path pkh =
Lwt_utils_unix.Socket.connect path
>>=? fun conn ->
Lwt_utils_unix.Socket.send conn Request.encoding (Request.Public_key pkh)
>>=? fun () ->
let encoding = result_encoding Public_key.Response.encoding in
Lwt_utils_unix.Socket.recv conn encoding
>>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res
module Unix = struct
let scheme = unix_scheme
let title =
"Built-in tezos-signer using remote signer through hardcoded unix socket."
let description =
"Valid locators are of the form\n - unix:/path/to/socket?pkh=tz1..."
let parse uri =
assert (Uri.scheme uri = Some scheme) ;
trace (Invalid_uri uri)
@@
match Uri.get_query_param uri "pkh" with
| None ->
failwith "Missing the query parameter: 'pkh=tz1...'"
| Some key ->
Lwt.return (Signature.Public_key_hash.of_b58check key)
>>=? fun key ->
return (Lwt_utils_unix.Socket.Unix (Uri.path uri), key)
let public_key uri =
parse (uri : pk_uri :> Uri.t) >>=? fun (path, pkh) -> public_key path pkh
let neuterize uri =
return (Client_keys.make_pk_uri (uri : sk_uri :> Uri.t))
let public_key_hash uri =
public_key uri
>>=? fun pk -> return (Signature.Public_key.hash pk, Some pk)
let import_secret_key ~io:_ = public_key_hash
let sign ?watermark uri msg =
parse (uri : sk_uri :> Uri.t)
>>=? fun (path, pkh) -> sign ?watermark path pkh msg
let deterministic_nonce uri msg =
parse (uri : sk_uri :> Uri.t)
>>=? fun (path, pkh) -> deterministic_nonce path pkh msg
let deterministic_nonce_hash uri msg =
parse (uri : sk_uri :> Uri.t)
>>=? fun (path, pkh) -> deterministic_nonce_hash path pkh msg
let supports_deterministic_nonces uri =
parse (uri : sk_uri :> Uri.t)
>>=? fun (path, pkh) -> supports_deterministic_nonces path pkh
end
module Tcp = struct
let scheme = tcp_scheme
let title =
"Built-in tezos-signer using remote signer through hardcoded tcp socket."
let description =
"Valid locators are of the form\n - tcp://host:port/tz1..."
let parse uri =
assert (Uri.scheme uri = Some scheme) ;
trace (Invalid_uri uri)
@@
match (Uri.host uri, Uri.port uri) with
| (None, _) ->
failwith "Missing host address"
| (_, None) ->
failwith "Missing host port"
| (Some path, Some port) ->
let pkh = Uri.path uri in
let pkh = try String.(sub pkh 1 (length pkh - 1)) with _ -> "" in
Lwt.return (Signature.Public_key_hash.of_b58check pkh)
>>=? fun pkh ->
return
( Lwt_utils_unix.Socket.Tcp
(path, string_of_int port, [Lwt_unix.AI_SOCKTYPE SOCK_STREAM]),
pkh )
let public_key uri =
parse (uri : pk_uri :> Uri.t) >>=? fun (path, pkh) -> public_key path pkh
let neuterize uri =
return (Client_keys.make_pk_uri (uri : sk_uri :> Uri.t))
let public_key_hash uri =
public_key uri
>>=? fun pk -> return (Signature.Public_key.hash pk, Some pk)
let import_secret_key ~io:_ = public_key_hash
let sign ?watermark uri msg =
parse (uri : sk_uri :> Uri.t)
>>=? fun (path, pkh) -> sign ?watermark path pkh msg
let deterministic_nonce uri msg =
parse (uri : sk_uri :> Uri.t)
>>=? fun (path, pkh) -> deterministic_nonce path pkh msg
let deterministic_nonce_hash uri msg =
parse (uri : sk_uri :> Uri.t)
>>=? fun (path, pkh) -> deterministic_nonce_hash path pkh msg
let supports_deterministic_nonces uri =
parse (uri : sk_uri :> Uri.t)
>>=? fun (path, pkh) -> supports_deterministic_nonces path pkh
end
end
let make_unix_base path = Uri.make ~scheme:unix_scheme ~path ()
let make_tcp_base host port = Uri.make ~scheme:tcp_scheme ~host ~port ()
src/lib_signer_backends/unix/socket.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. Import Client_keys. Import Signer_messages. Definition tcp_scheme : string := "tcp" % string. Definition unix_scheme : string := "unix" % string. (* ❌ Functors are not handled. *) functor Definition make_unix_base (path : string) : Uri.t := Uri.make (Some unix_scheme) None None None (Some path) None None tt. Definition make_tcp_base (host : string) (port : Z) : Uri.t := Uri.make (Some tcp_scheme) None (Some host) (Some port) None None None tt.
src/lib_signer_backends/unix/test/test_crouching.ml 5 errors
let test_example () =
let name = Ledger_names.crouching_tiger "12345" in
assert (
name = {c = "calculating"; t = "meerkat"; h = "straight"; d = "beetle"} )
let tests = [Alcotest.test_case "print_example" `Quick test_example]
let () = Alcotest.run "tezos-signed-backends" [("ledger-names", tests)]
src/lib_signer_backends/unix/test/test_crouching.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition test_example (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let name := Ledger_names.crouching_tiger "12345" % string in
(* ❌ Assert instruction is not handled. *)
assert
(equiv_decb name
{| c := "calculating" % string; t := "meerkat" % string;
h := "straight" % string; d := "beetle" % string |}).
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "print_example" % string
(* ❌ Variants not supported *)
variant test_example) [].
src/lib_signer_services/signer_messages.ml 17 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type Authenticated_request = sig
type t = {
pkh : Signature.Public_key_hash.t;
data : Bytes.t;
signature : Signature.t option;
}
val to_sign : pkh:Signature.Public_key_hash.t -> data:Bytes.t -> Bytes.t
val encoding : t Data_encoding.t
end
module type Tag = sig
val tag : int
end
module Make_authenticated_request (T : Tag) : Authenticated_request = struct
type t = {
pkh : Signature.Public_key_hash.t;
data : Bytes.t;
signature : Signature.t option;
}
let to_sign ~pkh ~data =
let tag = Bytes.make 1 '0' in
TzEndian.set_int8 tag 0 T.tag ;
Bytes.concat
(Bytes.of_string "")
[ Bytes.of_string "\x04";
tag;
Signature.Public_key_hash.to_bytes pkh;
data ]
let encoding =
let open Data_encoding in
conv
(fun {pkh; data; signature} -> (pkh, data, signature))
(fun (pkh, data, signature) -> {pkh; data; signature})
(obj3
(req "pkh" Signature.Public_key_hash.encoding)
(req "data" bytes)
(opt "signature" Signature.encoding))
end
module Sign = struct
module Request = Make_authenticated_request (struct
let tag = 1
end)
module Response = struct
type t = Signature.t
let encoding =
let open Data_encoding in
def "signer_messages.sign.response"
@@ obj1 (req "signature" Signature.encoding)
end
end
module Deterministic_nonce = struct
module Request = Make_authenticated_request (struct
let tag = 2
end)
module Response = struct
type t = Bigstring.t
let bigstring =
let open Data_encoding in
conv Bigstring.to_bytes Bigstring.of_bytes bytes
let encoding =
let open Data_encoding in
def "signer_messages.deterministic_nonce.response"
@@ obj1 (req "deterministic_nonce" bigstring)
end
end
module Deterministic_nonce_hash = struct
module Request = Make_authenticated_request (struct
let tag = 3
end)
module Response = struct
type t = Bytes.t
let encoding =
let open Data_encoding in
def "signer_messages.deterministic_nonce_hash.response"
@@ obj1 (req "deterministic_nonce_hash" bytes)
end
end
module Supports_deterministic_nonces = struct
module Request = struct
type t = Signature.Public_key_hash.t
let encoding =
let open Data_encoding in
def "signer_messages.supports_deterministic_nonces.request"
@@ obj1 (req "pkh" Signature.Public_key_hash.encoding)
end
module Response = struct
type t = bool
let encoding =
let open Data_encoding in
def "signer_messages.supports_deterministic_nonces.response"
@@ obj1 (req "bool" bool)
end
end
module Public_key = struct
module Request = struct
type t = Signature.Public_key_hash.t
let encoding =
let open Data_encoding in
def "signer_messages.public_key.request"
@@ obj1 (req "pkh" Signature.Public_key_hash.encoding)
end
module Response = struct
type t = Signature.Public_key.t
let encoding =
let open Data_encoding in
def "signer_messages.public_key.response"
@@ obj1 (req "pubkey" Signature.Public_key.encoding)
end
end
module Authorized_keys = struct
module Response = struct
type t =
| No_authentication
| Authorized_keys of Signature.Public_key_hash.t list
let encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"No_authentication"
(constant "no_authentication_required")
(function No_authentication -> Some () | _ -> None)
(fun () -> No_authentication);
case
(Tag 1)
~title:"Authorized_keys"
(list Signature.Public_key_hash.encoding)
(function Authorized_keys l -> Some l | _ -> None)
(fun l -> Authorized_keys l) ]
end
end
module Request = struct
type t =
| Sign of Sign.Request.t
| Public_key of Public_key.Request.t
| Authorized_keys
| Deterministic_nonce of Deterministic_nonce.Request.t
| Deterministic_nonce_hash of Deterministic_nonce_hash.Request.t
| Supports_deterministic_nonces of Supports_deterministic_nonces.Request.t
let encoding =
let open Data_encoding in
def "signer_messages.request"
@@ union
[ case
(Tag 0)
~title:"Sign"
(merge_objs
(obj1 (req "kind" (constant "sign")))
Sign.Request.encoding)
(function Sign req -> Some ((), req) | _ -> None)
(fun ((), req) -> Sign req);
case
(Tag 1)
~title:"Public_key"
(merge_objs
(obj1 (req "kind" (constant "public_key")))
Public_key.Request.encoding)
(function Public_key req -> Some ((), req) | _ -> None)
(fun ((), req) -> Public_key req);
case
(Tag 2)
~title:"Authorized_keys"
(obj1 (req "kind" (constant "authorized_keys")))
(function Authorized_keys -> Some () | _ -> None)
(fun () -> Authorized_keys);
case
(Tag 3)
~title:"Deterministic_nonce"
(merge_objs
(obj1 (req "kind" (constant "deterministic_nonce")))
Deterministic_nonce.Request.encoding)
(function Deterministic_nonce req -> Some ((), req) | _ -> None)
(fun ((), req) -> Deterministic_nonce req);
case
(Tag 4)
~title:"Deterministic_nonce_hash"
(merge_objs
(obj1 (req "kind" (constant "deterministic_nonce_hash")))
Deterministic_nonce_hash.Request.encoding)
(function
| Deterministic_nonce_hash req -> Some ((), req) | _ -> None)
(fun ((), req) -> Deterministic_nonce_hash req);
case
(Tag 5)
~title:"Supports_deterministic_nonces"
(merge_objs
(obj1 (req "kind" (constant "supports_deterministic_nonces")))
Supports_deterministic_nonces.Request.encoding)
(function
| Supports_deterministic_nonces req ->
Some ((), req)
| _ ->
None)
(fun ((), req) -> Supports_deterministic_nonces req) ]
end
let () =
let open Tezos_data_encoding in
Data_encoding.Registration.register Request.encoding ;
Data_encoding.Registration.register Sign.Response.encoding ;
Data_encoding.Registration.register Deterministic_nonce.Response.encoding ;
Data_encoding.Registration.register
Deterministic_nonce_hash.Response.encoding ;
Data_encoding.Registration.register
Supports_deterministic_nonces.Response.encoding ;
Data_encoding.Registration.register Public_key.Response.encoding
src/lib_signer_services/signer_messages.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Authenticated_request.
Record signature {t : Type} := {
t := t;
to_sign : Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
Stdlib.Bytes.t -> Stdlib.Bytes.t;
encoding : Tezos_base__TzPervasives.Data_encoding.t t;
}.
Arguments signature : clear implicits.
End Authenticated_request.
Module Tag.
Record signature := {
tag : Z;
}.
End Tag.
(* ❌ Functors are not handled. *)
functor
Module Sign.
(* ❌ Applications of functors are not handled. *)
functor_application
Module Response.
Definition t := Tezos_base__TzPervasives.Signature.t.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_base__TzPervasives.Signature.t :=
apply
(let arg := def "signer_messages.sign.response" % string in
fun eta => arg None None eta)
(obj1 (req None None "signature" % string Signature.encoding)).
End Response.
End Sign.
Module Deterministic_nonce.
(* ❌ Applications of functors are not handled. *)
functor_application
Module Response.
Definition t := Bigstring.t.
Definition bigstring
: Tezos_base__TzPervasives.Data_encoding.encoding Bigstring.t :=
conv Bigstring.to_bytes Bigstring.of_bytes None bytes.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Bigstring.t :=
apply
(let arg := def "signer_messages.deterministic_nonce.response" % string
in
fun eta => arg None None eta)
(obj1 (req None None "deterministic_nonce" % string bigstring)).
End Response.
End Deterministic_nonce.
Module Deterministic_nonce_hash.
(* ❌ Applications of functors are not handled. *)
functor_application
Module Response.
Definition t := Stdlib.Bytes.t.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
apply
(let arg :=
def "signer_messages.deterministic_nonce_hash.response" % string in
fun eta => arg None None eta)
(obj1 (req None None "deterministic_nonce_hash" % string bytes)).
End Response.
End Deterministic_nonce_hash.
Module Supports_deterministic_nonces.
Module Request.
Definition t := Tezos_base__TzPervasives.Signature.Public_key_hash.t.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_base__TzPervasives.Signature.Public_key_hash.t :=
apply
(let arg :=
def "signer_messages.supports_deterministic_nonces.request" % string
in
fun eta => arg None None eta)
(obj1 (req None None "pkh" % string Signature.Public_key_hash.encoding)).
End Request.
Module Response.
Definition t := bool.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding bool :=
apply
(let arg :=
def "signer_messages.supports_deterministic_nonces.response" % string
in
fun eta => arg None None eta)
(obj1 (req None None "bool" % string bool)).
End Response.
End Supports_deterministic_nonces.
Module Public_key.
Module Request.
Definition t := Tezos_base__TzPervasives.Signature.Public_key_hash.t.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_base__TzPervasives.Signature.Public_key_hash.t :=
apply
(let arg := def "signer_messages.public_key.request" % string in
fun eta => arg None None eta)
(obj1 (req None None "pkh" % string Signature.Public_key_hash.encoding)).
End Request.
Module Response.
Definition t := Tezos_base__TzPervasives.Signature.Public_key.t.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
Tezos_base__TzPervasives.Signature.Public_key.t :=
apply
(let arg := def "signer_messages.public_key.response" % string in
fun eta => arg None None eta)
(obj1 (req None None "pubkey" % string Signature.Public_key.encoding)).
End Response.
End Public_key.
Module Authorized_keys.
Module Response.
Inductive t : Type :=
| No_authentication : t
| Authorized_keys :
(list Tezos_base__TzPervasives.Signature.Public_key_hash.t) -> t.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
union None
(cons
(case "No_authentication" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(constant "no_authentication_required" % string)
(fun function_parameter =>
match function_parameter with
| No_authentication => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
No_authentication))
(cons
(case "Authorized_keys" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(list None Signature.Public_key_hash.encoding)
(fun function_parameter =>
match function_parameter with
| Authorized_keys l => Some l
| _ => None
end) (fun l => Authorized_keys l)) [])).
End Response.
End Authorized_keys.
Module Request.
Inductive t : Type :=
| Sign : Sign.Request.(Authenticated_request.t) -> t
| Public_key : Public_key.Request.t -> t
| Authorized_keys : t
| Deterministic_nonce : Deterministic_nonce.Request.(Authenticated_request.t)
-> t
| Deterministic_nonce_hash :
Deterministic_nonce_hash.Request.(Authenticated_request.t) -> t
| Supports_deterministic_nonces : Supports_deterministic_nonces.Request.t -> t.
Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
apply
(let arg := def "signer_messages.request" % string in
fun eta => arg None None eta)
(union None
(cons
(case "Sign" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(merge_objs
(obj1 (req None None "kind" % string (constant "sign" % string)))
Sign.Request.(Authenticated_request.encoding))
(fun function_parameter =>
match function_parameter with
| Sign req => Some (tt, req)
| _ => None
end)
(fun function_parameter =>
let '(tt, req) := function_parameter in
Sign req))
(cons
(case "Public_key" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(merge_objs
(obj1
(req None None "kind" % string
(constant "public_key" % string)))
Public_key.Request.encoding)
(fun function_parameter =>
match function_parameter with
| Public_key req => Some (tt, req)
| _ => None
end)
(fun function_parameter =>
let '(tt, req) := function_parameter in
Public_key req))
(cons
(case "Authorized_keys" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 2)
(obj1
(req None None "kind" % string
(constant "authorized_keys" % string)))
(fun function_parameter =>
match function_parameter with
| Authorized_keys => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Authorized_keys))
(cons
(case "Deterministic_nonce" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 3)
(merge_objs
(obj1
(req None None "kind" % string
(constant "deterministic_nonce" % string)))
Deterministic_nonce.Request.(Authenticated_request.encoding))
(fun function_parameter =>
match function_parameter with
| Deterministic_nonce req => Some (tt, req)
| _ => None
end)
(fun function_parameter =>
let '(tt, req) := function_parameter in
Deterministic_nonce req))
(cons
(case "Deterministic_nonce_hash" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 4)
(merge_objs
(obj1
(req None None "kind" % string
(constant "deterministic_nonce_hash" % string)))
Deterministic_nonce_hash.Request.(Authenticated_request.encoding))
(fun function_parameter =>
match function_parameter with
| Deterministic_nonce_hash req => Some (tt, req)
| _ => None
end)
(fun function_parameter =>
let '(tt, req) := function_parameter in
Deterministic_nonce_hash req))
(cons
(case "Supports_deterministic_nonces" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 5)
(merge_objs
(obj1
(req None None "kind" % string
(constant "supports_deterministic_nonces" % string)))
Supports_deterministic_nonces.Request.encoding)
(fun function_parameter =>
match function_parameter with
| Supports_deterministic_nonces req => Some (tt, req)
| _ => None
end)
(fun function_parameter =>
let '(tt, req) := function_parameter in
Supports_deterministic_nonces req)) []))))))).
End Request.
src/lib_signer_services/signer_services.ml 20 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let query =
let open RPC_query in
query (fun signature -> signature)
|+ opt_field
~descr:
"Must be provided if the signer requires authentication. In this \
case, it must be the signature of the public key hash and message \
concatenated, by one of the keys authorized by the signer."
"authentication"
Signature.rpc_arg
(fun signature -> signature)
|> seal
let sign =
RPC_service.post_service
~description:"Sign a piece of data with a given remote key"
~query
~input:Data_encoding.bytes
~output:Data_encoding.(obj1 (req "signature" Signature.encoding))
RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)
let bigstring =
let open Data_encoding in
conv Bigstring.to_bytes Bigstring.of_bytes bytes
let deterministic_nonce =
RPC_service.post_service
~description:
"Obtain some random data generated deterministically from some piece of \
data with a given remote key"
~query
~input:Data_encoding.bytes
~output:Data_encoding.(obj1 (req "deterministic_nonce" bigstring))
RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)
let deterministic_nonce_hash =
RPC_service.post_service
~description:
"Obtain the hash of some random data generated deterministically from \
some piece of data with a given remote key"
~query
~input:Data_encoding.bytes
~output:Data_encoding.(obj1 (req "deterministic_nonce_hash" bytes))
RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)
let supports_deterministic_nonces =
RPC_service.get_service
~description:
"Obtain whether the signing service suppports the determinstic nonces \
functionality"
~query:RPC_query.empty
~output:Data_encoding.(obj1 (req "supports_deterministic_nonces" bool))
RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)
let public_key =
RPC_service.get_service
~description:"Retrieve the public key of a given remote key"
~query:RPC_query.empty
~output:
Data_encoding.(obj1 (req "public_key" Signature.Public_key.encoding))
RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)
let authorized_keys =
RPC_service.get_service
~description:
"Retrieve the public keys that can be used to authenticate signing \
commands.\n\
If the empty object is returned, the signer has been set to accept \
unsigned commands."
~query:RPC_query.empty
~output:
Data_encoding.(
obj1 (opt "authorized_keys" (list Signature.Public_key_hash.encoding)))
RPC_path.(root / "authorized_keys")
src/lib_signer_services/signer_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition query
: Tezos_rpc.RPC_query.t (option Tezos_base__TzPervasives.Signature.t) :=
OCaml.Stdlib.reverse_apply
(op_pipeplus (query (fun signature => signature))
(opt_field
(Some
"Must be provided if the signer requires authentication. In this case, it must be the signature of the public key hash and message concatenated, by one of the keys authorized by the signer."
% string) "authentication" % string Signature.rpc_arg
(fun signature => signature))) seal.
Definition sign
: Tezos_rpc.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(option Tezos_base__TzPervasives.Signature.t) Stdlib.Bytes.t
Tezos_base__TzPervasives.Signature.t :=
RPC_service.post_service
(Some "Sign a piece of data with a given remote key" % string) query
Data_encoding.bytes
(obj1 (req None None "signature" % string Signature.encoding))
(op_divcolon (op_div root "keys" % string) Signature.Public_key_hash.rpc_arg).
Definition bigstring
: Tezos_base__TzPervasives.Data_encoding.encoding Bigstring.t :=
conv Bigstring.to_bytes Bigstring.of_bytes None bytes.
Definition deterministic_nonce
: Tezos_rpc.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(option Tezos_base__TzPervasives.Signature.t) Stdlib.Bytes.t Bigstring.t :=
RPC_service.post_service
(Some
"Obtain some random data generated deterministically from some piece of data with a given remote key"
% string) query Data_encoding.bytes
(obj1 (req None None "deterministic_nonce" % string bigstring))
(op_divcolon (op_div root "keys" % string) Signature.Public_key_hash.rpc_arg).
Definition deterministic_nonce_hash
: Tezos_rpc.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(option Tezos_base__TzPervasives.Signature.t) Stdlib.Bytes.t Stdlib.Bytes.t :=
RPC_service.post_service
(Some
"Obtain the hash of some random data generated deterministically from some piece of data with a given remote key"
% string) query Data_encoding.bytes
(obj1 (req None None "deterministic_nonce_hash" % string bytes))
(op_divcolon (op_div root "keys" % string) Signature.Public_key_hash.rpc_arg).
Definition supports_deterministic_nonces
: Tezos_rpc.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t) unit unit bool :=
RPC_service.get_service
(Some
"Obtain whether the signing service suppports the determinstic nonces functionality"
% string) RPC_query.empty
(obj1 (req None None "supports_deterministic_nonces" % string bool))
(op_divcolon (op_div root "keys" % string) Signature.Public_key_hash.rpc_arg).
Definition public_key
: Tezos_rpc.RPC_service.service variant unit
(unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t) unit unit
Tezos_base__TzPervasives.Signature.Public_key.t :=
RPC_service.get_service
(Some "Retrieve the public key of a given remote key" % string)
RPC_query.empty
(obj1 (req None None "public_key" % string Signature.Public_key.encoding))
(op_divcolon (op_div root "keys" % string) Signature.Public_key_hash.rpc_arg).
Definition authorized_keys
: Tezos_rpc.RPC_service.service variant unit unit unit unit
(option (list Tezos_base__TzPervasives.Signature.Public_key_hash.t)) :=
RPC_service.get_service
(Some
"Retrieve the public keys that can be used to authenticate signing commands.
If the empty object is returned, the signer has been set to accept unsigned commands."
% string) RPC_query.empty
(obj1
(opt None None "authorized_keys" % string
(list None Signature.Public_key_hash.encoding)))
(op_div root "authorized_keys" % string).
src/lib_stdlib/bytes_encodings.ml success
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* this module is a temporary fix waiting for ocaml 4.08 *)
(** {1 Binary encoding/decoding of integers} *)
external get_uint8 : bytes -> int -> int = "%bytes_safe_get"
external get_uint16_ne : bytes -> int -> int = "%caml_bytes_get16"
external get_int32_ne : bytes -> int -> int32 = "%caml_bytes_get32"
external get_int64_ne : bytes -> int -> int64 = "%caml_bytes_get64"
external set_int8 : bytes -> int -> int -> unit = "%bytes_safe_set"
external set_int16_ne : bytes -> int -> int -> unit = "%caml_bytes_set16"
external set_int32_ne : bytes -> int -> int32 -> unit = "%caml_bytes_set32"
external set_int64_ne : bytes -> int -> int64 -> unit = "%caml_bytes_set64"
external swap16 : int -> int = "%bswap16"
external swap32 : int32 -> int32 = "%bswap_int32"
external swap64 : int64 -> int64 = "%bswap_int64"
let get_int8 b i = (get_uint8 b i lsl (Sys.int_size - 8)) asr (Sys.int_size - 8)
let get_uint16_le b i =
if Sys.big_endian then swap16 (get_uint16_ne b i) else get_uint16_ne b i
let get_uint16_be b i =
if not Sys.big_endian then swap16 (get_uint16_ne b i) else get_uint16_ne b i
let get_int16_ne b i =
(get_uint16_ne b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
let get_int16_le b i =
(get_uint16_le b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
let get_int16_be b i =
(get_uint16_be b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
let get_int32_le b i =
if Sys.big_endian then swap32 (get_int32_ne b i) else get_int32_ne b i
let get_int32_be b i =
if not Sys.big_endian then swap32 (get_int32_ne b i) else get_int32_ne b i
let get_int64_le b i =
if Sys.big_endian then swap64 (get_int64_ne b i) else get_int64_ne b i
let get_int64_be b i =
if not Sys.big_endian then swap64 (get_int64_ne b i) else get_int64_ne b i
let set_int16_le b i x =
if Sys.big_endian then set_int16_ne b i (swap16 x) else set_int16_ne b i x
let set_int16_be b i x =
if not Sys.big_endian then set_int16_ne b i (swap16 x)
else set_int16_ne b i x
let set_int32_le b i x =
if Sys.big_endian then set_int32_ne b i (swap32 x) else set_int32_ne b i x
let set_int32_be b i x =
if not Sys.big_endian then set_int32_ne b i (swap32 x)
else set_int32_ne b i x
let set_int64_le b i x =
if Sys.big_endian then set_int64_ne b i (swap64 x) else set_int64_ne b i x
let set_int64_be b i x =
if not Sys.big_endian then set_int64_ne b i (swap64 x)
else set_int64_ne b i x
let set_uint8 = set_int8
let set_uint16_ne = set_int16_ne
let set_uint16_be = set_int16_be
let set_uint16_le = set_int16_le
module type S = sig
(** {1 Binary encoding/decoding of integers} *)
(** The functions in this section binary encode and decode integers to
and from byte sequences.
All following functions raise [Invalid_argument] if the space
needed at index [i] to decode or encode the integer is not
available.
Little-endian (resp. big-endian) encoding means that least
(resp. most) significant bytes are stored first. Big-endian is
also known as network byte order. Native-endian encoding is
either little-endian or big-endian depending on {!Sys.big_endian}.
32-bit and 64-bit integers are represented by the [int32] and
[int64] types, which can be interpreted either as signed or
unsigned numbers.
8-bit and 16-bit integers are represented by the [int] type,
which has more bits than the binary encoding. These extra bits
are handled as follows:
{ul
{- Functions that decode signed (resp. unsigned) 8-bit or 16-bit
integers represented by [int] values sign-extend
(resp. zero-extend) their result.}
{- Functions that encode 8-bit or 16-bit integers represented by
[int] values truncate their input to their least significant
bytes.}
}
*)
(** [get_uint8 b i] is [b]'s unsigned 8-bit integer starting at byte index [i].
@since 4.08
*)
val get_uint8 : bytes -> int -> int
(** [get_int8 b i] is [b]'s signed 8-bit integer starting at byte index [i].
@since 4.08
*)
val get_int8 : bytes -> int -> int
(** [get_uint16_ne b i] is [b]'s native-endian unsigned 16-bit integer
starting at byte index [i].
@since 4.08
*)
val get_uint16_ne : bytes -> int -> int
(** [get_uint16_be b i] is [b]'s big-endian unsigned 16-bit integer
starting at byte index [i].
@since 4.08
*)
val get_uint16_be : bytes -> int -> int
(** [get_uint16_le b i] is [b]'s little-endian unsigned 16-bit integer
starting at byte index [i].
@since 4.08
*)
val get_uint16_le : bytes -> int -> int
(** [get_int16_ne b i] is [b]'s native-endian signed 16-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int16_ne : bytes -> int -> int
(** [get_int16_be b i] is [b]'s big-endian signed 16-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int16_be : bytes -> int -> int
(** [get_int16_le b i] is [b]'s little-endian signed 16-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int16_le : bytes -> int -> int
(** [get_int32_ne b i] is [b]'s native-endian 32-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int32_ne : bytes -> int -> int32
(** [get_int32_be b i] is [b]'s big-endian 32-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int32_be : bytes -> int -> int32
(** [get_int32_le b i] is [b]'s little-endian 32-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int32_le : bytes -> int -> int32
(** [get_int64_ne b i] is [b]'s native-endian 64-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int64_ne : bytes -> int -> int64
(** [get_int64_be b i] is [b]'s big-endian 64-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int64_be : bytes -> int -> int64
(** [get_int64_le b i] is [b]'s little-endian 64-bit integer
starting at byte index [i].
@since 4.08
*)
val get_int64_le : bytes -> int -> int64
(** [set_uint8 b i v] sets [b]'s unsigned 8-bit integer starting at byte index
[i] to [v].
@since 4.08
*)
val set_uint8 : bytes -> int -> int -> unit
(** [set_int8 b i v] sets [b]'s signed 8-bit integer starting at byte index
[i] to [v].
@since 4.08
*)
val set_int8 : bytes -> int -> int -> unit
(** [set_uint16_ne b i v] sets [b]'s native-endian unsigned 16-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_uint16_ne : bytes -> int -> int -> unit
(** [set_uint16_be b i v] sets [b]'s big-endian unsigned 16-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_uint16_be : bytes -> int -> int -> unit
(** [set_uint16_le b i v] sets [b]'s little-endian unsigned 16-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_uint16_le : bytes -> int -> int -> unit
(** [set_int16_ne b i v] sets [b]'s native-endian signed 16-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int16_ne : bytes -> int -> int -> unit
(** [set_int16_be b i v] sets [b]'s big-endian signed 16-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int16_be : bytes -> int -> int -> unit
(** [set_int16_le b i v] sets [b]'s little-endian signed 16-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int16_le : bytes -> int -> int -> unit
(** [set_int32_ne b i v] sets [b]'s native-endian 32-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int32_ne : bytes -> int -> int32 -> unit
(** [set_int32_be b i v] sets [b]'s big-endian 32-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int32_be : bytes -> int -> int32 -> unit
(** [set_int32_le b i v] sets [b]'s little-endian 32-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int32_le : bytes -> int -> int32 -> unit
(** [set_int64_ne b i v] sets [b]'s native-endian 64-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int64_ne : bytes -> int -> int64 -> unit
(** [set_int64_be b i v] sets [b]'s big-endian 64-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int64_be : bytes -> int -> int64 -> unit
(** [set_int64_le b i v] sets [b]'s little-endian 64-bit integer
starting at byte index [i] to [v].
@since 4.08
*)
val set_int64_le : bytes -> int -> int64 -> unit
end
src/lib_stdlib/bytes_encodings.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Parameter get_uint8 : string -> Z -> Z.
Parameter get_uint16_ne : string -> Z -> Z.
Parameter get_int32_ne : string -> Z -> int32.
Parameter get_int64_ne : string -> Z -> int64.
Parameter set_int8 : string -> Z -> Z -> unit.
Parameter set_int16_ne : string -> Z -> Z -> unit.
Parameter set_int32_ne : string -> Z -> int32 -> unit.
Parameter set_int64_ne : string -> Z -> int64 -> unit.
Parameter swap16 : Z -> Z.
Parameter swap32 : int32 -> int32.
Parameter swap64 : int64 -> int64.
Definition get_int8 (b : string) (i : Z) : Z :=
Stdlib.asr (Z.shiftl (get_uint8 b i) (Z.sub Sys.int_size 8))
(Z.sub Sys.int_size 8).
Definition get_uint16_le (b : string) (i : Z) : Z :=
if Sys.big_endian then
swap16 (get_uint16_ne b i)
else
get_uint16_ne b i.
Definition get_uint16_be (b : string) (i : Z) : Z :=
if negb Sys.big_endian then
swap16 (get_uint16_ne b i)
else
get_uint16_ne b i.
Definition get_int16_ne (b : string) (i : Z) : Z :=
Stdlib.asr (Z.shiftl (get_uint16_ne b i) (Z.sub Sys.int_size 16))
(Z.sub Sys.int_size 16).
Definition get_int16_le (b : string) (i : Z) : Z :=
Stdlib.asr (Z.shiftl (get_uint16_le b i) (Z.sub Sys.int_size 16))
(Z.sub Sys.int_size 16).
Definition get_int16_be (b : string) (i : Z) : Z :=
Stdlib.asr (Z.shiftl (get_uint16_be b i) (Z.sub Sys.int_size 16))
(Z.sub Sys.int_size 16).
Definition get_int32_le (b : string) (i : Z) : int32 :=
if Sys.big_endian then
swap32 (get_int32_ne b i)
else
get_int32_ne b i.
Definition get_int32_be (b : string) (i : Z) : int32 :=
if negb Sys.big_endian then
swap32 (get_int32_ne b i)
else
get_int32_ne b i.
Definition get_int64_le (b : string) (i : Z) : int64 :=
if Sys.big_endian then
swap64 (get_int64_ne b i)
else
get_int64_ne b i.
Definition get_int64_be (b : string) (i : Z) : int64 :=
if negb Sys.big_endian then
swap64 (get_int64_ne b i)
else
get_int64_ne b i.
Definition set_int16_le (b : string) (i : Z) (x : Z) : unit :=
if Sys.big_endian then
set_int16_ne b i (swap16 x)
else
set_int16_ne b i x.
Definition set_int16_be (b : string) (i : Z) (x : Z) : unit :=
if negb Sys.big_endian then
set_int16_ne b i (swap16 x)
else
set_int16_ne b i x.
Definition set_int32_le (b : string) (i : Z) (x : int32) : unit :=
if Sys.big_endian then
set_int32_ne b i (swap32 x)
else
set_int32_ne b i x.
Definition set_int32_be (b : string) (i : Z) (x : int32) : unit :=
if negb Sys.big_endian then
set_int32_ne b i (swap32 x)
else
set_int32_ne b i x.
Definition set_int64_le (b : string) (i : Z) (x : int64) : unit :=
if Sys.big_endian then
set_int64_ne b i (swap64 x)
else
set_int64_ne b i x.
Definition set_int64_be (b : string) (i : Z) (x : int64) : unit :=
if negb Sys.big_endian then
set_int64_ne b i (swap64 x)
else
set_int64_ne b i x.
Definition set_uint8 : string -> Z -> Z -> unit := set_int8.
Definition set_uint16_ne : string -> Z -> Z -> unit := set_int16_ne.
Definition set_uint16_be : string -> Z -> Z -> unit := set_int16_be.
Definition set_uint16_le : string -> Z -> Z -> unit := set_int16_le.
Module S.
Record signature := {
get_uint8 : string -> Z -> Z;
get_int8 : string -> Z -> Z;
get_uint16_ne : string -> Z -> Z;
get_uint16_be : string -> Z -> Z;
get_uint16_le : string -> Z -> Z;
get_int16_ne : string -> Z -> Z;
get_int16_be : string -> Z -> Z;
get_int16_le : string -> Z -> Z;
get_int32_ne : string -> Z -> int32;
get_int32_be : string -> Z -> int32;
get_int32_le : string -> Z -> int32;
get_int64_ne : string -> Z -> int64;
get_int64_be : string -> Z -> int64;
get_int64_le : string -> Z -> int64;
set_uint8 : string -> Z -> Z -> unit;
set_int8 : string -> Z -> Z -> unit;
set_uint16_ne : string -> Z -> Z -> unit;
set_uint16_be : string -> Z -> Z -> unit;
set_uint16_le : string -> Z -> Z -> unit;
set_int16_ne : string -> Z -> Z -> unit;
set_int16_be : string -> Z -> Z -> unit;
set_int16_le : string -> Z -> Z -> unit;
set_int32_ne : string -> Z -> int32 -> unit;
set_int32_be : string -> Z -> int32 -> unit;
set_int32_le : string -> Z -> int32 -> unit;
set_int64_ne : string -> Z -> int64 -> unit;
set_int64_be : string -> Z -> int64 -> unit;
set_int64_le : string -> Z -> int64 -> unit;
}.
End S.
src/lib_stdlib/compare.ml 14 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type COMPARABLE = sig
type t
val compare : t -> t -> int
end
module type S = sig
type t
val ( = ) : t -> t -> bool
val ( <> ) : t -> t -> bool
val ( < ) : t -> t -> bool
val ( <= ) : t -> t -> bool
val ( >= ) : t -> t -> bool
val ( > ) : t -> t -> bool
val compare : t -> t -> int
val equal : t -> t -> bool
val max : t -> t -> t
val min : t -> t -> t
end
module Make (P : COMPARABLE) = struct
include P
let compare = compare
let ( = ) a b = compare a b = 0
let ( <> ) a b = compare a b <> 0
let ( < ) a b = compare a b < 0
let ( <= ) a b = compare a b <= 0
let ( >= ) a b = compare a b >= 0
let ( > ) a b = compare a b > 0
let equal = ( = )
let max x y = if x >= y then x else y
let min x y = if x <= y then x else y
end
module List (P : COMPARABLE) = struct
type t = P.t list
let rec compare xs ys =
match (xs, ys) with
| ([], []) ->
0
| ([], _) ->
-1
| (_, []) ->
1
| (x :: xs, y :: ys) ->
let hd = P.compare x y in
if hd <> 0 then hd else compare xs ys
let ( = ) xs ys = compare xs ys = 0
let ( <> ) xs ys = compare xs ys <> 0
let ( < ) xs ys = compare xs ys < 0
let ( <= ) xs ys = compare xs ys <= 0
let ( >= ) xs ys = compare xs ys >= 0
let ( > ) xs ys = compare xs ys > 0
let equal = ( = )
let max x y = if x >= y then x else y
let min x y = if x <= y then x else y
end
module Option (P : COMPARABLE) = struct
type t = P.t option
let compare xs ys =
match (xs, ys) with
| (None, None) ->
0
| (None, _) ->
-1
| (_, None) ->
1
| (Some x, Some y) ->
P.compare x y
let ( = ) xs ys = compare xs ys = 0
let ( <> ) xs ys = compare xs ys <> 0
let ( < ) xs ys = compare xs ys < 0
let ( <= ) xs ys = compare xs ys <= 0
let ( >= ) xs ys = compare xs ys >= 0
let ( > ) xs ys = compare xs ys > 0
let equal = ( = )
let max x y = if x >= y then x else y
let min x y = if x <= y then x else y
end
module Char = Make (Char)
module Bool = Make (struct
type t = bool
let compare = Pervasives.compare
end)
module Int = Make (struct
type t = int
let compare = Pervasives.compare
end)
module Int32 = Make (Int32)
module Int64 = Make (Int64)
module MakeUnsigned
(Int : S) (Z : sig
val zero : Int.t
end) =
struct
type t = Int.t
let compare va vb =
Int.(
if va >= Z.zero then if vb >= Z.zero then compare va vb else -1
else if vb >= Z.zero then 1
else compare va vb)
let ( = ) = (( = ) : t -> t -> bool)
let ( <> ) = (( <> ) : t -> t -> bool)
let ( < ) a b =
Int.(if Z.zero <= a then a < b || b < Z.zero else b < Z.zero && a < b)
let ( <= ) a b =
Int.(if Z.zero <= a then a <= b || b < Z.zero else b < Z.zero && a <= b)
let ( >= ) a b = b <= a
let ( > ) a b = b < a
let equal = ( = )
let max x y = if x >= y then x else y
let min x y = if x <= y then x else y
end
module Uint32 =
MakeUnsigned
(Int32)
(struct
let zero = 0l
end)
module Uint64 =
MakeUnsigned
(Int64)
(struct
let zero = 0L
end)
module Float = Make (struct
type t = float
let compare = Pervasives.compare
end)
module String = Make (String)
module Z = Make (Z)
src/lib_stdlib/compare.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module COMPARABLE.
Record signature {t : Type} := {
t := t;
compare : t -> t -> Z;
}.
Arguments signature : clear implicits.
End COMPARABLE.
Module S.
Record signature {t : Type} := {
t := t;
op_eq : t -> t -> bool;
op_ltgt : t -> t -> bool;
op_lt : t -> t -> bool;
op_lteq : t -> t -> bool;
op_gteq : t -> t -> bool;
op_gt : t -> t -> bool;
compare : t -> t -> Z;
equal : t -> t -> bool;
max : t -> t -> t;
min : t -> t -> t;
}.
Arguments signature : clear implicits.
End S.
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Functors are not handled. *)
functor
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
src/lib_stdlib/hashPtree.ml 28 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Ptree_sig = struct
module type Value = sig
type t
val equal : t -> t -> bool
val hash : t -> int
end
type prefix_order = Equal | Shorter | Longer | Different
module type Prefix = sig
type key (* bit sequence *)
type prefix (* prefix of a bit sequence *)
type mask (* integer length of a bit sequence *)
val equal_key : key -> key -> bool
val equal_mask : mask -> mask -> bool
val equal_prefix : prefix -> prefix -> bool
val hash_key : key -> int
val hash_mask : mask -> int
val hash_prefix : prefix -> int
val full_length_mask : mask
val strictly_shorter_mask : mask -> mask -> bool
val key_prefix : key -> prefix
(* Full length prefix *)
val prefix_key : prefix -> mask -> key
(* Some key matching the prefix with the given mask *)
val match_prefix : key:key -> prefix:prefix -> mask:mask -> bool
(* Does the prefix of length [mask] of [key] equals to [prefix] *)
val select_bit : prefix:prefix -> mask:mask -> bool
(* Get the bit of [prefix] at position [mask] assumes that [mask] is
less than the length of prefix *)
val common_mask : prefix -> prefix -> mask
(* The length of the common part of given prefixes *)
val apply_mask : prefix -> mask -> prefix
(* Cut the prefix to the given length *)
val compare_prefix : mask -> prefix -> mask -> prefix -> prefix_order
(* [compare_prefix m1 p1 m2 p2]:
let p1' (resp p2') be the sub-prefix of length m1 of p1 (resp m2 of p2)
The result is
Equal if p1' equal p2'
Shorter if p1' is a prefix of p2'
Longer if p2' is a prefix of p1'
Different if those not ordered
*)
end
module type S = sig
type key
type prefix
type mask
type value
type not_empty = TNot_empty
type empty = TEmpty
type _ t = private
| Leaf : {
mutable id : int;
(* Mutable to get a good sharing semantics *)
mask : mask;
key : key;
value : value;
}
-> not_empty t
| Node : {
mutable id : int;
mask : mask;
prefix : prefix;
true_ : not_empty t;
false_ : not_empty t;
}
-> not_empty t
| Empty : empty t
val leaf : key:key -> mask:mask -> value -> not_empty t
val node :
prefix:prefix ->
mask:mask ->
true_:not_empty t ->
false_:not_empty t ->
not_empty t
val empty : empty t
val equal : not_empty t -> not_empty t -> bool
val fast_partial_equal : not_empty t -> not_empty t -> bool
(* if [fast_partial_equal x y] is true, then [equal x y] is true,
but if fast_partial_equal returns false, nothing can be
asserted. *)
val id : not_empty t -> int
end
end
module Shared_tree : sig
module Hash_consed_tree (P : Ptree_sig.Prefix) (V : Ptree_sig.Value) :
Ptree_sig.S
with type value = V.t
and type key = P.key
and type prefix = P.prefix
and type mask = P.mask
module Simple_tree
(P : Ptree_sig.Prefix) (V : sig
type t
val equal : t -> t -> bool
end) :
Ptree_sig.S
with type value = V.t
and type key = P.key
and type prefix = P.prefix
and type mask = P.mask
end = struct
open Ptree_sig
(*
type int2 = { mutable i1 : int; mutable i2 : int }
let h2 = { i1 = 0; i2 = 0 }
let hash2int x1 x2 =
h2.i1 <- x1; h2.i2 <- x2;
Hashtbl.hash h2
*)
type int3 = {mutable i1 : int; mutable i2 : int; mutable i3 : int}
let h3 = {i1 = 0; i2 = 0; i3 = 0}
let hash3int x1 x2 x3 =
h3.i1 <- x1 ;
h3.i2 <- x2 ;
h3.i3 <- x3 ;
Hashtbl.hash h3
type int4 = {
mutable i1 : int;
mutable i2 : int;
mutable i3 : int;
mutable i4 : int;
}
let h4 = {i1 = 0; i2 = 0; i3 = 0; i4 = 0}
let hash4int x1 x2 x3 x4 =
h4.i1 <- x1 ;
h4.i2 <- x2 ;
h4.i3 <- x3 ;
h4.i4 <- x4 ;
Hashtbl.hash h4
module Hash_consed_tree (P : Prefix) (V : Value) :
S
with type value = V.t
and type key = P.key
and type prefix = P.prefix
and type mask = P.mask = struct
type key = P.key
type mask = P.mask
type prefix = P.prefix
type value = V.t
type not_empty = TNot_empty
type empty = TEmpty
type _ t =
| Leaf : {
mutable id : int;
(* Mutable to get a good sharing semantics *)
mask : mask;
key : key;
value : value;
}
-> not_empty t
| Node : {
mutable id : int;
mask : mask;
prefix : prefix;
true_ : not_empty t;
false_ : not_empty t;
}
-> not_empty t
| Empty : empty t
let id : not_empty t -> int = function
| Leaf {id; _} ->
id
| Node {id; _} ->
id
let set_id (n : not_empty t) id =
match n with Leaf r -> r.id <- id | Node r -> r.id <- id
(*let mask : not_empty t -> mask = function
| Leaf { mask ; _ } -> mask
| Node { mask ; _ } -> mask
*)
(* let prefix_table = WeakPrefixTbl.create 20 *)
module Tree : Hashtbl.HashedType with type t = not_empty t = struct
type nonrec t = not_empty t
let equal (t1 : t) (t2 : t) =
match (t1, t2) with
| (Leaf _, Node _) | (Node _, Leaf _) ->
false
| ( Leaf {key = p1; value = v1; mask = m1; _},
Leaf {key = p2; value = v2; mask = m2; _} ) ->
P.equal_key p1 p2 && P.equal_mask m1 m2 && V.equal v1 v2
| ( Node {prefix = p1; mask = m1; true_ = t1; false_ = f1; _},
Node {prefix = p2; mask = m2; true_ = t2; false_ = f2; _} ) ->
(* Assumes that only the head can be unshared: this means
that structural equality implies physical one on children *)
P.equal_prefix p1 p2 && P.equal_mask m1 m2 && t1 == t2 && f1 == f2
let hash : t -> int = function
| Leaf {key; value; mask; _} ->
hash3int (P.hash_key key) (V.hash value) (P.hash_mask mask)
| Node {mask; prefix; true_; false_; _} ->
hash4int
(P.hash_mask mask)
(P.hash_prefix prefix)
(id true_)
(id false_)
end
module WeakTreeTbl = Weak.Make (Tree)
(* Or move that to a state ? *)
let weak_tree_tbl = WeakTreeTbl.create 10
let next =
let r = ref 0 in
fun () -> incr r ; !r
let leaf ~key ~mask value =
let l = Leaf {id = 0; key; value; mask} in
match WeakTreeTbl.find_opt weak_tree_tbl l with
| None ->
set_id l (next ()) ;
WeakTreeTbl.add weak_tree_tbl l ;
l
| Some l ->
l
let node ~prefix ~mask ~true_ ~false_ =
let l = Node {id = 0; mask; prefix; true_; false_} in
match WeakTreeTbl.find_opt weak_tree_tbl l with
| None ->
set_id l (next ()) ;
WeakTreeTbl.add weak_tree_tbl l ;
l
| Some l ->
l
let empty = Empty
let equal (x : not_empty t) (y : not_empty t) = x == y
let fast_partial_equal = equal
end
[@@inline]
module Simple_tree
(P : Ptree_sig.Prefix) (V : sig
type t
val equal : t -> t -> bool
end) :
S
with type value = V.t
and type key = P.key
and type prefix = P.prefix
and type mask = P.mask = struct
type key = P.key
type mask = P.mask
type prefix = P.prefix
type value = V.t
type not_empty = TNot_empty
type empty = TEmpty
type _ t =
| Leaf : {
mutable id : int;
(* Mutable to get a good sharing semantics *)
mask : mask;
key : key;
value : value;
}
-> not_empty t
| Node : {
mutable id : int;
mask : mask;
prefix : prefix;
true_ : not_empty t;
false_ : not_empty t;
}
-> not_empty t
| Empty : empty t
let id : not_empty t -> int = function
| Leaf {id; _} ->
id
| Node {id; _} ->
id
(*let set_id (n : not_empty t) id = match n with
| Leaf r -> r.id <- id
| Node r -> r.id <- id
let mask : not_empty t -> mask = function
| Leaf { mask ; _ } -> mask
| Node { mask ; _ } -> mask
*)
let leaf ~key ~mask value = Leaf {id = 0; key; value; mask}
let node ~prefix ~mask ~true_ ~false_ =
Node {id = 0; mask; prefix; true_; false_}
let empty = Empty
let rec equal_not_empty (x : not_empty t) (y : not_empty t) =
x == y
||
match (x, y) with
| (Leaf l1, Leaf l2) ->
P.equal_key l1.key l2.key && V.equal l1.value l2.value
| (Node n1, Node n2) ->
P.equal_prefix n1.prefix n2.prefix
&& P.equal_mask n1.mask n2.mask
&& equal_not_empty n1.true_ n2.true_
&& equal_not_empty n1.false_ n2.false_
| (Node _, Leaf _) | (Leaf _, Node _) ->
false
let equal : type a b. a t -> b t -> bool =
fun x y ->
match (x, y) with
| (Empty, Empty) ->
true
| (Leaf _, Leaf _) ->
equal_not_empty x y
| (Node _, Node _) ->
equal_not_empty x y
| (_, _) ->
false
let fast_partial_equal (x : not_empty t) (y : not_empty t) = x == y
end
[@@inline]
end
module type Value = sig
type t
val equal : t -> t -> bool
val hash : t -> int
end
module type Bits = sig
type t
val lnot : t -> t
val ( land ) : t -> t -> t
val ( lxor ) : t -> t -> t
val ( lor ) : t -> t -> t
val ( lsr ) : t -> int -> t
val ( lsl ) : t -> int -> t
val pred : t -> t
val less_than : t -> t -> bool
val highest_bit : t -> t
val equal : t -> t -> bool
val hash : t -> int
val zero : t
val one : t
val size : int
end
module type Size = sig
val size : int
end
module Bits (S : Size) = struct
type t = Z.t
let size = S.size
let higher_bit = Z.shift_left Z.one size
let mask = Z.pred higher_bit
let mark n = Z.logor higher_bit n
let unmark n = Z.logxor higher_bit n
let one = mark Z.one
let zero = higher_bit
let hash = Z.hash
let equal = Z.equal
let less_than = Z.lt
let highest_bit_unmarked n =
if Z.equal Z.zero n then Z.zero
else Z.(Z.one lsl Pervasives.pred (numbits n))
let highest_bit n = mark (highest_bit_unmarked (unmark n))
let lnot x = Z.logor (Z.lognot x) higher_bit
let ( land ) = Z.logand
let ( lxor ) a b = Z.logor (Z.logxor a b) higher_bit
let ( lor ) = Z.logor
let ( lsr ) a n =
Z.logor (Z.shift_right_trunc (Z.logxor a higher_bit) n) higher_bit
let ( lsl ) a n = Z.logor (Z.logand (Z.shift_left a n) mask) higher_bit
let pred = Z.pred
let of_z n = mark n
let to_z n = unmark n
end
module BE_gen_prefix (Bits : Bits) :
Ptree_sig.Prefix
with type key = Bits.t
and type prefix = Bits.t
and type mask = Bits.t = struct
type key = Bits.t
type mask = Bits.t (* Only a single bit set *)
type prefix = Bits.t
let equal_key = Bits.equal
let equal_mask = Bits.equal
let equal_prefix = Bits.equal
let hash_key x = Bits.hash x
let hash_mask x = Bits.hash x
let hash_prefix x = Bits.hash x
open Bits
let full_length_mask = Bits.one
let strictly_shorter_mask (m1 : mask) m2 = Bits.less_than m2 m1
let select_bit ~prefix ~mask = not (Bits.equal (prefix land mask) Bits.zero)
let apply_mask prefix mask = prefix land lnot (pred mask)
let match_prefix ~key ~prefix ~mask =
equal_prefix (apply_mask key mask) prefix
let common_mask p0 p1 = Bits.highest_bit (* [@inlined] *) (p0 lxor p1)
let key_prefix x = x
let prefix_key p _m = p
let smaller_set_mask m1 m2 = lnot (pred m1) land lnot (pred m2)
let compare_prefix m1 p1 m2 p2 =
let min_mask = smaller_set_mask m1 m2 in
let applied_p1 = p1 land min_mask in
let applied_p2 = p2 land min_mask in
if applied_p1 = applied_p2 then
if m1 > m2 then Ptree_sig.Shorter
else if m1 < m2 then Ptree_sig.Longer
else Ptree_sig.Equal
else Ptree_sig.Different
end
module LE_prefix :
Ptree_sig.Prefix
with type key = int
and type prefix = int
and type mask = int = struct
type key = int
type mask = int (* Only a single bit set *)
type prefix = int
let equal_key = ( == )
let equal_mask = ( == )
let equal_prefix = ( == )
let hash_key x = x
let hash_mask x = x
let hash_prefix x = x
let full_length_mask = -1 lxor (-1 lsr 1)
let strictly_shorter_mask (m1 : mask) m2 = m1 < m2
let select_bit ~prefix ~mask = prefix land mask != 0
let apply_mask prefix mask = prefix land (mask - 1)
let match_prefix ~key ~prefix ~mask = apply_mask key mask == prefix
let lowest_bit x = x land -x
let common_mask p0 p1 = lowest_bit (p0 lxor p1)
let key_prefix x = x
let prefix_key p _m = p
let smaller_set_mask m1 m2 = (m1 - 1) land (m2 - 1)
let compare_prefix m1 p1 m2 p2 =
let min_mask = smaller_set_mask m1 m2 in
let applied_p1 = p1 land min_mask in
let applied_p2 = p2 land min_mask in
if applied_p1 = applied_p2 then
if m1 < m2 then Ptree_sig.Shorter
else if m1 > m2 then Ptree_sig.Longer
else Ptree_sig.Equal
else Ptree_sig.Different
end
module BE_prefix :
Ptree_sig.Prefix
with type key = int
and type prefix = int
and type mask = int = struct
type key = int
type mask = int (* Only a single bit set *)
type prefix = int
let equal_key = ( == )
let equal_mask = ( == )
let equal_prefix = ( == )
let hash_key x = x
let hash_mask x = x
let hash_prefix x = x
let full_length_mask = 1
let strictly_shorter_mask (m1 : mask) m2 = m1 > m2
let select_bit ~prefix ~mask = prefix land mask != 0
module Nativeint_infix = struct
let ( lor ) = Nativeint.logor
(*let (lsl) = Nativeint.shift_left*)
let ( lsr ) = Nativeint.shift_right_logical
(*let (asr) = Nativeint.shift_right*)
let ( land ) = Nativeint.logand
let lnot = Nativeint.lognot
let ( lxor ) = Nativeint.logxor
let ( - ) = Nativeint.sub
end
let apply_mask prefix mask =
let open Nativeint_infix in
let prefix = Nativeint.of_int prefix in
let mask = Nativeint.of_int mask in
Nativeint.to_int (prefix land lnot (mask - 1n))
let match_prefix ~key ~prefix ~mask = apply_mask key mask == prefix
let highest_bit x =
Nativeint_infix.(
let x = x lor (x lsr 1) in
let x = x lor (x lsr 2) in
let x = x lor (x lsr 4) in
let x = x lor (x lsr 8) in
let x = x lor (x lsr 16) in
let x = if Sys.word_size > 32 then x lor (x lsr 32) else x in
Nativeint.to_int (x - (x lsr 1)))
let common_mask p0 p1 =
let open Nativeint_infix in
let p0 = Nativeint.of_int p0 in
let p1 = Nativeint.of_int p1 in
highest_bit (p0 lxor p1)
let key_prefix x = x
let prefix_key p _m = p
let smaller_set_mask m1 m2 =
let open Nativeint_infix in
lnot (m1 - 1n) land lnot (m2 - 1n)
let compare_prefix m1 p1 m2 p2 =
let open Nativeint_infix in
let m1 = Nativeint.of_int m1 in
let m2 = Nativeint.of_int m2 in
let p1 = Nativeint.of_int p1 in
let p2 = Nativeint.of_int p2 in
let min_mask = smaller_set_mask m1 m2 in
let applied_p1 = p1 land min_mask in
let applied_p2 = p2 land min_mask in
if applied_p1 = applied_p2 then
if m1 > m2 then Ptree_sig.Shorter
else if m1 < m2 then Ptree_sig.Longer
else Ptree_sig.Equal
else Ptree_sig.Different
end
module Make (P : Ptree_sig.Prefix) (V : Value) = struct
module T = Shared_tree.Hash_consed_tree (P) (V)
type t = E : 'a T.t -> t [@@ocaml.unboxed]
type key = T.key
type value = T.value
type mask = T.mask
(*
let (=) = `Do_not_use_polymorphic_equality
let (<=) = `Do_not_use_polymorphic_comparison
let (>=) = `Do_not_use_polymorphic_comparison
let (<) = `Do_not_use_polymorphic_comparison
let (>) = `Do_not_use_polymorphic_comparison
let compare = `Do_not_use_polymorphic_comparison
*)
let equal (E t1) (E t2) =
match (t1, t2) with
| (T.Empty, T.Empty) ->
true
| (T.Empty, T.Leaf _) ->
false
| (T.Empty, T.Node _) ->
false
| (T.Leaf _, T.Empty) ->
false
| (T.Node _, T.Empty) ->
false
| (T.Node _, T.Node _) ->
T.equal t1 t2
| (T.Node _, T.Leaf _) ->
T.equal t1 t2
| (T.Leaf _, T.Node _) ->
T.equal t1 t2
| (T.Leaf _, T.Leaf _) ->
T.equal t1 t2
let select_key_bit k m = P.select_bit ~prefix:(P.key_prefix k) ~mask:m
let matching_key k1 k2 mask =
let p1 = P.apply_mask (P.key_prefix k1) mask in
let p2 = P.apply_mask (P.key_prefix k2) mask in
P.equal_prefix p1 p2
let rec mem : type k. key -> k T.t -> bool =
fun k -> function
| T.Empty ->
false
| T.Leaf {key; mask; _} ->
matching_key key k mask
| T.Node {prefix = _; mask; true_; false_; _} ->
mem k (if select_key_bit k mask then true_ else false_)
let rec mem_exact : type k. key -> k T.t -> bool =
fun k -> function
| T.Empty ->
false
| T.Leaf {key; mask; _} ->
P.equal_key k key && P.equal_mask mask P.full_length_mask
| T.Node {prefix = _; mask; true_; false_; _} ->
mem_exact k (if select_key_bit k mask then true_ else false_)
let rec find_ne k (t : T.not_empty T.t) =
match t with
| T.Leaf {key; value; mask; _} ->
if matching_key key k mask then Some value else None
| T.Node {prefix = _; mask; true_; false_; _} ->
find_ne k (if select_key_bit k mask then true_ else false_)
let find : type k. key -> k T.t -> value option =
fun k -> function
| T.Empty ->
None
| T.Leaf _ as t ->
find_ne k t
| T.Node _ as t ->
find_ne k t
let singleton ~key ~value ~mask = T.leaf ~key value ~mask
let join ~mask p0 t0 p1 t1 =
(* assumes p0 <> p1 *)
let c_mask = P.common_mask p0 p1 in
let mask = if P.strictly_shorter_mask c_mask mask then c_mask else mask in
let prefix = P.apply_mask p1 mask in
let (true_, false_) =
if P.select_bit ~prefix:p0 ~mask then (t0, t1) else (t1, t0)
in
T.node ~prefix ~mask ~true_ ~false_
let rebuild_ne_branch node prefix mask ~node_true ~node_false ~true_ ~false_
=
if
T.fast_partial_equal node_true true_
&& T.fast_partial_equal node_false false_
then node
else T.node ~prefix ~mask ~true_ ~false_
let rec add_ne combine ~key ~value ?(mask = P.full_length_mask) t =
match t with
| T.Leaf leaf ->
if
P.equal_key key leaf.key && P.equal_mask leaf.mask P.full_length_mask
then
if value == leaf.value then t
else T.leaf ~key (combine value leaf.value) ~mask
else if
P.strictly_shorter_mask leaf.mask mask
&& P.match_prefix
~key
~prefix:(P.key_prefix leaf.key)
~mask:leaf.mask
then (* The previous leaf shadows the new one: no modification *)
t
else if
P.strictly_shorter_mask mask leaf.mask
&& P.match_prefix ~key:leaf.key ~prefix:(P.key_prefix key) ~mask
then
(* The new leaf shadows the previous one: replace *)
T.leaf ~key (combine value leaf.value) ~mask
else
join
~mask
(P.key_prefix key)
(T.leaf ~key value ~mask)
(P.key_prefix leaf.key)
t
| T.Node node ->
if P.match_prefix ~key ~prefix:node.prefix ~mask:node.mask then
let (true_, false_) =
if select_key_bit key node.mask then
(add_ne combine ~key ~value ~mask node.true_, node.false_)
else (node.true_, add_ne combine ~key ~value ~mask node.false_)
in
rebuild_ne_branch
t
node.prefix
node.mask
~node_false:node.false_
~node_true:node.true_
~true_
~false_
else
join ~mask (P.key_prefix key) (T.leaf ~key value ~mask) node.prefix t
let add :
type k.
(value -> value -> value) ->
key:key ->
value:value ->
?mask:P.mask ->
k T.t ->
T.not_empty T.t =
fun combine ~key ~value ?(mask = P.full_length_mask) -> function
| T.Empty ->
singleton ~key ~value ~mask
(* Should be merged by matcher *)
| T.Leaf _ as t ->
add_ne combine ~key ~value ~mask t
| T.Node _ as t ->
add_ne combine ~key ~value ~mask t
let empty = E T.empty
let rebuild_branch node prefix mask ~node_true ~node_false ~true_:(E true_)
~false_:(E false_) =
match (true_, false_) with
| (T.Empty, T.Empty) ->
empty
| (T.Empty, t) ->
E t
| (t, T.Empty) ->
E t
| ((T.Leaf _ as true_), (T.Leaf _ as false_)) ->
E
(rebuild_ne_branch
node
prefix
mask
~node_true
~node_false
~true_
~false_)
| ((T.Leaf _ as true_), (T.Node _ as false_)) ->
E
(rebuild_ne_branch
node
prefix
mask
~node_true
~node_false
~true_
~false_)
| ((T.Node _ as true_), (T.Leaf _ as false_)) ->
E
(rebuild_ne_branch
node
prefix
mask
~node_true
~node_false
~true_
~false_)
| ((T.Node _ as true_), (T.Node _ as false_)) ->
E
(rebuild_ne_branch
node
prefix
mask
~node_true
~node_false
~true_
~false_)
let rec remove_ne : key -> T.not_empty T.t -> t =
fun key t ->
match t with
| T.Leaf leaf ->
if matching_key leaf.key key leaf.mask then E T.empty else E t
| T.Node node ->
if P.match_prefix ~key ~prefix:node.prefix ~mask:node.mask then
let (true_, false_) =
if select_key_bit key node.mask then
(remove_ne key node.true_, E node.false_)
else (E node.true_, remove_ne key node.false_)
in
rebuild_branch
t
node.prefix
node.mask
~node_true:node.true_
~node_false:node.false_
~true_
~false_
else E t
let remove key (E t) =
match t with
| T.Empty ->
empty
| T.Leaf _ as t ->
remove_ne key t
| T.Node _ as t ->
remove_ne key t
let rec remove_prefix_ne : key -> mask -> T.not_empty T.t -> t =
fun key mask t ->
match t with
| T.Leaf leaf ->
if matching_key key leaf.key mask then E T.empty else E t
| T.Node node -> (
match P.compare_prefix mask (P.key_prefix key) node.mask node.prefix with
| Different ->
E t
| Equal ->
E T.empty
| Shorter ->
E T.empty
| Longer ->
let (true_, false_) =
if select_key_bit key node.mask then
(remove_prefix_ne key mask node.true_, E node.false_)
else (E node.true_, remove_prefix_ne key mask node.false_)
in
rebuild_branch
t
node.prefix
node.mask
~node_true:node.true_
~node_false:node.false_
~true_
~false_ )
let remove_prefix key mask (E t) =
match t with
| T.Empty ->
empty
| T.Leaf _ as t ->
remove_prefix_ne key mask t
| T.Node _ as t ->
remove_prefix_ne key mask t
let rec remove_ne_exact : key -> T.not_empty T.t -> t =
fun key t ->
match t with
| T.Leaf leaf ->
if
P.equal_key leaf.key key && P.equal_mask leaf.mask P.full_length_mask
then E T.empty
else E t
| T.Node node ->
if P.match_prefix ~key ~prefix:node.prefix ~mask:node.mask then
let (true_, false_) =
if select_key_bit key node.mask then
(remove_ne_exact key node.true_, E node.false_)
else (E node.true_, remove_ne_exact key node.false_)
in
rebuild_branch
t
node.prefix
node.mask
~node_true:node.true_
~node_false:node.false_
~true_
~false_
else E t
let remove_exact key (E t) =
match t with
| T.Empty ->
empty
| T.Leaf _ as t ->
remove_ne_exact key t
| T.Node _ as t ->
remove_ne_exact key t
let rec replace_subtree_ne ~key ~id value t =
match t with
| T.Leaf leaf ->
if leaf.id == id then T.leaf ~key:leaf.key ~mask:leaf.mask value else t
| T.Node node ->
if node.id == id then
T.leaf
~key:(P.prefix_key node.prefix node.mask)
~mask:node.mask
value
else if P.match_prefix ~key ~prefix:node.prefix ~mask:node.mask then
let (true_, false_) =
if select_key_bit key node.mask then
(replace_subtree_ne ~key ~id value node.true_, node.false_)
else (node.true_, replace_subtree_ne ~key ~id value node.false_)
in
rebuild_ne_branch
t
node.prefix
node.mask
~node_true:node.true_
~node_false:node.false_
~true_
~false_
else t
let replace_subtree ~replaced:(E replaced) value t =
let replace_subtree_aux ~key ~id value (E t) =
match t with
| T.Empty ->
empty
| T.Leaf _ as t ->
E (replace_subtree_ne ~key ~id value t)
| T.Node _ as t ->
E (replace_subtree_ne ~key ~id value t)
in
match replaced with
| T.Empty ->
t
| T.Leaf leaf ->
replace_subtree_aux ~key:leaf.key ~id:leaf.id value t
| T.Node node ->
replace_subtree_aux
~key:(P.prefix_key node.prefix node.mask)
~id:node.id
value
t
let rec fold_ne :
(key -> mask -> value -> 'a -> 'a) -> T.not_empty T.t -> 'a -> 'a =
fun f t acc ->
match t with
| T.Leaf {key; mask; value; _} ->
f key mask value acc
| T.Node node ->
let acc = fold_ne f node.false_ acc in
fold_ne f node.true_ acc
let fold f (E t) acc =
match t with
| T.Empty ->
acc
| T.Leaf _ as t ->
fold_ne f t acc
| T.Node _ as t ->
fold_ne f t acc
module T_id = struct
type t = T.not_empty T.t
let hash = T.id
let equal t1 t2 = T.id t1 == T.id t2
end
module Map_cache = Ephemeron.K1.Make (T_id)
module type Map_Reduce = sig
type result
val default : result
val map : t -> key -> T.value -> result
val reduce : t -> result -> result -> result
end
module Map_Reduce (M : Map_Reduce) = struct
let cache : M.result Map_cache.t = Map_cache.create 10
let rec map_reduce_ne t =
match Map_cache.find_opt cache t with
| Some v ->
v
| None ->
let v =
match t with
| T.Leaf leaf ->
M.map (E t) leaf.key leaf.value
| T.Node node ->
let v_true = map_reduce_ne node.true_ in
let v_false = map_reduce_ne node.false_ in
M.reduce (E t) v_true v_false
in
Map_cache.add cache t v ; v
let run (E t) =
match t with
| T.Empty ->
M.default
| T.Leaf _ as t ->
map_reduce_ne t
| T.Node _ as t ->
map_reduce_ne t
let rec filter_ne f t =
let result = map_reduce_ne t in
if f result then E t
else
match t with
| T.Leaf _ ->
empty
| T.Node node ->
let true_ = filter_ne f node.true_ in
let false_ = filter_ne f node.false_ in
rebuild_branch
t
node.prefix
node.mask
~node_true:node.true_
~node_false:node.false_
~true_
~false_
let filter f (E t) =
match t with
| T.Empty ->
empty
| T.Leaf _ as t ->
filter_ne f t
| T.Node _ as t ->
filter_ne f t
end
(* Packing in the existential *)
let mem key (E t) = mem key t
let mem_exact key (E t) = mem_exact key t
let find key (E t) = find key t
let singleton ~key ~value ~mask = E (singleton ~key ~value ~mask)
let add combine ~key ~value ?mask (E t) = E (add combine ~key ~value ?mask t)
end
[@@inline]
module type S = sig
type key
type value
type mask
type t
val equal : t -> t -> bool
val empty : t
val singleton : key:key -> value:value -> mask:mask -> t
val add :
(value -> value -> value) -> key:key -> value:value -> ?mask:mask -> t -> t
val remove : key -> t -> t
val remove_exact : key -> t -> t
val remove_prefix : key -> mask -> t -> t
val mem : key -> t -> bool
val mem_exact : key -> t -> bool
val find : key -> t -> value option
val replace_subtree : replaced:t -> value -> t -> t
val fold : (key -> mask -> value -> 'a -> 'a) -> t -> 'a -> 'a
module type Map_Reduce = sig
type result
val default : result
val map : t -> key -> value -> result
val reduce : t -> result -> result -> result
end
module Map_Reduce (M : Map_Reduce) : sig
val run : t -> M.result
val filter : (M.result -> bool) -> t -> t
end
end
module Make_LE (V : Value) = Make (LE_prefix) (V)
module Make_BE (V : Value) = Make (BE_prefix) (V)
module Make_BE_gen (V : Value) (B : Bits) = Make (BE_gen_prefix (B)) (V)
module Make_BE_sized (V : Value) (S : Size) =
Make (BE_gen_prefix (Bits (S))) (V)
src/lib_stdlib/hashPtree.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Ptree_sig.
Module Value.
Record signature {t : Type} := {
t := t;
equal : t -> t -> bool;
hash : t -> Z;
}.
Arguments signature : clear implicits.
End Value.
Inductive prefix_order : Type :=
| Equal : prefix_order
| Shorter : prefix_order
| Longer : prefix_order
| Different : prefix_order.
Module Prefix.
Record signature {key prefix mask : Type} := {
key := key;
prefix := prefix;
mask := mask;
equal_key : key -> key -> bool;
equal_mask : mask -> mask -> bool;
equal_prefix : prefix -> prefix -> bool;
hash_key : key -> Z;
hash_mask : mask -> Z;
hash_prefix : prefix -> Z;
full_length_mask : mask;
strictly_shorter_mask : mask -> mask -> bool;
key_prefix : key -> prefix;
prefix_key : prefix -> mask -> key;
match_prefix : key -> prefix -> mask -> bool;
select_bit : prefix -> mask -> bool;
common_mask : prefix -> prefix -> mask;
apply_mask : prefix -> mask -> prefix;
compare_prefix : mask -> prefix -> mask -> prefix -> prefix_order;
}.
Arguments signature : clear implicits.
End Prefix.
Module S.
Record signature {key prefix mask value not_empty empty t : Type} := {
key := key;
prefix := prefix;
mask := mask;
value := value;
not_empty := not_empty;
empty := empty;
polymorphic_abstract_type;
leaf : key -> mask -> value -> t not_empty;
node : prefix -> mask -> (t not_empty) -> (t not_empty) -> t not_empty;
empty : t empty;
equal : (t not_empty) -> (t not_empty) -> bool;
fast_partial_equal : (t not_empty) -> (t not_empty) -> bool;
id : (t not_empty) -> Z;
}.
Arguments signature : clear implicits.
End S.
End Ptree_sig.
Module Shared_tree.
Import Ptree_sig.
Record int3 := {
i1 : Z;
i2 : Z;
i3 : Z }.
Definition h3 : int3 := {| i1 := 0; i2 := 0; i3 := 0 |}.
Definition hash3int (x1 : Z) (x2 : Z) (x3 : Z) : Z :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field h3 "i1" % string x1 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field h3 "i2" % string x2 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field h3 "i3" % string x3 in
Hashtbl.hash h3.
Record int4 := {
i1 : Z;
i2 : Z;
i3 : Z;
i4 : Z }.
Definition h4 : int4 := {| i1 := 0; i2 := 0; i3 := 0; i4 := 0 |}.
Definition hash4int (x1 : Z) (x2 : Z) (x3 : Z) (x4 : Z) : Z :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field h4 "i1" % string x1 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field h4 "i2" % string x2 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field h4 "i3" % string x3 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field h4 "i4" % string x4 in
Hashtbl.hash h4.
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
End Shared_tree.
Module Value.
Record signature {t : Type} := {
t := t;
equal : t -> t -> bool;
hash : t -> Z;
}.
Arguments signature : clear implicits.
End Value.
Module Bits.
Record signature {t : Type} := {
t := t;
lnot : t -> t;
land : t -> t -> t;
lxor : t -> t -> t;
lor : t -> t -> t;
lsr : t -> Z -> t;
lsl : t -> Z -> t;
pred : t -> t;
less_than : t -> t -> bool;
highest_bit : t -> t;
equal : t -> t -> bool;
hash : t -> Z;
zero : t;
one : t;
size : Z;
}.
Arguments signature : clear implicits.
End Bits.
Module Size.
Record signature := {
size : Z;
}.
End Size.
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
Module LE_prefix.
Definition key := Z.
Definition mask := Z.
Definition prefix := Z.
Definition equal_key {A : Type} : A -> A -> bool := Stdlib.op_eqeq.
Definition equal_mask {A : Type} : A -> A -> bool := Stdlib.op_eqeq.
Definition equal_prefix {A : Type} : A -> A -> bool := Stdlib.op_eqeq.
Definition hash_key {A : Type} (x : A) : A := x.
Definition hash_mask {A : Type} (x : A) : A := x.
Definition hash_prefix {A : Type} (x : A) : A := x.
Definition full_length_mask : Z := Z.lxor (-1) (Z.shiftr (-1) 1).
Definition strictly_shorter_mask (m1 : mask) (m2 : mask) : bool :=
OCaml.Stdlib.lt m1 m2.
Definition select_bit (prefix : Z) (mask : Z) : bool :=
Stdlib.op_exclamationeq (Z.land prefix mask) 0.
Definition apply_mask (prefix : Z) (mask : Z) : Z :=
Z.land prefix (Z.sub mask 1).
Definition match_prefix (key : Z) (prefix : Z) (mask : Z) : bool :=
Stdlib.op_eqeq (apply_mask key mask) prefix.
Definition lowest_bit (x : Z) : Z := Z.land x (Z.opp x).
Definition common_mask (p0 : Z) (p1 : Z) : Z := lowest_bit (Z.lxor p0 p1).
Definition key_prefix {A : Type} (x : A) : A := x.
Definition prefix_key {A B : Type} (p : A) (_m : B) : A := p.
Definition smaller_set_mask (m1 : Z) (m2 : Z) : Z :=
Z.land (Z.sub m1 1) (Z.sub m2 1).
Definition compare_prefix (m1 : Z) (p1 : Z) (m2 : Z) (p2 : Z)
: Ptree_sig.prefix_order :=
let min_mask := smaller_set_mask m1 m2 in
let applied_p1 := Z.land p1 min_mask in
let applied_p2 := Z.land p2 min_mask in
if equiv_decb applied_p1 applied_p2 then
if OCaml.Stdlib.lt m1 m2 then
Ptree_sig.Shorter
else
if OCaml.Stdlib.gt m1 m2 then
Ptree_sig.Longer
else
Ptree_sig.Equal
else
Ptree_sig.Different.
End LE_prefix.
Module BE_prefix.
Definition key := Z.
Definition mask := Z.
Definition prefix := Z.
Definition equal_key {A : Type} : A -> A -> bool := Stdlib.op_eqeq.
Definition equal_mask {A : Type} : A -> A -> bool := Stdlib.op_eqeq.
Definition equal_prefix {A : Type} : A -> A -> bool := Stdlib.op_eqeq.
Definition hash_key {A : Type} (x : A) : A := x.
Definition hash_mask {A : Type} (x : A) : A := x.
Definition hash_prefix {A : Type} (x : A) : A := x.
Definition full_length_mask : Z := 1.
Definition strictly_shorter_mask (m1 : mask) (m2 : mask) : bool :=
OCaml.Stdlib.gt m1 m2.
Definition select_bit (prefix : Z) (mask : Z) : bool :=
Stdlib.op_exclamationeq (Z.land prefix mask) 0.
Module Nativeint_infix.
Definition lor : nativeint -> nativeint -> nativeint := Nativeint.logor.
Definition lsr : nativeint -> Z -> nativeint :=
Nativeint.shift_right_logical.
Definition land : nativeint -> nativeint -> nativeint := Nativeint.logand.
Definition lnot : nativeint -> nativeint := Nativeint.lognot.
Definition lxor : nativeint -> nativeint -> nativeint := Nativeint.logxor.
Definition op_minus : nativeint -> nativeint -> nativeint := Nativeint.sub.
End Nativeint_infix.
Definition apply_mask (prefix : Z) (mask : Z) : Z :=
let prefix := Nativeint.of_int prefix in
let mask := Nativeint.of_int mask in
Nativeint.to_int
(land prefix
(lnot
(op_minus mask
(* ❌ Constant of type nativeint is converted to int *)
1))).
Definition match_prefix (key : Z) (prefix : Z) (mask : Z) : bool :=
Stdlib.op_eqeq (apply_mask key mask) prefix.
Definition highest_bit (x : nativeint) : Z :=
let x := lor x (lsr x 1) in
let x := lor x (lsr x 2) in
let x := lor x (lsr x 4) in
let x := lor x (lsr x 8) in
let x := lor x (lsr x 16) in
let x :=
if OCaml.Stdlib.gt Sys.word_size 32 then
lor x (lsr x 32)
else
x in
Nativeint.to_int (op_minus x (lsr x 1)).
Definition common_mask (p0 : Z) (p1 : Z) : Z :=
let p0 := Nativeint.of_int p0 in
let p1 := Nativeint.of_int p1 in
highest_bit (lxor p0 p1).
Definition key_prefix {A : Type} (x : A) : A := x.
Definition prefix_key {A B : Type} (p : A) (_m : B) : A := p.
Definition smaller_set_mask (m1 : nativeint) (m2 : nativeint) : nativeint :=
land
(lnot
(op_minus m1
(* ❌ Constant of type nativeint is converted to int *)
1))
(lnot
(op_minus m2
(* ❌ Constant of type nativeint is converted to int *)
1)).
Definition compare_prefix (m1 : Z) (p1 : Z) (m2 : Z) (p2 : Z)
: Ptree_sig.prefix_order :=
let m1 := Nativeint.of_int m1 in
let m2 := Nativeint.of_int m2 in
let p1 := Nativeint.of_int p1 in
let p2 := Nativeint.of_int p2 in
let min_mask := smaller_set_mask m1 m2 in
let applied_p1 := land p1 min_mask in
let applied_p2 := land p2 min_mask in
if equiv_decb applied_p1 applied_p2 then
if OCaml.Stdlib.gt m1 m2 then
Ptree_sig.Shorter
else
if OCaml.Stdlib.lt m1 m2 then
Ptree_sig.Longer
else
Ptree_sig.Equal
else
Ptree_sig.Different.
End BE_prefix.
(* ❌ Functors are not handled. *)
functor
Module S.
Record signature {key value mask t : Type} := {
key := key;
value := value;
mask := mask;
t := t;
equal : t -> t -> bool;
empty : t;
singleton : key -> value -> mask -> t;
add : (value -> value -> value) -> key -> value -> (option mask) -> t -> t;
remove : key -> t -> t;
remove_exact : key -> t -> t;
remove_prefix : key -> mask -> t -> t;
mem : key -> t -> bool;
mem_exact : key -> t -> bool;
find : key -> t -> option value;
replace_subtree : t -> value -> t -> t;
fold : forall {a : Type}, (key -> mask -> value -> a -> a) -> t -> a -> a;
module_type;
Map_Reduce : functor;
}.
Arguments signature : clear implicits.
End S.
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
src/lib_stdlib/lwt_canceler.ml 7 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Lwt.Infix
type t = {
cancellation : unit Lwt_condition.t;
cancellation_complete : unit Lwt_condition.t;
mutable cancel_hook : unit -> unit Lwt.t;
mutable canceling : bool;
mutable canceled : bool;
}
let create () =
let cancellation = Lwt_condition.create () in
let cancellation_complete = Lwt_condition.create () in
{
cancellation;
cancellation_complete;
cancel_hook = (fun () -> Lwt.return_unit);
canceling = false;
canceled = false;
}
let cancel st =
if st.canceled then Lwt.return_unit
else if st.canceling then Lwt_condition.wait st.cancellation_complete
else (
st.canceling <- true ;
Lwt_condition.broadcast st.cancellation () ;
Lwt.finalize st.cancel_hook (fun () ->
st.canceled <- true ;
Lwt_condition.broadcast st.cancellation_complete () ;
Lwt.return_unit) )
let on_cancel st cb =
let hook = st.cancel_hook in
st.cancel_hook <- (fun () -> hook () >>= cb)
let cancellation st =
if st.canceling then Lwt.return_unit else Lwt_condition.wait st.cancellation
let canceled st = st.canceling
src/lib_stdlib/lwt_canceler.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
Record t := {
cancellation : Lwt_condition.t unit;
cancellation_complete : Lwt_condition.t unit;
cancel_hook : unit -> Lwt.t unit;
canceling : bool;
canceled : bool }.
Definition create (function_parameter : unit) : t :=
let 'tt := function_parameter in
let cancellation := Lwt_condition.create tt in
let cancellation_complete := Lwt_condition.create tt in
{| cancellation := cancellation;
cancellation_complete := cancellation_complete;
cancel_hook :=
fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_unit; canceling := false; canceled := false |}.
Definition cancel (st : t) : Lwt.t unit :=
if canceled st then
Lwt.return_unit
else
if canceling st then
Lwt_condition.wait None (cancellation_complete st)
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field st "canceling" % string true in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_condition.broadcast (cancellation st) tt in
Lwt.finalize (cancel_hook st)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field st "canceled" % string true in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_condition.broadcast (cancellation_complete st) tt in
Lwt.return_unit).
Definition on_cancel (st : t) (cb : unit -> Lwt.t unit) : unit :=
let hook := cancel_hook st in
(* ❌ Set record field not handled. *)
set_record_field st "cancel_hook" % string
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (hook tt) cb).
Definition cancellation (st : t) : Lwt.t unit :=
if canceling st then
Lwt.return_unit
else
Lwt_condition.wait None (cancellation st).
Definition canceled (st : t) : bool := canceling st.
src/lib_stdlib/lwt_dropbox.ml 14 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Lwt.Infix
exception Closed
type 'a t = {
mutable data : 'a option;
mutable closed : bool;
mutable put_waiter : (unit Lwt.t * unit Lwt.u) option;
}
let create () = {data = None; closed = false; put_waiter = None}
let notify_put dropbox =
match dropbox.put_waiter with
| None ->
()
| Some (_waiter, wakener) ->
dropbox.put_waiter <- None ;
Lwt.wakeup_later wakener ()
let put dropbox elt =
if dropbox.closed then raise Closed
else (
dropbox.data <- Some elt ;
notify_put dropbox )
let peek dropbox = dropbox.data
let close dropbox =
if not dropbox.closed then (
dropbox.closed <- true ;
notify_put dropbox )
let wait_put ~timeout dropbox =
match dropbox.put_waiter with
| Some (waiter, _wakener) ->
Lwt.choose [timeout; Lwt.protected waiter]
| None ->
let (waiter, wakener) = Lwt.wait () in
dropbox.put_waiter <- Some (waiter, wakener) ;
Lwt.choose [timeout; Lwt.protected waiter]
let rec take dropbox =
match dropbox.data with
| Some elt ->
dropbox.data <- None ;
Lwt.return elt
| None ->
if dropbox.closed then Lwt.fail Closed
else
wait_put ~timeout:(Lwt_utils.never_ending ()) dropbox
>>= fun () -> take dropbox
let rec take_with_timeout timeout dropbox =
match dropbox.data with
| Some elt ->
Lwt.cancel timeout ;
dropbox.data <- None ;
Lwt.return_some elt
| None ->
if Lwt.is_sleeping timeout then
if dropbox.closed then Lwt.fail Closed
else
wait_put ~timeout dropbox
>>= fun () -> take_with_timeout timeout dropbox
else Lwt.return_none
src/lib_stdlib/lwt_dropbox.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
(* ❌ The definition of exceptions is not handled. *)
exception
Record t {a : Type} := {
data : option a;
closed : bool;
put_waiter : option ((Lwt.t unit) * (Lwt.u unit)) }.
Arguments t : clear implicits.
Definition create {A : Type} (function_parameter : unit) : t A :=
let 'tt := function_parameter in
{| data := None; closed := false; put_waiter := None |}.
Definition notify_put {A : Type} (dropbox : t A) : unit :=
match put_waiter dropbox with
| None => tt
| Some (_waiter, wakener) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field dropbox "put_waiter" % string None in
Lwt.wakeup_later wakener tt
end.
Definition put {A : Type} (dropbox : t A) (elt : A) : unit :=
if closed dropbox then
Stdlib.raise Closed
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field dropbox "data" % string (Some elt) in
notify_put dropbox.
Definition peek {A : Type} (dropbox : t A) : option A := data dropbox.
Definition close {A : Type} (dropbox : t A) : unit :=
if negb (closed dropbox) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field dropbox "closed" % string true in
notify_put dropbox
else
tt.
Definition wait_put {A : Type} (timeout : Lwt.t unit) (dropbox : t A)
: Lwt.t unit :=
match put_waiter dropbox with
| Some (waiter, _wakener) =>
Lwt.choose (cons timeout (cons (Lwt.protected waiter) []))
| None =>
let '(waiter, wakener) := Lwt.wait tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field dropbox "put_waiter" % string (Some (waiter, wakener)) in
Lwt.choose (cons timeout (cons (Lwt.protected waiter) []))
end.
Fixpoint take {A : Type} (dropbox : t A) : Lwt.t A :=
match data dropbox with
| Some elt =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field dropbox "data" % string None in
Lwt._return elt
| None =>
if closed dropbox then
Lwt.fail Closed
else
op_gtgteq (wait_put (Lwt_utils.never_ending tt) dropbox)
(fun function_parameter =>
let 'tt := function_parameter in
take dropbox)
end.
Fixpoint take_with_timeout {A : Type} (timeout : Lwt.t unit) (dropbox : t A)
: Lwt.t (option A) :=
match data dropbox with
| Some elt =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt.cancel timeout in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field dropbox "data" % string None in
Lwt.return_some elt
| None =>
if Lwt.is_sleeping timeout then
if closed dropbox then
Lwt.fail Closed
else
op_gtgteq (wait_put timeout dropbox)
(fun function_parameter =>
let 'tt := function_parameter in
take_with_timeout timeout dropbox)
else
Lwt.return_none
end.
src/lib_stdlib/lwt_idle_waiter.ml 26 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Lwt.Infix
type t = {
mutable pending_tasks : unit Lwt.u list;
mutable pending_idle : (unit -> unit Lwt.t) list;
mutable running_tasks : int;
mutable running_idle : bool;
mutable prevent_tasks : bool;
}
let create () =
{
pending_tasks = [];
pending_idle = [];
running_tasks = 0;
running_idle = false;
prevent_tasks = false;
}
let rec may_run_idle_tasks w =
if w.running_tasks = 0 && not w.running_idle then
match w.pending_idle with
| [] ->
()
| pending_idle ->
w.running_idle <- true ;
w.prevent_tasks <- false ;
w.pending_idle <- [] ;
Lwt.async (fun () ->
let pending_idle = List.rev pending_idle in
Lwt_list.iter_s (fun f -> f ()) pending_idle
>>= fun () ->
w.running_idle <- false ;
let pending_tasks = List.rev w.pending_tasks in
w.pending_tasks <- [] ;
List.iter (fun u -> Lwt.wakeup u ()) pending_tasks ;
may_run_idle_tasks w ;
Lwt.return_unit)
let wrap_error f =
Lwt.catch
(fun () -> f () >>= fun r -> Lwt.return_ok r)
(fun exn -> Lwt.return_error exn)
let unwrap_error = function Ok r -> Lwt.return r | Error exn -> Lwt.fail exn
let wakeup_error u = function
| Ok r ->
Lwt.wakeup u r
| Error exn ->
Lwt.wakeup_exn u exn
let rec task w f =
if w.running_idle || w.prevent_tasks then (
let (t, u) = Lwt.task () in
w.pending_tasks <- u :: w.pending_tasks ;
t >>= fun () -> task w f )
else (
w.running_tasks <- w.running_tasks + 1 ;
wrap_error f
>>= fun res ->
w.running_tasks <- w.running_tasks - 1 ;
may_run_idle_tasks w ;
unwrap_error res )
let when_idle w f =
let (t, u) = Lwt.task () in
let canceled = ref false in
Lwt.on_cancel t (fun () -> canceled := true) ;
let f () =
if !canceled then Lwt.return_unit
else wrap_error f >>= fun res -> wakeup_error u res ; Lwt.return_unit
in
w.pending_idle <- f :: w.pending_idle ;
may_run_idle_tasks w ;
t
let force_idle w f =
w.prevent_tasks <- true ;
when_idle w f
src/lib_stdlib/lwt_idle_waiter.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
Record t := {
pending_tasks : list (Lwt.u unit);
pending_idle : list (unit -> Lwt.t unit);
running_tasks : Z;
running_idle : bool;
prevent_tasks : bool }.
Definition create (function_parameter : unit) : t :=
let 'tt := function_parameter in
{| pending_tasks := []; pending_idle := []; running_tasks := 0;
running_idle := false; prevent_tasks := false |}.
Fixpoint may_run_idle_tasks (w : t) : unit :=
if andb (equiv_decb (running_tasks w) 0) (negb (running_idle w)) then
match pending_idle w with
| [] => tt
| pending_idle =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field w "running_idle" % string true in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field w "prevent_tasks" % string false in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field w "pending_idle" % string [] in
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
let pending_idle := List.rev pending_idle in
op_gtgteq (Lwt_list.iter_s (fun f => f tt) pending_idle)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field w "running_idle" % string false in
let pending_tasks := List.rev (pending_tasks w) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field w "pending_tasks" % string [] in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.List.iter (fun u => Lwt.wakeup u tt) pending_tasks
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := may_run_idle_tasks w in
Lwt.return_unit))
end
else
tt.
Definition wrap_error {A : Type} (f : unit -> Lwt.t A)
: Lwt.t (Result.result A exn) :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (f tt) (fun r => Lwt.return_ok r))
(fun exn => Lwt.return_error exn).
Definition unwrap_error {A : Type} (function_parameter : sum A exn) : Lwt.t A :=
match function_parameter with
| Stdlib.Ok r => Lwt._return r
| Stdlib.Error exn => Lwt.fail exn
end.
Definition wakeup_error {A : Type}
(u : Lwt.u A) (function_parameter : sum A exn) : unit :=
match function_parameter with
| Stdlib.Ok r => Lwt.wakeup u r
| Stdlib.Error exn => Lwt.wakeup_exn u exn
end.
Fixpoint task {A : Type} (w : t) (f : unit -> Lwt.t A) : Lwt.t A :=
if orb (running_idle w) (prevent_tasks w) then
let '(t, u) := Lwt.task tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field w "pending_tasks" % string (cons u (pending_tasks w)) in
op_gtgteq t
(fun function_parameter =>
let 'tt := function_parameter in
task w f)
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field w "running_tasks" % string (Z.add (running_tasks w) 1) in
op_gtgteq (wrap_error f)
(fun res =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field w "running_tasks" % string
(Z.sub (running_tasks w) 1) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := may_run_idle_tasks w in
unwrap_error res).
Definition when_idle {A : Type} (w : t) (f : unit -> Lwt.t A) : Lwt.t A :=
let '(t, u) := Lwt.task tt in
let canceled := Stdlib.ref false in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt.on_cancel t
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.op_coloneq canceled true) in
let f (function_parameter : unit) : Lwt.t unit :=
let 'tt := function_parameter in
if Stdlib.op_exclamation canceled then
Lwt.return_unit
else
op_gtgteq (wrap_error f)
(fun res =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := wakeup_error u res in
Lwt.return_unit) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field w "pending_idle" % string (cons f (pending_idle w)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := may_run_idle_tasks w in
t.
Definition force_idle {A : Type} (w : t) (f : unit -> Lwt.t A) : Lwt.t A :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field w "prevent_tasks" % string true in
when_idle w f.
src/lib_stdlib/lwt_pipe.ml 37 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Lwt.Infix
type 'a t = {
queue : (int * 'a) Queue.t;
mutable current_size : int;
max_size : int;
compute_size : 'a -> int;
mutable closed : bool;
mutable push_waiter : (unit Lwt.t * unit Lwt.u) option;
mutable pop_waiter : (unit Lwt.t * unit Lwt.u) option;
empty : unit Lwt_condition.t;
}
let push_overhead = 4 * (Sys.word_size / 8)
let create ?size () =
let (max_size, compute_size) =
match size with
| None ->
(max_int, fun _ -> 0)
| Some (max_size, compute_size) ->
(max_size, compute_size)
in
{
queue = Queue.create ();
current_size = 0;
max_size;
compute_size;
closed = false;
push_waiter = None;
pop_waiter = None;
empty = Lwt_condition.create ();
}
let notify_push q =
match q.push_waiter with
| None ->
()
| Some (_, w) ->
q.push_waiter <- None ;
Lwt.wakeup_later w ()
let notify_pop q =
match q.pop_waiter with
| None ->
()
| Some (_, w) ->
q.pop_waiter <- None ;
Lwt.wakeup_later w ()
let wait_push q =
match q.push_waiter with
| Some (t, _) ->
Lwt.protected t
| None ->
let (waiter, wakener) = Lwt.wait () in
q.push_waiter <- Some (waiter, wakener) ;
Lwt.protected waiter
let wait_pop q =
match q.pop_waiter with
| Some (t, _) ->
Lwt.protected t
| None ->
let (waiter, wakener) = Lwt.wait () in
q.pop_waiter <- Some (waiter, wakener) ;
Lwt.protected waiter
let length {queue; _} = Queue.length queue
let is_empty {queue; _} = Queue.is_empty queue
let rec empty q =
if is_empty q then Lwt.return_unit
else Lwt_condition.wait q.empty >>= fun () -> empty q
exception Closed
let rec push ({closed; queue; current_size; max_size; compute_size; _} as q)
elt =
let elt_size = compute_size elt in
if closed then Lwt.fail Closed
else if current_size + elt_size < max_size || Queue.is_empty queue then (
Queue.push (elt_size, elt) queue ;
q.current_size <- current_size + elt_size ;
notify_push q ;
Lwt.return_unit )
else wait_pop q >>= fun () -> push q elt
let push_now ({closed; queue; compute_size; current_size; max_size; _} as q)
elt =
if closed then raise Closed ;
let elt_size = compute_size elt in
(current_size + elt_size < max_size || Queue.is_empty queue)
&&
( Queue.push (elt_size, elt) queue ;
q.current_size <- current_size + elt_size ;
notify_push q ;
true )
exception Full
let push_now_exn q elt = if not (push_now q elt) then raise Full
let safe_push_now q elt = try push_now_exn q elt with _ -> ()
let rec pop ({closed; queue; empty; current_size; _} as q) =
if not (Queue.is_empty queue) then (
let (elt_size, elt) = Queue.pop queue in
notify_pop q ;
q.current_size <- current_size - elt_size ;
if Queue.length queue = 0 then Lwt_condition.signal empty () ;
Lwt.return elt )
else if closed then Lwt.fail Closed
else wait_push q >>= fun () -> pop q
let rec pop_with_timeout timeout q =
if not (Queue.is_empty q.queue) then (
Lwt.cancel timeout ;
pop q >>= Lwt.return_some )
else if Lwt.is_sleeping timeout then
if q.closed then (Lwt.cancel timeout ; Lwt.fail Closed)
else
let waiter = wait_push q in
Lwt.choose [timeout; Lwt.protected waiter]
>>= fun () -> pop_with_timeout timeout q
else Lwt.return_none
let rec peek ({closed; queue; _} as q) =
if not (Queue.is_empty queue) then
let (_elt_size, elt) = Queue.peek queue in
Lwt.return elt
else if closed then Lwt.fail Closed
else wait_push q >>= fun () -> peek q
let peek_all {queue; closed; _} =
if closed then []
else List.rev (Queue.fold (fun acc (_, e) -> e :: acc) [] queue)
exception Empty
let pop_now_exn ({closed; queue; empty; current_size; _} as q) =
if Queue.is_empty queue then if closed then raise Closed else raise Empty ;
let (elt_size, elt) = Queue.pop queue in
if Queue.length queue = 0 then Lwt_condition.signal empty () ;
q.current_size <- current_size - elt_size ;
notify_pop q ;
elt
let pop_now q =
match pop_now_exn q with exception Empty -> None | elt -> Some elt
let rec values_available q =
if is_empty q then
if q.closed then raise Closed
else wait_push q >>= fun () -> values_available q
else Lwt.return_unit
let rec pop_all_loop q acc =
match pop_now_exn q with
| exception Empty ->
List.rev acc
| e ->
pop_all_loop q (e :: acc)
let pop_all q = pop q >>= fun e -> Lwt.return (pop_all_loop q [e])
let pop_all_now q = pop_all_loop q []
let close q =
if not q.closed then (
q.closed <- true ;
notify_push q ;
notify_pop q )
let rec iter q ~f =
Lwt.catch
(fun () -> pop q >>= fun elt -> f elt >>= fun () -> iter q ~f)
(function Closed -> Lwt.return_unit | exn -> Lwt.fail exn)
src/lib_stdlib/lwt_pipe.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
Record t {a : Type} := {
queue : Stdlib.Queue.t (Z * a);
current_size : Z;
max_size : Z;
compute_size : a -> Z;
closed : bool;
push_waiter : option ((Lwt.t unit) * (Lwt.u unit));
pop_waiter : option ((Lwt.t unit) * (Lwt.u unit));
empty : Lwt_condition.t unit }.
Arguments t : clear implicits.
Definition push_overhead : Z := Z.mul 4 (Z.div Sys.word_size 8).
Definition create {A : Type}
(size : option (Z * (A -> Z))) (function_parameter : unit) : t A :=
let 'tt := function_parameter in
let '(max_size, compute_size) :=
match size with
| None =>
(Stdlib.max_int,
(fun function_parameter =>
let '_ := function_parameter in
0))
| Some (max_size, compute_size) => (max_size, compute_size)
end in
{| queue := Queue.create tt; current_size := 0; max_size := max_size;
compute_size := compute_size; closed := false; push_waiter := None;
pop_waiter := None; empty := Lwt_condition.create tt |}.
Definition notify_push {A : Type} (q : t A) : unit :=
match push_waiter q with
| None => tt
| Some (_, w) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field q "push_waiter" % string None in
Lwt.wakeup_later w tt
end.
Definition notify_pop {A : Type} (q : t A) : unit :=
match pop_waiter q with
| None => tt
| Some (_, w) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field q "pop_waiter" % string None in
Lwt.wakeup_later w tt
end.
Definition wait_push {A : Type} (q : t A) : Lwt.t unit :=
match push_waiter q with
| Some (t, _) => Lwt.protected t
| None =>
let '(waiter, wakener) := Lwt.wait tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field q "push_waiter" % string (Some (waiter, wakener)) in
Lwt.protected waiter
end.
Definition wait_pop {A : Type} (q : t A) : Lwt.t unit :=
match pop_waiter q with
| Some (t, _) => Lwt.protected t
| None =>
let '(waiter, wakener) := Lwt.wait tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field q "pop_waiter" % string (Some (waiter, wakener)) in
Lwt.protected waiter
end.
Definition length {A : Type} (function_parameter : t A) : Z :=
let '{| queue := queue |} := function_parameter in
Queue.length queue.
Definition is_empty {A : Type} (function_parameter : t A) : bool :=
let '{| queue := queue |} := function_parameter in
Queue.is_empty queue.
Fixpoint empty {A : Type} (q : t A) : Lwt.t unit :=
if is_empty q then
Lwt.return_unit
else
op_gtgteq (Lwt_condition.wait None (empty q))
(fun function_parameter =>
let 'tt := function_parameter in
empty q).
(* ❌ The definition of exceptions is not handled. *)
exception
Fixpoint push {A : Type} (function_parameter : t A) : A -> Lwt.t unit :=
let
'{|
queue := queue;
current_size := current_size;
max_size := max_size;
compute_size := compute_size;
closed := closed
|} as q := function_parameter in
fun elt =>
let elt_size := compute_size elt in
if closed then
Lwt.fail Closed
else
if
orb (OCaml.Stdlib.lt (Z.add current_size elt_size) max_size)
(Queue.is_empty queue) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Queue.push (elt_size, elt) queue in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field q "current_size" % string
(Z.add current_size elt_size) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := notify_push q in
Lwt.return_unit
else
op_gtgteq (wait_pop q)
(fun function_parameter =>
let 'tt := function_parameter in
push q elt).
Definition push_now {A : Type} (function_parameter : t A) : A -> bool :=
let
'{|
queue := queue;
current_size := current_size;
max_size := max_size;
compute_size := compute_size;
closed := closed
|} as q := function_parameter in
fun elt =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if closed then
Stdlib.raise Closed
else
tt in
let elt_size := compute_size elt in
andb
(orb (OCaml.Stdlib.lt (Z.add current_size elt_size) max_size)
(Queue.is_empty queue))
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ := Queue.push (elt_size, elt) queue in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field q "current_size" % string (Z.add current_size elt_size)
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := notify_push q in
true).
(* ❌ The definition of exceptions is not handled. *)
exception
Definition push_now_exn {A : Type} (q : t A) (elt : A) : unit :=
if negb (push_now q elt) then
Stdlib.raise Full
else
tt.
Definition safe_push_now {A : Type} (q : t A) (elt : A) : unit :=
(* ❌ Try-with are not handled *)
try (push_now_exn q elt).
Fixpoint pop {A : Type} (function_parameter : t A) : Lwt.t A :=
let
'{|
queue := queue;
current_size := current_size;
closed := closed;
empty := empty
|} as q := function_parameter in
if negb (Queue.is_empty queue) then
let '(elt_size, elt) := Queue.pop queue in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := notify_pop q in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field q "current_size" % string (Z.sub current_size elt_size)
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if equiv_decb (Queue.length queue) 0 then
Lwt_condition.signal empty tt
else
tt in
Lwt._return elt
else
if closed then
Lwt.fail Closed
else
op_gtgteq (wait_push q)
(fun function_parameter =>
let 'tt := function_parameter in
pop q).
Fixpoint pop_with_timeout {A : Type} (timeout : Lwt.t unit) (q : t A)
: Lwt.t (option A) :=
if negb (Queue.is_empty (queue q)) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt.cancel timeout in
op_gtgteq (pop q) Lwt.return_some
else
if Lwt.is_sleeping timeout then
if closed q then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt.cancel timeout in
Lwt.fail Closed
else
let waiter := wait_push q in
op_gtgteq (Lwt.choose (cons timeout (cons (Lwt.protected waiter) [])))
(fun function_parameter =>
let 'tt := function_parameter in
pop_with_timeout timeout q)
else
Lwt.return_none.
Fixpoint peek {A : Type} (function_parameter : t A) : Lwt.t A :=
let '{| queue := queue; closed := closed |} as q := function_parameter in
if negb (Queue.is_empty queue) then
let '(_elt_size, elt) := Queue.peek queue in
Lwt._return elt
else
if closed then
Lwt.fail Closed
else
op_gtgteq (wait_push q)
(fun function_parameter =>
let 'tt := function_parameter in
peek q).
Definition peek_all {A : Type} (function_parameter : t A) : list A :=
let '{| queue := queue; closed := closed |} := function_parameter in
if closed then
[]
else
List.rev
(Queue.fold
(fun acc =>
fun function_parameter =>
let '(_, e) := function_parameter in
cons e acc) [] queue).
(* ❌ The definition of exceptions is not handled. *)
exception
Definition pop_now_exn {A : Type} (function_parameter : t A) : A :=
let
'{|
queue := queue;
current_size := current_size;
closed := closed;
empty := empty
|} as q := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if Queue.is_empty queue then
if closed then
Stdlib.raise Closed
else
Stdlib.raise Empty
else
tt in
let '(elt_size, elt) := Queue.pop queue in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if equiv_decb (Queue.length queue) 0 then
Lwt_condition.signal empty tt
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field q "current_size" % string (Z.sub current_size elt_size) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := notify_pop q in
elt.
Definition pop_now {A : Type} (q : t A) : option A :=
let 'elt := pop_now_exn q in
Some elt.
Fixpoint values_available {A : Type} (q : t A) : Lwt.t unit :=
if is_empty q then
if closed q then
Stdlib.raise Closed
else
op_gtgteq (wait_push q)
(fun function_parameter =>
let 'tt := function_parameter in
values_available q)
else
Lwt.return_unit.
Fixpoint pop_all_loop {A : Type} (q : t A) (acc : list A) : list A :=
let 'e := pop_now_exn q in
pop_all_loop q (cons e acc).
Definition pop_all {A : Type} (q : t A) : Lwt.t (list A) :=
op_gtgteq (pop q) (fun e => Lwt._return (pop_all_loop q (cons e []))).
Definition pop_all_now {A : Type} (q : t A) : list A := pop_all_loop q [].
Definition close {A : Type} (q : t A) : unit :=
if negb (closed q) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field q "closed" % string true in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := notify_push q in
notify_pop q
else
tt.
Fixpoint iter {A : Type} (q : t A) (f : A -> Lwt.t unit) : Lwt.t unit :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (pop q)
(fun elt =>
op_gtgteq (f elt)
(fun function_parameter =>
let 'tt := function_parameter in
iter q f)))
(fun function_parameter =>
match function_parameter with
| Closed => Lwt.return_unit
| exn => Lwt.fail exn
end).
src/lib_stdlib/lwt_utils.ml 11 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module LC = Lwt_condition
open Lwt.Infix
let may ~f = function None -> Lwt.return_unit | Some x -> f x
let never_ending () = fst (Lwt.wait ())
type trigger = Absent | Present | Waiting of unit Lwt.t * unit Lwt.u
let trigger () : (unit -> unit) * (unit -> unit Lwt.t) =
let state = ref Absent in
let trigger () =
match !state with
| Absent ->
state := Present
| Present ->
()
| Waiting (_waiter, wakener) ->
state := Absent ;
Lwt.wakeup wakener ()
in
let wait () =
match !state with
| Absent ->
let (waiter, wakener) = Lwt.wait () in
state := Waiting (waiter, wakener) ;
waiter
| Present ->
state := Absent ;
Lwt.return_unit
| Waiting (waiter, _wakener) ->
waiter
in
(trigger, wait)
(* A worker launcher, takes a cancel callback to call upon *)
let worker name ~on_event ~run ~cancel =
let stop = LC.create () in
let fail e =
on_event
name
(`Failed (Printf.sprintf "Exception: %s" (Printexc.to_string e)))
>>= fun () -> cancel ()
in
let waiter = LC.wait stop in
on_event name `Started
>>= fun () ->
Lwt.async (fun () ->
Lwt.catch run fail >>= fun () -> LC.signal stop () ; Lwt.return_unit) ;
waiter >>= fun () -> on_event name `Ended >>= fun () -> Lwt.return_unit
let rec chop k l =
if k = 0 then l
else match l with _ :: t -> chop (k - 1) t | _ -> assert false
let stable_sort cmp l =
let rec rev_merge l1 l2 accu =
match (l1, l2) with
| ([], l2) ->
Lwt.return (List.rev_append l2 accu)
| (l1, []) ->
Lwt.return (List.rev_append l1 accu)
| (h1 :: t1, h2 :: t2) -> (
cmp h1 h2
>>= function
| x when x <= 0 ->
rev_merge t1 l2 (h1 :: accu)
| _ ->
rev_merge l1 t2 (h2 :: accu) )
in
let rec rev_merge_rev l1 l2 accu =
match (l1, l2) with
| ([], l2) ->
Lwt.return (List.rev_append l2 accu)
| (l1, []) ->
Lwt.return (List.rev_append l1 accu)
| (h1 :: t1, h2 :: t2) -> (
cmp h1 h2
>>= function
| x when x > 0 ->
rev_merge_rev t1 l2 (h1 :: accu)
| _ ->
rev_merge_rev l1 t2 (h2 :: accu) )
in
let rec sort n l =
match (n, l) with
| (2, x1 :: x2 :: _) -> (
cmp x1 x2 >|= function x when x <= 0 -> [x1; x2] | _ -> [x2; x1] )
| (3, x1 :: x2 :: x3 :: _) -> (
cmp x1 x2
>>= function
| x when x <= 0 -> (
cmp x2 x3
>>= function
| x when x <= 0 ->
Lwt.return [x1; x2; x3]
| _ -> (
cmp x1 x3
>|= function x when x <= 0 -> [x1; x3; x2] | _ -> [x3; x1; x2]
) )
| _ -> (
cmp x1 x3
>>= function
| x when x <= 0 ->
Lwt.return [x2; x1; x3]
| _ -> (
cmp x2 x3
>|= function x when x <= 0 -> [x2; x3; x1] | _ -> [x3; x2; x1]
) ) )
| (n, l) ->
let n1 = n asr 1 in
let n2 = n - n1 in
let l2 = chop n1 l in
rev_sort n1 l
>>= fun s1 -> rev_sort n2 l2 >>= fun s2 -> rev_merge_rev s1 s2 []
and rev_sort n l =
match (n, l) with
| (2, x1 :: x2 :: _) -> (
cmp x1 x2 >|= function x when x > 0 -> [x1; x2] | _ -> [x2; x1] )
| (3, x1 :: x2 :: x3 :: _) -> (
cmp x1 x2
>>= function
| x when x > 0 -> (
cmp x2 x3
>>= function
| x when x > 0 ->
Lwt.return [x1; x2; x3]
| _ -> (
cmp x1 x3
>|= function x when x > 0 -> [x1; x3; x2] | _ -> [x3; x1; x2] )
)
| _ -> (
cmp x1 x3
>>= function
| x when x > 0 ->
Lwt.return [x2; x1; x3]
| _ -> (
cmp x2 x3
>|= function x when x > 0 -> [x2; x3; x1] | _ -> [x3; x2; x1] )
) )
| (n, l) ->
let n1 = n asr 1 in
let n2 = n - n1 in
let l2 = chop n1 l in
sort n1 l >>= fun s1 -> sort n2 l2 >>= fun s2 -> rev_merge s1 s2 []
in
let len = List.length l in
if len < 2 then Lwt.return l else sort len l
let sort = stable_sort
let unless cond f = if cond then Lwt.return_unit else f ()
let rec fold_left_s_n ~n f acc l =
if n = 0 then Lwt.return (acc, l)
else
match l with
| [] ->
Lwt.return (acc, [])
| x :: l ->
f acc x
>>= fun acc -> (fold_left_s_n [@ocaml.tailcall]) f ~n:(n - 1) acc l
src/lib_stdlib/lwt_utils.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ This kind of module is not handled. *)
unhandled_module
Import Lwt.Infix.
Definition may {A : Type} (f : A -> Lwt.t unit) (function_parameter : option A)
: Lwt.t unit :=
match function_parameter with
| None => Lwt.return_unit
| Some x => f x
end.
Definition never_ending {A : Type} (function_parameter : unit) : Lwt.t A :=
let 'tt := function_parameter in
fst (Lwt.wait tt).
Inductive trigger : Type :=
| Absent : trigger
| Present : trigger
| Waiting : (Lwt.t unit) -> (Lwt.u unit) -> trigger.
Definition trigger (function_parameter : unit)
: (unit -> unit) * (unit -> Lwt.t unit) :=
let 'tt := function_parameter in
let state := Stdlib.ref Absent in
let trigger (function_parameter : unit) : unit :=
let 'tt := function_parameter in
match Stdlib.op_exclamation state with
| Absent => Stdlib.op_coloneq state Present
| Present => tt
| Waiting _waiter wakener =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq state Absent in
Lwt.wakeup wakener tt
end in
let wait (function_parameter : unit) : Lwt.t unit :=
let 'tt := function_parameter in
match Stdlib.op_exclamation state with
| Absent =>
let '(waiter, wakener) := Lwt.wait tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq state (Waiting waiter wakener) in
waiter
| Present =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq state Absent in
Lwt.return_unit
| Waiting waiter _wakener => waiter
end in
(trigger, wait).
Definition worker {A : Type}
(name : A) (on_event : A -> variant -> Lwt.t unit) (run : unit -> Lwt.t unit)
(cancel : unit -> Lwt.t unit) : Lwt.t unit :=
let stop := LC.create tt in
let fail (e : exn) : Lwt.t unit :=
op_gtgteq
(on_event name
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
cancel tt) in
let waiter := LC.wait None stop in
op_gtgteq
(on_event name
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt.catch run fail)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := LC.signal stop tt in
Lwt.return_unit)) in
op_gtgteq waiter
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(on_event name
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_unit))).
Fixpoint chop {A : Type} (k : Z) (l : list A) : list A :=
if equiv_decb k 0 then
l
else
match l with
| cons _ t => chop (Z.sub k 1) t
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end.
Definition stable_sort {A : Type} (cmp : A -> A -> Lwt.t Z) (l : list A)
: Lwt.t (list A) :=
let fix rev_merge (l1 : list A) (l2 : list A) (accu : list A)
: Lwt.t (list A) :=
match (l1, l2) with
| ([], l2) => Lwt._return (Stdlib.List.rev_append l2 accu)
| (l1, []) => Lwt._return (Stdlib.List.rev_append l1 accu)
| (cons h1 t1, cons h2 t2) =>
op_gtgteq (cmp h1 h2)
(fun function_parameter =>
match function_parameter with
| x => rev_merge t1 l2 (cons h1 accu)
| _ => rev_merge l1 t2 (cons h2 accu)
end)
end in
let fix rev_merge_rev (l1 : list A) (l2 : list A) (accu : list A)
: Lwt.t (list A) :=
match (l1, l2) with
| ([], l2) => Lwt._return (Stdlib.List.rev_append l2 accu)
| (l1, []) => Lwt._return (Stdlib.List.rev_append l1 accu)
| (cons h1 t1, cons h2 t2) =>
op_gtgteq (cmp h1 h2)
(fun function_parameter =>
match function_parameter with
| x => rev_merge_rev t1 l2 (cons h1 accu)
| _ => rev_merge_rev l1 t2 (cons h2 accu)
end)
end in
let fix sort (n : Z) (l : list A) : Lwt.t (list A) :=
match (n, l) with
| (2, cons x1 (cons x2 _)) =>
op_gtpipeeq (cmp x1 x2)
(fun function_parameter =>
match function_parameter with
| x => cons x1 (cons x2 [])
| _ => cons x2 (cons x1 [])
end)
| (3, cons x1 (cons x2 (cons x3 _))) =>
op_gtgteq (cmp x1 x2)
(fun function_parameter =>
match function_parameter with
| x =>
op_gtgteq (cmp x2 x3)
(fun function_parameter =>
match function_parameter with
| x => Lwt._return (cons x1 (cons x2 (cons x3 [])))
| _ =>
op_gtpipeeq (cmp x1 x3)
(fun function_parameter =>
match function_parameter with
| x => cons x1 (cons x3 (cons x2 []))
| _ => cons x3 (cons x1 (cons x2 []))
end)
end)
| _ =>
op_gtgteq (cmp x1 x3)
(fun function_parameter =>
match function_parameter with
| x => Lwt._return (cons x2 (cons x1 (cons x3 [])))
| _ =>
op_gtpipeeq (cmp x2 x3)
(fun function_parameter =>
match function_parameter with
| x => cons x2 (cons x3 (cons x1 []))
| _ => cons x3 (cons x2 (cons x1 []))
end)
end)
end)
| (n, l) =>
let n1 := Stdlib.asr n 1 in
let n2 := Z.sub n n1 in
let l2 := chop n1 l in
op_gtgteq (rev_sort n1 l)
(fun s1 => op_gtgteq (rev_sort n2 l2) (fun s2 => rev_merge_rev s1 s2 []))
end
with rev_sort (n : Z) (l : list A) : Lwt.t (list A) :=
match (n, l) with
| (2, cons x1 (cons x2 _)) =>
op_gtpipeeq (cmp x1 x2)
(fun function_parameter =>
match function_parameter with
| x => cons x1 (cons x2 [])
| _ => cons x2 (cons x1 [])
end)
| (3, cons x1 (cons x2 (cons x3 _))) =>
op_gtgteq (cmp x1 x2)
(fun function_parameter =>
match function_parameter with
| x =>
op_gtgteq (cmp x2 x3)
(fun function_parameter =>
match function_parameter with
| x => Lwt._return (cons x1 (cons x2 (cons x3 [])))
| _ =>
op_gtpipeeq (cmp x1 x3)
(fun function_parameter =>
match function_parameter with
| x => cons x1 (cons x3 (cons x2 []))
| _ => cons x3 (cons x1 (cons x2 []))
end)
end)
| _ =>
op_gtgteq (cmp x1 x3)
(fun function_parameter =>
match function_parameter with
| x => Lwt._return (cons x2 (cons x1 (cons x3 [])))
| _ =>
op_gtpipeeq (cmp x2 x3)
(fun function_parameter =>
match function_parameter with
| x => cons x2 (cons x3 (cons x1 []))
| _ => cons x3 (cons x2 (cons x1 []))
end)
end)
end)
| (n, l) =>
let n1 := Stdlib.asr n 1 in
let n2 := Z.sub n n1 in
let l2 := chop n1 l in
op_gtgteq (sort n1 l)
(fun s1 => op_gtgteq (sort n2 l2) (fun s2 => rev_merge s1 s2 []))
end in
let len := OCaml.List.length l in
if OCaml.Stdlib.lt len 2 then
Lwt._return l
else
sort len l.
Definition sort {A : Type}
: (A -> A -> Lwt.t Z) -> (list A) -> Lwt.t (list A) := stable_sort.
Definition unless (cond : bool) (f : unit -> Lwt.t unit) : Lwt.t unit :=
if cond then
Lwt.return_unit
else
f tt.
Fixpoint fold_left_s_n {A B : Type}
(n : Z) (f : A -> B -> Lwt.t A) (acc : A) (l : list B)
: Lwt.t (A * (list B)) :=
if equiv_decb n 0 then
Lwt._return (acc, l)
else
match l with
| [] => Lwt._return (acc, [])
| cons x l =>
op_gtgteq (f acc x) (fun acc => fold_left_s_n (Z.sub n 1) f acc l)
end.
src/lib_stdlib/lwt_watcher.ml 16 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type 'a inner_stopper = {
id : int;
push : 'a option -> unit;
mutable active : bool;
input : 'a input;
}
and 'a input = {mutable watchers : 'a inner_stopper list; mutable cpt : int}
type stopper = unit -> unit
let create_input () = {watchers = []; cpt = 0}
let shutdown_input input =
let {watchers; _} = input in
List.iter
(fun w ->
w.active <- false ;
w.push None)
watchers ;
input.cpt <- 0 ;
input.watchers <- []
let create_fake_stream () =
let (str, push) = Lwt_stream.create () in
(str, fun () -> push None)
let notify input info = List.iter (fun w -> w.push (Some info)) input.watchers
let shutdown_output output =
if output.active then (
output.active <- false ;
output.push None ;
output.input.watchers <-
List.filter (fun w -> w.id <> output.id) output.input.watchers )
let create_stream input =
input.cpt <- input.cpt + 1 ;
let id = input.cpt in
let (stream, push) = Lwt_stream.create () in
let output = {id; push; input; active = true} in
input.watchers <- output :: input.watchers ;
(stream, fun () -> shutdown_output output)
let shutdown f = f ()
src/lib_stdlib/lwt_watcher.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
.
Definition stopper := unit -> unit.
Definition create_input {A : Type} (function_parameter : unit) : input A :=
let 'tt := function_parameter in
{| watchers := []; cpt := 0 |}.
Definition shutdown_input {A : Type} (input : input A) : unit :=
let '{| watchers := watchers |} := input in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.List.iter
(fun w =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field w "active" % string false in
(push w) None) watchers in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field input "cpt" % string 0 in
(* ❌ Set record field not handled. *)
set_record_field input "watchers" % string [].
Definition create_fake_stream {A : Type} (function_parameter : unit)
: (Lwt_stream.t A) * (unit -> unit) :=
let 'tt := function_parameter in
let '(str, push) := Lwt_stream.create tt in
(str,
(fun function_parameter =>
let 'tt := function_parameter in
push None)).
Definition notify {A : Type} (input : input A) (info : A) : unit :=
Stdlib.List.iter (fun w => (push w) (Some info)) (watchers input).
Definition shutdown_output {A : Type} (output : inner_stopper A) : unit :=
if active output then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field output "active" % string false in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := (push output) None in
(* ❌ Set record field not handled. *)
set_record_field (input output) "watchers" % string
(Stdlib.List.filter (fun w => nequiv_decb (id w) (id output))
(watchers (input output)))
else
tt.
Definition create_stream {A : Type} (input : input A)
: (Lwt_stream.t A) * (unit -> unit) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field input "cpt" % string (Z.add (cpt input) 1) in
let id := cpt input in
let '(stream, push) := Lwt_stream.create tt in
let output := {| id := id; push := push; active := true; input := input |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field input "watchers" % string (cons output (watchers input)) in
(stream,
(fun function_parameter =>
let 'tt := function_parameter in
shutdown_output output)).
Definition shutdown {A : Type} (f : unit -> A) : A := f tt.
src/lib_stdlib/mBytes.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) type t = bytes let create = Bytes.create let length = Bytes.length let copy = Bytes.copy let sub = Bytes.sub let blit = Bytes.blit let blit_of_string = Bytes.blit_string let blit_to_bytes = Bytes.blit let of_string = Bytes.of_string let to_string = Bytes.to_string let sub_string = Bytes.sub_string let get_char = Bytes.get let set_char = Bytes.set include TzEndian module LE = struct let get_uint16 = Bytes_encodings.get_uint16_le let get_int16 = Bytes_encodings.get_int16_le let get_int32 = Bytes_encodings.get_int32_le let get_int64 = Bytes_encodings.get_int64_le let set_int16 = Bytes_encodings.set_int16_le let set_int32 = Bytes_encodings.set_int32_le let set_int64 = Bytes_encodings.set_int64_le end let ( = ) = Pervasives.( = ) let ( <> ) = Pervasives.( <> ) let ( < ) = Pervasives.( < ) let ( <= ) = Pervasives.( <= ) let ( >= ) = Pervasives.( >= ) let ( > ) = Pervasives.( > ) let compare = Bytes.compare let concat s bs = Bytes.concat (Bytes.of_string s) bs let to_hex t = Hex.of_bytes t let of_hex hex = Hex.to_bytes hex
src/lib_stdlib/mBytes.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := string.
Definition create : Z -> string := Stdlib.Bytes.create.
Definition length : string -> Z := String.length.
Definition copy : string -> string := Stdlib.Bytes.copy.
Definition sub : string -> Z -> Z -> string := String.sub.
Definition blit : string -> Z -> string -> Z -> Z -> unit := Stdlib.Bytes.blit.
Definition blit_of_string : string -> Z -> string -> Z -> Z -> unit :=
Stdlib.Bytes.blit_string.
Definition blit_to_bytes : string -> Z -> string -> Z -> Z -> unit :=
Stdlib.Bytes.blit.
Definition of_string : string -> string := Stdlib.Bytes.of_string.
Definition to_string : string -> string := Stdlib.Bytes.to_string.
Definition sub_string : string -> Z -> Z -> string := Stdlib.Bytes.sub_string.
Definition get_char : string -> Z -> ascii := Stdlib.Bytes.get.
Definition set_char : string -> Z -> ascii -> unit := Stdlib.Bytes.set.
(* ❌ Structure item `include` not handled. *)
include
Module LE.
Definition get_uint16 : string -> Z -> Z := Bytes_encodings.get_uint16_le.
Definition get_int16 : string -> Z -> Z := Bytes_encodings.get_int16_le.
Definition get_int32 : string -> Z -> int32 := Bytes_encodings.get_int32_le.
Definition get_int64 : string -> Z -> int64 := Bytes_encodings.get_int64_le.
Definition set_int16 : string -> Z -> Z -> unit :=
Bytes_encodings.set_int16_le.
Definition set_int32 : string -> Z -> int32 -> unit :=
Bytes_encodings.set_int32_le.
Definition set_int64 : string -> Z -> int64 -> unit :=
Bytes_encodings.set_int64_le.
End LE.
Definition op_eq {A : Type} : A -> A -> bool := Pervasives.op_eq.
Definition op_ltgt {A : Type} : A -> A -> bool := Pervasives.op_ltgt.
Definition op_lt {A : Type} : A -> A -> bool := Pervasives.op_lt.
Definition op_lteq {A : Type} : A -> A -> bool := Pervasives.op_lteq.
Definition op_gteq {A : Type} : A -> A -> bool := Pervasives.op_gteq.
Definition op_gt {A : Type} : A -> A -> bool := Pervasives.op_gt.
Definition compare : Stdlib.Bytes.t -> Stdlib.Bytes.t -> Z :=
Stdlib.Bytes.compare.
Definition concat (s : string) (bs : list string) : string :=
String.concat (Stdlib.Bytes.of_string s) bs.
Definition to_hex (t : string) : Hex.t := Hex.of_bytes None t.
Definition of_hex (hex : Hex.t) : string := Hex.to_bytes hex.
src/lib_stdlib/memory.ml success
(*****************************************************************************)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type proc_statm = {
page_size : int;
size : int64;
resident : int64;
shared : int64;
text : int64;
lib : int64;
data : int64;
dt : int64;
}
type ps_stats = {page_size : int; mem : float; resident : int64}
type mem_stats = Statm of proc_statm | Ps of ps_stats
src/lib_stdlib/memory.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record proc_statm := {
page_size : Z;
size : int64;
resident : int64;
shared : int64;
text : int64;
lib : int64;
data : int64;
dt : int64 }.
Record ps_stats := {
page_size : Z;
mem : Z;
resident : int64 }.
Inductive mem_stats : Type :=
| Statm : proc_statm -> mem_stats
| Ps : ps_stats -> mem_stats.
src/lib_stdlib/option.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let map ~f = function None -> None | Some x -> Some (f x)
let apply ~f = function None -> None | Some x -> f x
let ( >>= ) x f = apply ~f x
let ( >>| ) x f = map ~f x
let iter ~f = function None -> () | Some x -> f x
let unopt ~default = function None -> default | Some x -> x
let unopt_map ~f ~default = function None -> default | Some x -> f x
let unopt_exn err = function Some x -> x | _ -> raise err
let unopt_assert ~loc:(name, line, pos, _) = function
| Some v ->
v
| None ->
raise (Assert_failure (name, line, pos))
let first_some a b =
match (a, b) with
| (None, None) ->
None
| (None, Some v) ->
Some v
| (Some v, _) ->
Some v
let try_with f = try Some (f ()) with _ -> None
let some x = Some x
let pp ?(default = "None") pp fmt = function
| Some value ->
pp fmt value
| None ->
Format.pp_print_text fmt default
src/lib_stdlib/option.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition map {A B : Type} (f : A -> B) (function_parameter : option A)
: option B :=
match function_parameter with
| None => None
| Some x => Some (f x)
end.
Definition apply {A B : Type}
(f : A -> option B) (function_parameter : option A) : option B :=
match function_parameter with
| None => None
| Some x => f x
end.
Definition op_gtgteq {A B : Type} (x : option A) (f : A -> option B)
: option B := apply f x.
Definition op_gtgtpipe {A B : Type} (x : option A) (f : A -> B) : option B :=
map f x.
Definition iter {A : Type} (f : A -> unit) (function_parameter : option A)
: unit :=
match function_parameter with
| None => tt
| Some x => f x
end.
Definition unopt {A : Type} (default : A) (function_parameter : option A) : A :=
match function_parameter with
| None => default
| Some x => x
end.
Definition unopt_map {A B : Type}
(f : A -> B) (default : B) (function_parameter : option A) : B :=
match function_parameter with
| None => default
| Some x => f x
end.
Definition unopt_exn {A : Type} (err : exn) (function_parameter : option A)
: A :=
match function_parameter with
| Some x => x
| _ => Stdlib.raise err
end.
Definition unopt_assert {A B : Type} (function_parameter : string * Z * Z * A)
: (option B) -> B :=
let '(name, line, pos, _) := function_parameter in
fun function_parameter =>
match function_parameter with
| Some v => v
| None => Stdlib.raise (OCaml.Assert_failure (name, line, pos))
end.
Definition first_some {A : Type} (a : option A) (b : option A) : option A :=
match (a, b) with
| (None, None) => None
| (None, Some v) => Some v
| (Some v, _) => Some v
end.
Definition try_with {A : Type} (f : unit -> A) : option A :=
(* ❌ Try-with are not handled *)
try (Some (f tt)).
Definition some {A : Type} (x : A) : option A := Some x.
Definition pp {A : Type} (op_staroptstar : option string)
: (Stdlib.Format.formatter -> A -> unit) ->
Stdlib.Format.formatter -> (option A) -> unit :=
let default :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "None" % string
end in
fun pp =>
fun fmt =>
fun function_parameter =>
match function_parameter with
| Some value => pp fmt value
| None => Format.pp_print_text fmt default
end.
src/lib_stdlib/registry.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type S = sig
type k
type v
val register : k -> v -> unit
val alter : k -> (v -> v) -> unit
val remove : k -> unit
val query : k -> v option
val iter_p : (k -> v -> unit Lwt.t) -> unit Lwt.t
val fold : (k -> v -> 'a -> 'a) -> 'a -> 'a
end
module Make (M : sig
type v
include Map.OrderedType
end) : S with type k = M.t and type v = M.v = struct
module Reg = Map.Make (M)
type v = M.v
type k = Reg.key
let registry : v Reg.t ref = ref Reg.empty
let register k v = registry := Reg.add k v !registry
let alter k f =
match Reg.find_opt k !registry with
| None ->
()
| Some v ->
registry := Reg.add k (f v) !registry
let remove k = registry := Reg.remove k !registry
let query k = Reg.find_opt k !registry
let iter_p f = Lwt.join (Reg.fold (fun k v acc -> f k v :: acc) !registry [])
let fold f a = Reg.fold f !registry a
end
src/lib_stdlib/registry.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module S.
Record signature {k v : Type} := {
k := k;
v := v;
register : k -> v -> unit;
alter : k -> (v -> v) -> unit;
remove : k -> unit;
query : k -> option v;
iter_p : (k -> v -> Lwt.t unit) -> Lwt.t unit;
fold : forall {a : Type}, (k -> v -> a -> a) -> a -> a;
}.
Arguments signature : clear implicits.
End S.
(* ❌ Functors are not handled. *)
functor
src/lib_stdlib/ring.ml 9 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Ring = struct
type 'a raw = Empty of int | Inited of {data : 'a array; mutable pos : int}
type 'a t = 'a raw ref
let create size =
if size <= 0 then invalid_arg "Ring.create: size must be positive"
else ref (Empty size)
let add r v =
match !r with
| Empty size ->
r := Inited {data = Array.make size v; pos = 0}
| Inited s ->
s.pos <-
( if s.pos = (2 * Array.length s.data) - 1 then Array.length s.data
else s.pos + 1 ) ;
s.data.(s.pos mod Array.length s.data) <- v
let add_and_return_erased r v =
let replaced =
match !r with
| Empty _ ->
None
| Inited s ->
if s.pos >= Array.length s.data - 1 then
Some s.data.((s.pos + 1) mod Array.length s.data)
else None
in
add r v ; replaced
let clear r =
match !r with
| Empty _ ->
()
| Inited {data; _} ->
r := Empty (Array.length data)
let add_list r l = List.iter (add r) l
let last r =
match !r with
| Empty _ ->
None
| Inited {data; pos} ->
Some data.(pos mod Array.length data)
let fold r ~init ~f =
match !r with
| Empty _ ->
init
| Inited {data; pos} ->
let size = Array.length data in
let acc = ref init in
for i = 0 to min pos (size - 1) do
acc := f !acc data.((pos - i) mod size)
done ;
!acc
let elements t = fold t ~init:[] ~f:(fun acc elt -> elt :: acc)
exception Empty
let last_exn r = match last r with None -> raise Empty | Some d -> d
end
include Ring
(** Ring Buffer Table *)
module type TABLE = sig
type t
type v
val create : int -> t
val add : t -> v -> unit
val add_and_return_erased : t -> v -> v option
val mem : t -> v -> bool
val remove : t -> v -> unit
val clear : t -> unit
val elements : t -> v list
end
(* fixed size set of Peers id. If the set exceed the maximal allowed capacity, the
element that was added first is removed when a new one is added *)
module MakeTable (V : Hashtbl.HashedType) = struct
module Table = Hashtbl.Make (V)
type raw = {size : int; ring : V.t Ring.t; table : unit Table.t}
type t = raw ref
type v = V.t
let create size =
ref {size; ring = Ring.create size; table = Table.create size}
let add {contents = t} v =
Option.iter (Ring.add_and_return_erased t.ring v) ~f:(Table.remove t.table) ;
Table.add t.table v ()
let add_and_return_erased {contents = t} v =
match Ring.add_and_return_erased t.ring v with
| None ->
Table.add t.table v () ; None
| Some erased ->
Table.remove t.table erased ;
Table.add t.table v () ;
Some erased
let mem {contents = t} v = Table.mem t.table v
let remove {contents = t} v = Table.remove t.table v
let clear ({contents = t} as tt) =
tt := {t with ring = Ring.create t.size; table = Table.create t.size}
let elements {contents = t} = Table.fold (fun k _ acc -> k :: acc) t.table []
end
src/lib_stdlib/ring.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Ring.
Inductive raw (a : Type) : Type :=
| Empty : Z -> raw a
| Inited : (array a) -> Z -> raw a.
Arguments Empty {_}.
Arguments Inited {_}.
Definition t (a : Type) := Stdlib.ref (raw a).
Definition create {A : Type} (size : Z) : Stdlib.ref (raw A) :=
if OCaml.Stdlib.le size 0 then
OCaml.Stdlib.invalid_arg "Ring.create: size must be positive" % string
else
Stdlib.ref (Empty size).
Definition add {A : Type} (r : Stdlib.ref (raw A)) (v : A) : unit :=
match Stdlib.op_exclamation r with
| Empty size =>
Stdlib.op_coloneq r (Inited {| data := Array.make size v; pos := 0 |})
| Inited s =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field s "pos" % string
(if equiv_decb (pos s) (Z.sub (Z.mul 2 (Array.length (data s))) 1)
then
Array.length (data s)
else
Z.add (pos s) 1) in
Array.set (data s) (Z.modulo (pos s) (Array.length (data s))) v
end.
Definition add_and_return_erased {A : Type} (r : Stdlib.ref (raw A)) (v : A)
: option A :=
let replaced :=
match Stdlib.op_exclamation r with
| Empty _ => None
| Inited s =>
if OCaml.Stdlib.ge (pos s) (Z.sub (Array.length (data s)) 1) then
Some
(Array.get (data s)
(Z.modulo (Z.add (pos s) 1) (Array.length (data s))))
else
None
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := add r v in
replaced.
Definition clear {A : Type} (r : Stdlib.ref (raw A)) : unit :=
match Stdlib.op_exclamation r with
| Empty _ => tt
| Inited {| data := data |} =>
Stdlib.op_coloneq r (Empty (Array.length data))
end.
Definition add_list {A : Type} (r : Stdlib.ref (raw A)) (l : list A) : unit :=
Stdlib.List.iter (add r) l.
Definition last {A : Type} (r : Stdlib.ref (raw A)) : option A :=
match Stdlib.op_exclamation r with
| Empty _ => None
| Inited {| data := data; pos := pos |} =>
Some (Array.get data (Z.modulo pos (Array.length data)))
end.
Definition fold {A B : Type}
(r : Stdlib.ref (raw A)) (init : B) (f : B -> A -> B) : B :=
match Stdlib.op_exclamation r with
| Empty _ => init
| Inited {| data := data; pos := pos |} =>
let size := Array.length data in
let acc := Stdlib.ref init in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ For loops not handled. *)
for in
Stdlib.op_exclamation acc
end.
Definition elements {A : Type} (t : Stdlib.ref (raw A)) : list A :=
fold t [] (fun acc => fun elt => cons elt acc).
(* ❌ The definition of exceptions is not handled. *)
exception
Definition last_exn {A : Type} (r : Stdlib.ref (raw A)) : A :=
match last r with
| None => Stdlib.raise Empty
| Some d => d
end.
End Ring.
(* ❌ Structure item `include` not handled. *)
include
Module TABLE.
Record signature {t v : Type} := {
t := t;
v := v;
create : Z -> t;
add : t -> v -> unit;
add_and_return_erased : t -> v -> option v;
mem : t -> v -> bool;
remove : t -> v -> unit;
clear : t -> unit;
elements : t -> list v;
}.
Arguments signature : clear implicits.
End TABLE.
(* ❌ Functors are not handled. *)
functor
src/lib_stdlib/tag.ml 14 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type _ selector = ..
module type DEF_ARG = sig
val name : string
type t
val doc : string
val pp : Format.formatter -> t -> unit
end
module type DEF = sig
include DEF_ARG
type id
val id : id
type _ selector += Me : t selector
val uid : int
end
module Def (X : DEF_ARG) : DEF with type t = X.t = struct
include X
type id = Id
let id = Id
type _ selector += Me : t selector
let uid = Obj.(extension_id @@ extension_constructor @@ Me)
end
type 'a def = (module DEF with type t = 'a)
let def (type a) ?(doc = "undocumented") name pp =
( module Def (struct
let name = name
type t = a
let doc = doc
let pp = pp
end) : DEF
with type t = a )
type (_, _) eq = Refl : ('a, 'a) eq
let maybe_eq : type a b. a def -> b def -> (a, b) eq option =
fun s t ->
let module S = (val s) in
let module T = (val t) in
match S.Me with T.Me -> Some Refl | _ -> None
let selector_of : type a. a def -> a selector =
fun d ->
let module D = (val d) in
D.Me
let name : type a. a def -> string =
fun d ->
let module D = (val d) in
D.name
let doc : type a. a def -> string =
fun d ->
let module D = (val d) in
D.doc
let printer : type a. a def -> Format.formatter -> a -> unit =
fun d ->
let module D = (val d) in
D.pp
let pp_def ppf d = Format.fprintf ppf "tag:%s" (name d)
module Key = struct
type t = V : 'a def -> t
type s = S : 'a selector -> s
let compare (V k0) (V k1) = compare (S (selector_of k0)) (S (selector_of k1))
end
module TagSet = Map.Make (Key)
type t = V : 'a def * 'a -> t
type binding = t
type set = binding TagSet.t
let pp ppf (V (tag, v)) =
Format.fprintf ppf "@[<1>(%a@ @[%a@])@]" pp_def tag (printer tag) v
let option_map f = function None -> None | Some v -> Some (f v)
let option_bind f = function None -> None | Some v -> f v
let reveal2 : type a b. a def -> b def -> b -> a option =
fun t u v -> match maybe_eq t u with None -> None | Some Refl -> Some v
let reveal : 'a. 'a def -> binding -> 'a option =
fun tag -> function V (another, v) -> reveal2 tag another v
let unveil : 'a. 'a def -> binding option -> 'a option =
fun tag -> option_bind @@ reveal tag
let conceal : 'a. 'a def -> 'a -> binding = fun tag v -> V (tag, v)
let veil : 'a. 'a def -> 'a option -> binding option =
fun tag -> option_map @@ conceal tag
let empty = TagSet.empty
let is_empty = TagSet.is_empty
let mem tag = TagSet.mem (Key.V tag)
let add tag v = TagSet.add (Key.V tag) (V (tag, v))
let update tag f =
TagSet.update (Key.V tag) (fun b -> veil tag @@ f @@ unveil tag b)
let singleton tag v = TagSet.singleton (Key.V tag) (V (tag, v))
let remove tag = TagSet.remove (Key.V tag)
let rem = remove
type merger = {merger : 'a. 'a def -> 'a option -> 'a option -> 'a option}
let merge f =
TagSet.merge
@@ function
| Key.V tag ->
fun a b -> veil tag @@ f.merger tag (unveil tag a) (unveil tag b)
type unioner = {unioner : 'a. 'a def -> 'a -> 'a -> 'a}
let union f =
merge
{
merger =
(fun tag a b ->
match (a, b) with
| (Some aa, Some bb) ->
Some (f.unioner tag aa bb)
| (Some _, None) ->
a
| (None, _) ->
b);
}
(* no compare and equal, compare especially makes little sense *)
let iter f = TagSet.iter (fun _ -> f)
let fold f = TagSet.fold (fun _ -> f)
let for_all p = TagSet.for_all (fun _ -> p)
let exists p = TagSet.exists (fun _ -> p)
let filter p = TagSet.filter (fun _ -> p)
let partition p = TagSet.partition (fun _ -> p)
let cardinal = TagSet.cardinal
let bindings s = List.map snd @@ TagSet.bindings s
let min_binding s = snd @@ TagSet.min_binding s
let min_binding_opt s = option_map snd @@ TagSet.min_binding_opt s
let max_binding s = snd @@ TagSet.max_binding s
let max_binding_opt s = option_map snd @@ TagSet.max_binding_opt s
let choose s = snd @@ TagSet.choose s
let choose_opt s = option_map snd @@ TagSet.choose_opt s
let split tag s =
(fun (l, m, r) -> (l, unveil tag m, r)) @@ TagSet.split (Key.V tag) s
(* In order to match the usual interface for maps, `find` should be different from
`find_opt` but `Logs` has `find_opt` called `find` so we favor that. *)
let find tag s = option_bind (reveal tag) @@ TagSet.find_opt (Key.V tag) s
let find_opt tag s = option_bind (reveal tag) @@ TagSet.find_opt (Key.V tag) s
(* This would usually be called `find` but `Logs` has it with this name. We can't
have it at both named because `Logs` has `find_opt` as `find`. *)
let get tag s =
find_opt tag s
|> function
| None ->
invalid_arg (Format.asprintf "tag named %s not found in set" (name tag))
| Some v ->
v
let find_first p s = snd @@ TagSet.find_first p s
let find_first_opt p s = option_map snd @@ TagSet.find_first_opt p s
let find_last p s = snd @@ TagSet.find_last p s
let find_last_opt p s = option_map snd @@ TagSet.find_last_opt p s
let map = TagSet.map
let mapi = TagSet.map
let pp_set ppf s =
Format.(
fprintf ppf "@[<1>{" ;
pp_print_list pp ppf (bindings s) ;
Format.fprintf ppf "}@]")
module DSL = struct
type (_, _, _, _) arg =
| A : ('x def * 'x) -> (('b -> 'x -> 'c) -> 'x -> 'd, 'b, 'c, 'd) arg
| S : ('x def * 'x) -> ('x -> 'd, 'b, 'c, 'd) arg
| T : ('x def * 'x) -> ('d, 'b, 'c, 'd) arg
let a tag v = A (tag, v)
let s tag v = S (tag, v)
let t tag v = T (tag, v)
let pp_of_def (type a) tag =
let module Tg = (val tag : DEF with type t = a) in
Tg.pp
let ( -% ) :
type a d.
(?tags:set -> a) -> (a, Format.formatter, unit, d) arg -> ?tags:set -> d
=
fun f -> function
| A (tag, v) ->
fun [@warning "-16"] ?(tags = empty) ->
f ~tags:(add tag v tags) (pp_of_def tag) v
| S (tag, v) ->
fun [@warning "-16"] ?(tags = empty) -> f ~tags:(add tag v tags) v
| T (tag, v) ->
fun [@warning "-16"] ?(tags = empty) -> f ~tags:(add tag v tags)
end
src/lib_stdlib/tag.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition selector := False.
Module DEF_ARG.
Record signature {t : Type} := {
name : string;
t := t;
doc : string;
pp : Stdlib.Format.formatter -> t -> unit;
}.
Arguments signature : clear implicits.
End DEF_ARG.
Module DEF.
Record signature {t id : Type} := {
include;
id := id;
id : id;
extensible_type;
uid : Z;
}.
Arguments signature : clear implicits.
End DEF.
(* ❌ Functors are not handled. *)
functor
Definition def (a : Type) := {id : _ & DEF.signature a id}.
Definition def {A : Type} (op_staroptstar : option string)
: string ->
(Stdlib.Format.formatter -> A -> unit) -> {id : _ & DEF.signature A id} :=
let doc :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "undocumented" % string
end in
fun name =>
fun pp =>
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application.
Inductive eq : forall (_ _ : Type), Type :=
| Refl : forall {a : Type}, eq a a.
Definition maybe_eq {a b : Type} (s : def a) (t : def b) : option (eq a b) :=
let S := projT2 s in
let T := projT2 t in
match Me with
| Me => Some Refl
| _ => None
end.
Definition selector_of {a : Type} (d : def a) : selector a :=
let D := projT2 d in
Me.
Definition name {a : Type} (d : def a) : string :=
let D := projT2 d in
D.(DEF.name).
Definition doc {a : Type} (d : def a) : string :=
let D := projT2 d in
D.(DEF.doc).
Definition printer {a : Type} (d : def a)
: Stdlib.Format.formatter -> a -> unit :=
let D := projT2 d in
D.(DEF.pp).
Definition pp_def {A : Type} (ppf : Stdlib.Format.formatter) (d : def A)
: unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "tag:" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "tag:%s" % string) (name d).
Module Key.
Inductive t : Type :=
| V : forall {a : Type}, (def a) -> t.
Inductive s : Type :=
| S : forall {a : Type}, (selector a) -> s.
Definition compare (function_parameter : t) : t -> Z :=
let 'V k0 := function_parameter in
fun function_parameter =>
let 'V k1 := function_parameter in
OCaml.Stdlib.compare (S (selector_of k0)) (S (selector_of k1)).
End Key.
(* ❌ Applications of functors are not handled. *)
functor_application
Inductive t : Type :=
| V : forall {a : Type}, (def a) -> a -> t.
Definition binding := t.
Definition set := TagSet.t binding.
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
let 'V tag v := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<1>" % string
CamlinternalFormatBasics.End_of_format) "<1>" % string))
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Char_literal ")" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[<1>(%a@ @[%a@])@]" % string) pp_def tag (printer tag) v.
Definition option_map {A B : Type} (f : A -> B) (function_parameter : option A)
: option B :=
match function_parameter with
| None => None
| Some v => Some (f v)
end.
Definition option_bind {A B : Type}
(f : A -> option B) (function_parameter : option A) : option B :=
match function_parameter with
| None => None
| Some v => f v
end.
Definition reveal2 {a b : Type} (t : def a) (u : def b) (v : b) : option a :=
match maybe_eq t u with
| None => None
| Some Refl => Some v
end.
Definition reveal {a : Type} (tag : def a) (function_parameter : binding)
: option a :=
let 'V another v := function_parameter in
reveal2 tag another v.
Definition unveil {a : Type} (tag : def a) : (option binding) -> option a :=
apply option_bind (reveal tag).
Definition conceal {a : Type} (tag : def a) (v : a) : binding := V tag v.
Definition veil {a : Type} (tag : def a) : (option a) -> option binding :=
apply option_map (conceal tag).
Definition empty {A : Type} : TagSet.t A := TagSet.empty.
Definition is_empty {A : Type} : (TagSet.t A) -> bool := TagSet.is_empty.
Definition mem {A B : Type} (tag : def A) : (TagSet.t B) -> bool :=
TagSet.mem (Key.V tag).
Definition add {A : Type} (tag : def A) (v : A) : (TagSet.t t) -> TagSet.t t :=
TagSet.add (Key.V tag) (V tag v).
Definition update {A : Type} (tag : def A) (f : (option A) -> option A)
: (TagSet.t binding) -> TagSet.t binding :=
TagSet.update (Key.V tag) (fun b => apply (veil tag) (apply f (unveil tag b))).
Definition singleton {A : Type} (tag : def A) (v : A) : TagSet.t t :=
TagSet.singleton (Key.V tag) (V tag v).
Definition remove {A B : Type} (tag : def A) : (TagSet.t B) -> TagSet.t B :=
TagSet.remove (Key.V tag).
Definition rem {A B : Type} : (def A) -> (TagSet.t B) -> TagSet.t B := remove.
Record merger := {
merger : ((def a) -> (option a) -> (option a) -> option a) * (a) }.
Definition merge (f : merger)
: (TagSet.t binding) -> (TagSet.t binding) -> TagSet.t binding :=
apply TagSet.merge
(fun function_parameter =>
let 'Key.V tag := function_parameter in
fun a =>
fun b => apply (veil tag) ((merger f) tag (unveil tag a) (unveil tag b))).
Record unioner := {
unioner : ((def a) -> a -> a -> a) * (a) }.
Definition union (f : unioner)
: (TagSet.t binding) -> (TagSet.t binding) -> TagSet.t binding :=
merge
{|
merger :=
fun tag =>
fun a =>
fun b =>
match (a, b) with
| (Some aa, Some bb) => Some ((unioner f) tag aa bb)
| (Some _, None) => a
| (None, _) => b
end |}.
Definition iter {A : Type} (f : A -> unit) : (TagSet.t A) -> unit :=
TagSet.iter
(fun function_parameter =>
let '_ := function_parameter in
f).
Definition fold {A B : Type} (f : A -> B -> B) : (TagSet.t A) -> B -> B :=
TagSet.fold
(fun function_parameter =>
let '_ := function_parameter in
f).
Definition for_all {A : Type} (p : A -> bool) : (TagSet.t A) -> bool :=
TagSet.for_all
(fun function_parameter =>
let '_ := function_parameter in
p).
Definition _exists {A : Type} (p : A -> bool) : (TagSet.t A) -> bool :=
TagSet._exists
(fun function_parameter =>
let '_ := function_parameter in
p).
Definition filter {A : Type} (p : A -> bool) : (TagSet.t A) -> TagSet.t A :=
TagSet.filter
(fun function_parameter =>
let '_ := function_parameter in
p).
Definition partition {A : Type} (p : A -> bool)
: (TagSet.t A) -> (TagSet.t A) * (TagSet.t A) :=
TagSet.partition
(fun function_parameter =>
let '_ := function_parameter in
p).
Definition cardinal {A : Type} : (TagSet.t A) -> Z := TagSet.cardinal.
Definition bindings {A : Type} (s : TagSet.t A) : list A :=
apply (List.map snd) (TagSet.bindings s).
Definition min_binding {A : Type} (s : TagSet.t A) : A :=
apply snd (TagSet.min_binding s).
Definition min_binding_opt {A : Type} (s : TagSet.t A) : option A :=
apply (option_map snd) (TagSet.min_binding_opt s).
Definition max_binding {A : Type} (s : TagSet.t A) : A :=
apply snd (TagSet.max_binding s).
Definition max_binding_opt {A : Type} (s : TagSet.t A) : option A :=
apply (option_map snd) (TagSet.max_binding_opt s).
Definition choose {A : Type} (s : TagSet.t A) : A := apply snd (TagSet.choose s).
Definition choose_opt {A : Type} (s : TagSet.t A) : option A :=
apply (option_map snd) (TagSet.choose_opt s).
Definition split {A : Type} (tag : def A) (s : TagSet.t binding)
: (TagSet.t binding) * (option A) * (TagSet.t binding) :=
apply
(fun function_parameter =>
let '(l, m, r) := function_parameter in
(l, (unveil tag m), r)) (TagSet.split (Key.V tag) s).
Definition find {A : Type} (tag : def A) (s : TagSet.t binding) : option A :=
apply (option_bind (reveal tag)) (TagSet.find_opt (Key.V tag) s).
Definition find_opt {A : Type} (tag : def A) (s : TagSet.t binding)
: option A := apply (option_bind (reveal tag)) (TagSet.find_opt (Key.V tag) s).
Definition get {A : Type} (tag : def A) (s : TagSet.t binding) : A :=
OCaml.Stdlib.reverse_apply (find_opt tag s)
(fun function_parameter =>
match function_parameter with
| None =>
OCaml.Stdlib.invalid_arg
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "tag named " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" not found in set" % string
CamlinternalFormatBasics.End_of_format)))
"tag named %s not found in set" % string) (name tag))
| Some v => v
end).
Definition find_first {A : Type} (p : TagSet.key -> bool) (s : TagSet.t A)
: A := apply snd (TagSet.find_first p s).
Definition find_first_opt {A : Type} (p : TagSet.key -> bool) (s : TagSet.t A)
: option A := apply (option_map snd) (TagSet.find_first_opt p s).
Definition find_last {A : Type} (p : TagSet.key -> bool) (s : TagSet.t A) : A :=
apply snd (TagSet.find_last p s).
Definition find_last_opt {A : Type} (p : TagSet.key -> bool) (s : TagSet.t A)
: option A := apply (option_map snd) (TagSet.find_last_opt p s).
Definition map {A B : Type} : (A -> B) -> (TagSet.t A) -> TagSet.t B :=
TagSet.map.
Definition mapi {A B : Type} : (A -> B) -> (TagSet.t A) -> TagSet.t B :=
TagSet.map.
Definition pp_set (ppf : Stdlib.Format.formatter) (s : TagSet.t t) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<1>" % string
CamlinternalFormatBasics.End_of_format) "<1>" % string))
(CamlinternalFormatBasics.Char_literal "{" % char
CamlinternalFormatBasics.End_of_format)) "@[<1>{" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_print_list None pp ppf (bindings s) in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "}" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)) "}@]" % string).
Module DSL.
Inductive arg : forall (_ _ _ _ : Type), Type :=
| A : forall {b c d x : Type}, ((def x) * x) ->
arg ((b -> x -> c) -> x -> d) b c d
| S : forall {b c d x : Type}, ((def x) * x) -> arg (x -> d) b c d
| T : forall {b c d x : Type}, ((def x) * x) -> arg d b c d.
Definition a {A B C D : Type} (tag : def A) (v : A)
: arg ((B -> A -> C) -> A -> D) B C D := A (tag, v).
Definition s {A B C D : Type} (tag : def A) (v : A) : arg (A -> B) C D B :=
S (tag, v).
Definition t {A B C D : Type} (tag : def A) (v : A) : arg B C D B :=
T (tag, v).
Definition pp_of_def {A : Type} (tag : {id : _ & DEF.signature A id})
: Stdlib.Format.formatter -> A -> unit :=
let Tg := projT2 tag in
Tg.(DEF.pp).
Definition op_minuspercent {a d : Type}
(f : (option set) -> a)
(function_parameter : arg a Stdlib.Format.formatter unit d)
: (option set) -> d :=
match function_parameter with
| A (tag, v) =>
fun op_staroptstar =>
let tags :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => empty
end in
f (Some (add tag v tags)) (pp_of_def tag) v
| S (tag, v) =>
fun op_staroptstar =>
let tags :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => empty
end in
f (Some (add tag v tags)) v
| T (tag, v) =>
fun op_staroptstar =>
let tags :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => empty
end in
f (Some (add tag v tags))
end.
End DSL.
src/lib_stdlib/test/assert.ml success
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) let fail expected given msg = Format.kasprintf failwith "@[%s@ expected: %s@ got: %s@]" msg expected given let fail_msg fmt = Format.kasprintf (fail "" "") fmt let default_printer _ = "" let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y = if not (eq x y) then fail (prn x) (prn y) msg
src/lib_stdlib/test/assert.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition fail {A : Type} (expected : string) (given : string) (msg : string)
: A :=
Format.kasprintf OCaml.Stdlib.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "expected: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "got: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[%s@ expected: %s@ got: %s@]" % string) msg expected given.
Definition fail_msg {A B : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
Format.kasprintf (fail "" % string "" % string) fmt.
Definition default_printer {A : Type} (function_parameter : A) : string :=
let '_ := function_parameter in
"" % string.
Definition equal {A : Type} (op_staroptstar : option (A -> A -> bool))
: (option (A -> string)) -> (option string) -> A -> A -> unit :=
let eq :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => equiv_decb
end in
fun op_staroptstar =>
let prn :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_printer
end in
fun op_staroptstar =>
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
fun y =>
if negb (eq x y) then
fail (prn x) (prn y) msg
else
tt.
src/lib_stdlib/test/test_lwt_pipe.ml 7 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Lwt.Infix
let rec producer queue = function
| 0 ->
Format.eprintf "Done producing." ;
Lwt.return_unit
| n ->
Lwt_pipe.push queue () >>= fun () -> producer queue (pred n)
let rec consumer queue = function
| 0 ->
Format.eprintf "Done consuming." ;
Lwt.return_unit
| n ->
Lwt_pipe.pop queue >>= fun _ -> consumer queue (pred n)
let rec gen acc f = function 0 -> acc | n -> gen (f () :: acc) f (pred n)
let run qsize nbp nbc p c =
let q = Lwt_pipe.create ~size:(qsize, fun () -> qsize) () in
let producers = gen [] (fun () -> producer q p) nbp in
let consumers = gen [] (fun () -> consumer q c) nbc in
Lwt.join producers <&> Lwt.join consumers
let main () =
let qsize = ref 10 in
let nb_producers = ref 10 in
let nb_consumers = ref 10 in
let produced_per_producer = ref 10 in
let consumed_per_consumer = ref 10 in
let spec =
Arg.
[ ("-qsize", Set_int qsize, "<int> Size of the pipe");
("-nc", Set_int nb_consumers, "<int> Number of consumers");
("-np", Set_int nb_producers, "<int> Number of producers");
( "-n",
Set_int consumed_per_consumer,
"<int> Number of consumed items per consumers" );
( "-p",
Set_int produced_per_producer,
"<int> Number of produced items per producers" );
( "-v",
Unit (fun () -> Lwt_log_core.(add_rule "*" Info)),
" Log up to info msgs" );
( "-vv",
Unit (fun () -> Lwt_log_core.(add_rule "*" Debug)),
" Log up to debug msgs" ) ]
in
let anon_fun _ = () in
let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
Arg.parse spec anon_fun usage_msg ;
run
!qsize
!nb_producers
!nb_consumers
!produced_per_producer
!consumed_per_consumer
let () = Lwt_main.run @@ main ()
src/lib_stdlib/test/test_lwt_pipe.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
Fixpoint producer
(queue : Tezos_stdlib.Lwt_pipe.t unit) (function_parameter : Z)
: Lwt.t unit :=
match function_parameter with
| 0 =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Done producing." % string
CamlinternalFormatBasics.End_of_format) "Done producing." % string)
in
Lwt.return_unit
| n =>
op_gtgteq (Lwt_pipe.push queue tt)
(fun function_parameter =>
let 'tt := function_parameter in
producer queue (Z.pred n))
end.
Fixpoint consumer {A : Type}
(queue : Tezos_stdlib.Lwt_pipe.t A) (function_parameter : Z) : Lwt.t unit :=
match function_parameter with
| 0 =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Done consuming." % string
CamlinternalFormatBasics.End_of_format) "Done consuming." % string)
in
Lwt.return_unit
| n =>
op_gtgteq (Lwt_pipe.pop queue)
(fun function_parameter =>
let '_ := function_parameter in
consumer queue (Z.pred n))
end.
Fixpoint gen {A : Type} (acc : list A) (f : unit -> A) (function_parameter : Z)
: list A :=
match function_parameter with
| 0 => acc
| n => gen (cons (f tt) acc) f (Z.pred n)
end.
Definition run (qsize : Z) (nbp : Z) (nbc : Z) (p : Z) (c : Z) : Lwt.t unit :=
let q :=
Lwt_pipe.create
(Some
(qsize,
(fun function_parameter =>
let 'tt := function_parameter in
qsize))) tt in
let producers :=
gen []
(fun function_parameter =>
let 'tt := function_parameter in
producer q p) nbp in
let consumers :=
gen []
(fun function_parameter =>
let 'tt := function_parameter in
consumer q c) nbc in
op_ltandgt (Lwt.join producers) (Lwt.join consumers).
Definition main (function_parameter : unit) : Lwt.t unit :=
let 'tt := function_parameter in
let qsize := Stdlib.ref 10 in
let nb_producers := Stdlib.ref 10 in
let nb_consumers := Stdlib.ref 10 in
let produced_per_producer := Stdlib.ref 10 in
let consumed_per_consumer := Stdlib.ref 10 in
let spec :=
cons
("-qsize" % string, (Stdlib.Arg.Set_int qsize),
"<int> Size of the pipe" % string)
(cons
("-nc" % string, (Stdlib.Arg.Set_int nb_consumers),
"<int> Number of consumers" % string)
(cons
("-np" % string, (Stdlib.Arg.Set_int nb_producers),
"<int> Number of producers" % string)
(cons
("-n" % string, (Stdlib.Arg.Set_int consumed_per_consumer),
"<int> Number of consumed items per consumers" % string)
(cons
("-p" % string, (Stdlib.Arg.Set_int produced_per_producer),
"<int> Number of produced items per producers" % string)
(cons
("-v" % string,
(Stdlib.Arg.Unit
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar)),
" Log up to info msgs" % string)
(cons
("-vv" % string,
(Stdlib.Arg.Unit
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar)),
" Log up to debug msgs" % string) [])))))) in
let anon_fun {A : Type} (function_parameter : A) : unit :=
let '_ := function_parameter in
tt in
let usage_msg := "Usage: %s <num_peers>.
Arguments are:" % string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Arg.parse spec anon_fun usage_msg in
run (Stdlib.op_exclamation qsize) (Stdlib.op_exclamation nb_producers)
(Stdlib.op_exclamation nb_consumers)
(Stdlib.op_exclamation produced_per_producer)
(Stdlib.op_exclamation consumed_per_consumer).
src/lib_stdlib/test/test_tzList.ml 15 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let rec permut = function
| [] ->
[[]]
| x :: xs ->
let insert xs =
let rec loop acc left right =
match right with
| [] ->
List.rev (x :: left) :: acc
| y :: ys ->
loop (List.rev_append left (x :: right) :: acc) (y :: left) ys
in
loop [] [] xs
in
List.concat (List.map insert (permut xs))
let test_take_n _ =
ListLabels.iter
(permut [1; 2; 3; 4; 5; 6; 7; 8; 9])
~f:(fun xs -> Assert.equal ~msg:__LOC__ (TzList.take_n ~compare 1 xs) [9]) ;
ListLabels.iter
(permut [1; 2; 3; 4; 5; 6; 7; 8; 9])
~f:(fun xs ->
Assert.equal ~msg:__LOC__ (TzList.take_n ~compare 3 xs) [7; 8; 9]) ;
let inv_compare x y = compare y x in
ListLabels.iter
(permut [1; 2; 3; 4; 5; 6; 7; 8; 9])
~f:(fun xs ->
Assert.equal
~msg:__LOC__
(TzList.take_n ~compare:inv_compare 3 xs)
[3; 2; 1]) ;
(* less elements than the bound. *)
ListLabels.iter
(permut [1; 2; 3; 4; 5; 6; 7; 8; 9])
~f:(fun xs ->
Assert.equal
~msg:__LOC__
(TzList.take_n ~compare 12 xs)
[1; 2; 3; 4; 5; 6; 7; 8; 9]) ;
(* with duplicates. *)
ListLabels.iter
(permut [1; 2; 3; 3; 4; 5; 5; 5; 6])
~f:(fun xs ->
Assert.equal ~msg:__LOC__ (TzList.take_n ~compare 3 xs) [5; 5; 6]) ;
ListLabels.iter
(permut [1; 2; 3; 3; 4; 5; 5; 5; 6])
~f:(fun xs ->
Assert.equal ~msg:__LOC__ (TzList.take_n ~compare 5 xs) [4; 5; 5; 5; 6])
let tests = [("take_n", `Quick, test_take_n)]
let () = Alcotest.run "stdlib" [("tzList", tests)]
src/lib_stdlib/test/test_tzList.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Fixpoint permut {A : Type} (function_parameter : list A) : list (list A) :=
match function_parameter with
| [] => cons [] []
| cons x xs =>
let insert (xs : list A) : list (list A) :=
let fix loop (acc : list (list A)) (left : list A) (right : list A)
: list (list A) :=
match right with
| [] => cons (List.rev (cons x left)) acc
| cons y ys =>
loop (cons (Stdlib.List.rev_append left (cons x right)) acc)
(cons y left) ys
end in
loop [] [] xs in
Stdlib.List.concat (List.map insert (permut xs))
end.
Definition test_take_n {A : Type} (function_parameter : A) : unit :=
let '_ := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
ListLabels.iter
(fun xs =>
op_startypeminuserrorstar Stdlib.__LOC__
(TzList.take_n (Some OCaml.Stdlib.compare) 1 xs) (cons 9 []))
(permut
(cons 1
(cons 2
(cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))))
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
ListLabels.iter
(fun xs =>
op_startypeminuserrorstar Stdlib.__LOC__
(TzList.take_n (Some OCaml.Stdlib.compare) 3 xs)
(cons 7 (cons 8 (cons 9 []))))
(permut
(cons 1
(cons 2
(cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))))
in
let inv_compare {B : Type} (x : B) (y : B) : Z :=
OCaml.Stdlib.compare y x in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
ListLabels.iter
(fun xs =>
op_startypeminuserrorstar Stdlib.__LOC__
(TzList.take_n (Some inv_compare) 3 xs) (cons 3 (cons 2 (cons 1 []))))
(permut
(cons 1
(cons 2
(cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))))
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
ListLabels.iter
(fun xs =>
op_startypeminuserrorstar Stdlib.__LOC__
(TzList.take_n (Some OCaml.Stdlib.compare) 12 xs)
(cons 1
(cons 2
(cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))))
(permut
(cons 1
(cons 2
(cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))))
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
ListLabels.iter
(fun xs =>
op_startypeminuserrorstar Stdlib.__LOC__
(TzList.take_n (Some OCaml.Stdlib.compare) 3 xs)
(cons 5 (cons 5 (cons 6 []))))
(permut
(cons 1
(cons 2
(cons 3 (cons 3 (cons 4 (cons 5 (cons 5 (cons 5 (cons 6 []))))))))))
in
ListLabels.iter
(fun xs =>
op_startypeminuserrorstar Stdlib.__LOC__
(TzList.take_n (Some OCaml.Stdlib.compare) 5 xs)
(cons 4 (cons 5 (cons 5 (cons 5 (cons 6 []))))))
(permut
(cons 1
(cons 2
(cons 3 (cons 3 (cons 4 (cons 5 (cons 5 (cons 5 (cons 6 [])))))))))).
Definition tests {A : Type} : list (string * variant * (A -> unit)) :=
cons
("take_n" % string,
(* ❌ Variants not supported *)
variant, test_take_n) [].
src/lib_stdlib/tzEndian.ml success
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) open Bytes_encodings let set_int32 = set_int32_be let get_int32 = get_int32_be let set_int8 = set_int8 let get_int8 = get_int8 let set_int16 = set_int16_be let get_int16 = get_int16_be let set_int64 = set_int64_be let get_int64 = get_int64_be let get_uint8 = get_uint8 let get_uint16 = get_uint16_be let get_double buff i = Int64.float_of_bits (get_int64_be buff i) let set_double buff i v = set_int64_be buff i (Int64.bits_of_float v)
src/lib_stdlib/tzEndian.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. Import Bytes_encodings. Definition set_int32 : string -> Z -> int32 -> unit := set_int32_be. Definition get_int32 : string -> Z -> int32 := get_int32_be. Definition set_int8 : string -> Z -> Z -> unit := set_int8. Definition get_int8 : string -> Z -> Z := get_int8. Definition set_int16 : string -> Z -> Z -> unit := set_int16_be. Definition get_int16 : string -> Z -> Z := get_int16_be. Definition set_int64 : string -> Z -> int64 -> unit := set_int64_be. Definition get_int64 : string -> Z -> int64 := get_int64_be. Definition get_uint8 : string -> Z -> Z := get_uint8. Definition get_uint16 : string -> Z -> Z := get_uint16_be. Definition get_double (buff : string) (i : Z) : Z := Int64.float_of_bits (get_int64_be buff i). Definition set_double (buff : string) (i : Z) (v : Z) : unit := set_int64_be buff i (Int64.bits_of_float v).
src/lib_stdlib/tzList.ml 5 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let may_cons xs x = match x with None -> xs | Some x -> x :: xs
let filter_map f l =
List.rev @@ List.fold_left (fun acc x -> may_cons acc (f x)) [] l
let rev_sub l n =
if n < 0 then invalid_arg "Utils.rev_sub: `n` must be non-negative." ;
let rec append_rev_sub acc l = function
| 0 ->
acc
| n -> (
match l with
| [] ->
acc
| hd :: tl ->
append_rev_sub (hd :: acc) tl (n - 1) )
in
append_rev_sub [] l n
let sub l n = rev_sub l n |> List.rev
let hd_opt = function [] -> None | h :: _ -> Some h
let rec last_exn = function
| [] ->
raise Not_found
| [x] ->
x
| _ :: xs ->
last_exn xs
let merge_filter2 ?(finalize = List.rev) ?(compare = compare)
?(f = Option.first_some) l1 l2 =
let sort = List.sort compare in
let rec merge_aux acc = function
| ([], []) ->
finalize acc
| (r1, []) ->
finalize acc @ filter_map (fun x1 -> f (Some x1) None) r1
| ([], r2) ->
finalize acc @ filter_map (fun x2 -> f None (Some x2)) r2
| ((h1 :: t1 as r1), (h2 :: t2 as r2)) ->
if compare h1 h2 > 0 then
merge_aux (may_cons acc (f None (Some h2))) (r1, t2)
else if compare h1 h2 < 0 then
merge_aux (may_cons acc (f (Some h1) None)) (t1, r2)
else
(* m1 = m2 *)
merge_aux (may_cons acc (f (Some h1) (Some h2))) (t1, t2)
in
merge_aux [] (sort l1, sort l2)
let merge2 ?finalize ?compare ?(f = fun x1 _x1 -> x1) l1 l2 =
merge_filter2
?finalize
?compare
~f:(fun x1 x2 ->
match (x1, x2) with
| (None, None) ->
assert false
| (Some x1, None) ->
Some x1
| (None, Some x2) ->
Some x2
| (Some x1, Some x2) ->
Some (f x1 x2))
l1
l2
let rec remove nb = function
| [] ->
[]
| l when nb <= 0 ->
l
| _ :: tl ->
remove (nb - 1) tl
let rec repeat n x = if n <= 0 then [] else x :: repeat (pred n) x
let split_n n l =
let rec loop acc n = function
| [] ->
(l, [])
| rem when n <= 0 ->
(List.rev acc, rem)
| x :: xs ->
loop (x :: acc) (pred n) xs
in
loop [] n l
let take_n_unsorted n l = fst (split_n n l)
module Bounded (E : Set.OrderedType) : sig
type t
val create : int -> t
val insert : E.t -> t -> unit
val get : t -> E.t list
end = struct
(* TODO one day replace the list by an heap array *)
type t = {bound : int; mutable size : int; mutable data : E.t list}
let create bound =
if bound <= 0 then invalid_arg "Utils.Bounded(_).create" ;
{bound; size = 0; data = []}
let rec push x = function
| [] ->
[x]
| y :: xs as ys ->
if E.compare x y <= 0 then x :: ys else y :: push x xs
let insert x t =
if t.size < t.bound then (
t.size <- t.size + 1 ;
t.data <- push x t.data )
else
match t.data with
| [] ->
assert false
| hd :: tl ->
if E.compare hd x < 0 then t.data <- push x tl
let get {data; _} = data
end
let take_n_sorted (type a) compare n l =
let module B = Bounded (struct
type t = a
let compare = compare
end) in
let t = B.create n in
List.iter (fun x -> B.insert x t) l ;
B.get t
let take_n ?compare n l =
match compare with
| None ->
take_n_unsorted n l
| Some compare ->
take_n_sorted compare n l
let select n l =
let rec loop n acc = function
| [] ->
invalid_arg "Utils.select"
| x :: xs when n <= 0 ->
(x, List.rev_append acc xs)
| x :: xs ->
loop (pred n) (x :: acc) xs
in
loop n [] l
let shift = function [] -> [] | hd :: tl -> tl @ [hd]
let rec product a b =
match a with
| [] ->
[]
| hd :: tl ->
List.map (fun x -> (hd, x)) b @ product tl b
let shuffle l =
l
|> List.map (fun d -> (Random.bits (), d))
|> List.sort (fun (x, _) (y, _) -> compare x y)
|> List.map snd
src/lib_stdlib/tzList.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition may_cons {A : Type} (xs : list A) (x : option A) : list A :=
match x with
| None => xs
| Some x => cons x xs
end.
Definition filter_map {A B : Type} (f : A -> option B) (l : list A) : list B :=
apply List.rev
(Stdlib.List.fold_left (fun acc => fun x => may_cons acc (f x)) [] l).
Definition rev_sub {A : Type} (l : list A) (n : Z) : list A :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if OCaml.Stdlib.lt n 0 then
OCaml.Stdlib.invalid_arg
"Utils.rev_sub: `n` must be non-negative." % string
else
tt in
let fix append_rev_sub {B : Type}
(acc : list B) (l : list B) (function_parameter : Z) : list B :=
match function_parameter with
| 0 => acc
| n =>
match l with
| [] => acc
| cons hd tl => append_rev_sub (cons hd acc) tl (Z.sub n 1)
end
end in
append_rev_sub [] l n.
Definition sub {A : Type} (l : list A) (n : Z) : list A :=
OCaml.Stdlib.reverse_apply (rev_sub l n) List.rev.
Definition hd_opt {A : Type} (function_parameter : list A) : option A :=
match function_parameter with
| [] => None
| cons h _ => Some h
end.
Fixpoint last_exn {A : Type} (function_parameter : list A) : A :=
match function_parameter with
| [] => Stdlib.raise OCaml.Not_found
| cons x [] => x
| cons _ xs => last_exn xs
end.
Definition merge_filter2 {A : Type}
(op_staroptstar : option ((list A) -> list A))
: (option (A -> A -> Z)) ->
(option ((option A) -> (option A) -> option A)) ->
(list A) -> (list A) -> list A :=
let finalize :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => List.rev
end in
fun op_staroptstar =>
let compare :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => OCaml.Stdlib.compare
end in
fun op_staroptstar =>
let f :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Option.first_some
end in
fun l1 =>
fun l2 =>
let sort := Stdlib.List.sort compare in
let fix merge_aux
(acc : list A) (function_parameter : (list A) * (list A))
: list A :=
match function_parameter with
| ([], []) => finalize acc
| (r1, []) =>
OCaml.Stdlib.app (finalize acc)
(filter_map (fun x1 => f (Some x1) None) r1)
| ([], r2) =>
OCaml.Stdlib.app (finalize acc)
(filter_map (fun x2 => f None (Some x2)) r2)
| ((cons h1 t1) as r1, (cons h2 t2) as r2) =>
if OCaml.Stdlib.gt (compare h1 h2) 0 then
merge_aux (may_cons acc (f None (Some h2))) (r1, t2)
else
if OCaml.Stdlib.lt (compare h1 h2) 0 then
merge_aux (may_cons acc (f (Some h1) None)) (t1, r2)
else
merge_aux (may_cons acc (f (Some h1) (Some h2))) (t1, t2)
end in
merge_aux [] ((sort l1), (sort l2)).
Definition merge2 {A : Type}
(finalize : option ((list A) -> list A)) (compare : option (A -> A -> Z))
(op_staroptstar : option (A -> A -> A)) : (list A) -> (list A) -> list A :=
let f :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => fun x1 => fun _x1 => x1
end in
fun l1 =>
fun l2 =>
merge_filter2 finalize compare
(Some
(fun x1 =>
fun x2 =>
match (x1, x2) with
| (None, None) =>
(* ❌ Assert instruction is not handled. *)
assert false
| (Some x1, None) => Some x1
| (None, Some x2) => Some x2
| (Some x1, Some x2) => Some (f x1 x2)
end)) l1 l2.
Fixpoint remove {A : Type} (nb : Z) (function_parameter : list A) : list A :=
match function_parameter with
| [] => []
| l => l
| cons _ tl => remove (Z.sub nb 1) tl
end.
Fixpoint repeat {A : Type} (n : Z) (x : A) : list A :=
if OCaml.Stdlib.le n 0 then
[]
else
cons x (repeat (Z.pred n) x).
Definition split_n {A : Type} (n : Z) (l : list A) : (list A) * (list A) :=
let fix loop (acc : list A) (n : Z) (function_parameter : list A)
: (list A) * (list A) :=
match function_parameter with
| [] => (l, [])
| rem => ((List.rev acc), rem)
| cons x xs => loop (cons x acc) (Z.pred n) xs
end in
loop [] n l.
Definition take_n_unsorted {A : Type} (n : Z) (l : list A) : list A :=
fst (split_n n l).
(* ❌ Functors are not handled. *)
functor
Definition take_n_sorted {A : Type} (compare : A -> A -> Z) (n : Z) (l : list A)
: list A :=
let B :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
let t := B.create n in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.List.iter (fun x => B.insert x t) l in
B.get t.
Definition take_n {A : Type}
(compare : option (A -> A -> Z)) (n : Z) (l : list A) : list A :=
match compare with
| None => take_n_unsorted n l
| Some compare => take_n_sorted compare n l
end.
Definition select {A : Type} (n : Z) (l : list A) : A * (list A) :=
let fix loop {B : Type} (n : Z) (acc : list B) (function_parameter : list B)
: B * (list B) :=
match function_parameter with
| [] => OCaml.Stdlib.invalid_arg "Utils.select" % string
| cons x xs => (x, (Stdlib.List.rev_append acc xs))
| cons x xs => loop (Z.pred n) (cons x acc) xs
end in
loop n [] l.
Definition shift {A : Type} (function_parameter : list A) : list A :=
match function_parameter with
| [] => []
| cons hd tl => OCaml.Stdlib.app tl (cons hd [])
end.
Fixpoint product {A B : Type} (a : list A) (b : list B) : list (A * B) :=
match a with
| [] => []
| cons hd tl =>
OCaml.Stdlib.app (List.map (fun x => (hd, x)) b) (product tl b)
end.
Definition shuffle {A : Type} (l : list A) : list A :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply l (List.map (fun d => ((Random.bits tt), d))))
(Stdlib.List.sort
(fun function_parameter =>
let '(x, _) := function_parameter in
fun function_parameter =>
let '(y, _) := function_parameter in
OCaml.Stdlib.compare x y))) (List.map snd).
src/lib_stdlib/tzString.ml 6 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Set = Set.Make (String)
module Map = Map.Make (String)
let split delim ?(dup = true) ?(limit = max_int) path =
let l = String.length path in
let rec do_slashes acc limit i =
if i >= l then List.rev acc
else if path.[i] = delim then
if dup then do_slashes acc limit (i + 1) else do_split acc limit (i + 1)
else do_split acc limit i
and do_split acc limit i =
if limit <= 0 then
if i = l then List.rev acc
else List.rev (String.sub path i (l - i) :: acc)
else do_component acc (pred limit) i i
and do_component acc limit i j =
if j >= l then
if i = j then List.rev acc
else List.rev (String.sub path i (j - i) :: acc)
else if path.[j] = delim then
do_slashes (String.sub path i (j - i) :: acc) limit j
else do_component acc limit i (j + 1)
in
if limit > 0 then do_slashes [] limit 0 else [path]
let split_path path = split '/' path
let has_prefix ~prefix s =
let x = String.length prefix in
let n = String.length s in
n >= x && String.sub s 0 x = prefix
let remove_prefix ~prefix s =
let x = String.length prefix in
let n = String.length s in
if n >= x && String.sub s 0 x = prefix then Some (String.sub s x (n - x))
else None
let common_prefix s1 s2 =
let last = min (String.length s1) (String.length s2) in
let rec loop i =
if last <= i then last else if s1.[i] = s2.[i] then loop (i + 1) else i
in
loop 0
let mem_char s c = String.index_opt s c <> None
let fold_left f init s =
let acc = ref init in
String.iter (fun c -> acc := f !acc c) s ;
!acc
let is_hex s =
let len = String.length s in
len mod 2 = 0
&&
try
for i = 0 to len - 1 do
match s.[i] with
| '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' ->
()
| _ ->
raise Exit
done ;
true
with Exit -> false
src/lib_stdlib/tzString.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Definition split (delim : ascii) (op_staroptstar : option bool)
: (option Z) -> string -> list string :=
let dup :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun op_staroptstar =>
let limit :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Stdlib.max_int
end in
fun path =>
let l := OCaml.String.length path in
let fix do_slashes (acc : list string) (limit : Z) (i : Z)
: list string :=
if OCaml.Stdlib.ge i l then
List.rev acc
else
if equiv_decb (Stdlib.String.get path i) delim then
if dup then
do_slashes acc limit (Z.add i 1)
else
do_split acc limit (Z.add i 1)
else
do_split acc limit i
with do_split (acc : list string) (limit : Z) (i : Z) : list string :=
if OCaml.Stdlib.le limit 0 then
if equiv_decb i l then
List.rev acc
else
List.rev (cons (Stdlib.String.sub path i (Z.sub l i)) acc)
else
do_component acc (Z.pred limit) i i
with do_component (acc : list string) (limit : Z) (i : Z) (j : Z)
: list string :=
if OCaml.Stdlib.ge j l then
if equiv_decb i j then
List.rev acc
else
List.rev (cons (Stdlib.String.sub path i (Z.sub j i)) acc)
else
if equiv_decb (Stdlib.String.get path j) delim then
do_slashes (cons (Stdlib.String.sub path i (Z.sub j i)) acc) limit j
else
do_component acc limit i (Z.add j 1) in
if OCaml.Stdlib.gt limit 0 then
do_slashes [] limit 0
else
cons path [].
Definition split_path (path : string) : list string :=
split "/" % char None None path.
Definition has_prefix (prefix : string) (s : string) : bool :=
let x := OCaml.String.length prefix in
let n := OCaml.String.length s in
andb (OCaml.Stdlib.ge n x) (equiv_decb (Stdlib.String.sub s 0 x) prefix).
Definition remove_prefix (prefix : string) (s : string) : option string :=
let x := OCaml.String.length prefix in
let n := OCaml.String.length s in
if andb (OCaml.Stdlib.ge n x) (equiv_decb (Stdlib.String.sub s 0 x) prefix)
then
Some (Stdlib.String.sub s x (Z.sub n x))
else
None.
Definition common_prefix (s1 : string) (s2 : string) : Z :=
let last := OCaml.Stdlib.min (OCaml.String.length s1) (OCaml.String.length s2)
in
let fix loop (i : Z) : Z :=
if OCaml.Stdlib.le last i then
last
else
if equiv_decb (Stdlib.String.get s1 i) (Stdlib.String.get s2 i) then
loop (Z.add i 1)
else
i in
loop 0.
Definition mem_char (s : string) (c : ascii) : bool :=
nequiv_decb (Stdlib.String.index_opt s c) None.
Definition fold_left {A : Type} (f : A -> ascii -> A) (init : A) (s : string)
: A :=
let acc := Stdlib.ref init in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.String.iter
(fun c => Stdlib.op_coloneq acc (f (Stdlib.op_exclamation acc) c)) s in
Stdlib.op_exclamation acc.
Definition is_hex (s : string) : bool :=
let len := OCaml.String.length s in
andb (equiv_decb (Z.modulo len 2) 0)
(* ❌ Try-with are not handled *)
(try
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ :=
(* ❌ For loops not handled. *)
for in
true)).
src/lib_stdlib/utils.ml 4 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Infix = struct
let ( -- ) i j = List.init (j - i + 1) (fun x -> x + i)
end
let cut ?(copy = false) sz bytes =
let length = Bytes.length bytes in
if length <= sz then [bytes] (* if the result fits in the given sz *)
else
let may_copy = if copy then Bytes.copy else fun t -> t in
let nb_full = length / sz in
(* nb of blocks of size sz *)
let sz_full = nb_full * sz in
(* size of the full part *)
let acc =
(* eventually init acc with a non-full block *)
if sz_full = length then []
else [may_copy (Bytes.sub bytes sz_full (length - sz_full))]
in
let rec split_full_blocks curr_upper_limit acc =
let start = curr_upper_limit - sz in
assert (start >= 0) ;
(* copy the block [ start, curr_upper_limit [ of size sz *)
let acc = may_copy (Bytes.sub bytes start sz) :: acc in
if start = 0 then acc else split_full_blocks start acc
in
split_full_blocks sz_full acc
let nbsp = Re.(compile (str "\xC2\xA0"))
let display_paragraph ppf description =
Format.fprintf
ppf
"@[%a@]"
(Format.pp_print_list ~pp_sep:Format.pp_print_newline (fun ppf line ->
Format.pp_print_list
~pp_sep:Format.pp_print_space
(fun ppf w ->
(* replace by real spaces... *)
Format.fprintf
ppf
"%s@ "
(Re.replace ~all:true nbsp ~f:(fun _ -> " ") w))
ppf
(TzString.split ' ' line)))
(TzString.split ~dup:false '\n' description)
let finalize f g =
try
let res = f () in
g () ; res
with exn -> g () ; raise exn
src/lib_stdlib/utils.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Infix.
Definition op_minusminus (i : Z) (j : Z) : list Z :=
Stdlib.List.init (Z.add (Z.sub j i) 1) (fun x => Z.add x i).
End Infix.
Definition cut (op_staroptstar : option bool) : Z -> string -> list string :=
let copy :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun sz =>
fun bytes =>
let length := String.length string in
if OCaml.Stdlib.le length sz then
cons string []
else
let may_copy :=
if copy then
Stdlib.Bytes.copy
else
fun t => t in
let nb_full := Z.div length sz in
let sz_full := Z.mul nb_full sz in
let acc :=
if equiv_decb sz_full length then
[]
else
cons (may_copy (String.sub string sz_full (Z.sub length sz_full)))
[] in
let fix split_full_blocks (curr_upper_limit : Z) (acc : list string)
: list string :=
let start := Z.sub curr_upper_limit sz in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.ge start 0) in
let acc := cons (may_copy (String.sub string start sz)) acc in
if equiv_decb start 0 then
acc
else
split_full_blocks start acc in
split_full_blocks sz_full acc.
Definition nbsp : Re.re := compile (str " " % string).
Definition display_paragraph
(ppf : Stdlib.Format.formatter) (description : string) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))) "@[%a@]" % string)
(Format.pp_print_list (Some Format.pp_print_newline)
(fun ppf =>
fun line =>
Format.pp_print_list (Some Format.pp_print_space)
(fun ppf =>
fun w =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
CamlinternalFormatBasics.End_of_format)) "%s@ " % string)
(Re.replace None None (Some true) nbsp
(fun function_parameter =>
let '_ := function_parameter in
" " % string) w)) ppf
(TzString.split " " % char None None line)))
(TzString.split "010" % char (Some false) None description).
Definition finalize {A : Type} (f : unit -> A) (g : unit -> unit) : A :=
(* ❌ Try-with are not handled *)
try
(let res := f tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := g tt in
res).
src/lib_stdlib/weakRingTable.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs, Inc. <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type S = sig
type 'a t
type key
val create : int -> 'a t
val add : 'a t -> key -> 'a -> unit
val add_and_return_erased : 'a t -> key -> 'a -> key option
val iter : (key -> 'a -> unit) -> 'a t -> unit
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
val find_opt : 'a t -> key -> 'a option
val remove : 'a t -> key -> unit
val length : 'a t -> int
end
module Make (M : Hashtbl.HashedType) = struct
module Table = Ephemeron.K1.Make (struct
type t = int
let hash a = a
let equal = ( = )
end)
module Ring = Ring.MakeTable (struct
type t = int * M.t
let hash (i, _) = i
let equal = ( = )
end)
type key = M.t
module Visit_tracking = Set.Make (struct
type t = int
let compare = Pervasives.compare
end)
type 'a t = {table : 'a Table.t; ring : Ring.t}
let create n = {table = Table.create n; ring = Ring.create n}
let add {ring; table} k v =
let i = M.hash k in
Ring.add ring (i, k) ;
Table.replace table i v
let add_and_return_erased {ring; table} k v =
let i = M.hash k in
let erased = Option.map ~f:snd (Ring.add_and_return_erased ring (i, k)) in
Table.replace table i v ; erased
let find_opt {table; _} k =
let i = M.hash k in
Table.find_opt table i
let fold f {table; ring} acc =
let elts = Ring.elements ring in
let (res, _) =
List.fold_left
(fun (acc, visited) (i, k) ->
if Visit_tracking.mem i visited then (acc, visited)
else
match Table.find_opt table i with
| None ->
(acc, visited)
| Some elt ->
(f k elt acc, Visit_tracking.add i visited))
(acc, Visit_tracking.empty)
elts
in
res
let iter f t = fold (fun k v () -> f k v) t ()
let remove t k =
let i = M.hash k in
Table.remove t.table i
let length {table; _} = Table.length table
end
src/lib_stdlib/weakRingTable.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module S.
Record signature {t key : Type} := {
polymorphic_abstract_type;
key := key;
create : forall {a : Type}, Z -> t a;
add : forall {a : Type}, (t a) -> key -> a -> unit;
add_and_return_erased : forall {a : Type}, (t a) -> key -> a -> option key;
iter : forall {a : Type}, (key -> a -> unit) -> (t a) -> unit;
fold : forall {a b : Type}, (key -> a -> b -> b) -> (t a) -> b -> b;
find_opt : forall {a : Type}, (t a) -> key -> option a;
remove : forall {a : Type}, (t a) -> key -> unit;
length : forall {a : Type}, (t a) -> Z;
}.
Arguments signature : clear implicits.
End S.
(* ❌ Functors are not handled. *)
functor
src/lib_stdlib_unix/animation.ml 4 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let animation =
[| "|.....|";
"|o....|";
"|oo...|";
"|ooo..|";
"|.ooo.|";
"|..ooo|";
"|...oo|";
"|....o|";
"|.....|";
"|.....|";
"|.....|";
"|.....|" |]
let init = String.make (String.length animation.(0)) ' '
let clean = String.make (String.length animation.(0)) '\b'
let animation = Array.map (fun x -> clean ^ x) animation
let number_of_frames = Array.length animation
let make_with_animation ppf ~make ~on_retry seed =
Format.fprintf ppf "%s%!" init ;
let rec loop n seed =
let start = Mtime_clock.counter () in
Format.fprintf ppf "%s%!" animation.(n mod number_of_frames) ;
match make seed with
| Ok v ->
v
| Error r ->
let time = Mtime_clock.count start in
let v = on_retry time r in
loop (n + 1) v
in
let result = loop 0 seed in
Format.fprintf ppf "%s%s\n%!" clean init ;
result
src/lib_stdlib_unix/animation.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition animation : array string :=
(* ❌ Arrays not handled. *)
[
"|.....|" % string;
"|o....|" % string;
"|oo...|" % string;
"|ooo..|" % string;
"|.ooo.|" % string;
"|..ooo|" % string;
"|...oo|" % string;
"|....o|" % string;
"|.....|" % string;
"|.....|" % string;
"|.....|" % string;
"|.....|" % string
].
Definition init : string :=
Stdlib.String.make (OCaml.String.length (Array.get animation 0)) " " % char.
Definition clean : string :=
Stdlib.String.make (OCaml.String.length (Array.get animation 0)) "008" % char.
Definition animation : array string :=
Array.map (fun x => String.append clean x) animation.
Definition number_of_frames : Z := Array.length animation.
Definition make_with_animation {A B C : Type}
(ppf : Stdlib.Format.formatter) (make : A -> sum B C)
(on_retry : Mtime.span -> C -> A) (seed : A) : B :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format))
"%s%!" % string) init in
let fix loop (n : Z) (seed : A) : B :=
let start := Mtime_clock.counter tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format)) "%s%!" % string)
(Array.get animation (Z.modulo n number_of_frames)) in
match make seed with
| Stdlib.Ok v => v
| Stdlib.Error r =>
let time := Mtime_clock.count start in
let v := on_retry time r in
loop (Z.add n 1) v
end in
let result := loop 0 seed in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format)))) "%s%s
%!" % string)
clean init in
result.
src/lib_stdlib_unix/file_descriptor_sink.ml 14 errors
(******************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
type t = {
output : Lwt_unix.file_descr;
format : [`One_per_line | `Netstring];
(* Hopefully temporary hack to handle event which are emitted with
the non-cooperative log functions in `Legacy_logging`: *)
lwt_bad_citizen_hack : Data_encoding.json list ref;
level_at_least : Internal_event.Level.t;
}
type 'event wrapped = {
time_stamp : float;
section : Internal_event.Section.t;
event : 'event;
}
let wrap time_stamp section event = {time_stamp; section; event}
let wrapped_encoding event_encoding =
let open Data_encoding in
let v0 =
conv
(fun {time_stamp; section; event} -> (time_stamp, section, event))
(fun (time_stamp, section, event) -> {time_stamp; section; event})
(obj3
(req "time_stamp" float)
(req "section" Internal_event.Section.encoding)
(req "event" event_encoding))
in
With_version.(encoding ~name:"fd-sink-item" (first_version v0))
module Make_sink (K : sig
val kind : [`Path | `Stdout | `Stderr]
end) : Internal_event.SINK with type t = t = struct
type nonrec t = t
let uri_scheme =
match K.kind with
| `Path ->
"file-descriptor-path"
| `Stdout ->
"file-descriptor-stdout"
| `Stderr ->
"file-descriptor-stderr"
let configure uri =
let level_at_least =
Option.(
Uri.get_query_param uri "level-at-least"
>>= Internal_event.Level.of_string)
|> Option.unopt ~default:Internal_event.Level.default
in
let fail_parsing fmt =
Format.kasprintf (failwith "Parsing URI: %s: %s" (Uri.to_string uri)) fmt
in
( match Uri.get_query_param uri "format" with
| Some "netstring" ->
return `Netstring
| None | Some "one-per-line" ->
return `One_per_line
| Some other ->
fail_parsing "Unknown format: %S" other )
>>=? fun format ->
( match K.kind with
| `Path -> (
let flag name =
match Uri.get_query_param uri name with
| Some "true" ->
true
| _ ->
false
in
let with_pid = flag "with-pid" in
let fresh = flag "fresh" in
( match Uri.get_query_param uri "chmod" with
| Some n -> (
try return (int_of_string n)
with _ ->
fail_parsing "Access-rights parameter should be an integer: %S" n )
| None ->
return 0o600 )
>>=? fun rights ->
match Uri.path uri with
| "" | "/" ->
fail_parsing "Missing path configuration."
| path ->
let fixed_path =
if with_pid then
let ext = Filename.extension path in
let chopped =
if ext = "" then path else Filename.chop_extension path
in
Fmt.strf "%s-%d%s" chopped (Unix.getpid ()) ext
else path
in
protect (fun () ->
Lwt_unix.(
let flags =
[O_WRONLY; O_CREAT]
@ if fresh then [O_TRUNC] else [O_APPEND]
in
openfile fixed_path flags rights)
>>= fun fd -> return fd) )
| `Stdout ->
return Lwt_unix.stdout
| `Stderr ->
return Lwt_unix.stderr )
>>=? fun output ->
let t = {output; lwt_bad_citizen_hack = ref []; level_at_least; format} in
return t
let output_one output format event_json =
let to_write =
match format with
| `One_per_line ->
Ezjsonm.value_to_string ~minify:true event_json ^ "\n"
| `Netstring ->
let bytes = Ezjsonm.value_to_string ~minify:true event_json in
Fmt.str "%d:%s," (String.length bytes) bytes
in
protect (fun () ->
(*
If the write does happen at once (i.e. returns the same number of bytes),
POSIX (and Linux >= 3.14) ensure this is atomic.
Cf. http://man7.org/linux/man-pages/man2/write.2.html#BUGS
and `https://github.com/ocsigen/lwt/blob/master/src/unix/unix_c/unix_write.c` *)
Lwt_utils_unix.write_string output to_write >>= fun () -> return_unit)
let handle (type a) {output; lwt_bad_citizen_hack; level_at_least; format; _}
m ?(section = Internal_event.Section.empty) (v : unit -> a) =
let module M = (val m : Internal_event.EVENT_DEFINITION with type t = a) in
let now = Unix.gettimeofday () in
let forced_event = v () in
let level = M.level forced_event in
if Internal_event.Level.compare level level_at_least >= 0 then (
let wrapped_event = wrap now section forced_event in
let event_json =
Data_encoding.Json.construct
(wrapped_encoding M.encoding)
wrapped_event
in
lwt_bad_citizen_hack := event_json :: !lwt_bad_citizen_hack ;
output_one output format event_json
>>=? fun () ->
lwt_bad_citizen_hack :=
List.filter (( = ) event_json) !lwt_bad_citizen_hack ;
return_unit )
else return_unit
let close {lwt_bad_citizen_hack; output; format; _} =
iter_s
(fun event_json -> output_one output format event_json)
!lwt_bad_citizen_hack
>>=? fun () -> Lwt_unix.close output >>= fun () -> return_unit
end
module Sink_implementation_path = Make_sink (struct
let kind = `Path
end)
module Sink_implementation_stdout = Make_sink (struct
let kind = `Stdout
end)
module Sink_implementation_stderr = Make_sink (struct
let kind = `Stderr
end)
let () = Internal_event.All_sinks.register (module Sink_implementation_path)
let () = Internal_event.All_sinks.register (module Sink_implementation_stdout)
let () = Internal_event.All_sinks.register (module Sink_implementation_stderr)
src/lib_stdlib_unix/file_descriptor_sink.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Record t := {
output : Lwt_unix.file_descr;
format : variant;
lwt_bad_citizen_hack :
Stdlib.ref (list Tezos_data_encoding.Data_encoding.json);
level_at_least : Tezos_event_logging.Internal_event.Level.t }.
Record wrapped {event : Type} := {
time_stamp : Z;
section : Tezos_event_logging.Internal_event.Section.t;
event : event }.
Arguments wrapped : clear implicits.
Definition wrap {A : Type}
(time_stamp : Z) (section : Tezos_event_logging.Internal_event.Section.t)
(event : A) : wrapped A :=
{| time_stamp := time_stamp; section := section; event := event |}.
Definition wrapped_encoding {A : Type}
(event_encoding : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding__Data_encoding.encoding (wrapped A) :=
let v0 :=
conv
(fun function_parameter =>
let '{|
time_stamp := time_stamp; section := section; event := event |} :=
function_parameter in
(time_stamp, section, event))
(fun function_parameter =>
let '(time_stamp, section, event) := function_parameter in
{| time_stamp := time_stamp; section := section; event := event |}) None
(obj3 (req None None "time_stamp" % string float)
(req None None "section" % string Internal_event.Section.encoding)
(req None None "event" % string event_encoding)) in
encoding "fd-sink-item" % string (first_version v0).
(* ❌ Functors are not handled. *)
functor
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
src/lib_stdlib_unix/file_event_sink.ml 103 errors
(******************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
module Micro_seconds : sig
(** Module with time-stamps with âat least micro-secondsâ precision. *)
type t = private float
val now : unit -> t
val of_float : float -> t
val encoding : t Data_encoding.t
val date_string : t -> string * string
end = struct
(* Time.t is in seconds, we want more precision. *)
type t = float
let now () = Unix.gettimeofday ()
let of_float f = f
let encoding =
let open Data_encoding in
conv (* Cf. https://github.com/OCamlPro/ocplib-json-typed/issues/25 *)
(fun f -> f *. 1_000_000. |> Int64.of_float)
(fun i64 -> Int64.to_float i64 /. 1_000_000.)
int64
let date_string time_value =
let open Unix in
let open Printf in
let tm = gmtime time_value in
( sprintf "%04d%02d%02d" (1900 + tm.tm_year) (tm.tm_mon + 1) tm.tm_mday,
sprintf
"%02d%02d%02d-%06d"
tm.tm_hour
tm.tm_min
tm.tm_sec
((time_value -. floor time_value) *. 1_000_000. |> int_of_float) )
end
module Event_filter = struct
type t =
| True
| False
| Or of t list
| And of t list
| Name of string
| Name_matches of Re.re
| Level_in of Internal_event.level list
| Section_in of Internal_event.Section.t list
let rec run ~section ~level ~name filter =
let continue = run ~section ~level ~name in
match filter with
| True ->
true
| False ->
false
| Or l ->
List.exists continue l
| And l ->
List.for_all continue l
| Name s ->
String.equal s name
| Name_matches re ->
Re.execp re name
| Level_in l ->
List.mem level l
| Section_in l ->
List.mem section l
let rec pp fmt filter =
let open Format in
match filter with
| True ->
pp_print_string fmt "true"
| False ->
pp_print_string fmt "false"
| Or l ->
fprintf
fmt
"(or@ @[<2>%a@]"
(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ ") pp)
l
| And l ->
fprintf
fmt
"(and@ @[<2>%a@]"
(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ ") pp)
l
| Name s ->
fprintf fmt "(name-is@ %S)" s
| Name_matches re ->
fprintf fmt "(name-matches@ %a)" Re.pp_re re
| Level_in l ->
fprintf
fmt
"(level-in@ [%s])"
(String.concat "," (List.map Internal_event.Level.to_string l))
| Section_in l ->
fprintf
fmt
"(section-in@ [%a])"
(pp_print_list
~pp_sep:(fun fmt () -> fprintf fmt ",@ ")
(fun fmt s ->
fprintf
fmt
"(Some %s)"
(String.concat "," (Internal_event.Section.to_string_list s))))
l
[@@warning "-32"]
(* -> The "unused value" warning. *)
let t = True
let f = False [@@warning "-32"]
(* -> The "unused value" warning. *)
let any l = Or l
let all l = And l [@@warning "-32"]
(* -> The "unused value" warning. *)
let name_is s = Name s
let name_matches s = Name_matches s
let name_matches_posix s = name_matches (Re.Posix.compile_pat s)
let level_in l = Level_in l
let section_in l = Section_in l
let levels_in_order =
Internal_event.[Debug; Info; Notice; Warning; Error; Fatal]
let level_at_least lvl =
List.fold_left
(function
| None -> (
function l when l = lvl -> Some [l] | _ -> None )
| Some s ->
fun l -> Some (l :: s))
None
levels_in_order
|> Option.unopt_exn (Failure "level_at_least not found")
|> level_in
end
type t = {
path : string;
(* Hopefully temporary hack to handle event which are emitted with
the non-cooperative log functions in `Legacy_logging`: *)
lwt_bad_citizen_hack : (string * Data_encoding.json) list ref;
event_filter : Event_filter.t;
}
type 'event wrapped = {
time_stamp : Micro_seconds.t;
section : Internal_event.Section.t;
event : 'event;
}
let wrap time_stamp section event = {time_stamp; section; event}
let wrapped_encoding event_encoding =
let open Data_encoding in
let v0 =
conv
(fun {time_stamp; section; event} -> (time_stamp, section, event))
(fun (time_stamp, section, event) -> {time_stamp; section; event})
(obj3
(req "time_stamp" Micro_seconds.encoding)
(req "section" Internal_event.Section.encoding)
(req "event" event_encoding))
in
With_version.(encoding ~name:"file-event-sink-item" (first_version v0))
module Section_dir = struct
let of_section (section : Internal_event.Section.t) =
String.concat "." (Internal_event.Section.to_string_list section)
let section_name = function
| "no-section" ->
Ok None
| other -> (
match TzString.remove_prefix ~prefix:"section-" other with
| None ->
Error "wrong-dir-name"
| Some s ->
Ok (Some s) )
end
module Sink_implementation : Internal_event.SINK with type t = t = struct
type nonrec t = t
let uri_scheme = "unix-files"
let configure uri =
let event_filter =
let name_res =
Uri.get_query_param' uri "name-matches" |> Option.unopt ~default:[]
in
let names =
Uri.get_query_param' uri "name" |> Option.unopt ~default:[]
in
let levels =
Option.(
Uri.get_query_param uri "level-at-least"
>>= Internal_event.Level.of_string
>>= fun l ->
(* some (fun all more -> all [Event_filter.level_at_least l ; more ]) *)
some [Event_filter.level_at_least l])
|> Option.unopt ~default:[]
in
let sections =
let somes =
Uri.get_query_param' uri "section"
|> Option.unopt ~default:[]
|> List.map (fun s ->
Internal_event.Section.make_sanitized
(String.split_on_char '.' s))
in
let none =
match Uri.get_query_param uri "no-section" with
| Some "true" ->
[Internal_event.Section.empty]
| _ ->
[]
in
match somes @ none with
| [] ->
[]
| more ->
[Event_filter.section_in more]
in
Event_filter.(
match
levels @ sections
@ List.map name_matches_posix name_res
@ List.map name_is names
with
| [] ->
t
| more ->
any more)
in
let t =
{path = Uri.path uri; lwt_bad_citizen_hack = ref []; event_filter}
in
return t
let output_json ~pp file_path event_json =
Lwt.catch
(fun () ->
Lwt_utils_unix.create_dir ~perm:0o700 (Filename.dirname file_path)
>>= fun () ->
Lwt_utils_unix.Json.write_file file_path event_json
>>= function
| Ok () ->
return_unit
| Error el ->
failwith
"ERROR while Handling %a,@ cannot write JSON to %s:@ %a\n%!"
pp
()
file_path
Error_monad.pp_print_error
el)
(function
| e ->
failwith
"ERROR while Handling %a: %a\n%!"
pp
()
Error_monad.pp_exn
e)
let handle (type a) {path; lwt_bad_citizen_hack; event_filter} m
?(section = Internal_event.Section.empty) (v : unit -> a) =
let module M = (val m : Internal_event.EVENT_DEFINITION with type t = a) in
let now = Micro_seconds.now () in
let (date, time) = Micro_seconds.date_string now in
let forced = v () in
let level = M.level forced in
match Event_filter.run ~section ~level ~name:M.name event_filter with
| true ->
let event_json =
Data_encoding.Json.construct
(wrapped_encoding M.encoding)
(wrap now section forced)
in
let tag =
let hash =
Marshal.to_string event_json [] |> Digest.string |> Digest.to_hex
in
String.sub hash 0 8
in
let section_dir = Section_dir.of_section section in
let dir_path =
List.fold_left Filename.concat path [section_dir; M.name; date; time]
in
let file_path =
Filename.concat
dir_path
(Printf.sprintf "%s_%s_%s.json" date time tag)
in
lwt_bad_citizen_hack :=
(file_path, event_json) :: !lwt_bad_citizen_hack ;
output_json file_path event_json ~pp:(fun fmt () -> M.pp fmt forced)
>>=? fun () ->
lwt_bad_citizen_hack :=
List.filter (fun (f, _) -> f <> file_path) !lwt_bad_citizen_hack ;
return_unit
| false ->
return_unit
let close {lwt_bad_citizen_hack; _} =
iter_s
(fun (f, j) ->
output_json f j ~pp:(fun fmt () ->
Format.fprintf fmt "Destacking: %s" f))
!lwt_bad_citizen_hack
>>=? fun () -> return_unit
end
let () = Internal_event.All_sinks.register (module Sink_implementation)
open Sink_implementation
module Query = struct
let with_file_kind dir p =
protect (fun () ->
Lwt_unix.stat (Filename.concat dir p)
>>= fun {Lwt_unix.st_kind; _} -> return st_kind)
>>=? function
| Unix.S_DIR ->
return (`Directory p)
| Unix.S_REG ->
return (`Regular_file p)
| (Unix.S_CHR | Unix.S_BLK | Unix.S_LNK | Unix.S_FIFO | Unix.S_SOCK) as k
->
return (`Special (k, p))
let fold_directory path ~init ~f =
protect (fun () ->
Lwt_unix.opendir path >>= fun dirhandle -> return dirhandle)
>>=? fun dirhandle ->
let rec iter prev =
protect (fun () ->
Lwt.catch
(fun () ->
Lwt_unix.readdir dirhandle
>>= fun d -> with_file_kind path d >>=? fun wk -> return_some wk)
(function
| End_of_file ->
Lwt_unix.closedir dirhandle >>= fun () -> return_none
| (e : exn) ->
failwith
"ERROR while folding %s: %s"
path
(Printexc.to_string e)))
>>=? fun opt ->
prev
>>=? fun p ->
match opt with Some more -> iter (f p more) | None -> prev
in
iter init
let ( // ) = Filename.concat
module Time_constraint = struct
type op = [`Lt | `Le | `Ge | `Gt]
type t =
[ `Date of op * float
| `Time of op * float
| `And of t * t
| `Or of t * t
| `All ]
let rec check_logic check_terminal (t : t) string =
let continue = check_logic check_terminal in
match t with
| `All ->
true
| `And (a, b) ->
continue a string && continue b string
| `Or (a, b) ->
continue a string || continue b string
| (`Date _ | `Time _) as term ->
check_terminal term
let op_with_string = function
| `Lt ->
fun a b -> String.compare a b > 0
| `Gt ->
fun a b -> String.compare a b < 0
| `Le ->
fun a b -> String.compare a b >= 0
| `Ge ->
fun a b -> String.compare a b <= 0
let check_date (t : t) date_string =
check_logic
(function
| `Date (op, f) ->
let s = Micro_seconds.(date_string (of_float f) |> fst) in
op_with_string op s date_string
| `Time _ ->
true)
t
date_string
let check_time (t : t) string =
check_logic
(function
| `Time (op, f) ->
let s = Micro_seconds.(date_string (of_float f) |> snd) in
op_with_string op s string
| `Date _ ->
true)
t
Micro_seconds.date_string
end
module Report = struct
type item =
[ `Error of
[ `Parsing_event of
[`Encoding of string * exn | `Json of string * error list]
| `Cannot_recognize_section of string ]
| `Warning of
[ `Expecting_regular_file_at of string
| `Expecting_directory_at of string
| `Unknown_event_name_at of string * string ] ]
let pp fmt (x : item) =
let open Format in
let error fmt = function
| `Parsing_event e -> (
match e with
| `Encoding (path, exn) ->
fprintf
fmt
"@[Parse error:@ wrong encoding for %S: %a@]"
path
pp_exn
exn
| `Json (path, el) ->
fprintf
fmt
"@[Parse error:@ wrong JSON for %S: %a@]"
path
pp_print_error
el )
| `Cannot_recognize_section sec ->
fprintf
fmt
"@[Directory error:@ cannot recognize section directory@ %S@]"
sec
in
let warning fmt = function
| `Expecting_regular_file_at path ->
fprintf fmt "%S@ is not a regular file" path
| `Expecting_directory_at path ->
fprintf fmt "%S@ is not a directory" path
| `Unknown_event_name_at (name, path) ->
fprintf fmt "Unknown event name@ %S@ at@ %S" name path
in
match x with
| `Error e ->
fprintf fmt "@[Error:@ %a@]" error e
| `Warning e ->
fprintf fmt "@[Warning:@ %a@]" warning e
let make_return m ((prev : item list), value) warning =
return (m warning :: prev, value)
let return_with_warning v e = make_return (fun e -> `Warning e) v e
let return_with_error v e = make_return (fun e -> `Error e) v e
end
open Report
let fold_event_kind_directory ~time_query path ~init ~f =
fold_directory path ~init:(return init) ~f:(fun previous ->
function
| `Directory "." | `Directory ".." ->
return previous
| `Directory date when Time_constraint.check_date time_query date ->
fold_directory
(path // date)
~init:(return previous)
~f:(fun previous ->
function
| `Directory "." | `Directory ".." ->
return previous
| `Directory time when Time_constraint.check_time time_query time
->
fold_directory
(path // date // time)
~init:(return previous)
~f:(fun previous -> function
| `Directory "." | `Directory ".." -> return previous
| `Regular_file file ->
f previous (path // date // time // file)
| `Directory p | `Special (_, p) ->
return_with_warning
previous
(`Expecting_regular_file_at
(path // date // time // p)))
| `Directory _ (* filtered out *) ->
return previous
| `Regular_file p | `Special (_, p) ->
return_with_warning
previous
(`Expecting_directory_at (path // date // p)))
| `Directory _ (* filtered out *) ->
return previous
| `Regular_file p | `Special (_, p) ->
return_with_warning previous (`Expecting_directory_at (path // p)))
let handle_event_kind_directory (type a) ~time_query ~section_path ~init ~f
ev =
let module Event = ( val ev : Internal_event.EVENT_DEFINITION
with type t = a )
in
let handle_event_file previous path =
Lwt_utils_unix.Json.read_file path
>>= function
| Ok json -> (
try
let {time_stamp; event; _} =
Data_encoding.Json.destruct (wrapped_encoding Event.encoding) json
in
f
(snd previous)
~time_stamp:(time_stamp :> float)
(Internal_event.Generic.Event (Event.name, ev, event))
>>=? fun user_return -> return (fst previous, user_return)
with e ->
return_with_error previous (`Parsing_event (`Encoding (path, e))) )
| Error el ->
return_with_error previous (`Parsing_event (`Json (path, el)))
in
fold_event_kind_directory
~time_query
(section_path // Event.name)
~init
~f:(fun prev file -> handle_event_file prev file)
let fold ?on_unknown ?only_sections ?only_names ?(time_query = `All) uri
~init ~f =
let name_matches =
match only_names with
| None ->
fun _ -> true
| Some l ->
fun name -> List.mem name l
in
let section_matches =
match only_sections with
| None ->
fun _ -> true
| Some l ->
fun name -> List.mem name l
in
configure uri
>>=? fun {path = sink_path; _} ->
fold_directory
sink_path
~init:(return ([], init))
~f:(fun previous -> function `Directory ("." | "..") -> return previous
| `Directory dir -> (
match Section_dir.section_name dir with
| Ok sec when section_matches sec ->
fold_directory
(sink_path // dir)
~init:(return ([], init))
~f:(fun previous -> function `Directory ("." | "..") ->
return previous
| `Directory event_name when name_matches event_name -> (
let open Internal_event in
match All_definitions.find (( = ) event_name) with
| Some (Generic.Definition (_, ev)) ->
handle_event_kind_directory
~time_query
ev
~section_path:(sink_path // dir)
~init:previous
~f
| None -> (
match on_unknown with
| None ->
return_with_warning
previous
(`Unknown_event_name_at
(event_name, sink_path // dir))
| Some f ->
fold_event_kind_directory
~time_query
(sink_path // dir // event_name)
~init:previous
~f:(fun prev file ->
f file >>=? fun () -> return prev) ) )
| `Directory _ (* filtered out *) -> return previous
| `Regular_file p | `Special (_, p) ->
return_with_warning
previous
(`Expecting_directory_at (sink_path // p)))
| Ok _ (* section does not match *) ->
return previous
| Error _ ->
return_with_error previous (`Cannot_recognize_section dir) )
| `Regular_file p | `Special (_, p) ->
return_with_warning
previous
(`Expecting_directory_at (sink_path // p)))
end
src/lib_stdlib_unix/file_event_sink.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Module Micro_seconds.
Definition t := Z.
Definition now (function_parameter : unit) : Z :=
let 'tt := function_parameter in
Unix.gettimeofday tt.
Definition of_float {A : Type} (f : A) : A := f.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding Z :=
conv
(fun f =>
OCaml.Stdlib.reverse_apply
(Stdlib.op_starpoint f
(* ❌ Float constant 1_000_000. is approximated by the integer 1000000 *)
1000000) Int64.of_float)
(fun i64 =>
Stdlib.op_divpoint (Int64.to_float i64)
(* ❌ Float constant 1_000_000. is approximated by the integer 1000000 *)
1000000) None int64.
Definition date_string (time_value : Z) : string * string :=
let tm := gmtime time_value in
((sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding CamlinternalFormatBasics.Zeros 4)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding CamlinternalFormatBasics.Zeros
2) CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))) "%04d%02d%02d" % string)
(Z.add 1900 (tm_year tm)) (Z.add (tm_mon tm) 1) (tm_mday tm)),
(sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding CamlinternalFormatBasics.Zeros
2) CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 2)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal "-" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Lit_padding
CamlinternalFormatBasics.Zeros 6)
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format)))))
"%02d%02d%02d-%06d" % string) (tm_hour tm) (tm_min tm) (tm_sec tm)
(OCaml.Stdlib.reverse_apply
(Stdlib.op_starpoint
(Stdlib.op_minuspoint time_value (Stdlib.floor time_value))
(* ❌ Float constant 1_000_000. is approximated by the integer 1000000 *)
1000000) Stdlib.int_of_float))).
End Micro_seconds.
Module Event_filter.
Inductive t : Type :=
| True : t
| False : t
| Or : (list t) -> t
| And : (list t) -> t
| Name : string -> t
| Name_matches : Re.re -> t
| Level_in : (list Tezos_event_logging.Internal_event.level) -> t
| Section_in : (list Tezos_event_logging.Internal_event.Section.t) -> t.
Fixpoint run
(section : Tezos_event_logging.Internal_event.Section.t)
(level : Tezos_event_logging.Internal_event.level) (name : Stdlib.String.t)
(filter : t) : bool :=
let continue := run section level name in
match filter with
| True => true
| False => false
| Or l => Stdlib.List._exists continue l
| And l => Stdlib.List.for_all continue l
| Name s => Stdlib.String.equal s name
| Name_matches re => Re.execp None None re name
| Level_in l => Stdlib.List.mem level l
| Section_in l => Stdlib.List.mem section l
end.
Fixpoint pp (fmt : Stdlib.Format.formatter) (filter : t) : unit :=
match filter with
| True => pp_print_string fmt "true" % string
| False => pp_print_string fmt "false" % string
| Or l =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "(or" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<2>" % string
CamlinternalFormatBasics.End_of_format) "<2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"(or@ @[<2>%a@]" % string)
(pp_print_list
(Some
(fun fmt =>
fun function_parameter =>
let 'tt := function_parameter in
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
CamlinternalFormatBasics.End_of_format) "@ " % string)))
pp) l
| And l =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "(and" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<2>" % string
CamlinternalFormatBasics.End_of_format) "<2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"(and@ @[<2>%a@]" % string)
(pp_print_list
(Some
(fun fmt =>
fun function_parameter =>
let 'tt := function_parameter in
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
CamlinternalFormatBasics.End_of_format) "@ " % string)))
pp) l
| Name s =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "(name-is" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))
"(name-is@ %S)" % string) s
| Name_matches re =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "(name-matches" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))
"(name-matches@ %a)" % string) Re.pp_re re
| Level_in l =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "(level-in" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal "])" % string
CamlinternalFormatBasics.End_of_format)))))
"(level-in@ [%s])" % string)
(Stdlib.String.concat "," % string
(List.map Internal_event.Level.to_string l))
| Section_in l =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "(section-in" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "])" % string
CamlinternalFormatBasics.End_of_format)))))
"(section-in@ [%a])" % string)
(pp_print_list
(Some
(fun fmt =>
fun function_parameter =>
let 'tt := function_parameter in
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "," % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
CamlinternalFormatBasics.End_of_format)) ",@ " % string)))
(fun fmt =>
fun s =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "(Some " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"(Some %s)" % string)
(Stdlib.String.concat "," % string
(Internal_event.Section.to_string_list s)))) l
end.
Definition t : t := True.
Definition f : t := False.
Definition any (l : list t) : t := Or l.
Definition all (l : list t) : t := And l.
Definition name_is (s : string) : t := Name s.
Definition name_matches (s : Re.re) : t := Name_matches s.
Definition name_matches_posix (s : string) : t :=
name_matches (Re.Posix.compile_pat None s).
Definition level_in (l : list Tezos_event_logging.Internal_event.level) : t :=
Level_in l.
Definition section_in (l : list Tezos_event_logging.Internal_event.Section.t)
: t := Section_in l.
Definition levels_in_order : list Tezos_event_logging.Internal_event.level :=
cons Tezos_event_logging.Internal_event.Debug
(cons Tezos_event_logging.Internal_event.Info
(cons Tezos_event_logging.Internal_event.Notice
(cons Tezos_event_logging.Internal_event.Warning
(cons Tezos_event_logging.Internal_event.Error
(cons Tezos_event_logging.Internal_event.Fatal []))))).
Definition level_at_least (lvl : Tezos_event_logging.Internal_event.level)
: t :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(Stdlib.List.fold_left
(fun function_parameter =>
match function_parameter with
| None =>
fun function_parameter =>
match function_parameter with
| l => Some (cons l [])
| _ => None
end
| Some s => fun l => Some (cons l s)
end) None levels_in_order)
(Option.unopt_exn (OCaml.Failure "level_at_least not found" % string)))
level_in.
End Event_filter.
Record t := {
path : string;
lwt_bad_citizen_hack :
Stdlib.ref (list (string * Tezos_data_encoding.Data_encoding.json));
event_filter : Event_filter.t }.
Record wrapped {event : Type} := {
time_stamp : Micro_seconds.t;
section : Tezos_event_logging.Internal_event.Section.t;
event : event }.
Arguments wrapped : clear implicits.
Definition wrap {A : Type}
(time_stamp : Micro_seconds.t)
(section : Tezos_event_logging.Internal_event.Section.t) (event : A)
: wrapped A :=
{| time_stamp := time_stamp; section := section; event := event |}.
Definition wrapped_encoding {A : Type}
(event_encoding : Tezos_data_encoding.Data_encoding.encoding A)
: Tezos_data_encoding__Data_encoding.encoding (wrapped A) :=
let v0 :=
conv
(fun function_parameter =>
let '{|
time_stamp := time_stamp; section := section; event := event |} :=
function_parameter in
(time_stamp, section, event))
(fun function_parameter =>
let '(time_stamp, section, event) := function_parameter in
{| time_stamp := time_stamp; section := section; event := event |}) None
(obj3 (req None None "time_stamp" % string Micro_seconds.encoding)
(req None None "section" % string Internal_event.Section.encoding)
(req None None "event" % string event_encoding)) in
encoding "file-event-sink-item" % string (first_version v0).
Module Section_dir.
Definition of_section (section : Tezos_event_logging.Internal_event.Section.t)
: string :=
Stdlib.String.concat "." % string
(Internal_event.Section.to_string_list section).
Definition section_name (function_parameter : string)
: sum (option string) string :=
match function_parameter with
| "no-section" % string => Stdlib.Ok None
| other =>
match TzString.remove_prefix "section-" % string other with
| None => Stdlib.Error "wrong-dir-name" % string
| Some s => Stdlib.Ok (Some s)
end
end.
End Section_dir.
Module Sink_implementation.
Definition t := t.
Definition uri_scheme : string := "unix-files" % string.
Definition configure (uri : Uri.t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult t) :=
let event_filter :=
let name_res :=
OCaml.Stdlib.reverse_apply
(Uri.get_query_param' uri "name-matches" % string) (Option.unopt [])
in
let names :=
OCaml.Stdlib.reverse_apply (Uri.get_query_param' uri "name" % string)
(Option.unopt []) in
let levels :=
OCaml.Stdlib.reverse_apply
(op_gtgteq
(op_gtgteq (Uri.get_query_param uri "level-at-least" % string)
Internal_event.Level.of_string)
(fun l => some (cons (Event_filter.level_at_least l) [])))
(Option.unopt []) in
let sections :=
let somes :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(Uri.get_query_param' uri "section" % string) (Option.unopt []))
(List.map
(fun s =>
Internal_event.Section.make_sanitized
(Stdlib.String.split_on_char "." % char s))) in
let none :=
match Uri.get_query_param uri "no-section" % string with
| Some "true" % string => cons Internal_event.Section.empty []
| _ => []
end in
match OCaml.Stdlib.app somes none with
| [] => []
| more => cons (Event_filter.section_in more) []
end in
match
OCaml.Stdlib.app levels
(OCaml.Stdlib.app sections
(OCaml.Stdlib.app (List.map name_matches_posix name_res)
(List.map name_is names))) with
| [] => t
| more => any more
end in
let t :=
{| path := Uri.path uri; lwt_bad_citizen_hack := Stdlib.ref [];
event_filter := event_filter |} in
_return t.
Definition output_json
(pp : Stdlib.Format.formatter -> unit -> unit) (file_path : string)
(event_json : Tezos_data_encoding.Data_encoding.json)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_utils_unix.create_dir (Some 448) (Filename.dirname file_path))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_utils_unix.Json.write_file file_path event_json)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => return_unit
| Stdlib.Error el =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"ERROR while Handling " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "," % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"cannot write JSON to " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format)))))))))))
"ERROR while Handling %a,@ cannot write JSON to %s:@ %a
%!"
% string) pp tt file_path Error_monad.pp_print_error el
end)))
(fun e =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"ERROR while Handling " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))))))
"ERROR while Handling %a: %a
%!" % string) pp tt Error_monad.pp_exn
e).
Definition handle {A : Type} (function_parameter : t)
: {_ : unit &
Tezos_event_logging.Internal_event.EVENT_DEFINITION.signature A} ->
(option Tezos_event_logging.Internal_event.Section.t) ->
(unit -> A) -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
let '{|
path := path;
lwt_bad_citizen_hack := lwt_bad_citizen_hack;
event_filter := event_filter
|} := function_parameter in
fun m =>
fun op_staroptstar =>
let section :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Internal_event.Section.empty
end in
fun v =>
let M := projT2 m in
let now := Micro_seconds.now tt in
let '(date, time) := Micro_seconds.date_string now in
let forced := v tt in
let level :=
M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.level)
forced in
match
Event_filter.run section level
M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.name)
event_filter with
| true =>
let event_json :=
Data_encoding.Json.construct
(wrapped_encoding
M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.encoding))
(wrap now section forced) in
let tag :=
let hash :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply (Marshal.to_string event_json [])
Digest.string) Digest.to_hex in
Stdlib.String.sub hash 0 8 in
let section_dir := Section_dir.of_section section in
let dir_path :=
Stdlib.List.fold_left Filename.concat path
(cons section_dir
(cons
M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.name)
(cons date (cons time [])))) in
let file_path :=
Filename.concat dir_path
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "_" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "_" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
".json" % string
CamlinternalFormatBasics.End_of_format))))))
"%s_%s_%s.json" % string) date time tag) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq lwt_bad_citizen_hack
(cons (file_path, event_json)
(Stdlib.op_exclamation lwt_bad_citizen_hack)) in
op_gtgteqquestion
(output_json
(fun fmt =>
fun function_parameter =>
let 'tt := function_parameter in
M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.pp)
fmt forced) file_path event_json)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq lwt_bad_citizen_hack
(Stdlib.List.filter
(fun function_parameter =>
let '(f, _) := function_parameter in
nequiv_decb f file_path)
(Stdlib.op_exclamation lwt_bad_citizen_hack)) in
return_unit)
| false => return_unit
end.
Definition close (function_parameter : t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
let '{| lwt_bad_citizen_hack := lwt_bad_citizen_hack |} :=
function_parameter in
op_gtgteqquestion
(iter_s
(fun function_parameter =>
let '(f, j) := function_parameter in
output_json
(fun fmt =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Destacking: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Destacking: %s" % string) f) f j)
(Stdlib.op_exclamation lwt_bad_citizen_hack))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit).
End Sink_implementation.
Import Sink_implementation.
Module Query.
Definition with_file_kind (dir : string) (p : string)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult variant) :=
op_gtgteqquestion
(protect None None
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_unix.stat (Filename.concat dir p))
(fun function_parameter =>
let '{| Lwt_unix.st_kind := st_kind |} := function_parameter in
_return st_kind)))
(fun function_parameter =>
match function_parameter with
| Unix.S_DIR =>
_return
(* ❌ Variants not supported *)
variant
| Unix.S_REG =>
_return
(* ❌ Variants not supported *)
variant
|
(Unix.S_CHR | Unix.S_BLK | Unix.S_LNK | Unix.S_FIFO | Unix.S_SOCK) as
k =>
_return
(* ❌ Variants not supported *)
variant
end).
Definition fold_directory {A : Type}
(path : string) (init : Lwt.t (Tezos_error_monad.Error_monad.tzresult A))
(f : A -> variant -> Lwt.t (Tezos_error_monad.Error_monad.tzresult A))
: Lwt.t (Tezos_error_monad.Error_monad.tzresult A) :=
op_gtgteqquestion
(protect None None
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_unix.opendir path) (fun dirhandle => _return dirhandle)))
(fun dirhandle =>
let fix iter (prev : Lwt.t (Tezos_error_monad.Error_monad.tzresult A))
: Lwt.t (Tezos_error_monad.Error_monad.tzresult A) :=
op_gtgteqquestion
(protect None None
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_unix.readdir dirhandle)
(fun d =>
op_gtgteqquestion (with_file_kind path d)
(fun wk => return_some wk)))
(fun function_parameter =>
match function_parameter with
| OCaml.End_of_file =>
op_gtgteq (Lwt_unix.closedir dirhandle)
(fun function_parameter =>
let 'tt := function_parameter in
return_none)
| _ as e =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"ERROR while folding " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"ERROR while folding %s: %s" % string) path
(Printexc.to_string e)
end)))
(fun opt =>
op_gtgteqquestion prev
(fun p =>
match opt with
| Some more => iter (f p more)
| None => prev
end)) in
iter init).
Definition op_divdiv : string -> string -> string := Filename.concat.
Module Time_constraint.
Definition op := variant.
Definition t := variant.
Fixpoint check_logic {A : Type}
(check_terminal : variant -> bool) (t : t) (string : A) : bool :=
let continue := check_logic check_terminal in
match t with
| All => true
| And (a, b) => andb (continue a string) (continue b string)
| Or (a, b) => orb (continue a string) (continue b string)
| (Date _ | Time _) as term => check_terminal term
end.
Definition op_with_string (function_parameter : variant)
: Stdlib.String.t -> Stdlib.String.t -> bool :=
match function_parameter with
| Lt => fun a => fun b => OCaml.Stdlib.gt (Stdlib.String.compare a b) 0
| Gt => fun a => fun b => OCaml.Stdlib.lt (Stdlib.String.compare a b) 0
| Le => fun a => fun b => OCaml.Stdlib.ge (Stdlib.String.compare a b) 0
| Ge => fun a => fun b => OCaml.Stdlib.le (Stdlib.String.compare a b) 0
end.
Definition check_date (t : t) (date_string : Stdlib.String.t) : bool :=
check_logic
(fun function_parameter =>
match function_parameter with
| Date (op, f) =>
let s := OCaml.Stdlib.reverse_apply (date_string (of_float f)) fst
in
op_with_string op s date_string
| Time _ => true
end) t date_string.
Definition check_time (t : t) (string : Stdlib.String.t) : bool :=
check_logic
(fun function_parameter =>
match function_parameter with
| Time (op, f) =>
let s := OCaml.Stdlib.reverse_apply (date_string (of_float f)) snd
in
op_with_string op s string
| Date _ => true
end) t Micro_seconds.date_string.
End Time_constraint.
Module Report.
Definition item := variant.
Definition pp (fmt : Stdlib.Format.formatter) (x : item) : unit :=
let error (fmt : Stdlib.Format.formatter) (function_parameter : variant)
: unit :=
match function_parameter with
| Parsing_event e =>
match e with
| Encoding (path, exn) =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Parse error:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"wrong encoding for " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"@[Parse error:@ wrong encoding for %S: %a@]" % string) path
pp_exn exn
| Json (path, el) =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Parse error:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"wrong JSON for " % string
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"@[Parse error:@ wrong JSON for %S: %a@]" % string) path
pp_print_error el
end
| Cannot_recognize_section sec =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal
"Directory error:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"cannot recognize section directory" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[Directory error:@ cannot recognize section directory@ %S@]" %
string) sec
end in
let warning (fmt : Stdlib.Format.formatter) (function_parameter : variant)
: unit :=
match function_parameter with
| Expecting_regular_file_at path =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"is not a regular file" % string
CamlinternalFormatBasics.End_of_format)))
"%S@ is not a regular file" % string) path
| Expecting_directory_at path =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"is not a directory" % string
CamlinternalFormatBasics.End_of_format)))
"%S@ is not a directory" % string) path
| Unknown_event_name_at (name, path) =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unknown event name" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "at" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))))))
"Unknown event name@ %S@ at@ %S" % string) name path
end in
match x with
| Error e =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal "Error:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Error:@ %a@]" % string) error e
| Warning e =>
fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal "Warning:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[Warning:@ %a@]" % string) warning e
end.
Definition make_return {A B : Type}
(m : A -> item) (function_parameter : (list item) * B)
: A -> Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list item) * B)) :=
let '(_ as prev, value) := function_parameter in
fun warning => _return ((cons (m warning) prev), value).
Definition return_with_warning {A : Type}
(v : (list item) * A) (e : variant)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list item) * A)) :=
make_return
(fun e =>
(* ❌ Variants not supported *)
variant) v e.
Definition return_with_error {A : Type} (v : (list item) * A) (e : variant)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list item) * A)) :=
make_return
(fun e =>
(* ❌ Variants not supported *)
variant) v e.
End Report.
Import Report.
Definition fold_event_kind_directory {A : Type}
(time_query : Time_constraint.t) (path : string)
(init : (list Report.item) * A)
(f :
((list Report.item) * A) ->
string ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)))
: Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)) :=
fold_directory path (_return init)
(fun previous =>
fun function_parameter =>
match function_parameter with
| Directory "." % string | Directory ".." % string => _return previous
| Directory date =>
fold_directory (op_divdiv path date) (_return previous)
(fun previous =>
fun function_parameter =>
match function_parameter with
| Directory "." % string | Directory ".." % string =>
_return previous
| Directory time =>
fold_directory (op_divdiv (op_divdiv path date) time)
(_return previous)
(fun previous =>
fun function_parameter =>
match function_parameter with
| Directory "." % string | Directory ".." % string =>
_return previous
| Regular_file file =>
f previous
(op_divdiv (op_divdiv (op_divdiv path date) time)
file)
| Directory p | Special (_, p) =>
return_with_warning previous
(* ❌ Variants not supported *)
variant
end)
| Directory _ => _return previous
| Regular_file p | Special (_, p) =>
return_with_warning previous
(* ❌ Variants not supported *)
variant
end)
| Directory _ => _return previous
| Regular_file p | Special (_, p) =>
return_with_warning previous
(* ❌ Variants not supported *)
variant
end).
Definition handle_event_kind_directory {A B : Type}
(time_query : Time_constraint.t) (section_path : string)
(init : (list Report.item) * A)
(f :
A ->
Z ->
Tezos_event_logging.Internal_event.Generic.event ->
Lwt.t (Tezos_error_monad.Error_monad.tzresult A))
(ev :
{_ : unit &
Tezos_event_logging.Internal_event.EVENT_DEFINITION.signature B})
: Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)) :=
let Event := projT2 ev in
let handle_event_file (previous : (list Report.item) * A) (path : string)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)) :=
op_gtgteq (Lwt_utils_unix.Json.read_file path)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok json =>
(* ❌ Try-with are not handled *)
try
(let '{| time_stamp := time_stamp; event := event |} :=
Data_encoding.Json.destruct
(wrapped_encoding
Event.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.encoding))
json in
op_gtgteqquestion
(f (snd previous) time_stamp
(Tezos_event_logging.Internal_event.Generic.Event
(Event.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.name),
ev, event)))
(fun user_return => _return ((fst previous), user_return)))
| Stdlib.Error el =>
return_with_error previous
(* ❌ Variants not supported *)
variant
end) in
fold_event_kind_directory time_query
(op_divdiv section_path
Event.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.name)) init
(fun prev => fun file => handle_event_file prev file).
Definition fold {A : Type}
(on_unknown :
option (string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)))
(only_sections : option (list (option string)))
(only_names : option (list string)) (op_staroptstar : option variant)
: Uri.t ->
A ->
(A ->
Z ->
Tezos_event_logging.Internal_event.Generic.event ->
Lwt.t (Tezos_error_monad.Error_monad.tzresult A)) ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)) :=
let time_query :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun uri =>
fun init =>
fun f =>
let name_matches :=
match only_names with
| None =>
fun function_parameter =>
let '_ := function_parameter in
true
| Some l => fun name => Stdlib.List.mem name l
end in
let section_matches :=
match only_sections with
| None =>
fun function_parameter =>
let '_ := function_parameter in
true
| Some l => fun name => Stdlib.List.mem name l
end in
op_gtgteqquestion
(Sink_implementation.(Tezos_event_logging__Internal_event.SINK.configure)
uri)
(fun function_parameter =>
let '{| path := sink_path |} := function_parameter in
fold_directory sink_path (_return ([], init))
(fun previous =>
fun function_parameter =>
match function_parameter with
| Directory ("." % string | ".." % string) =>
_return previous
| Directory dir =>
match Section_dir.section_name dir with
| Stdlib.Ok sec =>
fold_directory (op_divdiv sink_path dir)
(_return ([], init))
(fun previous =>
fun function_parameter =>
match function_parameter with
| Directory ("." % string | ".." % string) =>
_return previous
| Directory event_name =>
match
All_definitions.find (equiv_decb event_name)
with
|
Some
(Tezos_event_logging.Internal_event.Generic.Definition
(_, ev)) =>
handle_event_kind_directory time_query
(op_divdiv sink_path dir) previous f ev
| None =>
match on_unknown with
| None =>
return_with_warning previous
(* ❌ Variants not supported *)
variant
| Some f =>
fold_event_kind_directory time_query
(op_divdiv (op_divdiv sink_path dir)
event_name) previous
(fun prev =>
fun file =>
op_gtgteqquestion (f file)
(fun function_parameter =>
let 'tt := function_parameter in
_return prev))
end
end
| Directory _ => _return previous
| Regular_file p | Special (_, p) =>
return_with_warning previous
(* ❌ Variants not supported *)
variant
end)
| Stdlib.Ok _ => _return previous
| Stdlib.Error _ =>
return_with_error previous
(* ❌ Variants not supported *)
variant
end
| Regular_file p | Special (_, p) =>
return_with_warning previous
(* ❌ Variants not supported *)
variant
end)).
End Query.
src/lib_stdlib_unix/internal_event_unix.ml 11 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
module Configuration = struct
type t = {activate : Uri.t list}
let default =
{activate = [Uri.make ~scheme:Internal_event.Lwt_log_sink.uri_scheme ()]}
let encoding =
let open Data_encoding in
conv
(fun {activate} -> List.map Uri.to_string activate)
(fun activate -> {activate = List.map Uri.of_string activate})
(obj1
(dft
"activate"
~description:"List of URIs to activate/configure sinks."
(list string)
[]))
let of_file path =
Lwt_utils_unix.Json.read_file path
>>=? fun json ->
protect (fun () -> return (Data_encoding.Json.destruct encoding json))
let apply {activate} =
List.fold_left
(fun prev uri ->
prev >>=? fun () -> Internal_event.All_sinks.activate uri)
return_unit
activate
end
let env_var_name = "TEZOS_EVENTS_CONFIG"
let init ?lwt_log_sink ?(configuration = Configuration.default) () =
let _ =
(* This is just here to force the linking (and hence
initialization) of all these modules: *)
[ File_descriptor_sink.Sink_implementation_path.uri_scheme;
File_event_sink.Sink_implementation.uri_scheme ]
in
Lwt_log_sink_unix.initialize ?cfg:lwt_log_sink ()
>>= fun () ->
( match Sys.(getenv_opt env_var_name) with
| None ->
return_unit
| Some s ->
let uris =
TzString.split ' ' s
|> List.map (TzString.split '\n')
|> List.concat
|> List.map (TzString.split '\t')
|> List.concat
|> List.filter (( <> ) "")
|> List.map Uri.of_string
in
List.fold_left
(fun prev uri ->
prev
>>=? fun () ->
match Uri.scheme uri with
| None ->
Configuration.of_file (Uri.path uri)
>>=? fun cfg -> Configuration.apply cfg
| Some _ ->
Internal_event.All_sinks.activate uri)
return_unit
uris
>>=? fun () ->
Internal_event.Debug_event.(
emit
(make
"Loaded URIs from environment"
~attach:
(`O [("variable", `String env_var_name); ("value", `String s)])))
)
>>=? (fun () -> Configuration.apply configuration)
>>= function
| Ok () ->
Lwt.return_unit
| Error el ->
Format.kasprintf
Lwt.fail_with
"ERROR@ Initializing Internal_event_unix:@ %a\n%!"
Error_monad.pp_print_error
el
let close () =
Internal_event.All_sinks.close ()
>>= function
| Ok () ->
Lwt.return_unit
| Error el ->
Format.kasprintf
Lwt.fail_with
"ERROR@ closing Internal_event_unix:@ %a\n%!"
Error_monad.pp_print_error
el
src/lib_stdlib_unix/internal_event_unix.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Module Configuration.
Record t := {
activate : list Uri.t }.
Definition default : t :=
{|
activate :=
cons
(Uri.make (Some Internal_event.Lwt_log_sink.uri_scheme) None None None
None None None tt) [] |}.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
conv
(fun function_parameter =>
let '{| activate := activate |} := function_parameter in
List.map Uri.to_string activate)
(fun activate => {| activate := List.map Uri.of_string activate |}) None
(obj1
(dft None (Some "List of URIs to activate/configure sinks." % string)
"activate" % string (list None string) [])).
Definition of_file (path : string)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult t) :=
op_gtgteqquestion (Lwt_utils_unix.Json.read_file path)
(fun json =>
protect None None
(fun function_parameter =>
let 'tt := function_parameter in
_return (Data_encoding.Json.destruct encoding json))).
Definition apply (function_parameter : t)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
let '{| activate := activate |} := function_parameter in
Stdlib.List.fold_left
(fun prev =>
fun uri =>
op_gtgteqquestion prev
(fun function_parameter =>
let 'tt := function_parameter in
Internal_event.All_sinks.activate uri)) return_unit activate.
End Configuration.
Definition env_var_name : string := "TEZOS_EVENTS_CONFIG" % string.
Definition init
(lwt_log_sink : option Tezos_stdlib_unix.Lwt_log_sink_unix.cfg)
(op_staroptstar : option Configuration.t) : unit -> Lwt.t unit :=
let configuration :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Configuration.default
end in
fun function_parameter =>
let 'tt := function_parameter in
let '_ :=
cons File_descriptor_sink.Sink_implementation_path.uri_scheme
(cons File_event_sink.Sink_implementation.uri_scheme []) in
op_gtgteq (Lwt_log_sink_unix.initialize lwt_log_sink tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_gtgteqquestion
match getenv_opt env_var_name with
| None => return_unit
| Some s =>
let uris :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(TzString.split " " % char None None s)
(List.map
(let arg := TzString.split "010" % char in
fun eta => arg None None eta))) Stdlib.List.concat)
(List.map
(let arg := TzString.split "009" % char in
fun eta => arg None None eta))) Stdlib.List.concat)
(Stdlib.List.filter (nequiv_decb "" % string)))
(List.map Uri.of_string) in
op_gtgteqquestion
(Stdlib.List.fold_left
(fun prev =>
fun uri =>
op_gtgteqquestion prev
(fun function_parameter =>
let 'tt := function_parameter in
match Uri.scheme uri with
| None =>
op_gtgteqquestion
(Configuration.of_file (Uri.path uri))
(fun cfg => Configuration.apply cfg)
| Some _ => Internal_event.All_sinks.activate uri
end)) return_unit uris)
(fun function_parameter =>
let 'tt := function_parameter in
emit None
(make
(Some
(* ❌ Variants not supported *)
variant) "Loaded URIs from environment" % string))
end
(fun function_parameter =>
let 'tt := function_parameter in
Configuration.apply configuration))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error el =>
Format.kasprintf Lwt.fail_with
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "ERROR" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"Initializing Internal_event_unix:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format)))))))
"ERROR@ Initializing Internal_event_unix:@ %a
%!" % string)
Error_monad.pp_print_error el
end)).
Definition close (function_parameter : unit) : Lwt.t unit :=
let 'tt := function_parameter in
op_gtgteq (Internal_event.All_sinks.close tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error el =>
Format.kasprintf Lwt.fail_with
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "ERROR" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"closing Internal_event_unix:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format)))))))
"ERROR@ closing Internal_event_unix:@ %a
%!" % string)
Error_monad.pp_print_error el
end).
src/lib_stdlib_unix/lwt_exit.ml 9 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
exception Exit
let (termination_thread, exit_wakener) = Lwt.wait ()
let exit x = Lwt.wakeup exit_wakener x ; raise Exit
let () =
Lwt.async_exception_hook :=
function
| Exit ->
()
| e ->
let backtrace = Printexc.get_backtrace () in
let pp_exn_trace ppf backtrace =
if String.length backtrace <> 0 then
Format.fprintf
ppf
"@,Backtrace:@, @[<h>%a@]"
Format.pp_print_text
backtrace
in
(* TODO Improve this *)
Format.eprintf
"@[<v 2>@[Uncaught (asynchronous) exception (%d):@ %s@]%a@]@.%!"
(Unix.getpid ())
(Printexc.to_string e)
pp_exn_trace
backtrace ;
Lwt.wakeup exit_wakener 1
let signals =
let open Sys in
[ (sigabrt, "ABRT");
(sigalrm, "ALRM");
(sigfpe, "FPE");
(sighup, "HUP");
(sigill, "ILL");
(sigint, "INT");
(sigkill, "KILL");
(sigpipe, "PIPE");
(sigquit, "QUIT");
(sigsegv, "SEGV");
(sigterm, "TERM");
(sigusr1, "USR1");
(sigusr2, "USR2");
(sigchld, "CHLD");
(sigcont, "CONT");
(sigstop, "STOP");
(sigtstp, "TSTP");
(sigttin, "TTIN");
(sigttou, "TTOU");
(sigvtalrm, "VTALRM");
(sigprof, "PROF");
(sigbus, "BUS");
(sigpoll, "POLL");
(sigsys, "SYS");
(sigtrap, "TRAP");
(sigurg, "URG");
(sigxcpu, "XCPU");
(sigxfsz, "XFSZ") ]
let set_exit_handler ?(log = Format.eprintf "%s\n%!") signal =
match List.assoc_opt signal signals with
| None ->
Format.kasprintf
invalid_arg
"Killable.set_exit_handler: unknown signal %d"
signal
| Some name ->
let handler signal =
try
Format.kasprintf
log
"Received the %s signal, triggering shutdown."
name ;
exit signal
with _ -> ()
in
ignore (Lwt_unix.on_signal signal handler : Lwt_unix.signal_handler_id)
(* Which signals is the program meant to exit on *)
let signals_to_exit_on = ref []
let exit_on ?log signal =
if List.mem signal !signals_to_exit_on then
Format.kasprintf
Pervasives.failwith
"Killable.exit_on: already registered signal %d"
signal
else (
signals_to_exit_on := signal :: !signals_to_exit_on ;
set_exit_handler ?log signal )
type outcome = Resolved of int | Exited of int
let retcode_of_unit_result_lwt p =
let open Lwt.Infix in
p
>>= function
| Error e ->
(* TODO: print *) ignore e ; Lwt.return 1
| Ok () ->
Lwt.return 0
let wrap_promise (p : int Lwt.t) =
let open Lwt.Infix in
Lwt.choose
[(p >|= fun v -> Resolved v); (termination_thread >|= fun s -> Exited s)]
>>= function
| Resolved r ->
Lwt.return r
| Exited s ->
(*TODO: what are the correct expected behaviour here?*)
if List.mem s !signals_to_exit_on then (
(* Exit because of signal *)
Lwt.cancel p ;
Lwt.return 2 )
else (* Other exit *)
Pervasives.exit 3
src/lib_stdlib_unix/lwt_exit.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ The definition of exceptions is not handled. *)
exception
Definition exit {A : Type} (x : Z) : A :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt.wakeup exit_wakener x in
Stdlib.raise Exit.
Definition signals : list (Z * string) :=
cons (sigabrt, "ABRT" % string)
(cons (sigalrm, "ALRM" % string)
(cons (sigfpe, "FPE" % string)
(cons (sighup, "HUP" % string)
(cons (sigill, "ILL" % string)
(cons (sigint, "INT" % string)
(cons (sigkill, "KILL" % string)
(cons (sigpipe, "PIPE" % string)
(cons (sigquit, "QUIT" % string)
(cons (sigsegv, "SEGV" % string)
(cons (sigterm, "TERM" % string)
(cons (sigusr1, "USR1" % string)
(cons (sigusr2, "USR2" % string)
(cons (sigchld, "CHLD" % string)
(cons (sigcont, "CONT" % string)
(cons (sigstop, "STOP" % string)
(cons (sigtstp, "TSTP" % string)
(cons (sigttin, "TTIN" % string)
(cons (sigttou, "TTOU" % string)
(cons (sigvtalrm, "VTALRM" % string)
(cons (sigprof, "PROF" % string)
(cons (sigbus, "BUS" % string)
(cons (sigpoll, "POLL" % string)
(cons (sigsys, "SYS" % string)
(cons
(sigtrap, "TRAP" % string)
(cons
(sigurg, "URG" % string)
(cons
(sigxcpu,
"XCPU" % string)
(cons
(sigxfsz,
"XFSZ" % string) []))))))))))))))))))))))))))).
Definition set_exit_handler (op_staroptstar : option (string -> unit))
: Z -> unit :=
let log :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))) "%s
%!" % string)
end in
fun signal =>
match Stdlib.List.assoc_opt signal signals with
| None =>
Format.kasprintf OCaml.Stdlib.invalid_arg
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Killable.set_exit_handler: unknown signal " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"Killable.set_exit_handler: unknown signal %d" % string) signal
| Some name =>
let handler (signal : Z) : unit :=
(* ❌ Try-with are not handled *)
try
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ :=
Format.kasprintf log
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Received the " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" signal, triggering shutdown." % string
CamlinternalFormatBasics.End_of_format)))
"Received the %s signal, triggering shutdown." % string) name in
exit signal) in
OCaml.Stdlib.ignore (Lwt_unix.on_signal signal handler)
end.
Definition signals_to_exit_on : Stdlib.ref (list Z) := Stdlib.ref [].
Definition exit_on (log : option (string -> unit)) (signal : Z) : unit :=
if Stdlib.List.mem signal (Stdlib.op_exclamation signals_to_exit_on) then
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Killable.exit_on: already registered signal " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))
"Killable.exit_on: already registered signal %d" % string) signal
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq signals_to_exit_on
(cons signal (Stdlib.op_exclamation signals_to_exit_on)) in
set_exit_handler log signal.
Inductive outcome : Type :=
| Resolved : Z -> outcome
| Exited : Z -> outcome.
Definition retcode_of_unit_result_lwt {A : Type} (p : Lwt.t (sum unit A))
: Lwt.t Z :=
op_gtgteq p
(fun function_parameter =>
match function_parameter with
| Stdlib.Error e =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := OCaml.Stdlib.ignore e in
Lwt._return 1
| Stdlib.Ok tt => Lwt._return 0
end).
Definition wrap_promise (p : Lwt.t Z) : Lwt.t Z :=
op_gtgteq
(Lwt.choose
(cons (op_gtpipeeq p (fun v => Resolved v))
(cons (op_gtpipeeq termination_thread (fun s => Exited s)) [])))
(fun function_parameter =>
match function_parameter with
| Resolved r => Lwt._return r
| Exited s =>
if Stdlib.List.mem s (Stdlib.op_exclamation signals_to_exit_on) then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt.cancel p in
Lwt._return 2
else
Pervasives.exit 3
end).
src/lib_stdlib_unix/lwt_lock_file.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
let create_inner lock_command ?(close_on_exec = true) ?(unlink_on_exit = false)
fn =
protect (fun () ->
Lwt_unix.openfile fn Unix.[O_CREAT; O_WRONLY; O_TRUNC] 0o644
>>= fun fd ->
if close_on_exec then Lwt_unix.set_close_on_exec fd ;
Lwt_unix.lockf fd lock_command 0
>>= fun () ->
if unlink_on_exit then Lwt_main.at_exit (fun () -> Lwt_unix.unlink fn) ;
let pid_str = string_of_int @@ Unix.getpid () in
Lwt_unix.write_string fd pid_str 0 (String.length pid_str)
>>= fun _ -> return_unit)
let create = create_inner Unix.F_TLOCK
let blocking_create ?timeout ?(close_on_exec = true) ?(unlink_on_exit = false)
fn =
let create () = create_inner Unix.F_LOCK ~close_on_exec ~unlink_on_exit fn in
match timeout with
| None ->
create ()
| Some duration ->
with_timeout (Lwt_unix.sleep duration) (fun _ -> create ())
let is_locked fn =
if not @@ Sys.file_exists fn then return_false
else
protect (fun () ->
Lwt_unix.openfile fn [Unix.O_RDONLY] 0o644
>>= fun fd ->
Lwt.finalize
(fun () ->
Lwt.try_bind
(fun () -> Lwt_unix.(lockf fd F_TEST 0))
(fun () -> return_false)
(fun _ -> return_true))
(fun () -> Lwt_unix.close fd))
let get_pid fn =
let open Lwt_io in
protect (fun () ->
with_file ~mode:Input fn (fun ic ->
read ic >>= fun content -> return (int_of_string content)))
src/lib_stdlib_unix/lwt_lock_file.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Definition create_inner
(lock_command : Lwt_unix.lock_command) (op_staroptstar : option bool)
: (option bool) ->
string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
let close_on_exec :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun op_staroptstar =>
let unlink_on_exit :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun fn =>
protect None None
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_unix.openfile fn
(cons Unix.O_CREAT (cons Unix.O_WRONLY (cons Unix.O_TRUNC [])))
420)
(fun fd =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if close_on_exec then
Lwt_unix.set_close_on_exec fd
else
tt in
op_gtgteq (Lwt_unix.lockf fd lock_command 0)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if unlink_on_exit then
Lwt_main.at_exit
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_unix.unlink fn)
else
tt in
let pid_str :=
apply OCaml.Stdlib.string_of_int (Unix.getpid tt) in
op_gtgteq
(Lwt_unix.write_string fd pid_str 0
(OCaml.String.length pid_str))
(fun function_parameter =>
let '_ := function_parameter in
return_unit)))).
Definition create
: (option bool) ->
(option bool) ->
string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
create_inner Unix.F_TLOCK.
Definition blocking_create (timeout : option Z) (op_staroptstar : option bool)
: (option bool) ->
string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
let close_on_exec :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun op_staroptstar =>
let unlink_on_exit :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun fn =>
let create (function_parameter : unit)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
create_inner Unix.F_LOCK (Some close_on_exec) (Some unlink_on_exit) fn
in
match timeout with
| None => create tt
| Some duration =>
with_timeout None (Lwt_unix.sleep duration)
(fun function_parameter =>
let '_ := function_parameter in
create tt)
end.
Definition is_locked (fn : string)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult bool) :=
if apply negb (Sys.file_exists fn) then
return_false
else
protect None None
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_unix.openfile fn (cons Unix.O_RDONLY []) 420)
(fun fd =>
Lwt.finalize
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.try_bind
(fun function_parameter =>
let 'tt := function_parameter in
lockf fd Lwt_unix.F_TEST 0)
(fun function_parameter =>
let 'tt := function_parameter in
return_false)
(fun function_parameter =>
let '_ := function_parameter in
return_true))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_unix.close fd))).
Definition get_pid (fn : Lwt_io.file_name)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult Z) :=
protect None None
(fun function_parameter =>
let 'tt := function_parameter in
with_file None None None Lwt_io.Input fn
(fun ic =>
op_gtgteq (read None ic)
(fun content => _return (OCaml.Stdlib.int_of_string content)))).
src/lib_stdlib_unix/lwt_log_sink_unix.ml 67 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Lwt.Infix
module Output = struct
type t =
| Null
| Stdout
| Stderr
| File of string
| Syslog of Lwt_log.syslog_facility
let to_string : t -> string = function
| Null ->
"/dev/null"
| Stdout ->
"stdout"
| Stderr ->
"stderr"
| File fp ->
fp
| Syslog `Auth ->
"syslog:auth"
| Syslog `Authpriv ->
"syslog:authpriv"
| Syslog `Cron ->
"syslog:cron"
| Syslog `Daemon ->
"syslog:daemon"
| Syslog `FTP ->
"syslog:ftp"
| Syslog `Kernel ->
"syslog:kernel"
| Syslog `Local0 ->
"syslog:local0"
| Syslog `Local1 ->
"syslog:local1"
| Syslog `Local2 ->
"syslog:local2"
| Syslog `Local3 ->
"syslog:local3"
| Syslog `Local4 ->
"syslog:local4"
| Syslog `Local5 ->
"syslog:local5"
| Syslog `Local6 ->
"syslog:local6"
| Syslog `Local7 ->
"syslog:local7"
| Syslog `LPR ->
"syslog:lpr"
| Syslog `Mail ->
"syslog:mail"
| Syslog `News ->
"syslog:news"
| Syslog `Syslog ->
"syslog:syslog"
| Syslog `User ->
"syslog:user"
| Syslog `UUCP ->
"syslog:uucp"
| Syslog `NTP ->
"syslog:ntp"
| Syslog `Security ->
"syslog:security"
| Syslog `Console ->
"syslog:console"
let of_string : string -> t = function
| "/dev/null" | "null" ->
Null
| "stdout" ->
Stdout
| "stderr" ->
Stderr
| "syslog:auth" ->
Syslog `Auth
| "syslog:authpriv" ->
Syslog `Authpriv
| "syslog:cron" ->
Syslog `Cron
| "syslog:daemon" ->
Syslog `Daemon
| "syslog:ftp" ->
Syslog `FTP
| "syslog:kernel" ->
Syslog `Kernel
| "syslog:local0" ->
Syslog `Local0
| "syslog:local1" ->
Syslog `Local1
| "syslog:local2" ->
Syslog `Local2
| "syslog:local3" ->
Syslog `Local3
| "syslog:local4" ->
Syslog `Local4
| "syslog:local5" ->
Syslog `Local5
| "syslog:local6" ->
Syslog `Local6
| "syslog:local7" ->
Syslog `Local7
| "syslog:lpr" ->
Syslog `LPR
| "syslog:mail" ->
Syslog `Mail
| "syslog:news" ->
Syslog `News
| "syslog:syslog" ->
Syslog `Syslog
| "syslog:user" ->
Syslog `User
| "syslog:uucp" ->
Syslog `UUCP
| "syslog:ntp" ->
Syslog `NTP
| "syslog:security" ->
Syslog `Security
| "syslog:console" ->
Syslog `Console
(* | s when start_with "syslog:" FIXME error or warning. *)
| fp ->
(* TODO check absolute path *)
File fp
let encoding =
let open Data_encoding in
conv to_string of_string string
let of_string str =
try Some (Data_encoding.Json.destruct encoding (`String str))
with _ -> None
let to_string output =
match Data_encoding.Json.construct encoding output with
| `String res ->
res
| #Data_encoding.json ->
assert false
let pp fmt output = Format.fprintf fmt "%s" (to_string output)
end
let default_template = "$(date) - $(section): $(message)"
type cfg = {
output : Output.t;
default_level : Internal_event.level;
rules : string option;
template : Lwt_log_core.template;
}
let create_cfg ?(output = Output.Stderr)
?(default_level = Internal_event.Notice) ?rules
?(template = default_template) () =
{output; default_level; rules; template}
let default_cfg = create_cfg ()
let cfg_encoding =
let open Data_encoding in
conv
(fun {output; default_level; rules; template} ->
(output, default_level, rules, template))
(fun (output, default_level, rules, template) ->
{output; default_level; rules; template})
(obj4
(dft
"output"
~description:
"Output for the logging function. Either 'stdout', 'stderr' or \
the name of a log file ."
Output.encoding
default_cfg.output)
(dft
"level"
~description:
"Verbosity level: one of 'fatal', 'error', 'warn','notice', \
'info', 'debug'."
Internal_event.Level.encoding
default_cfg.default_level)
(opt
"rules"
~description:
"Fine-grained logging instructions. Same format as described in \
`tezos-node run --help`, DEBUG section. In the example below, \
sections 'p2p' and all sections starting by 'client' will have \
their messages logged up to the debug level, whereas the rest of \
log sections will be logged up to the notice level."
string)
(dft
"template"
~description:
"Format for the log file, see \
http://ocsigen.org/lwt/dev/api/Lwt_log_core#2_Logtemplates."
string
default_cfg.template))
let init ?(template = default_template) output =
let open Output in
( match output with
| Stderr ->
Lwt.return
@@ Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr ()
| Stdout ->
Lwt.return
@@ Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stdout ()
| File file_name ->
Lwt_log.file ~file_name ~template ()
| Null ->
Lwt.return @@ Lwt_log.null
| Syslog facility ->
Lwt.return @@ Lwt_log.syslog ~template ~facility () )
>>= fun logger ->
Lwt_log.default := logger ;
Lwt.return_unit
let find_log_rules default =
match Sys.(getenv_opt "TEZOS_LOG", getenv_opt "LWT_LOG") with
| (Some rules, None) ->
("environment variable TEZOS_LOG", Some rules)
| (None, Some rules) ->
("environment variable LWT_LOG", Some rules)
| (None, None) ->
("configuration file", default)
| (Some rules, Some _) ->
Format.eprintf
"@[<v 2>@{<warning>@{<title>Warning@}@} Both environment variables \
TEZOS_LOG and LWT_LOG defined, using TEZOS_LOG.@]@\n\
@." ;
("environment varible TEZOS_LOG", Some rules)
let initialize ?(cfg = default_cfg) () =
Lwt_log_core.add_rule "*" (Internal_event.Level.to_lwt_log cfg.default_level) ;
let (origin, rules) = find_log_rules cfg.rules in
( match rules with
| None ->
Lwt.return_unit
| Some rules -> (
try
Lwt_log_core.load_rules rules ~fail_on_error:true ;
Lwt.return_unit
with _ ->
Printf.ksprintf Lwt.fail_with "Incorrect log rules defined in %s" origin
) )
>>= fun () -> init ~template:cfg.template cfg.output
src/lib_stdlib_unix/lwt_log_sink_unix.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
Module Output.
Inductive t : Type :=
| Null : t
| Stdout : t
| Stderr : t
| File : string -> t
| Syslog : Lwt_log.syslog_facility -> t.
Definition to_string (function_parameter : t) : string :=
match function_parameter with
| Null => "/dev/null" % string
| Stdout => "stdout" % string
| Stderr => "stderr" % string
| File fp => fp
| Syslog Auth => "syslog:auth" % string
| Syslog Authpriv => "syslog:authpriv" % string
| Syslog Cron => "syslog:cron" % string
| Syslog Daemon => "syslog:daemon" % string
| Syslog FTP => "syslog:ftp" % string
| Syslog Kernel => "syslog:kernel" % string
| Syslog Local0 => "syslog:local0" % string
| Syslog Local1 => "syslog:local1" % string
| Syslog Local2 => "syslog:local2" % string
| Syslog Local3 => "syslog:local3" % string
| Syslog Local4 => "syslog:local4" % string
| Syslog Local5 => "syslog:local5" % string
| Syslog Local6 => "syslog:local6" % string
| Syslog Local7 => "syslog:local7" % string
| Syslog LPR => "syslog:lpr" % string
| Syslog Mail => "syslog:mail" % string
| Syslog News => "syslog:news" % string
| Syslog Syslog => "syslog:syslog" % string
| Syslog User => "syslog:user" % string
| Syslog UUCP => "syslog:uucp" % string
| Syslog NTP => "syslog:ntp" % string
| Syslog Security => "syslog:security" % string
| Syslog Console => "syslog:console" % string
end.
Definition of_string (function_parameter : string) : t :=
match function_parameter with
| "/dev/null" % string | "null" % string => Null
| "stdout" % string => Stdout
| "stderr" % string => Stderr
| "syslog:auth" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:authpriv" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:cron" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:daemon" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:ftp" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:kernel" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:local0" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:local1" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:local2" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:local3" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:local4" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:local5" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:local6" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:local7" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:lpr" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:mail" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:news" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:syslog" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:user" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:uucp" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:ntp" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:security" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| "syslog:console" % string =>
Syslog
(* ❌ Variants not supported *)
variant
| fp => File fp
end.
Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
conv to_string of_string None string.
Definition of_string (str : string) : option t :=
(* ❌ Try-with are not handled *)
try
(Some
(Data_encoding.Json.destruct encoding
(* ❌ Variants not supported *)
variant)).
Definition to_string (output : t) : string :=
match Data_encoding.Json.construct encoding output with
| String res => res
| Bool _ | Null | O _ | Float _ | String _ | A _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end.
Definition pp (fmt : Stdlib.Format.formatter) (output : t) : unit :=
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
(to_string output).
End Output.
Definition default_template : string :=
"$(date) - $(section): $(message)" % string.
Record cfg := {
output : Output.t;
default_level : Tezos_event_logging.Internal_event.level;
rules : option string;
template : Lwt_log_core.template }.
Definition create_cfg (op_staroptstar : option Output.t)
: (option Tezos_event_logging.Internal_event.level) ->
(option string) -> (option string) -> unit -> cfg :=
let output :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Output.Stderr
end in
fun op_staroptstar =>
let default_level :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Tezos_event_logging.Internal_event.Notice
end in
fun rules =>
fun op_staroptstar =>
let template :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_template
end in
fun function_parameter =>
let 'tt := function_parameter in
{| output := output; default_level := default_level; rules := rules;
template := template |}.
Definition default_cfg : cfg := create_cfg None None None None tt.
Definition cfg_encoding : Tezos_data_encoding.Data_encoding.encoding cfg :=
conv
(fun function_parameter =>
let '{|
output := output;
default_level := default_level;
rules := rules;
template := template
|} := function_parameter in
(output, default_level, rules, template))
(fun function_parameter =>
let '(output, default_level, rules, template) := function_parameter in
{| output := output; default_level := default_level; rules := rules;
template := template |}) None
(obj4
(dft None
(Some
"Output for the logging function. Either 'stdout', 'stderr' or the name of a log file ."
% string) "output" % string Output.encoding (output default_cfg))
(dft None
(Some
"Verbosity level: one of 'fatal', 'error', 'warn','notice', 'info', 'debug'."
% string) "level" % string Internal_event.Level.encoding
(default_level default_cfg))
(opt None
(Some
"Fine-grained logging instructions. Same format as described in `tezos-node run --help`, DEBUG section. In the example below, sections 'p2p' and all sections starting by 'client' will have their messages logged up to the debug level, whereas the rest of log sections will be logged up to the notice level."
% string) "rules" % string string)
(dft None
(Some
"Format for the log file, see http://ocsigen.org/lwt/dev/api/Lwt_log_core#2_Logtemplates."
% string) "template" % string string (template default_cfg))).
Definition init (op_staroptstar : option string) : Output.t -> Lwt.t unit :=
let template :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_template
end in
fun output =>
op_gtgteq
match output with
| Output.Stderr =>
apply Lwt._return
(Lwt_log.channel (Some template)
(* ❌ Variants not supported *)
variant Lwt_io.stderr tt)
| Output.Stdout =>
apply Lwt._return
(Lwt_log.channel (Some template)
(* ❌ Variants not supported *)
variant Lwt_io.stdout tt)
| Output.File file_name =>
Lwt_log.file (Some template) None None file_name tt
| Output.Null => apply Lwt._return Lwt_log.null
| Output.Syslog facility =>
apply Lwt._return (Lwt_log.syslog (Some template) None facility tt)
end
(fun logger =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq Lwt_log.default logger in
Lwt.return_unit).
Definition find_log_rules (default : option string)
: string * (option string) :=
match ((getenv_opt "TEZOS_LOG" % string), (getenv_opt "LWT_LOG" % string))
with
| (Some rules, None) =>
("environment variable TEZOS_LOG" % string, (Some rules))
| (None, Some rules) =>
("environment variable LWT_LOG" % string, (Some rules))
| (None, None) => ("configuration file" % string, default)
| (Some rules, Some _) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<warning>" % string
CamlinternalFormatBasics.End_of_format) "<warning>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_tag
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<title>" % string
CamlinternalFormatBasics.End_of_format) "<title>" % string))
(CamlinternalFormatBasics.String_literal "Warning" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_tag
(CamlinternalFormatBasics.String_literal
" Both environment variables TEZOS_LOG and LWT_LOG defined, using TEZOS_LOG."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))))
"@[<v 2>@{<warning>@{<title>Warning@}@} Both environment variables TEZOS_LOG and LWT_LOG defined, using TEZOS_LOG.@]@
@."
% string) in
("environment varible TEZOS_LOG" % string, (Some rules))
end.
Definition initialize (op_staroptstar : option cfg) : unit -> Lwt.t unit :=
let cfg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_cfg
end in
fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_log_core.add_rule "*" % string
(Internal_event.Level.to_lwt_log (default_level cfg)) in
let '(origin, rules) := find_log_rules (rules cfg) in
op_gtgteq
match rules with
| None => Lwt.return_unit
| Some rules =>
(* ❌ Try-with are not handled *)
try
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ := Lwt_log_core.load_rules (Some true) rules in
Lwt.return_unit)
end
(fun function_parameter =>
let 'tt := function_parameter in
init (Some (template cfg)) (output cfg)).
src/lib_stdlib_unix/lwt_utils_unix.ml 32 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Error_monad
let () =
register_error_kind
`Temporary
~id:"unix_error"
~title:"Unix error"
~description:"An unhandled unix exception"
~pp:Format.pp_print_string
Data_encoding.(obj1 (req "msg" string))
(function
| Exn (Unix.Unix_error (err, fn, _)) ->
Some ("Unix error in " ^ fn ^ ": " ^ Unix.error_message err)
| _ ->
None)
(fun msg -> Exn (Failure msg))
let read_bytes ?(pos = 0) ?len fd buf =
let len = match len with None -> Bytes.length buf - pos | Some l -> l in
let rec inner pos len =
if len = 0 then Lwt.return_unit
else
Lwt_unix.read fd buf pos len
>>= function
| 0 ->
Lwt.fail End_of_file
(* other endpoint cleanly closed its connection *)
| nb_read ->
inner (pos + nb_read) (len - nb_read)
in
inner pos len
let read_string ~len fd =
let b = Bytes.create len in
read_bytes fd b >>= fun () -> Lwt.return @@ Bytes.to_string b
let read_mbytes ?(pos = 0) ?len fd buf =
let len = match len with None -> Bytes.length buf - pos | Some l -> l in
let rec inner pos len =
if len = 0 then Lwt.return_unit
else
Lwt_unix.read fd buf pos len
>>= function
| 0 ->
Lwt.fail End_of_file
(* other endpoint cleanly closed its connection *)
| nb_read ->
inner (pos + nb_read) (len - nb_read)
in
inner pos len
let write_mbytes ?(pos = 0) ?len descr buf =
let len = match len with None -> Bytes.length buf - pos | Some l -> l in
let rec inner pos len =
if len = 0 then Lwt.return_unit
else
Lwt_unix.write descr buf pos len
>>= function
| 0 ->
Lwt.fail End_of_file
(* other endpoint cleanly closed its connection *)
| nb_written ->
inner (pos + nb_written) (len - nb_written)
in
inner pos len
let write_bytes ?(pos = 0) ?len descr buf =
let len = match len with None -> Bytes.length buf - pos | Some l -> l in
let rec inner pos len =
if len = 0 then Lwt.return_unit
else
Lwt_unix.write descr buf pos len
>>= function
| 0 ->
Lwt.fail End_of_file
(* other endpoint cleanly closed its connection *)
| nb_written ->
inner (pos + nb_written) (len - nb_written)
in
inner pos len
let write_string ?(pos = 0) ?len descr buf =
let len = match len with None -> String.length buf - pos | Some l -> l in
let rec inner pos len =
if len = 0 then Lwt.return_unit
else
Lwt_unix.write_string descr buf pos len
>>= function
| 0 ->
Lwt.fail End_of_file
(* other endpoint cleanly closed its connection *)
| nb_written ->
inner (pos + nb_written) (len - nb_written)
in
inner pos len
let ( >>= ) = Lwt.bind
let remove_dir dir =
let rec remove dir =
let files = Lwt_unix.files_of_directory dir in
Lwt_stream.iter_s
(fun file ->
if file = "." || file = ".." then Lwt.return_unit
else
let file = Filename.concat dir file in
if Sys.is_directory file then remove file else Lwt_unix.unlink file)
files
>>= fun () -> Lwt_unix.rmdir dir
in
if Sys.file_exists dir && Sys.is_directory dir then remove dir
else Lwt.return_unit
let rec create_dir ?(perm = 0o755) dir =
Lwt_unix.file_exists dir
>>= function
| false ->
create_dir (Filename.dirname dir)
>>= fun () ->
Lwt.catch
(fun () -> Lwt_unix.mkdir dir perm)
(function
| Unix.Unix_error (Unix.EEXIST, _, _) ->
(* This is the case where the directory has been created
by another Lwt.t, after the call to Lwt_unix.file_exists. *)
Lwt.return_unit
| e ->
Lwt.fail e)
| true -> (
Lwt_unix.stat dir
>>= function
| {st_kind = S_DIR; _} ->
Lwt.return_unit
| _ ->
Pervasives.failwith "Not a directory" )
let create_file ?(perm = 0o644) name content =
Lwt_unix.openfile name Unix.[O_TRUNC; O_CREAT; O_WRONLY] perm
>>= fun fd ->
Lwt_unix.write_string fd content 0 (String.length content)
>>= fun _ -> Lwt_unix.close fd
let read_file fn = Lwt_io.with_file fn ~mode:Input (fun ch -> Lwt_io.read ch)
let safe_close fd =
Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit)
let of_sockaddr = function
| Unix.ADDR_UNIX _ ->
None
| Unix.ADDR_INET (addr, port) -> (
match Ipaddr_unix.of_inet_addr addr with
| V4 addr ->
Some (Ipaddr.v6_of_v4 addr, port)
| V6 addr ->
Some (addr, port) )
let getaddrinfo ~passive ~node ~service =
let open Lwt_unix in
getaddrinfo
node
service
(AI_SOCKTYPE SOCK_STREAM :: (if passive then [AI_PASSIVE] else []))
>>= fun addr ->
let points =
TzList.filter_map (fun {ai_addr; _} -> of_sockaddr ai_addr) addr
in
Lwt.return points
let getpass () =
let open Unix in
(* Turn echoing off and fail if we can't. *)
let tio = tcgetattr stdin in
let old_echo = tio.c_echo in
let old_echonl = tio.c_echonl in
tio.c_echo <- false ;
tio.c_echonl <- true ;
tcsetattr stdin TCSAFLUSH tio ;
(* Read the passwd. *)
let passwd = read_line () in
(* Restore terminal. *)
tio.c_echo <- old_echo ;
tio.c_echonl <- old_echonl ;
tcsetattr stdin TCSAFLUSH tio ;
passwd
module Json = struct
let to_root = function
| `O ctns ->
`O ctns
| `A ctns ->
`A ctns
| `Null ->
`O []
| oth ->
`A [oth]
let write_file file json =
let json = to_root json in
protect (fun () ->
Lwt_io.with_file ~mode:Output file (fun chan ->
let str = Data_encoding.Json.to_string ~minify:false json in
Lwt_io.write chan str >>= fun _ -> return_unit))
let read_file file =
protect (fun () ->
Lwt_io.with_file ~mode:Input file (fun chan ->
Lwt_io.read chan
>>= fun str ->
return (Ezjsonm.from_string str :> Data_encoding.json)))
end
let with_tempdir name f =
let base_dir = Filename.temp_file name "" in
Lwt_unix.unlink base_dir
>>= fun () ->
Lwt_unix.mkdir base_dir 0o700
>>= fun () ->
Lwt.finalize (fun () -> f base_dir) (fun () -> remove_dir base_dir)
module Socket = struct
type addr =
| Unix of string
| Tcp of string * string * Unix.getaddrinfo_option list
let handle_litteral_ipv6 host =
(* To strip '[' and ']' when a litteral IPv6 is provided *)
match Ipaddr.of_string host with
| Error (`Msg _) ->
host
| Ok ipaddr ->
Ipaddr.to_string ipaddr
let connect ?(timeout = 5.) = function
| Unix path ->
let addr = Lwt_unix.ADDR_UNIX path in
let sock = Lwt_unix.socket PF_UNIX SOCK_STREAM 0 in
Lwt_unix.connect sock addr >>= fun () -> return sock
| Tcp (host, service, opts) -> (
let host = handle_litteral_ipv6 host in
Lwt_unix.getaddrinfo host service opts
>>= function
| [] ->
failwith "could not resolve host '%s'" host
| addrs ->
let rec try_connect acc = function
| [] ->
Lwt.return
(Error
( failure "could not connect to '%s'" host
:: List.rev acc ))
| {Unix.ai_family; ai_socktype; ai_protocol; ai_addr; _} :: addrs
-> (
let sock =
Lwt_unix.socket ai_family ai_socktype ai_protocol
in
protect
~on_error:(fun e ->
Lwt_unix.close sock >>= fun () -> Lwt.return_error e)
(fun () ->
with_timeout (Lwt_unix.sleep timeout) (fun _c ->
Lwt_unix.connect sock ai_addr
>>= fun () -> return sock))
>>= function
| Ok sock ->
return sock
| Error e ->
try_connect (e @ acc) addrs )
in
try_connect [] addrs )
let bind ?(backlog = 10) = function
| Unix path ->
let addr = Lwt_unix.ADDR_UNIX path in
let sock = Lwt_unix.socket PF_UNIX SOCK_STREAM 0 in
Lwt_unix.bind sock addr
>>= fun () ->
Lwt_unix.listen sock backlog ;
return [sock]
| Tcp (host, service, opts) -> (
Lwt_unix.getaddrinfo
(handle_litteral_ipv6 host)
service
(AI_PASSIVE :: opts)
>>= function
| [] ->
failwith "could not resolve host '%s'" host
| addrs ->
let do_bind {Unix.ai_family; ai_socktype; ai_protocol; ai_addr; _}
=
let sock = Lwt_unix.socket ai_family ai_socktype ai_protocol in
Lwt_unix.setsockopt sock SO_REUSEADDR true ;
Lwt_unix.bind sock ai_addr
>>= fun () ->
Lwt_unix.listen sock backlog ;
return sock
in
map_s do_bind addrs )
type error += Encoding_error | Decoding_error
let () =
register_error_kind
`Permanent
~id:"signer.encoding_error"
~title:"Encoding_error"
~description:"Error while encoding a remote signer message"
~pp:(fun ppf () ->
Format.fprintf ppf "Could not encode a remote signer message")
Data_encoding.empty
(function Encoding_error -> Some () | _ -> None)
(fun () -> Encoding_error) ;
register_error_kind
`Permanent
~id:"signer.decoding_error"
~title:"Decoding_error"
~description:"Error while decoding a remote signer message"
~pp:(fun ppf () ->
Format.fprintf ppf "Could not decode a remote signer message")
Data_encoding.empty
(function Decoding_error -> Some () | _ -> None)
(fun () -> Decoding_error)
let message_len_size = 2
let send fd encoding message =
let encoded_message_len = Data_encoding.Binary.length encoding message in
fail_unless
(encoded_message_len < 1 lsl (message_len_size * 8))
Encoding_error
>>=? fun () ->
(* len is the length of int16 plus the length of the message we want to send *)
let len = message_len_size + encoded_message_len in
let buf = Bytes.create len in
match
Data_encoding.Binary.write
encoding
message
buf
message_len_size
encoded_message_len
with
| None ->
fail Encoding_error
| Some last ->
fail_unless (last = len) Encoding_error
>>=? fun () ->
(* we set the beginning of the buf with the length of what is next *)
TzEndian.set_int16 buf 0 encoded_message_len ;
write_mbytes fd buf >>= fun () -> return_unit
let recv fd encoding =
let header_buf = Bytes.create message_len_size in
read_mbytes ~len:message_len_size fd header_buf
>>= fun () ->
let len = TzEndian.get_uint16 header_buf 0 in
let buf = Bytes.create len in
read_mbytes ~len fd buf
>>= fun () ->
match Data_encoding.Binary.read encoding buf 0 len with
| None ->
fail Decoding_error
| Some (read_len, message) ->
if read_len <> len then fail Decoding_error else return message
end
let rec retry ?(log = fun _ -> Lwt.return_unit) ?(n = 5) ?(sleep = 1.) f =
f ()
>>= function
| Ok r ->
Lwt.return_ok r
| Error error as x ->
if n > 0 then
log error
>>= fun () ->
Lwt_unix.sleep sleep >>= fun () -> retry ~log ~n:(n - 1) ~sleep f
else Lwt.return x
src/lib_stdlib_unix/lwt_utils_unix.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Error_monad.
Definition read_bytes (op_staroptstar : option Z)
: (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
let pos :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 0
end in
fun len =>
fun fd =>
fun buf =>
let len :=
match len with
| None => Z.sub (String.length buf) pos
| Some l => l
end in
let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
if equiv_decb len 0 then
Lwt.return_unit
else
op_gtgteq (Lwt_unix.read fd buf pos len)
(fun function_parameter =>
match function_parameter with
| 0 => Lwt.fail OCaml.End_of_file
| nb_read => inner (Z.add pos nb_read) (Z.sub len nb_read)
end) in
inner pos len.
Definition read_string (len : Z) (fd : Lwt_unix.file_descr) : Lwt.t string :=
let b := Stdlib.Bytes.create len in
op_gtgteq (read_bytes None None fd b)
(fun function_parameter =>
let 'tt := function_parameter in
apply Lwt._return (Stdlib.Bytes.to_string b)).
Definition read_mbytes (op_staroptstar : option Z)
: (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
let pos :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 0
end in
fun len =>
fun fd =>
fun buf =>
let len :=
match len with
| None => Z.sub (String.length buf) pos
| Some l => l
end in
let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
if equiv_decb len 0 then
Lwt.return_unit
else
op_gtgteq (Lwt_unix.read fd buf pos len)
(fun function_parameter =>
match function_parameter with
| 0 => Lwt.fail OCaml.End_of_file
| nb_read => inner (Z.add pos nb_read) (Z.sub len nb_read)
end) in
inner pos len.
Definition write_mbytes (op_staroptstar : option Z)
: (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
let pos :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 0
end in
fun len =>
fun descr =>
fun buf =>
let len :=
match len with
| None => Z.sub (String.length buf) pos
| Some l => l
end in
let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
if equiv_decb len 0 then
Lwt.return_unit
else
op_gtgteq (Lwt_unix.write descr buf pos len)
(fun function_parameter =>
match function_parameter with
| 0 => Lwt.fail OCaml.End_of_file
| nb_written =>
inner (Z.add pos nb_written) (Z.sub len nb_written)
end) in
inner pos len.
Definition write_bytes (op_staroptstar : option Z)
: (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
let pos :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 0
end in
fun len =>
fun descr =>
fun buf =>
let len :=
match len with
| None => Z.sub (String.length buf) pos
| Some l => l
end in
let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
if equiv_decb len 0 then
Lwt.return_unit
else
op_gtgteq (Lwt_unix.write descr buf pos len)
(fun function_parameter =>
match function_parameter with
| 0 => Lwt.fail OCaml.End_of_file
| nb_written =>
inner (Z.add pos nb_written) (Z.sub len nb_written)
end) in
inner pos len.
Definition write_string (op_staroptstar : option Z)
: (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
let pos :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 0
end in
fun len =>
fun descr =>
fun buf =>
let len :=
match len with
| None => Z.sub (OCaml.String.length buf) pos
| Some l => l
end in
let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
if equiv_decb len 0 then
Lwt.return_unit
else
op_gtgteq (Lwt_unix.write_string descr buf pos len)
(fun function_parameter =>
match function_parameter with
| 0 => Lwt.fail OCaml.End_of_file
| nb_written =>
inner (Z.add pos nb_written) (Z.sub len nb_written)
end) in
inner pos len.
Definition op_gtgteq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
Lwt.bind.
Definition remove_dir (dir : string) : Lwt.t unit :=
let fix remove (dir : string) : Lwt.t unit :=
let files := Lwt_unix.files_of_directory dir in
op_gtgteq
(Lwt_stream.iter_s
(fun file =>
if orb (equiv_decb file "." % string) (equiv_decb file ".." % string)
then
Lwt.return_unit
else
let file := Filename.concat dir file in
if Sys.is_directory file then
remove file
else
Lwt_unix.unlink file) files)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_unix.rmdir dir) in
if andb (Sys.file_exists dir) (Sys.is_directory dir) then
remove dir
else
Lwt.return_unit.
Fixpoint create_dir (op_staroptstar : option Z) : string -> Lwt.t unit :=
let perm :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 493
end in
fun dir =>
op_gtgteq (Lwt_unix.file_exists dir)
(fun function_parameter =>
match function_parameter with
| false =>
op_gtgteq (create_dir None (Filename.dirname dir))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_unix.mkdir dir perm)
(fun function_parameter =>
match function_parameter with
| Unix_error Unix.EEXIST _ _ => Lwt.return_unit
| e => Lwt.fail e
end))
| true =>
op_gtgteq (Lwt_unix.stat dir)
(fun function_parameter =>
match function_parameter with
| {| st_kind := Lwt_unix.S_DIR |} => Lwt.return_unit
| _ => Pervasives.failwith "Not a directory" % string
end)
end).
Definition create_file (op_staroptstar : option Lwt_unix.file_perm)
: string -> string -> Lwt.t unit :=
let perm :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 420
end in
fun name =>
fun content =>
op_gtgteq
(Lwt_unix.openfile name
(cons Unix.O_TRUNC (cons Unix.O_CREAT (cons Unix.O_WRONLY []))) perm)
(fun fd =>
op_gtgteq
(Lwt_unix.write_string fd content 0 (OCaml.String.length content))
(fun function_parameter =>
let '_ := function_parameter in
Lwt_unix.close fd)).
Definition read_file (fn : Lwt_io.file_name) : Lwt.t string :=
Lwt_io.with_file None None None Lwt_io.Input fn
(fun ch => Lwt_io.read None ch).
Definition safe_close (fd : Lwt_unix.file_descr) : Lwt.t unit :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_unix.close fd)
(fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit).
Definition of_sockaddr (function_parameter : Unix.sockaddr)
: option (Ipaddr.V6.t * Z) :=
match function_parameter with
| Unix.ADDR_UNIX _ => None
| Unix.ADDR_INET addr port =>
match Ipaddr_unix.of_inet_addr addr with
| Ipaddr.V4 addr => Some ((Ipaddr.v6_of_v4 addr), port)
| Ipaddr.V6 addr => Some (addr, port)
end
end.
Definition getaddrinfo (passive : bool) (node : string) (service : string)
: Lwt.t (list (Ipaddr.V6.t * Z)) :=
op_gtgteq
(getaddrinfo node service
(cons (Lwt_unix.AI_SOCKTYPE Lwt_unix.SOCK_STREAM)
(if passive then
cons Lwt_unix.AI_PASSIVE []
else
[])))
(fun addr =>
let points :=
TzList.filter_map
(fun function_parameter =>
let '{| ai_addr := ai_addr |} := function_parameter in
of_sockaddr ai_addr) addr in
Lwt._return points).
Definition getpass (function_parameter : unit) : string :=
let 'tt := function_parameter in
let tio := tcgetattr stdin in
let old_echo := c_echo tio in
let old_echonl := c_echonl tio in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field tio "c_echo" % string false in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field tio "c_echonl" % string true in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := tcsetattr stdin Unix.TCSAFLUSH tio in
let passwd := OCaml.Stdlib.read_line tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field tio "c_echo" % string old_echo in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field tio "c_echonl" % string old_echonl in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := tcsetattr stdin Unix.TCSAFLUSH tio in
passwd.
Module Json.
Definition to_root (function_parameter : variant) : variant :=
match function_parameter with
| O ctns =>
(* ❌ Variants not supported *)
variant
| A ctns =>
(* ❌ Variants not supported *)
variant
| Null =>
(* ❌ Variants not supported *)
variant
| oth =>
(* ❌ Variants not supported *)
variant
end.
Definition write_file (file : Lwt_io.file_name) (json : variant)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
let json := to_root json in
protect None None
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_io.with_file None None None Lwt_io.Output file
(fun chan =>
let str := Data_encoding.Json.to_string None (Some false) json in
op_gtgteq (Lwt_io.write chan str)
(fun function_parameter =>
let '_ := function_parameter in
return_unit))).
Definition read_file (file : Lwt_io.file_name)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
Tezos_data_encoding.Data_encoding.json) :=
protect None None
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_io.with_file None None None Lwt_io.Input file
(fun chan =>
op_gtgteq (Lwt_io.read None chan)
(fun str => _return (Ezjsonm.from_string str)))).
End Json.
Definition with_tempdir {A : Type} (name : string) (f : string -> Lwt.t A)
: Lwt.t A :=
let base_dir := Filename.temp_file None name "" % string in
op_gtgteq (Lwt_unix.unlink base_dir)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_unix.mkdir base_dir 448)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.finalize
(fun function_parameter =>
let 'tt := function_parameter in
f base_dir)
(fun function_parameter =>
let 'tt := function_parameter in
remove_dir base_dir))).
Module Socket.
Inductive addr : Type :=
| Unix : string -> addr
| Tcp : string -> string -> (list Unix.getaddrinfo_option) -> addr.
Definition handle_litteral_ipv6 (host : string) : string :=
match Ipaddr.of_string host with
| Stdlib.Error (Msg _) => host
| Stdlib.Ok ipaddr => Ipaddr.to_string ipaddr
end.
Definition connect (op_staroptstar : option Z)
: addr -> Lwt.t (Tezos_error_monad.Error_monad.tzresult Lwt_unix.file_descr) :=
let timeout :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Float constant 5. is approximated by the integer 5 *)
5
end in
fun function_parameter =>
match function_parameter with
| Unix path =>
let addr := Lwt_unix.ADDR_UNIX path in
let sock := Lwt_unix.socket Lwt_unix.PF_UNIX Lwt_unix.SOCK_STREAM 0 in
op_gtgteq (Lwt_unix.connect sock addr)
(fun function_parameter =>
let 'tt := function_parameter in
_return sock)
| Tcp host service opts =>
let host := handle_litteral_ipv6 host in
op_gtgteq (Lwt_unix.getaddrinfo host service opts)
(fun function_parameter =>
match function_parameter with
| [] =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"could not resolve host '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "'" % char
CamlinternalFormatBasics.End_of_format)))
"could not resolve host '%s'" % string) host
| addrs =>
let fix try_connect
(acc : list Tezos_error_monad.Error_monad.error)
(function_parameter : list Unix.addr_info)
: Lwt.t
(sum Lwt_unix.file_descr Tezos_error_monad.Error_monad.trace) :=
match function_parameter with
| [] =>
Lwt._return
(Stdlib.Error
(cons
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"could not connect to '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))
"could not connect to '%s'" % string) host)
(List.rev acc)))
|
cons {|
Unix.ai_family := ai_family;
Unix.ai_socktype := ai_socktype;
Unix.ai_protocol := ai_protocol;
Unix.ai_addr := ai_addr
|} addrs =>
let sock := Lwt_unix.socket ai_family ai_socktype ai_protocol
in
op_gtgteq
(protect
(Some
(fun e =>
op_gtgteq (Lwt_unix.close sock)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_error e))) None
(fun function_parameter =>
let 'tt := function_parameter in
with_timeout None (Lwt_unix.sleep timeout)
(fun _c =>
op_gtgteq (Lwt_unix.connect sock ai_addr)
(fun function_parameter =>
let 'tt := function_parameter in
_return sock))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok sock => _return sock
| Stdlib.Error e =>
try_connect (OCaml.Stdlib.app e acc) addrs
end)
end in
try_connect [] addrs
end)
end.
Definition bind (op_staroptstar : option Z)
: addr ->
Lwt.t (Tezos_error_monad.Error_monad.tzresult (list Lwt_unix.file_descr)) :=
let backlog :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 10
end in
fun function_parameter =>
match function_parameter with
| Unix path =>
let addr := Lwt_unix.ADDR_UNIX path in
let sock := Lwt_unix.socket Lwt_unix.PF_UNIX Lwt_unix.SOCK_STREAM 0 in
op_gtgteq (Lwt_unix.bind sock addr)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_unix.listen sock backlog in
_return (cons sock []))
| Tcp host service opts =>
op_gtgteq
(Lwt_unix.getaddrinfo (handle_litteral_ipv6 host) service
(cons Lwt_unix.AI_PASSIVE opts))
(fun function_parameter =>
match function_parameter with
| [] =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"could not resolve host '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "'" % char
CamlinternalFormatBasics.End_of_format)))
"could not resolve host '%s'" % string) host
| addrs =>
let do_bind (function_parameter : Unix.addr_info)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult Lwt_unix.file_descr) :=
let '{|
Unix.ai_family := ai_family;
Unix.ai_socktype := ai_socktype;
Unix.ai_protocol := ai_protocol;
Unix.ai_addr := ai_addr
|} := function_parameter in
let sock := Lwt_unix.socket ai_family ai_socktype ai_protocol in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_unix.setsockopt sock Lwt_unix.SO_REUSEADDR true in
op_gtgteq (Lwt_unix.bind sock ai_addr)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_unix.listen sock backlog in
_return sock) in
map_s do_bind addrs
end)
end.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition message_len_size : Z := 2.
Definition send {A : Type}
(fd : Lwt_unix.file_descr)
(encoding : Tezos_data_encoding__Data_encoding.Encoding.t A) (message : A)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
let encoded_message_len := Data_encoding.Binary.length encoding message in
op_gtgteqquestion
(fail_unless
(OCaml.Stdlib.lt encoded_message_len
(Z.shiftl 1 (Z.mul message_len_size 8)))
Tezos_error_monad.Error_monad.Encoding_error)
(fun function_parameter =>
let 'tt := function_parameter in
let len := Z.add message_len_size encoded_message_len in
let buf := Stdlib.Bytes.create len in
match
Data_encoding.Binary.write encoding message buf message_len_size
encoded_message_len with
| None => fail Tezos_error_monad.Error_monad.Encoding_error
| Some last =>
op_gtgteqquestion
(fail_unless (equiv_decb last len)
Tezos_error_monad.Error_monad.Encoding_error)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := TzEndian.set_int16 buf 0 encoded_message_len in
op_gtgteq (write_mbytes None None fd buf)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))
end).
Definition recv {A : Type}
(fd : Lwt_unix.file_descr)
(encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
: Lwt.t (Tezos_error_monad.Error_monad.tzresult A) :=
let header_buf := Stdlib.Bytes.create message_len_size in
op_gtgteq (read_mbytes None (Some message_len_size) fd header_buf)
(fun function_parameter =>
let 'tt := function_parameter in
let len := TzEndian.get_uint16 header_buf 0 in
let buf := Stdlib.Bytes.create len in
op_gtgteq (read_mbytes None (Some len) fd buf)
(fun function_parameter =>
let 'tt := function_parameter in
match Data_encoding.Binary.read encoding buf 0 len with
| None => fail Tezos_error_monad.Error_monad.Decoding_error
| Some (read_len, message) =>
if nequiv_decb read_len len then
fail Tezos_error_monad.Error_monad.Decoding_error
else
_return message
end)).
End Socket.
Fixpoint retry {A B : Type} (op_staroptstar : option (A -> Lwt.t unit))
: (option Z) ->
(option Z) -> (unit -> Lwt.t (sum B A)) -> Lwt.t (Result.result B A) :=
let log :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit
end in
fun op_staroptstar =>
let n :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 5
end in
fun op_staroptstar =>
let sleep :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Float constant 1. is approximated by the integer 1 *)
1
end in
fun f =>
op_gtgteq (f tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok r => Lwt.return_ok r
| (Stdlib.Error error) as x =>
if OCaml.Stdlib.gt n 0 then
op_gtgteq (log error)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_unix.sleep sleep)
(fun function_parameter =>
let 'tt := function_parameter in
retry (Some log) (Some (Z.sub n 1)) (Some sleep) f))
else
Lwt._return x
end).
src/lib_stdlib_unix/moving_average.ml 18 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Lwt.Infix
module Inttbl = Hashtbl.Make (struct
type t = int
let equal (x : int) (y : int) = x = y
let hash = Hashtbl.hash
end)
type t = {
id : int;
alpha : int;
mutable total : int64;
mutable current : int;
mutable average : int;
}
let counters = Inttbl.create 51
let updated = Lwt_condition.create ()
let update_hook = ref []
let on_update f = update_hook := f :: !update_hook
let worker_loop () =
let prev = ref @@ Mtime_clock.elapsed () in
let rec inner sleep =
sleep
>>= fun () ->
let sleep = Lwt_unix.sleep 1. in
let now = Mtime_clock.elapsed () in
let elapsed = int_of_float Mtime.Span.(to_ms now -. to_ms !prev) in
prev := now ;
Inttbl.iter
(fun _ c ->
c.average <-
(c.alpha * c.current / elapsed)
+ ((1000 - c.alpha) * c.average / 1000) ;
c.current <- 0)
counters ;
List.iter (fun f -> f ()) !update_hook ;
Lwt_condition.broadcast updated () ;
inner sleep
in
inner (Lwt_unix.sleep 1.)
let worker =
lazy
(Lwt.async (fun () ->
Lwt_utils.worker
"counter"
~on_event:Internal_event.Lwt_worker_event.on_event
~run:worker_loop
~cancel:(fun _ -> Lwt.return_unit)))
let create =
let cpt = ref 0 in
fun ~init ~alpha ->
Lazy.force worker ;
let id = !cpt in
incr cpt ;
assert (0. < alpha && alpha <= 1.) ;
let alpha = int_of_float (1000. *. alpha) in
let c = {id; alpha; total = 0L; current = 0; average = init} in
Inttbl.add counters id c ; c
let add c x =
c.total <- Int64.(add c.total (of_int x)) ;
c.current <- c.current + x
let destroy c = Inttbl.remove counters c.id
type stat = {total : int64; average : int}
let stat ({total; average; _} : t) : stat = {total; average}
src/lib_stdlib_unix/moving_average.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Lwt.Infix.
(* ❌ Applications of functors are not handled. *)
functor_application
Record t := {
id : Z;
alpha : Z;
total : int64;
current : Z;
average : Z }.
Definition counters : Inttbl.t t := Inttbl.create 51.
Definition updated : Lwt_condition.t unit := Lwt_condition.create tt.
Definition update_hook : Stdlib.ref (list (unit -> unit)) := Stdlib.ref [].
Definition on_update (f : unit -> unit) : unit :=
Stdlib.op_coloneq update_hook (cons f (Stdlib.op_exclamation update_hook)).
Definition worker_loop {A : Type} (function_parameter : unit) : Lwt.t A :=
let 'tt := function_parameter in
let prev := apply Stdlib.ref (Mtime_clock.elapsed tt) in
let fix inner {B : Type} (sleep : Lwt.t unit) : Lwt.t B :=
op_gtgteq sleep
(fun function_parameter =>
let 'tt := function_parameter in
let sleep :=
Lwt_unix.sleep
(* ❌ Float constant 1. is approximated by the integer 1 *)
1 in
let now := Mtime_clock.elapsed tt in
let elapsed :=
Stdlib.int_of_float
(Stdlib.op_minuspoint (to_ms now)
(to_ms (Stdlib.op_exclamation prev))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq prev now in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Inttbl.iter
(fun function_parameter =>
let '_ := function_parameter in
fun c =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field c "average" % string
(Z.add (Z.div (Z.mul (alpha c) (current c)) elapsed)
(Z.div (Z.mul (Z.sub 1000 (alpha c)) (average c)) 1000))
in
(* ❌ Set record field not handled. *)
set_record_field c "current" % string 0) counters in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.List.iter (fun f => f tt) (Stdlib.op_exclamation update_hook)
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_condition.broadcast updated tt in
inner sleep) in
inner
(Lwt_unix.sleep
(* ❌ Float constant 1. is approximated by the integer 1 *)
1).
Definition worker : lazy_t unit :=
(* ❌ Lazy expressions are not handled *)
lazy
(Lwt.async
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils.worker "counter" % string
Internal_event.Lwt_worker_event.on_event worker_loop
(fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit))).
Definition create : Z -> Z -> t :=
let cpt := Stdlib.ref 0 in
fun init =>
fun alpha =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lazy.force worker in
let id := Stdlib.op_exclamation cpt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.incr cpt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(andb
(OCaml.Stdlib.lt
(* ❌ Float constant 0. is approximated by the integer 0 *)
0 alpha)
(OCaml.Stdlib.le alpha
(* ❌ Float constant 1. is approximated by the integer 1 *)
1)) in
let alpha :=
Stdlib.int_of_float
(Stdlib.op_starpoint
(* ❌ Float constant 1000. is approximated by the integer 1000 *)
1000 alpha) in
let c :=
{| id := id; alpha := alpha;
total :=
(* ❌ Constant of type int64 is converted to int *)
0; current := 0; average := init |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Inttbl.add counters id c in
c.
Definition add (c : t) (x : Z) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field c "total" % string (add (total c) (of_int x)) in
(* ❌ Set record field not handled. *)
set_record_field c "current" % string (Z.add (current c) x).
Definition destroy (c : t) : unit := Inttbl.remove counters (id c).
Record stat := {
total : int64;
average : Z }.
Definition stat (function_parameter : t) : stat :=
let '{| total := total; average := average |} := function_parameter in
{| total := total; average := average |}.
src/lib_stdlib_unix/sys_info.ml 13 errors
(*****************************************************************************)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Memory
open Error_monad
type Error_monad.error += Unix_system_info_failure of string
let () =
Error_monad.register_error_kind
`Temporary
~id:"unix.system_info"
~title:"Unix System_info failure"
~description:"Unix System_info failure"
~pp:(fun ppf s ->
Format.fprintf ppf "@[<v 2>Unix system_info failure %s@]" s)
Data_encoding.(obj1 (req "failure" string))
(function Unix_system_info_failure s -> Some s | _ -> None)
(fun s -> Unix_system_info_failure s)
let error_info process error =
Unix_system_info_failure
(Format.asprintf "Unix_system_info_failure (%s: %s)" process error)
type sysname = Linux | Darwin | Unknown of string
let uname =
Lwt.catch
(fun () ->
Lwt_process.with_process_in
~env:[|"LC_ALL=C"|]
("uname", [|"uname"|])
(fun pc -> Lwt_io.read_line pc#stdout)
>>= function
| "Linux" ->
Lwt.return_ok Linux
| "Darwin" ->
Lwt.return_ok Darwin
| os ->
Lwt.return_ok (Unknown os))
(function
| exn -> Lwt.return_error (error_info "uname" (Printexc.to_string exn)))
let page_size () =
let get_conf_process =
uname
>>= function
| Ok Linux ->
Lwt.return_ok ("getconf", [|"getconf"; "PAGE_SIZE"|])
| Ok Darwin ->
Lwt.return_ok ("pagesize", [|"pagesize"|])
| Ok (Unknown _) ->
Lwt.return_error (error_info "pagesize" "Unknown unix system")
| Error (Unix_system_info_failure e) ->
Lwt.return_error (error_info "pagesize" e)
| Error e ->
Lwt.return_error e
in
get_conf_process
>>= function
| Error e ->
Lwt.return_error e
| Ok process ->
Lwt.catch
(fun () ->
Lwt_process.with_process_in process ~env:[|"LC_ALL=C"|] (fun pc ->
Lwt_io.read_line pc#stdout
>>= fun ps -> Lwt.return_ok (int_of_string ps)))
(function
| exn ->
Lwt.return_error (error_info "pagesize" (Printexc.to_string exn)))
let linux_statm pid =
Lwt.catch
(fun () ->
let fname = Format.asprintf "/proc/%d/statm" pid in
Lwt_unix.file_exists fname
>>= function
| true ->
Lwt_io.with_file ~mode:Input fname (fun ic ->
Lwt_io.read_line ic
>>= fun line ->
match List.map Int64.of_string @@ TzString.split ' ' line with
| size :: resident :: shared :: text :: lib :: data :: dt :: _
-> (
page_size ()
>>= function
| Error e ->
Lwt.return_error e
| Ok page_size ->
Lwt.return_ok
(Statm
{
page_size;
size;
resident;
shared;
text;
lib;
data;
dt;
}) )
| _ ->
Lwt.return_error
(error_info
"procfs statm"
"Unexpected proc/<pid>/statm format"))
| false ->
Lwt.return_error
(error_info "procfs statm" (Format.asprintf "%s not found" fname)))
(function
| exn ->
Lwt.return_error (error_info "procfs statm" (Printexc.to_string exn)))
let darwin_ps pid =
Lwt.catch
(fun () ->
Lwt_process.with_process_in
~env:[|"LC_ALL=C"|]
("ps", [|"ps"; "-o"; "pid,%mem,rss"; "-p"; string_of_int pid|])
(fun pc ->
Lwt_io.read_line_opt pc#stdout
>>= function
| None ->
Lwt.return_error
(error_info "ps" "Unexpected ps answer (1st line)")
| Some _ -> (
(* first line is useless *)
Lwt_io.read_line_opt pc#stdout
>>= function
| None ->
Lwt.return_error
(error_info "ps" "Unexpected ps answer (2nd line)")
| Some ps_stats -> (
match TzString.split ' ' ps_stats with
| _pid :: mem :: resident :: _ -> (
page_size ()
>>= function
| Error e ->
Lwt.return_error e
| Ok page_size ->
Lwt.return_ok
(Ps
{
page_size;
mem = float_of_string mem;
resident = Int64.of_string resident;
}) )
| _ ->
Lwt.return_error (error_info "ps" "Unexpected answer") ) )))
(function
| exn -> Lwt.return_error (error_info "ps" (Printexc.to_string exn)))
let memory_stats () =
let pid = Unix.getpid () in
uname
>>= function
| Error e ->
Lwt.return_error e
| Ok Linux ->
linux_statm pid
| Ok Darwin ->
darwin_ps pid
| _ ->
Lwt.return_error (error_info "memory_stats" "Unknown unix system")
src/lib_stdlib_unix/sys_info.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Memory.
Import Error_monad.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition error_info (process : string) (error : string)
: Tezos_error_monad.Error_monad.error :=
Tezos_error_monad.Error_monad.Unix_system_info_failure
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unix_system_info_failure (" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"Unix_system_info_failure (%s: %s)" % string) process error).
Inductive sysname : Type :=
| Linux : sysname
| Darwin : sysname
| Unknown : string -> sysname.
Definition uname
: Lwt.t (Result.result sysname Tezos_error_monad.Error_monad.error) :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt_process.with_process_in None
(Some
(* ❌ Arrays not handled. *)
[ "LC_ALL=C" % string ]) None None
("uname" % string,
(* ❌ Arrays not handled. *)
[ "uname" % string ])
(fun pc =>
Lwt_io.read_line
(* ❌ Sending method message is not handled *)
send))
(fun function_parameter =>
match function_parameter with
| "Linux" % string => Lwt.return_ok Linux
| "Darwin" % string => Lwt.return_ok Darwin
| os => Lwt.return_ok (Unknown os)
end))
(fun exn =>
Lwt.return_error (error_info "uname" % string (Printexc.to_string exn))).
Definition page_size (function_parameter : unit)
: Lwt.t (Result.result Z Tezos_error_monad.Error_monad.error) :=
let 'tt := function_parameter in
let get_conf_process :=
op_gtgteq uname
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok Linux =>
Lwt.return_ok
("getconf" % string,
(* ❌ Arrays not handled. *)
[ "getconf" % string; "PAGE_SIZE" % string ])
| Stdlib.Ok Darwin =>
Lwt.return_ok
("pagesize" % string,
(* ❌ Arrays not handled. *)
[ "pagesize" % string ])
| Stdlib.Ok (Unknown _) =>
Lwt.return_error
(error_info "pagesize" % string "Unknown unix system" % string)
|
Stdlib.Error
(Tezos_error_monad.Error_monad.Unix_system_info_failure e) =>
Lwt.return_error (error_info "pagesize" % string e)
| Stdlib.Error e => Lwt.return_error e
end) in
op_gtgteq get_conf_process
(fun function_parameter =>
match function_parameter with
| Stdlib.Error e => Lwt.return_error e
| Stdlib.Ok process =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_process.with_process_in None
(Some
(* ❌ Arrays not handled. *)
[ "LC_ALL=C" % string ]) None None process
(fun pc =>
op_gtgteq
(Lwt_io.read_line
(* ❌ Sending method message is not handled *)
send)
(fun ps => Lwt.return_ok (OCaml.Stdlib.int_of_string ps))))
(fun exn =>
Lwt.return_error
(error_info "pagesize" % string (Printexc.to_string exn)))
end).
Definition linux_statm (pid : Z)
: Lwt.t
(Result.result Tezos_stdlib.Memory.mem_stats
Tezos_error_monad.Error_monad.error) :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
let fname :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "/proc/" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal "/statm" % string
CamlinternalFormatBasics.End_of_format)))
"/proc/%d/statm" % string) pid in
op_gtgteq (Lwt_unix.file_exists fname)
(fun function_parameter =>
match function_parameter with
| true =>
Lwt_io.with_file None None None Lwt_io.Input fname
(fun ic =>
op_gtgteq (Lwt_io.read_line ic)
(fun line =>
match
apply (List.map Int64.of_string)
(TzString.split " " % char None None line) with
|
cons size
(cons resident
(cons shared
(cons text (cons lib (cons data (cons dt _)))))) =>
op_gtgteq (page_size tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error e => Lwt.return_error e
| Stdlib.Ok page_size =>
Lwt.return_ok
(Tezos_stdlib.Memory.Statm
{| page_size := page_size; size := size;
resident := resident; shared := shared;
text := text; lib := lib; data := data;
dt := dt |})
end)
| _ =>
Lwt.return_error
(error_info "procfs statm" % string
"Unexpected proc/<pid>/statm format" % string)
end))
| false =>
Lwt.return_error
(error_info "procfs statm" % string
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" not found" % string
CamlinternalFormatBasics.End_of_format))
"%s not found" % string) fname))
end))
(fun exn =>
Lwt.return_error
(error_info "procfs statm" % string (Printexc.to_string exn))).
Definition darwin_ps (pid : Z)
: Lwt.t
(Result.result Tezos_stdlib.Memory.mem_stats
Tezos_error_monad.Error_monad.error) :=
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_process.with_process_in None
(Some
(* ❌ Arrays not handled. *)
[ "LC_ALL=C" % string ]) None None
("ps" % string,
(* ❌ Arrays not handled. *)
[
"ps" % string;
"-o" % string;
"pid,%mem,rss" % string;
"-p" % string;
OCaml.Stdlib.string_of_int pid
])
(fun pc =>
op_gtgteq
(Lwt_io.read_line_opt
(* ❌ Sending method message is not handled *)
send)
(fun function_parameter =>
match function_parameter with
| None =>
Lwt.return_error
(error_info "ps" % string
"Unexpected ps answer (1st line)" % string)
| Some _ =>
op_gtgteq
(Lwt_io.read_line_opt
(* ❌ Sending method message is not handled *)
send)
(fun function_parameter =>
match function_parameter with
| None =>
Lwt.return_error
(error_info "ps" % string
"Unexpected ps answer (2nd line)" % string)
| Some ps_stats =>
match TzString.split " " % char None None ps_stats with
| cons _pid (cons mem (cons resident _)) =>
op_gtgteq (page_size tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error e => Lwt.return_error e
| Stdlib.Ok page_size =>
Lwt.return_ok
(Tezos_stdlib.Memory.Ps
{| page_size := page_size;
mem := Stdlib.float_of_string mem;
resident := Int64.of_string resident |})
end)
| _ =>
Lwt.return_error
(error_info "ps" % string "Unexpected answer" % string)
end
end)
end)))
(fun exn =>
Lwt.return_error (error_info "ps" % string (Printexc.to_string exn))).
Definition memory_stats (function_parameter : unit)
: Lwt.t
(Result.result Tezos_stdlib.Memory.mem_stats
Tezos_error_monad.Error_monad.error) :=
let 'tt := function_parameter in
let pid := Unix.getpid tt in
op_gtgteq uname
(fun function_parameter =>
match function_parameter with
| Stdlib.Error e => Lwt.return_error e
| Stdlib.Ok Linux => linux_statm pid
| Stdlib.Ok Darwin => darwin_ps pid
| _ =>
Lwt.return_error
(error_info "memory_stats" % string "Unknown unix system" % string)
end).
src/lib_stdlib_unix/systime_os.ml success
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) let now () = Ptime_clock.now () let sleep s = Lwt_unix.sleep (Ptime.Span.to_float_s s)
src/lib_stdlib_unix/systime_os.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. Definition now (function_parameter : unit) : Ptime.t := let 'tt := function_parameter in Ptime_clock.now tt. Definition sleep (s : Ptime.span) : Lwt.t unit := Lwt_unix.sleep (Ptime.Span.to_float_s s).
src/lib_stdlib_unix/utils.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let hide_progress_line s =
let len = String.length s in
if len > 0 then Printf.eprintf "\r%*s\r" len ""
let display_progress ?(refresh_rate = (1, 1)) fmt =
let prnt s =
if Unix.isatty Unix.stderr then
let (index, rate) = refresh_rate in
if index mod rate == 0 then (
hide_progress_line s ; Format.eprintf "%s%!" s )
in
Format.kasprintf prnt fmt
let display_progress_end () =
if Unix.isatty Unix.stderr then Format.eprintf "@."
src/lib_stdlib_unix/utils.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition hide_progress_line (s : string) : unit :=
let len := OCaml.String.length s in
if OCaml.Stdlib.gt len 0 then
Printf.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "013" % char
(CamlinternalFormatBasics.String
(CamlinternalFormatBasics.Arg_padding CamlinternalFormatBasics.Right)
(CamlinternalFormatBasics.Char_literal "013" % char
CamlinternalFormatBasics.End_of_format))) "
%*s
" % string) len
"" % string
else
tt.
Definition display_progress {A : Type} (op_staroptstar : option (Z * Z))
: (Stdlib.format4 A Stdlib.Format.formatter unit unit) -> A :=
let refresh_rate :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => (1, 1)
end in
fun fmt =>
let prnt (s : string) : unit :=
if Unix.isatty Unix.stderr then
let '(index, rate) := refresh_rate in
if Stdlib.op_eqeq (Z.modulo index rate) 0 then
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := hide_progress_line s in
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format)) "%s%!" % string) s
else
tt
else
tt in
Format.kasprintf prnt fmt.
Definition display_progress_end (function_parameter : unit) : unit :=
let 'tt := function_parameter in
if Unix.isatty Unix.stderr then
Format.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format) "@." % string)
else
tt.
src/lib_storage/context_dump.ml 17 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let current_version = "tezos-snapshot-1.0.0"
(*****************************************************************************)
module type Dump_interface = sig
type index
type context
type tree
type hash
type step = string
type key = step list
type commit_info
type batch
val batch : index -> (batch -> 'a Lwt.t) -> 'a Lwt.t
val commit_info_encoding : commit_info Data_encoding.t
val hash_encoding : hash Data_encoding.t
module Block_header : sig
type t = Block_header.t
val to_bytes : t -> Bytes.t
val of_bytes : Bytes.t -> t option
val equal : t -> t -> bool
val encoding : t Data_encoding.t
end
module Pruned_block : sig
type t
val to_bytes : t -> Bytes.t
val of_bytes : Bytes.t -> t option
val header : t -> Block_header.t
val encoding : t Data_encoding.t
end
module Block_data : sig
type t
val to_bytes : t -> Bytes.t
val of_bytes : Bytes.t -> t option
val header : t -> Block_header.t
val encoding : t Data_encoding.t
end
module Protocol_data : sig
type t
val to_bytes : t -> Bytes.t
val of_bytes : Bytes.t -> t option
val encoding : t Data_encoding.t
end
module Commit_hash : sig
type t
val to_bytes : t -> Bytes.t
val of_bytes : Bytes.t -> t tzresult
val encoding : t Data_encoding.t
end
(* commit manipulation (for parents) *)
val context_parents : context -> Commit_hash.t list
(* Commit info *)
val context_info : context -> commit_info
(* block header manipulation *)
val get_context : index -> Block_header.t -> context option Lwt.t
val set_context :
info:commit_info ->
parents:Commit_hash.t list ->
context ->
Block_header.t ->
Block_header.t option Lwt.t
(* for dumping *)
val context_tree : context -> tree
val tree_hash : tree -> hash
val sub_tree : tree -> key -> tree option Lwt.t
val tree_list : tree -> (step * [`Contents | `Node]) list Lwt.t
val tree_content : tree -> string option Lwt.t
(* for restoring *)
val make_context : index -> context
val update_context : context -> tree -> context
val add_string : batch -> string -> tree Lwt.t
val add_dir : batch -> (step * hash) list -> tree option Lwt.t
end
module type S = sig
type index
type context
type block_header
type block_data
type pruned_block
type protocol_data
val dump_contexts_fd :
index ->
block_header
* block_data
* History_mode.t
* (block_header ->
(pruned_block option * protocol_data option) tzresult Lwt.t) ->
fd:Lwt_unix.file_descr ->
unit tzresult Lwt.t
val restore_contexts_fd :
index ->
fd:Lwt_unix.file_descr ->
((Block_hash.t * pruned_block) list -> unit tzresult Lwt.t) ->
(block_header option ->
Block_hash.t ->
pruned_block ->
unit tzresult Lwt.t) ->
( block_header
* block_data
* History_mode.t
* Block_header.t option
* Block_hash.t list
* protocol_data list )
tzresult
Lwt.t
end
type error += System_write_error of string
type error += Bad_hash of string * Bytes.t * Bytes.t
type error += Context_not_found of Bytes.t
type error += System_read_error of string
type error += Inconsistent_snapshot_file
type error += Inconsistent_snapshot_data
type error += Missing_snapshot_data
type error += Invalid_snapshot_version of string * string
type error += Restore_context_failure
let () =
let open Data_encoding in
register_error_kind
`Permanent
~id:"Writing_error"
~title:"Writing error"
~description:"Cannot write in file for context dump"
~pp:(fun ppf s ->
Format.fprintf ppf "Unable to write file for context dumping: %s" s)
(obj1 (req "context_dump_no_space" string))
(function System_write_error s -> Some s | _ -> None)
(fun s -> System_write_error s) ;
register_error_kind
`Permanent
~id:"Bad_hash"
~title:"Bad hash"
~description:"Wrong hash given"
~pp:(fun ppf (ty, his, hshould) ->
Format.fprintf
ppf
"Wrong hash [%s] given: %s, should be %s"
ty
(Bytes.to_string his)
(Bytes.to_string hshould))
(obj3
(req "hash_ty" string)
(req "hash_is" bytes)
(req "hash_should" bytes))
(function
| Bad_hash (ty, his, hshould) -> Some (ty, his, hshould) | _ -> None)
(fun (ty, his, hshould) -> Bad_hash (ty, his, hshould)) ;
register_error_kind
`Permanent
~id:"Context_not_found"
~title:"Context not found"
~description:"Cannot find context corresponding to hash"
~pp:(fun ppf mb ->
Format.fprintf ppf "No context with hash: %s" (Bytes.to_string mb))
(obj1 (req "context_not_found" bytes))
(function Context_not_found mb -> Some mb | _ -> None)
(fun mb -> Context_not_found mb) ;
register_error_kind
`Permanent
~id:"System_read_error"
~title:"System read error"
~description:"Failed to read file"
~pp:(fun ppf uerr ->
Format.fprintf
ppf
"Error while reading file for context dumping: %s"
uerr)
(obj1 (req "system_read_error" string))
(function System_read_error e -> Some e | _ -> None)
(fun e -> System_read_error e) ;
register_error_kind
`Permanent
~id:"Inconsistent_snapshot_file"
~title:"Inconsistent snapshot file"
~description:"Error while opening snapshot file"
~pp:(fun ppf () ->
Format.fprintf
ppf
"Failed to read snapshot file. The provided file is inconsistent.")
empty
(function Inconsistent_snapshot_file -> Some () | _ -> None)
(fun () -> Inconsistent_snapshot_file) ;
register_error_kind
`Permanent
~id:"Inconsistent_snapshot_data"
~title:"Inconsistent snapshot data"
~description:"The data provided by the snapshot is inconsistent"
~pp:(fun ppf () ->
Format.fprintf
ppf
"The data provided by the snapshot file is inconsistent (context_hash \
does not correspond for block).")
empty
(function Inconsistent_snapshot_data -> Some () | _ -> None)
(fun () -> Inconsistent_snapshot_data) ;
register_error_kind
`Permanent
~id:"Missing_snapshot_data"
~title:"Missing data in imported snapshot"
~description:"Mandatory data missing while reaching end of snapshot file."
~pp:(fun ppf () ->
Format.fprintf
ppf
"Mandatory data is missing is the provided snapshot file.")
empty
(function Missing_snapshot_data -> Some () | _ -> None)
(fun () -> Missing_snapshot_data) ;
register_error_kind
`Permanent
~id:"Invalid_snapshot_version"
~title:"Invalid snapshot version"
~description:"The version of the snapshot to import is not valid"
~pp:(fun ppf (found, expected) ->
Format.fprintf
ppf
"The snapshot to import has version \"%s\" but \"%s\" was expected."
found
expected)
(obj2 (req "found" string) (req "expected" string))
(function
| Invalid_snapshot_version (found, expected) ->
Some (found, expected)
| _ ->
None)
(fun (found, expected) -> Invalid_snapshot_version (found, expected)) ;
register_error_kind
`Permanent
~id:"Restore_context_failure"
~title:"Failed to restore context"
~description:"Internal error while restoring the context"
~pp:(fun ppf () ->
Format.fprintf ppf "Internal error while restoring the context.")
empty
(function Restore_context_failure -> Some () | _ -> None)
(fun () -> Restore_context_failure)
module Make (I : Dump_interface) = struct
type command =
| Root of {
block_header : I.Block_header.t;
info : I.commit_info;
parents : I.Commit_hash.t list;
block_data : I.Block_data.t;
}
| Node of (string * I.hash) list
| Blob of string
| Proot of I.Pruned_block.t
| Loot of I.Protocol_data.t
| End
(* Command encoding. *)
let blob_encoding =
let open Data_encoding in
case
~title:"blob"
(Tag (Char.code 'b'))
string
(function Blob string -> Some string | _ -> None)
(function string -> Blob string)
let node_encoding =
let open Data_encoding in
case
~title:"node"
(Tag (Char.code 'd'))
(list (obj2 (req "name" string) (req "hash" I.hash_encoding)))
(function Node x -> Some x | _ -> None)
(function x -> Node x)
let end_encoding =
let open Data_encoding in
case
~title:"end"
(Tag (Char.code 'e'))
empty
(function End -> Some () | _ -> None)
(fun () -> End)
let loot_encoding =
let open Data_encoding in
case
~title:"loot"
(Tag (Char.code 'l'))
I.Protocol_data.encoding
(function Loot protocol_data -> Some protocol_data | _ -> None)
(fun protocol_data -> Loot protocol_data)
let proot_encoding =
let open Data_encoding in
case
~title:"proot"
(Tag (Char.code 'p'))
(obj1 (req "pruned_block" I.Pruned_block.encoding))
(function Proot pruned_block -> Some pruned_block | _ -> None)
(fun pruned_block -> Proot pruned_block)
let root_encoding =
let open Data_encoding in
case
~title:"root"
(Tag (Char.code 'r'))
(obj4
(req "block_header" (dynamic_size I.Block_header.encoding))
(req "info" I.commit_info_encoding)
(req "parents" (list I.Commit_hash.encoding))
(req "block_data" I.Block_data.encoding))
(function
| Root {block_header; info; parents; block_data} ->
Some (block_header, info, parents, block_data)
| _ ->
None)
(fun (block_header, info, parents, block_data) ->
Root {block_header; info; parents; block_data})
let command_encoding =
Data_encoding.union
~tag_size:`Uint8
[ blob_encoding;
node_encoding;
end_encoding;
loot_encoding;
proot_encoding;
root_encoding ]
(* IO toolkit. *)
let rec read_string rbuf ~len =
let (fd, buf, ofs, total) = !rbuf in
if Bytes.length buf - ofs < len then (
let blen = Bytes.length buf - ofs in
let neu = Bytes.create (blen + 1_000_000) in
Bytes.blit buf ofs neu 0 blen ;
Lwt_unix.read fd neu blen 1_000_000
>>= fun bread ->
total := !total + bread ;
if bread = 0 then fail Inconsistent_snapshot_file
else
let neu =
if bread <> 1_000_000 then Bytes.sub neu 0 (blen + bread) else neu
in
rbuf := (fd, neu, 0, total) ;
read_string rbuf ~len )
else
let res = Bytes.sub_string buf ofs len in
rbuf := (fd, buf, ofs + len, total) ;
return res
let read_mbytes rbuf b =
read_string rbuf ~len:(Bytes.length b)
>>=? fun string ->
Bytes.blit_string string 0 b 0 (Bytes.length b) ;
return ()
let set_int64 buf i =
let b = Bytes.create 8 in
EndianBytes.BigEndian.set_int64 b 0 i ;
Buffer.add_bytes buf b
let get_int64 rbuf =
read_string ~len:8 rbuf
>>=? fun s -> return @@ EndianString.BigEndian.get_int64 s 0
let set_mbytes buf b =
set_int64 buf (Int64.of_int (Bytes.length b)) ;
Buffer.add_bytes buf b
let get_mbytes rbuf =
get_int64 rbuf >>|? Int64.to_int
>>=? fun l ->
let b = Bytes.create l in
read_mbytes rbuf b >>=? fun () -> return b
(* Getter and setters *)
let get_command rbuf =
get_mbytes rbuf
>>|? fun bytes -> Data_encoding.Binary.of_bytes_exn command_encoding bytes
let set_root buf block_header info parents block_data =
let root = Root {block_header; info; parents; block_data} in
let bytes = Data_encoding.Binary.to_bytes_exn command_encoding root in
set_mbytes buf bytes
let set_node buf contents =
let bytes =
Data_encoding.Binary.to_bytes_exn command_encoding (Node contents)
in
set_mbytes buf bytes
let set_blob buf data =
let bytes =
Data_encoding.Binary.to_bytes_exn command_encoding (Blob data)
in
set_mbytes buf bytes
let set_proot buf pruned_block =
let proot = Proot pruned_block in
let bytes = Data_encoding.Binary.to_bytes_exn command_encoding proot in
set_mbytes buf bytes
let set_loot buf protocol_data =
let loot = Loot protocol_data in
let bytes = Data_encoding.Binary.to_bytes_exn command_encoding loot in
set_mbytes buf bytes
let set_end buf =
let bytes = Data_encoding.Binary.to_bytes_exn command_encoding End in
set_mbytes buf bytes
(* Snapshot metadata *)
(* TODO add more info (e.g. nb context item, nb blocks, etc.) *)
type snapshot_metadata = {
version : string;
mode : Tezos_shell_services.History_mode.t;
}
let snapshot_metadata_encoding =
let open Data_encoding in
conv
(fun {version; mode} -> (version, mode))
(fun (version, mode) -> {version; mode})
(obj2
(req "version" string)
(req "mode" Tezos_shell_services.History_mode.encoding))
let write_snapshot_metadata ~mode buf =
let version = {version = current_version; mode} in
let bytes =
Data_encoding.(Binary.to_bytes_exn snapshot_metadata_encoding version)
in
set_mbytes buf bytes
let read_snapshot_metadata rbuf =
get_mbytes rbuf
>>|? fun bytes ->
Data_encoding.(Binary.of_bytes_exn snapshot_metadata_encoding) bytes
let check_version v =
fail_when
(v.version <> current_version)
(Invalid_snapshot_version (v.version, current_version))
let dump_contexts_fd idx data ~fd =
(* Dumping *)
let buf = Buffer.create 1_000_000 in
let written = ref 0 in
let flush () =
let contents = Buffer.contents buf in
Buffer.clear buf ;
written := !written + String.length contents ;
Lwt_utils_unix.write_string fd contents
in
let maybe_flush () =
if Buffer.length buf > 1_000_000 then flush () else Lwt.return_unit
in
(* Noting the visited hashes *)
let visited_hash = Hashtbl.create 1000 in
let visited h = Hashtbl.mem visited_hash h in
let set_visit h = Hashtbl.add visited_hash h () in
(* Folding through a node *)
let fold_tree_path ctxt tree =
let cpt = ref 0 in
let rec fold_tree_path ctxt tree =
I.tree_list tree
>>= fun keys ->
let keys = List.sort (fun (a, _) (b, _) -> String.compare a b) keys in
Lwt_list.map_s
(fun (name, kind) ->
I.sub_tree tree [name]
>>= function
| None ->
assert false
| Some sub_tree ->
let hash = I.tree_hash sub_tree in
( if visited hash then Lwt.return_unit
else (
Tezos_stdlib_unix.Utils.display_progress
~refresh_rate:(!cpt, 1_000)
"Context: %dK elements, %dMiB written%!"
(!cpt / 1_000)
(!written / 1_048_576) ;
incr cpt ;
set_visit hash ;
(* There cannot be a cycle *)
match kind with
| `Node ->
fold_tree_path ctxt sub_tree
| `Contents -> (
I.tree_content sub_tree
>>= function
| None ->
assert false
| Some data ->
set_blob buf data ; maybe_flush () ) ) )
>|= fun () -> (name, hash))
keys
>>= fun sub_keys -> set_node buf sub_keys ; maybe_flush ()
in
fold_tree_path ctxt tree
in
Lwt.catch
(fun () ->
let (bh, block_data, mode, pruned_iterator) = data in
write_snapshot_metadata ~mode buf ;
I.get_context idx bh
>>= function
| None ->
fail @@ Context_not_found (I.Block_header.to_bytes bh)
| Some ctxt ->
let tree = I.context_tree ctxt in
fold_tree_path ctxt tree
>>= fun () ->
Tezos_stdlib_unix.Utils.display_progress_end () ;
let parents = I.context_parents ctxt in
set_root buf bh (I.context_info ctxt) parents block_data ;
(* Dump pruned blocks *)
let dump_pruned cpt pruned =
Tezos_stdlib_unix.Utils.display_progress
~refresh_rate:(cpt, 1_000)
"History: %dK block, %dMiB written"
(cpt / 1_000)
(!written / 1_048_576) ;
set_proot buf pruned ;
maybe_flush ()
in
let rec aux cpt acc header =
pruned_iterator header
>>=? function
| (None, None) ->
return acc (* assert false *)
| (None, Some protocol_data) ->
return (protocol_data :: acc)
| (Some pred_pruned, Some protocol_data) ->
dump_pruned cpt pred_pruned
>>= fun () ->
aux
(succ cpt)
(protocol_data :: acc)
(I.Pruned_block.header pred_pruned)
| (Some pred_pruned, None) ->
dump_pruned cpt pred_pruned
>>= fun () ->
aux (succ cpt) acc (I.Pruned_block.header pred_pruned)
in
let starting_block_header = I.Block_data.header block_data in
aux 0 [] starting_block_header
>>=? fun protocol_datas ->
(* Dump protocol data *)
Lwt_list.iter_s
(fun proto -> set_loot buf proto ; maybe_flush ())
protocol_datas
>>= fun () ->
Tezos_stdlib_unix.Utils.display_progress_end () ;
return_unit
>>=? fun () ->
set_end buf ;
flush () >>= fun () -> return_unit)
(function
| Unix.Unix_error (e, _, _) ->
fail @@ System_write_error (Unix.error_message e)
| err ->
Lwt.fail err)
(* Restoring *)
let restore_contexts_fd index ~fd k_store_pruned_blocks block_validation =
let read = ref 0 in
let rbuf = ref (fd, Bytes.empty, 0, read) in
(* Editing the repository *)
let add_blob t blob = I.add_string t blob >>= fun tree -> return tree in
let add_dir t keys =
I.add_dir t keys
>>= function
| None -> fail Restore_context_failure | Some tree -> return tree
in
let restore history_mode =
let rec first_pass batch ctxt cpt =
Tezos_stdlib_unix.Utils.display_progress
~refresh_rate:(cpt, 1_000)
"Context: %dK elements, %dMiB read"
(cpt / 1_000)
(!read / 1_048_576) ;
get_command rbuf
>>=? function
| Root {block_header; info; parents; block_data} -> (
I.set_context ~info ~parents ctxt block_header
>>= function
| None ->
fail Inconsistent_snapshot_data
| Some block_header ->
return (block_header, block_data) )
| Node contents ->
add_dir batch contents
>>=? fun tree ->
first_pass batch (I.update_context ctxt tree) (cpt + 1)
| Blob data ->
add_blob batch data
>>=? fun tree ->
first_pass batch (I.update_context ctxt tree) (cpt + 1)
| _ ->
fail Inconsistent_snapshot_data
in
let rec second_pass pred_header (rev_block_hashes, protocol_datas) todo
cpt =
Tezos_stdlib_unix.Utils.display_progress
~refresh_rate:(cpt, 1_000)
"Store: %dK elements, %dMiB read"
(cpt / 1_000)
(!read / 1_048_576) ;
get_command rbuf
>>=? function
| Proot pruned_block ->
let header = I.Pruned_block.header pruned_block in
let hash = Block_header.hash header in
block_validation pred_header hash pruned_block
>>=? fun () ->
if (cpt + 1) mod 5_000 = 0 then
k_store_pruned_blocks ((hash, pruned_block) :: todo)
>>=? fun () ->
second_pass
(Some header)
(hash :: rev_block_hashes, protocol_datas)
[]
(cpt + 1)
else
second_pass
(Some header)
(hash :: rev_block_hashes, protocol_datas)
((hash, pruned_block) :: todo)
(cpt + 1)
| Loot protocol_data ->
k_store_pruned_blocks todo
>>=? fun () ->
second_pass
pred_header
(rev_block_hashes, protocol_data :: protocol_datas)
todo
(cpt + 1)
| End ->
return (pred_header, rev_block_hashes, List.rev protocol_datas)
| _ ->
fail Inconsistent_snapshot_data
in
I.batch index (fun batch -> first_pass batch (I.make_context index) 0)
>>=? fun (block_header, block_data) ->
Tezos_stdlib_unix.Utils.display_progress_end () ;
second_pass None ([], []) [] 0
>>=? fun (oldest_header_opt, rev_block_hashes, protocol_datas) ->
Tezos_stdlib_unix.Utils.display_progress_end () ;
return
( block_header,
block_data,
history_mode,
oldest_header_opt,
rev_block_hashes,
protocol_datas )
in
(* Check snapshot version *)
read_snapshot_metadata rbuf
>>=? fun version ->
check_version version
>>=? fun () ->
Lwt.catch
(fun () -> restore version.mode)
(function
| Unix.Unix_error (e, _, _) ->
fail @@ System_read_error (Unix.error_message e)
| err ->
Lwt.fail err)
end
src/lib_storage/context_dump.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition current_version : string := "tezos-snapshot-1.0.0" % string.
Module Dump_interface.
Record signature {index context tree hash commit_info batch Pruned_block_t
Block_data_t Protocol_data_t Commit_hash_t : Type} := {
index := index;
context := context;
tree := tree;
hash := hash;
step := string;
key := list step;
commit_info := commit_info;
batch := batch;
batch : forall {a : Type}, index -> (batch -> Lwt.t a) -> Lwt.t a;
commit_info_encoding : Tezos_base__TzPervasives.Data_encoding.t commit_info;
hash_encoding : Tezos_base__TzPervasives.Data_encoding.t hash;
Block_header : signature;
Pruned_block : signature;
Block_data : signature;
Protocol_data : signature;
Commit_hash : signature;
context_parents : context -> list Commit_hash.t;
context_info : context -> commit_info;
get_context : index -> Block_header.t -> Lwt.t (option context);
set_context : commit_info ->
(list Commit_hash.t) ->
context -> Block_header.t -> Lwt.t (option Block_header.t);
context_tree : context -> tree;
tree_hash : tree -> hash;
sub_tree : tree -> key -> Lwt.t (option tree);
tree_list : forall {variant : Type}, tree -> Lwt.t (list (step * variant));
tree_content : tree -> Lwt.t (option string);
make_context : index -> context;
update_context : context -> tree -> context;
add_string : batch -> string -> Lwt.t tree;
add_dir : batch -> (list (step * hash)) -> Lwt.t (option tree);
}.
Arguments signature : clear implicits.
End Dump_interface.
Module S.
Record signature {index context block_header block_data pruned_block
protocol_data : Type} := {
index := index;
context := context;
block_header := block_header;
block_data := block_data;
pruned_block := pruned_block;
protocol_data := protocol_data;
dump_contexts_fd : index ->
(block_header * block_data * Tezos_shell_services.History_mode.t *
(block_header ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
((option pruned_block) * (option protocol_data))))) ->
Lwt_unix.file_descr -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
restore_contexts_fd : index ->
Lwt_unix.file_descr ->
((list (Tezos_base__TzPervasives.Block_hash.t * pruned_block)) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) ->
((option block_header) ->
Tezos_base__TzPervasives.Block_hash.t ->
pruned_block -> Lwt.t (Tezos_base__TzPervasives.tzresult unit)) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(block_header * block_data * Tezos_shell_services.History_mode.t
* (option Tezos_base__TzPervasives.Block_header.t) *
(list Tezos_base__TzPervasives.Block_hash.t) *
(list protocol_data)));
}.
Arguments signature : clear implicits.
End S.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Functors are not handled. *)
functor
src/lib_storage/raw_store.ml 15 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Rresult
type t = {
dir : Lmdb.t;
parent : (Lmdb.rw Lmdb.txn * Lmdb.db * Lmdb.rw Lmdb.cursor) Lwt.key;
}
type key = string list
type value = Bytes.t
type error += Unknown of string list
let () =
Error_monad.register_error_kind
`Permanent
~id:"raw_store.unknown"
~title:"Missing key in store"
~description:"Missing key in store"
~pp:(fun ppf keys ->
Format.fprintf ppf "Missing key in store: %s" (String.concat "/" keys))
Data_encoding.(obj1 (req "key" (list string)))
(function Unknown keys -> Some keys | _ -> None)
(fun keys -> Unknown keys)
let concat = String.concat "/"
let split = String.split_on_char '/'
let lwt_fail_error err = Lwt.fail_with (Lmdb.string_of_error err)
let of_result = function
| Ok res ->
Lwt.return res
| Error err ->
lwt_fail_error err
let ( >>=? ) v f = match v with Error err -> lwt_fail_error err | Ok v -> f v
let init ?(readonly = false) ?mapsize path =
if not (Sys.file_exists path) then Unix.mkdir path 0o755 ;
let sync_flag =
match Sys.getenv_opt "TEZOS_STORE_SYNC" with
| None ->
[]
| Some s -> (
match String.lowercase_ascii s with
| "nosync" ->
[Lmdb.NoSync]
| "nometasync" ->
[Lmdb.NoMetaSync]
| _ ->
Printf.eprintf
"Unrecognized TEZOS_STORE_SYNC option : %s\n\
allowed: nosync nometasync"
s ;
[] )
in
let readonly_flag = if readonly then [Lmdb.RdOnly] else [] in
let file_flags = if readonly then 0o444 else 0o644 in
match
Lmdb.opendir
?mapsize
~flags:(sync_flag @ readonly_flag @ [NoTLS; NoMetaSync])
path
file_flags
with
| Ok dir ->
return {dir; parent = Lwt.new_key ()}
| Error err ->
failwith "%a" Lmdb.pp_error err
let close {dir; _} = Lmdb.closedir dir
let known {dir; parent} key =
( match Lwt.get parent with
| Some (txn, db, _cursor) ->
Lmdb.mem txn db (concat key)
| None ->
Lmdb.with_ro_db dir ~f:(fun txn db -> Lmdb.mem txn db (concat key)) )
|> of_result
let read_opt {dir; parent} key =
( match Lwt.get parent with
| Some (txn, db, _cursor) ->
Lmdb.get txn db (concat key) >>| Bigstring.to_bytes
| None ->
Lmdb.with_ro_db dir ~f:(fun txn db ->
Lmdb.get txn db (concat key) >>| Bigstring.to_bytes) )
|> function
| Ok v ->
Lwt.return_some v
| Error KeyNotFound ->
Lwt.return_none
| Error err ->
lwt_fail_error err
let read {dir; parent} key =
( match Lwt.get parent with
| Some (txn, db, _cursor) ->
Lmdb.get txn db (concat key) >>| Bigstring.to_bytes
| None ->
Lmdb.with_ro_db dir ~f:(fun txn db ->
Lmdb.get txn db (concat key) >>| Bigstring.to_bytes) )
|> function Ok v -> return v | Error _err -> fail (Unknown key)
let store {dir; parent} k v =
let v = Bigstring.of_bytes v in
( match Lwt.get parent with
| Some (txn, db, _cursor) ->
Lmdb.put txn db (concat k) v
| None ->
Lmdb.with_rw_db dir ~f:(fun txn db -> Lmdb.put txn db (concat k) v) )
|> of_result
let remove {dir; parent} k =
let remove txn db =
match Lmdb.del txn db (concat k) with
| Ok () ->
Ok ()
| Error KeyNotFound ->
Ok ()
| Error err ->
Error err
in
( match Lwt.get parent with
| Some (txn, db, _cursor) ->
remove txn db
| None ->
Lmdb.with_rw_db dir ~f:remove )
|> of_result
let is_prefix s s' =
String.(length s <= length s' && compare s (sub s' 0 (length s)) = 0)
let known_dir {dir; parent} k =
let k = concat k in
let cursor_fun cursor =
Lmdb.cursor_at cursor k
>>= fun () ->
Lmdb.cursor_get cursor
>>| fun (first_k, _v) -> is_prefix k (Bigstring.to_string first_k)
in
( match Lwt.get parent with
| Some (txn, db, _cursor) ->
Lmdb.with_cursor txn db ~f:cursor_fun
| None ->
Lmdb.with_ro_db dir ~f:(fun txn db ->
Lmdb.with_cursor txn db ~f:cursor_fun) )
|> of_result
let remove_dir {dir; parent} k =
let k = concat k in
let cursor_fun cursor =
Lmdb.cursor_at cursor k
>>= fun () ->
Lmdb.cursor_iter cursor ~f:(fun (kk, _v) ->
let kk_string = Bigstring.to_string kk in
if is_prefix k kk_string then Lmdb.cursor_del cursor
else Error KeyNotFound)
in
( match Lwt.get parent with
| Some (txn, db, _cursor) ->
Lmdb.with_cursor txn db ~f:cursor_fun
| None ->
Lmdb.with_rw_db dir ~f:(fun txn db ->
Lmdb.with_cursor txn db ~f:cursor_fun) )
|> function
| Error KeyNotFound | Ok () ->
Lwt.return_unit
| Error err ->
lwt_fail_error err
let list_equal l1 l2 len =
if len < 0 || len > List.length l1 || len > List.length l2 then
invalid_arg "list_compare: invalid len" ;
let rec inner l1 l2 len =
match (len, l1, l2) with
| (0, _, _) ->
true
| (_, [], _) | (_, _, []) ->
false
| (_, h1 :: t1, h2 :: t2) ->
if h1 <> h2 then false else inner t1 t2 (pred len)
in
inner l1 l2 len
let is_child ~parent ~child =
let plen = List.length parent in
let clen = List.length child in
clen > plen && list_equal parent child plen
let list_sub l pos len =
if len < 0 || pos < 0 || pos + len > List.length l then
invalid_arg "list_sub" ;
let rec inner (acc, n) = function
| [] ->
List.rev acc
| h :: t ->
if n = 0 then List.rev acc else inner (h :: acc, pred n) t
in
inner ([], len) l
let with_rw_cursor_lwt ?nosync ?nometasync ?flags ?name {dir; parent} ~f =
let local_parent =
match Lwt.get parent with
| None ->
None
| Some (txn, _db, _cursor) ->
Some txn
in
Lmdb.create_rw_txn ?nosync ?nometasync ?parent:local_parent dir
>>=? fun txn ->
Lmdb.opendb ?flags ?name txn
>>=? fun db ->
Lmdb.opencursor txn db
>>=? fun cursor ->
Lwt.with_value
parent
(Some (txn, db, cursor))
(fun () ->
Lwt.try_bind
(fun () -> f cursor)
(fun res ->
Lmdb.cursor_close cursor ;
Lmdb.commit_txn txn >>=? fun () -> Lwt.return res)
(fun exn ->
Lmdb.cursor_close cursor ; Lmdb.abort_txn txn ; Lwt.fail exn))
let cursor_next_lwt cursor acc f =
match Lmdb.cursor_next cursor with
| Error KeyNotFound ->
acc
| Error err ->
lwt_fail_error err
| Ok () ->
Lwt.bind acc f
let cursor_at_lwt cursor k acc f =
match Lmdb.cursor_at cursor (concat k) with
| Error KeyNotFound ->
acc
| Error err ->
lwt_fail_error err
| Ok () ->
Lwt.bind acc f
(* assumption: store path segments have only characters different than
the separator '/', which immediately precedes '0' *)
let zero_char_str = String.make 1 (Char.chr (Char.code '/' + 1))
let next_key_after_subdirs = function
| [] ->
[zero_char_str]
| _ :: _ as path ->
List.sub path (List.length path - 1)
@ [List.last_exn path ^ zero_char_str]
let fold t k ~init ~f =
let base_len = List.length k in
let rec inner ht cursor acc =
Lmdb.cursor_get cursor
>>=? fun (kk, _v) ->
let kk = Bigstring.to_string kk in
let kk_split = split kk in
match is_child ~child:kk_split ~parent:k with
| false ->
Lwt.return acc
| true ->
let cur_len = List.length kk_split in
if cur_len = succ base_len then
cursor_next_lwt cursor (f (`Key kk_split) acc) (inner ht cursor)
else
let dir = list_sub kk_split 0 (succ base_len) in
if Hashtbl.mem ht dir then
cursor_at_lwt
cursor
(next_key_after_subdirs dir)
(Lwt.return acc)
(inner ht cursor)
else (
Hashtbl.add ht dir () ;
cursor_next_lwt cursor (f (`Dir dir) acc) (inner ht cursor) )
in
with_rw_cursor_lwt t ~f:(fun cursor ->
cursor_at_lwt cursor k (Lwt.return init) (fun acc ->
let ht = Hashtbl.create 31 in
inner ht cursor acc))
let fold_keys t k ~init ~f =
with_rw_cursor_lwt t ~f:(fun cursor ->
cursor_at_lwt
cursor
k
(Lwt.return init)
(let rec inner acc =
Lmdb.cursor_get cursor
>>=? fun (kk, _v) ->
let kk = Bigstring.to_string kk in
let kk_split = split kk in
match is_child ~child:kk_split ~parent:k with
| false ->
Lwt.return acc
| true ->
cursor_next_lwt cursor (f kk_split acc) inner
in
inner))
let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
let open_with_atomic_rw ?mapsize path f =
let open Error_monad in
init ?mapsize path
>>=? fun state ->
with_rw_cursor_lwt state ~f:(fun _c -> f state)
>>=? fun res -> close state ; return res
let with_atomic_rw state f = with_rw_cursor_lwt state ~f:(fun _c -> f ())
src/lib_storage/raw_store.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Rresult.
Record t := {
dir : Lmdb.t;
parent : Lwt.key ((Lmdb.txn Lmdb.rw) * Lmdb.db * (Lmdb.cursor Lmdb.rw)) }.
Definition key := list string.
Definition value := Stdlib.Bytes.t.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition concat : (list string) -> string := String.concat "/" % string.
Definition split : string -> list string := String.split_on_char "/" % char.
Definition lwt_fail_error {A : Type} (err : Lmdb.error) : Lwt.t A :=
Lwt.fail_with (Lmdb.string_of_error err).
Definition of_result {A : Type}
(function_parameter : Rresult.result A Lmdb.error) : Lwt.t A :=
match function_parameter with
| Rresult.Ok res => Lwt._return res
| Rresult.Error err => lwt_fail_error err
end.
Definition op_gtgteqquestion {A B : Type}
(v : Rresult.result A Lmdb.error) (f : A -> Lwt.t B) : Lwt.t B :=
match v with
| Rresult.Error err => lwt_fail_error err
| Rresult.Ok v => f v
end.
Definition init (op_staroptstar : option bool)
: (option int64) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
let readonly :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun mapsize =>
fun path =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if negb (Sys.file_exists path) then
Unix.mkdir path 493
else
tt in
let sync_flag :=
match Sys.getenv_opt "TEZOS_STORE_SYNC" % string with
| None => []
| Some s =>
match String.lowercase_ascii s with
| "nosync" % string => cons Lmdb.NoSync []
| "nometasync" % string => cons Lmdb.NoMetaSync []
| _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Printf.eprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unrecognized TEZOS_STORE_SYNC option : " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"
allowed: nosync nometasync" % string
CamlinternalFormatBasics.End_of_format)))
"Unrecognized TEZOS_STORE_SYNC option : %s
allowed: nosync nometasync"
% string) s in
[]
end
end in
let readonly_flag :=
if readonly then
cons Lmdb.RdOnly []
else
[] in
let file_flags :=
if readonly then
292
else
420 in
match
Lmdb.opendir None None mapsize
(Some
(OCaml.Stdlib.app sync_flag
(OCaml.Stdlib.app readonly_flag
(cons Lmdb.NoTLS (cons Lmdb.NoMetaSync []))))) path file_flags
with
| Rresult.Ok dir => _return {| dir := dir; parent := Lwt.new_key tt |}
| Rresult.Error err =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Lmdb.pp_error err
end.
Definition close (function_parameter : t) : unit :=
let '{| dir := dir |} := function_parameter in
Lmdb.closedir dir.
Definition known (function_parameter : t) : (list string) -> Lwt.t bool :=
let '{| dir := dir; parent := parent |} := function_parameter in
fun key =>
OCaml.Stdlib.reverse_apply
match Lwt.get parent with
| Some (txn, db, _cursor) => Lmdb.mem txn db (concat key)
| None =>
Lmdb.with_ro_db None None None None None dir
(fun txn => fun db => Lmdb.mem txn db (concat key))
end of_result.
Definition read_opt (function_parameter : t)
: (list string) -> Lwt.t (option Stdlib.Bytes.t) :=
let '{| dir := dir; parent := parent |} := function_parameter in
fun key =>
OCaml.Stdlib.reverse_apply
match Lwt.get parent with
| Some (txn, db, _cursor) =>
op_gtgtpipe (Lmdb.get txn db (concat key)) Bigstring.to_bytes
| None =>
Lmdb.with_ro_db None None None None None dir
(fun txn =>
fun db =>
op_gtgtpipe (Lmdb.get txn db (concat key)) Bigstring.to_bytes)
end
(fun function_parameter =>
match function_parameter with
| Rresult.Ok v => Lwt.return_some v
| Rresult.Error Lmdb.KeyNotFound => Lwt.return_none
| Rresult.Error err => lwt_fail_error err
end).
Definition read (function_parameter : t)
: (list string) -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
let '{| dir := dir; parent := parent |} := function_parameter in
fun key =>
OCaml.Stdlib.reverse_apply
match Lwt.get parent with
| Some (txn, db, _cursor) =>
op_gtgtpipe (Lmdb.get txn db (concat key)) Bigstring.to_bytes
| None =>
Lmdb.with_ro_db None None None None None dir
(fun txn =>
fun db =>
op_gtgtpipe (Lmdb.get txn db (concat key)) Bigstring.to_bytes)
end
(fun function_parameter =>
match function_parameter with
| Rresult.Ok v => _return v
| Rresult.Error _err => fail (Tezos_base__TzPervasives.Unknown key)
end).
Definition store (function_parameter : t)
: (list string) -> Stdlib.Bytes.t -> Lwt.t unit :=
let '{| dir := dir; parent := parent |} := function_parameter in
fun k =>
fun v =>
let v := Bigstring.of_bytes v in
OCaml.Stdlib.reverse_apply
match Lwt.get parent with
| Some (txn, db, _cursor) => Lmdb.put None txn db (concat k) v
| None =>
Lmdb.with_rw_db None None None None None dir
(fun txn => fun db => Lmdb.put None txn db (concat k) v)
end of_result.
Definition remove (function_parameter : t) : (list string) -> Lwt.t unit :=
let '{| dir := dir; parent := parent |} := function_parameter in
fun k =>
let remove (txn : Lmdb.txn Lmdb.rw) (db : Lmdb.db)
: Rresult.result unit Lmdb.error :=
match Lmdb.del None txn db (concat k) with
| Rresult.Ok tt => Rresult.Ok tt
| Rresult.Error Lmdb.KeyNotFound => Rresult.Ok tt
| Rresult.Error err => Rresult.Error err
end in
OCaml.Stdlib.reverse_apply
match Lwt.get parent with
| Some (txn, db, _cursor) => remove txn db
| None => Lmdb.with_rw_db None None None None None dir remove
end of_result.
Definition is_prefix (s : Tezos_base__TzPervasives.String.t) (s' : string)
: bool :=
andb (OCaml.Stdlib.le (length s) (length s'))
(equiv_decb (compare s (sub s' 0 (length s))) 0).
Definition known_dir (function_parameter : t) : (list string) -> Lwt.t bool :=
let '{| dir := dir; parent := parent |} := function_parameter in
fun k =>
let k := concat k in
let cursor_fun {A : Type} (cursor : Lmdb.cursor A)
: Result.result bool Lmdb.error :=
op_gtgteq (Lmdb.cursor_at cursor k)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtpipe (Lmdb.cursor_get cursor)
(fun function_parameter =>
let '(first_k, _v) := function_parameter in
is_prefix k (Bigstring.to_string first_k))) in
OCaml.Stdlib.reverse_apply
match Lwt.get parent with
| Some (txn, db, _cursor) => Lmdb.with_cursor txn db cursor_fun
| None =>
Lmdb.with_ro_db None None None None None dir
(fun txn => fun db => Lmdb.with_cursor txn db cursor_fun)
end of_result.
Definition remove_dir (function_parameter : t) : (list string) -> Lwt.t unit :=
let '{| dir := dir; parent := parent |} := function_parameter in
fun k =>
let k := concat k in
let cursor_fun (cursor : Lmdb.cursor Lmdb.rw)
: Result.result unit Lmdb.error :=
op_gtgteq (Lmdb.cursor_at cursor k)
(fun function_parameter =>
let 'tt := function_parameter in
Lmdb.cursor_iter
(fun function_parameter =>
let '(kk, _v) := function_parameter in
let kk_string := Bigstring.to_string kk in
if is_prefix k kk_string then
Lmdb.cursor_del None cursor
else
Rresult.Error Lmdb.KeyNotFound) cursor) in
OCaml.Stdlib.reverse_apply
match Lwt.get parent with
| Some (txn, db, _cursor) => Lmdb.with_cursor txn db cursor_fun
| None =>
Lmdb.with_rw_db None None None None None dir
(fun txn => fun db => Lmdb.with_cursor txn db cursor_fun)
end
(fun function_parameter =>
match function_parameter with
| Rresult.Error Lmdb.KeyNotFound | Rresult.Ok tt => Lwt.return_unit
| Rresult.Error err => lwt_fail_error err
end).
Definition list_equal {A : Type} (l1 : list A) (l2 : list A) (len : Z) : bool :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
orb (OCaml.Stdlib.lt len 0)
(orb (OCaml.Stdlib.gt len (List.length l1))
(OCaml.Stdlib.gt len (List.length l2))) then
OCaml.Stdlib.invalid_arg "list_compare: invalid len" % string
else
tt in
let fix inner {B : Type} (l1 : list B) (l2 : list B) (len : Z) : bool :=
match (len, l1, l2) with
| (0, _, _) => true
| (_, [], _) | (_, _, []) => false
| (_, cons h1 t1, cons h2 t2) =>
if nequiv_decb h1 h2 then
false
else
inner t1 t2 (Z.pred len)
end in
inner l1 l2 len.
Definition is_child {A : Type} (parent : list A) (child : list A) : bool :=
let plen := List.length parent in
let clen := List.length child in
andb (OCaml.Stdlib.gt clen plen) (list_equal parent child plen).
Definition list_sub {A : Type} (l : list A) (pos : Z) (len : Z) : list A :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
orb (OCaml.Stdlib.lt len 0)
(orb (OCaml.Stdlib.lt pos 0)
(OCaml.Stdlib.gt (Z.add pos len) (List.length l))) then
OCaml.Stdlib.invalid_arg "list_sub" % string
else
tt in
let fix inner {B : Type} (function_parameter : (list B) * Z)
: (list B) -> list B :=
let '(acc, n) := function_parameter in
fun function_parameter =>
match function_parameter with
| [] => List.rev acc
| cons h t =>
if equiv_decb n 0 then
List.rev acc
else
inner ((cons h acc), (Z.pred n)) t
end in
inner ([], len) l.
Definition with_rw_cursor_lwt {A : Type}
(nosync : option bool) (nometasync : option bool)
(flags : option (list Lmdb.flag_open)) (name : option string)
(function_parameter : t) : ((Lmdb.cursor Lmdb.rw) -> Lwt.t A) -> Lwt.t A :=
let '{| dir := dir; parent := parent |} := function_parameter in
fun f =>
let local_parent :=
match Lwt.get parent with
| None => None
| Some (txn, _db, _cursor) => Some txn
end in
op_gtgteqquestion (Lmdb.create_rw_txn nosync nometasync local_parent dir)
(fun txn =>
op_gtgteqquestion (Lmdb.opendb flags name txn)
(fun db =>
op_gtgteqquestion (Lmdb.opencursor txn db)
(fun cursor =>
Lwt.with_value parent (Some (txn, db, cursor))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.try_bind
(fun function_parameter =>
let 'tt := function_parameter in
f cursor)
(fun res =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lmdb.cursor_close cursor in
op_gtgteqquestion (Lmdb.commit_txn txn)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return res))
(fun exn =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lmdb.cursor_close cursor in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lmdb.abort_txn txn in
Lwt.fail exn))))).
Definition cursor_next_lwt {A B : Type}
(cursor : Lmdb.cursor A) (acc : Lwt.t B) (f : B -> Lwt.t B) : Lwt.t B :=
match Lmdb.cursor_next cursor with
| Rresult.Error Lmdb.KeyNotFound => acc
| Rresult.Error err => lwt_fail_error err
| Rresult.Ok tt => Lwt.bind acc f
end.
Definition cursor_at_lwt {A B : Type}
(cursor : Lmdb.cursor A) (k : list string) (acc : Lwt.t B) (f : B -> Lwt.t B)
: Lwt.t B :=
match Lmdb.cursor_at cursor (concat k) with
| Rresult.Error Lmdb.KeyNotFound => acc
| Rresult.Error err => lwt_fail_error err
| Rresult.Ok tt => Lwt.bind acc f
end.
Definition zero_char_str : string :=
String.make 1 (Char.chr (Z.add (Char.code "/" % char) 1)).
Definition next_key_after_subdirs (function_parameter : list string)
: list string :=
match function_parameter with
| [] => cons zero_char_str []
| (cons _ _) as path =>
OCaml.Stdlib.app (List.sub path (Z.sub (List.length path) 1))
(cons (String.append (List.last_exn path) zero_char_str) [])
end.
Definition fold {A : Type}
(t : t) (k : list string) (init : A) (f : variant -> A -> Lwt.t A)
: Lwt.t A :=
let base_len := List.length k in
let fix inner {B : Type}
(ht : Stdlib.Hashtbl.t (list string) unit) (cursor : Lmdb.cursor B) (acc :
A) : Lwt.t A :=
op_gtgteqquestion (Lmdb.cursor_get cursor)
(fun function_parameter =>
let '(kk, _v) := function_parameter in
let kk := Bigstring.to_string kk in
let kk_split := split kk in
match is_child k kk_split with
| false => Lwt._return acc
| true =>
let cur_len := List.length kk_split in
if equiv_decb cur_len (Z.succ base_len) then
cursor_next_lwt cursor
(f
(* ❌ Variants not supported *)
variant acc) (inner ht cursor)
else
let dir := list_sub kk_split 0 (Z.succ base_len) in
if Hashtbl.mem ht dir then
cursor_at_lwt cursor (next_key_after_subdirs dir)
(Lwt._return acc) (inner ht cursor)
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Hashtbl.add ht dir tt in
cursor_next_lwt cursor
(f
(* ❌ Variants not supported *)
variant acc) (inner ht cursor)
end) in
with_rw_cursor_lwt None None None None t
(fun cursor =>
cursor_at_lwt cursor k (Lwt._return init)
(fun acc =>
let ht := Hashtbl.create None 31 in
inner ht cursor acc)).
Definition fold_keys {A : Type}
(t : t) (k : list string) (init : A) (f : (list string) -> A -> Lwt.t A)
: Lwt.t A :=
with_rw_cursor_lwt None None None None t
(fun cursor =>
cursor_at_lwt cursor k (Lwt._return init)
(let fix inner (acc : A) : Lwt.t A :=
op_gtgteqquestion (Lmdb.cursor_get cursor)
(fun function_parameter =>
let '(kk, _v) := function_parameter in
let kk := Bigstring.to_string kk in
let kk_split := split kk in
match is_child k kk_split with
| false => Lwt._return acc
| true => cursor_next_lwt cursor (f kk_split acc) inner
end) in
inner)).
Definition keys (t : t) : (list string) -> Lwt.t (list (list string)) :=
fold_keys t
(* ❌ expected an argument *)
expected_argument [] (fun k => fun acc => Lwt._return (cons k acc)).
Definition open_with_atomic_rw {A : Type}
(mapsize : option int64) (path : string)
(f : t -> Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult A))
: Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult A) :=
op_gtgteqquestion (init None mapsize path)
(fun state =>
op_gtgteqquestion
(with_rw_cursor_lwt None None None None state (fun _c => f state))
(fun res =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := close state in
_return res)).
Definition with_atomic_rw {A : Type} (state : t) (f : unit -> Lwt.t A)
: Lwt.t A := with_rw_cursor_lwt None None None None state (fun _c => f tt).
src/lib_storage/store_helpers.ml 15 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Store_sigs
module Make_value (V : ENCODED_VALUE) = struct
type t = V.t
let of_bytes b =
match Data_encoding.Binary.of_bytes V.encoding b with
| None ->
generic_error "Cannot parse data" (* TODO personalize *)
| Some v ->
ok v
let to_bytes v =
try Data_encoding.Binary.to_bytes_exn V.encoding v
with Data_encoding.Binary.Write_error error ->
Store_logging.log_error
"Exception while serializing value %a"
Data_encoding.Binary.pp_write_error
error ;
Bytes.create 0
end
module Raw_value = struct
type t = Bytes.t
let of_bytes b = ok b
let to_bytes b = b
end
module Make_single_store (S : STORE) (N : NAME) (V : VALUE) = struct
type t = S.t
type value = V.t
let known t = S.known t N.name
let read t = S.read t N.name >>=? fun b -> Lwt.return (V.of_bytes b)
let read_opt t = read t >|= function Error _ -> None | Ok v -> Some v
let store t v = S.store t N.name (V.to_bytes v)
let remove t = S.remove t N.name
end
let map_key f = function `Key k -> `Key (f k) | `Dir k -> `Dir (f k)
module Make_substore (S : STORE) (N : NAME) : STORE with type t = S.t = struct
type t = S.t
type key = string list
type value = Bytes.t
let name_length = List.length N.name
let to_key k = N.name @ k
let of_key k = List.remove name_length k
let known t k = S.known t (to_key k)
let known_dir t k = S.known_dir t (to_key k)
let read t k = S.read t (to_key k)
let read_opt t k = S.read_opt t (to_key k)
let store t k v = S.store t (to_key k) v
let remove t k = S.remove t (to_key k)
let fold t k ~init ~f =
S.fold t (to_key k) ~init ~f:(fun k acc -> f (map_key of_key k) acc)
let keys t k = S.keys t (to_key k) >|= fun keys -> List.map of_key keys
let fold_keys t k ~init ~f =
S.fold_keys t (to_key k) ~init ~f:(fun k acc -> f (of_key k) acc)
let remove_dir t k = S.remove_dir t (to_key k)
end
module Make_indexed_substore (S : STORE) (I : INDEX) = struct
type t = S.t
type key = I.t
module Store = struct
type t = S.t * I.t
type key = string list
type value = Bytes.t
let to_key i k =
assert (List.length (I.to_path i []) = I.path_length) ;
I.to_path i k
let of_key k = List.remove I.path_length k
let known (t, i) k = S.known t (to_key i k)
let known_dir (t, i) k = S.known_dir t (to_key i k)
let read (t, i) k = S.read t (to_key i k)
let read_opt (t, i) k = S.read_opt t (to_key i k)
let store (t, i) k v = S.store t (to_key i k) v
let remove (t, i) k = S.remove t (to_key i k)
let fold (t, i) k ~init ~f =
S.fold t (to_key i k) ~init ~f:(fun k acc -> f (map_key of_key k) acc)
let keys (t, i) k =
S.keys t (to_key i k) >|= fun keys -> List.map of_key keys
let fold_keys (t, i) k ~init ~f =
S.fold_keys t (to_key i k) ~init ~f:(fun k acc -> f (of_key k) acc)
let remove_dir (t, i) k = S.remove_dir t (to_key i k)
end
let remove_all t i = Store.remove_dir (t, i) []
let fold_indexes t ~init ~f =
let rec dig i path acc =
if i <= 0 then
match I.of_path path with
| None ->
assert false
| Some path ->
f path acc
else
S.fold t path ~init:acc ~f:(fun k acc ->
match k with
| `Dir k ->
dig (i - 1) k acc
| `Key _ ->
Lwt.return acc)
in
dig I.path_length [] init
let indexes t =
fold_indexes t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc))
let list t k = S.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
let resolve_index t prefix =
let rec loop i prefix = function
| [] when i = I.path_length -> (
match I.of_path prefix with
| None ->
assert false
| Some path ->
Lwt.return [path] )
| [] ->
list t prefix
>>= fun prefixes ->
Lwt_list.map_p
(function `Key prefix | `Dir prefix -> loop (i + 1) prefix [])
prefixes
>|= List.flatten
| [d] when i = I.path_length - 1 ->
if i >= I.path_length then invalid_arg "IO.resolve" ;
list t prefix
>>= fun prefixes ->
Lwt_list.map_p
(function
| `Key prefix | `Dir prefix -> (
match
String.remove_prefix ~prefix:d (List.hd (List.rev prefix))
with
| None ->
Lwt.return_nil
| Some _ ->
loop (i + 1) prefix [] ))
prefixes
>|= List.flatten
| "" :: ds ->
list t prefix
>>= fun prefixes ->
Lwt_list.map_p
(function `Key prefix | `Dir prefix -> loop (i + 1) prefix ds)
prefixes
>|= List.flatten
| d :: ds -> (
if i >= I.path_length then invalid_arg "IO.resolve" ;
S.known_dir t (prefix @ [d])
>>= function
| true -> loop (i + 1) (prefix @ [d]) ds | false -> Lwt.return_nil )
in
loop 0 [] prefix
module Make_set (N : NAME) = struct
type t = S.t
type elt = I.t
let inited = Bytes.of_string "inited"
let known s i = Store.known (s, i) N.name
let store s i = Store.store (s, i) N.name inited
let remove s i = Store.remove (s, i) N.name
let remove_all s = fold_indexes s ~init:() ~f:(fun i () -> remove s i)
let fold s ~init ~f =
fold_indexes s ~init ~f:(fun i acc ->
known s i >>= function true -> f i acc | false -> Lwt.return acc)
let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
let iter s ~f = fold s ~init:() ~f:(fun p () -> f p)
end
module Make_buffered_set (N : NAME) (Set : Set.S with type elt = I.t) =
struct
include Make_set (N)
module Set = Set
let read_all s =
fold s ~init:Set.empty ~f:(fun i set -> Lwt.return (Set.add i set))
let store_all s new_set =
read_all s
>>= fun old_set ->
Lwt_list.iter_p (remove s) Set.(elements (diff old_set new_set))
>>= fun () ->
Lwt_list.iter_p (store s) Set.(elements (diff new_set old_set))
end
module Make_map (N : NAME) (V : VALUE) = struct
type t = S.t
type key = I.t
type value = V.t
let known s i = Store.known (s, i) N.name
let read s i =
Store.read (s, i) N.name >>=? fun b -> Lwt.return (V.of_bytes b)
let read_opt s i =
read s i
>>= function Error _ -> Lwt.return_none | Ok v -> Lwt.return_some v
let store s i v = Store.store (s, i) N.name (V.to_bytes v)
let remove s i = Store.remove (s, i) N.name
let remove_all s = fold_indexes s ~init:() ~f:(fun i () -> remove s i)
let fold s ~init ~f =
fold_indexes s ~init ~f:(fun i acc ->
read_opt s i
>>= function None -> Lwt.return acc | Some v -> f i v acc)
let bindings s =
fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))
let iter s ~f = fold s ~init:() ~f:(fun p v () -> f p v)
let fold_keys s ~init ~f =
fold_indexes s ~init ~f:(fun i acc ->
known s i >>= function false -> Lwt.return acc | true -> f i acc)
let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
let iter_keys s ~f = fold_keys s ~init:() ~f:(fun p () -> f p)
end
module Make_buffered_map
(N : NAME)
(V : VALUE)
(Map : Map.S with type key = I.t) =
struct
include Make_map (N) (V)
module Map = Map
let read_all s =
fold s ~init:Map.empty ~f:(fun i v set -> Lwt.return (Map.add i v set))
let store_all s map =
remove_all s
>>= fun () ->
Map.fold
(fun k v acc ->
let res = store s k v in
acc >>= fun () -> res)
map
Lwt.return_unit
end
end
module Make_set (S : STORE) (I : INDEX) = struct
type t = S.t
type elt = I.t
let inited = Bytes.of_string "inited"
let known s i = S.known s (I.to_path i [])
let store s i = S.store s (I.to_path i []) inited
let remove s i = S.remove s (I.to_path i [])
let remove_all s = S.remove_dir s []
let fold s ~init ~f =
let rec dig i path acc =
if i <= 1 then
S.fold s path ~init:acc ~f:(fun k acc ->
match k with
| `Dir _ ->
Lwt.return acc
| `Key file -> (
match I.of_path file with
| None ->
assert false
| Some p ->
f p acc ))
else
S.fold s path ~init:acc ~f:(fun k acc ->
match k with
| `Dir k ->
dig (i - 1) k acc
| `Key _ ->
Lwt.return acc)
in
dig I.path_length [] init
let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
let iter s ~f = fold s ~init:() ~f:(fun p () -> f p)
end
module Make_buffered_set
(S : STORE)
(I : INDEX)
(Set : Set.S with type elt = I.t) =
struct
include Make_set (S) (I)
module Set = Set
let read_all s =
fold s ~init:Set.empty ~f:(fun i set -> Lwt.return (Set.add i set))
let store_all s new_set =
read_all s
>>= fun old_set ->
Lwt_list.iter_p (remove s) Set.(elements (diff old_set new_set))
>>= fun () ->
Lwt_list.iter_p (store s) Set.(elements (diff new_set old_set))
end
module Make_map (S : STORE) (I : INDEX) (V : VALUE) = struct
type t = S.t
type key = I.t
type value = V.t
let known s i = S.known s (I.to_path i [])
let read s i =
S.read s (I.to_path i []) >>=? fun b -> Lwt.return (V.of_bytes b)
let read_opt s i =
read s i
>>= function Error _ -> Lwt.return_none | Ok v -> Lwt.return_some v
let store s i v = S.store s (I.to_path i []) (V.to_bytes v)
let remove s i = S.remove s (I.to_path i [])
let remove_all s = S.remove_dir s []
let fold s ~init ~f =
let rec dig i path acc =
if i <= 1 then
S.fold s path ~init:acc ~f:(fun k acc ->
match k with
| `Dir _ ->
Lwt.return acc
| `Key file -> (
S.read_opt s file
>>= function
| None ->
Lwt.return acc
| Some b -> (
match V.of_bytes b with
| Error _ ->
(* Silently ignore unparsable data *)
Lwt.return acc
| Ok v -> (
match I.of_path file with
| None ->
assert false
| Some path ->
f path v acc ) ) ))
else
S.fold s path ~init:acc ~f:(fun k acc ->
match k with
| `Dir k ->
dig (i - 1) k acc
| `Key _ ->
Lwt.return acc)
in
dig I.path_length [] init
let bindings s =
fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))
let iter s ~f = fold s ~init:() ~f:(fun p v () -> f p v)
let fold_keys s ~init ~f =
S.fold s [] ~init ~f:(fun p acc ->
match p with
| `Dir _ ->
Lwt.return acc
| `Key p -> (
match I.of_path p with
| None ->
assert false
| Some path ->
f path acc ))
let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
let iter_keys s ~f = fold_keys s ~init:() ~f:(fun p () -> f p)
end
module Make_buffered_map
(S : STORE)
(I : INDEX)
(V : VALUE)
(Map : Map.S with type key = I.t) =
struct
include Make_map (S) (I) (V)
module Map = Map
let read_all s =
fold s ~init:Map.empty ~f:(fun i v set -> Lwt.return (Map.add i v set))
let store_all s map =
remove_all s
>>= fun () ->
Map.fold
(fun k v acc ->
let res = store s k v in
acc >>= fun () -> res)
map
Lwt.return_unit
end
module Integer_index = struct
type t = int
let path_length = 1
let to_path x l = string_of_int x :: l
let of_path = function
| [x] -> (
try Some (int_of_string x) with _ -> None )
| _ ->
None
end
src/lib_storage/store_helpers.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Store_sigs.
(* ❌ Functors are not handled. *)
functor
Module Raw_value.
Definition t := Stdlib.Bytes.t.
Definition of_bytes {A : Type} (b : A)
: Tezos_base__TzPervasives.tzresult A := ok b.
Definition to_bytes {A : Type} (b : A) : A := b.
End Raw_value.
(* ❌ Functors are not handled. *)
functor
Definition map_key {A B : Type} (f : A -> B) (function_parameter : variant)
: variant :=
match function_parameter with
| Key k =>
(* ❌ Variants not supported *)
variant
| Dir k =>
(* ❌ Variants not supported *)
variant
end.
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
Module Integer_index.
Definition t := Z.
Definition path_length : Z := 1.
Definition to_path (x : Z) (l : list string) : list string :=
cons (OCaml.Stdlib.string_of_int x) l.
Definition of_path (function_parameter : list string) : option Z :=
match function_parameter with
| cons x [] =>
(* ❌ Try-with are not handled *)
try (Some (OCaml.Stdlib.int_of_string x))
| _ => None
end.
End Integer_index.
src/lib_storage/store_logging.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Internal_event.Legacy_logging.Make (struct let name = "db" end)
src/lib_storage/store_logging.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Structure item `include` not handled. *) include
src/lib_storage/store_sigs.ml 11 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type NAME = sig
val name : string list
end
module type VALUE = sig
type t
val of_bytes : Bytes.t -> t tzresult
val to_bytes : t -> Bytes.t
end
module type ENCODED_VALUE = sig
type t
val encoding : t Data_encoding.t
end
module type INDEX = sig
type t
val path_length : int
val to_path : t -> string list -> string list
val of_path : string list -> t option
end
module type SINGLE_STORE = sig
type t
type value
val known : t -> bool Lwt.t
val read : t -> value tzresult Lwt.t
val read_opt : t -> value option Lwt.t
val store : t -> value -> unit Lwt.t
val remove : t -> unit Lwt.t
end
module type STORE = sig
type t
type key = string list
type value = Bytes.t
val known : t -> key -> bool Lwt.t
val read : t -> key -> value tzresult Lwt.t
val read_opt : t -> key -> value option Lwt.t
val store : t -> key -> value -> unit Lwt.t
val remove : t -> key -> unit Lwt.t
val known_dir : t -> key -> bool Lwt.t
val remove_dir : t -> key -> unit Lwt.t
val fold :
t ->
key ->
init:'a ->
f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
'a Lwt.t
val keys : t -> key -> key list Lwt.t
val fold_keys : t -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
end
module type SET_STORE = sig
type t
type elt
val known : t -> elt -> bool Lwt.t
val store : t -> elt -> unit Lwt.t
val remove : t -> elt -> unit Lwt.t
val elements : t -> elt list Lwt.t
val remove_all : t -> unit Lwt.t
val iter : t -> f:(elt -> unit Lwt.t) -> unit Lwt.t
val fold : t -> init:'a -> f:(elt -> 'a -> 'a Lwt.t) -> 'a Lwt.t
end
module type BUFFERED_SET_STORE = sig
include SET_STORE
module Set : Set.S with type elt = elt
val read_all : t -> Set.t Lwt.t
val store_all : t -> Set.t -> unit Lwt.t
end
module type MAP_STORE = sig
type t
type key
type value
val known : t -> key -> bool Lwt.t
val read : t -> key -> value tzresult Lwt.t
val read_opt : t -> key -> value option Lwt.t
val store : t -> key -> value -> unit Lwt.t
val remove : t -> key -> unit Lwt.t
val keys : t -> key list Lwt.t
val bindings : t -> (key * value) list Lwt.t
val remove_all : t -> unit Lwt.t
val iter : t -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t
val iter_keys : t -> f:(key -> unit Lwt.t) -> unit Lwt.t
val fold : t -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t
val fold_keys : t -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
end
module type BUFFERED_MAP_STORE = sig
include MAP_STORE
module Map : Map.S with type key = key
val read_all : t -> value Map.t Lwt.t
val store_all : t -> value Map.t -> unit Lwt.t
end
module type INDEXED_STORE = sig
type t
type key
module Store : STORE with type t = t * key
val remove_all : t -> key -> unit Lwt.t
val fold_indexes : t -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
val indexes : t -> key list Lwt.t
val resolve_index : t -> string list -> key list Lwt.t
module Make_set (N : NAME) : SET_STORE with type t = t and type elt = key
module Make_buffered_set (N : NAME) (Set : Set.S with type elt = key) :
BUFFERED_SET_STORE with type t = t and type elt = key and module Set = Set
module Make_map (N : NAME) (V : VALUE) :
MAP_STORE with type t = t and type key = key and type value = V.t
module Make_buffered_map
(N : NAME)
(V : VALUE)
(Map : Map.S with type key = key) :
BUFFERED_MAP_STORE
with type t = t
and type key = key
and type value = V.t
and module Map = Map
end
src/lib_storage/store_sigs.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module NAME.
Record signature := {
name : list string;
}.
End NAME.
Module VALUE.
Record signature {t : Type} := {
t := t;
of_bytes : Stdlib.Bytes.t -> Tezos_base__TzPervasives.tzresult t;
to_bytes : t -> Stdlib.Bytes.t;
}.
Arguments signature : clear implicits.
End VALUE.
Module ENCODED_VALUE.
Record signature {t : Type} := {
t := t;
encoding : Tezos_base__TzPervasives.Data_encoding.t t;
}.
Arguments signature : clear implicits.
End ENCODED_VALUE.
Module INDEX.
Record signature {t : Type} := {
t := t;
path_length : Z;
to_path : t -> (list string) -> list string;
of_path : (list string) -> option t;
}.
Arguments signature : clear implicits.
End INDEX.
Module SINGLE_STORE.
Record signature {t value : Type} := {
t := t;
value := value;
known : t -> Lwt.t bool;
read : t -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
read_opt : t -> Lwt.t (option value);
store : t -> value -> Lwt.t unit;
remove : t -> Lwt.t unit;
}.
Arguments signature : clear implicits.
End SINGLE_STORE.
Module STORE.
Record signature {t : Type} := {
t := t;
key := list string;
value := Stdlib.Bytes.t;
known : t -> key -> Lwt.t bool;
read : t -> key -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
read_opt : t -> key -> Lwt.t (option value);
store : t -> key -> value -> Lwt.t unit;
remove : t -> key -> Lwt.t unit;
known_dir : t -> key -> Lwt.t bool;
remove_dir : t -> key -> Lwt.t unit;
fold : forall {a variant : Type}, t ->
key -> a -> (variant -> a -> Lwt.t a) -> Lwt.t a;
keys : t -> key -> Lwt.t (list key);
fold_keys : forall {a : Type}, t ->
key -> a -> (key -> a -> Lwt.t a) -> Lwt.t a;
}.
Arguments signature : clear implicits.
End STORE.
Module SET_STORE.
Record signature {t elt : Type} := {
t := t;
elt := elt;
known : t -> elt -> Lwt.t bool;
store : t -> elt -> Lwt.t unit;
remove : t -> elt -> Lwt.t unit;
elements : t -> Lwt.t (list elt);
remove_all : t -> Lwt.t unit;
iter : t -> (elt -> Lwt.t unit) -> Lwt.t unit;
fold : forall {a : Type}, t -> a -> (elt -> a -> Lwt.t a) -> Lwt.t a;
}.
Arguments signature : clear implicits.
End SET_STORE.
Module BUFFERED_SET_STORE.
Record signature {t elt Set_t : Type} := {
include;
Set : Set.S.signature elt Set_t;
read_all : t -> Lwt.t Set.t;
store_all : t -> Set.t -> Lwt.t unit;
}.
Arguments signature : clear implicits.
End BUFFERED_SET_STORE.
Module MAP_STORE.
Record signature {t key value : Type} := {
t := t;
key := key;
value := value;
known : t -> key -> Lwt.t bool;
read : t -> key -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
read_opt : t -> key -> Lwt.t (option value);
store : t -> key -> value -> Lwt.t unit;
remove : t -> key -> Lwt.t unit;
keys : t -> Lwt.t (list key);
bindings : t -> Lwt.t (list (key * value));
remove_all : t -> Lwt.t unit;
iter : t -> (key -> value -> Lwt.t unit) -> Lwt.t unit;
iter_keys : t -> (key -> Lwt.t unit) -> Lwt.t unit;
fold : forall {a : Type}, t ->
a -> (key -> value -> a -> Lwt.t a) -> Lwt.t a;
fold_keys : forall {a : Type}, t -> a -> (key -> a -> Lwt.t a) -> Lwt.t a;
}.
Arguments signature : clear implicits.
End MAP_STORE.
Module BUFFERED_MAP_STORE.
Record signature {t key value Map_t : Type} := {
include;
Map : Map.S.signature key Map_t;
read_all : t -> Lwt.t (Map.t value);
store_all : t -> (Map.t value) -> Lwt.t unit;
}.
Arguments signature : clear implicits.
End BUFFERED_MAP_STORE.
Module INDEXED_STORE.
Record signature {t key : Type} := {
t := t;
key := key;
Store : STORE.signature (t * key);
remove_all : t -> key -> Lwt.t unit;
fold_indexes : forall {a : Type}, t -> a -> (key -> a -> Lwt.t a) -> Lwt.t a;
indexes : t -> Lwt.t (list key);
resolve_index : t -> (list string) -> Lwt.t (list key);
Make_set : functor;
Make_buffered_set : functor;
Make_map : functor;
Make_buffered_map : functor;
}.
Arguments signature : clear implicits.
End INDEXED_STORE.
src/lib_storage/test/assert.ml 4 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let fail expected given msg =
Format.kasprintf
Pervasives.failwith
"@[%s@ expected: %s@ got: %s@]"
msg
expected
given
let fail_msg fmt = Format.kasprintf (fail "" "") fmt
let default_printer _ = ""
let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
if not (eq x y) then fail (prn x) (prn y) msg
let equal_string ?msg s1 s2 = equal ?msg ~prn:(fun s -> s) s1 s2
let equal_string_option ?msg o1 o2 =
let prn = function None -> "None" | Some s -> s in
equal ?msg ~prn o1 o2
let is_none ?(msg = "") x = if x <> None then fail "None" "Some _" msg
let make_equal_list eq prn ?(msg = "") x y =
let rec iter i x y =
match (x, y) with
| (hd_x :: tl_x, hd_y :: tl_y) ->
if eq hd_x hd_y then iter (succ i) tl_x tl_y
else
let fm = Printf.sprintf "%s (at index %d)" msg i in
fail (prn hd_x) (prn hd_y) fm
| (_ :: _, []) | ([], _ :: _) ->
let fm = Printf.sprintf "%s (lists of different sizes)" msg in
fail_msg "%s" fm
| ([], []) ->
()
in
iter 0 x y
let equal_string_list ?msg l1 l2 =
make_equal_list ?msg ( = ) (fun x -> x) l1 l2
let equal_string_list_list ?msg l1 l2 =
let pr_persist l =
let res =
String.concat ";" (List.map (fun s -> Printf.sprintf "%S" s) l)
in
Printf.sprintf "[%s]" res
in
make_equal_list ?msg ( = ) pr_persist l1 l2
let equal_key_dir_list ?msg l1 l2 =
make_equal_list
?msg
( = )
(function
| `Key k ->
"Key " ^ String.concat "/" k
| `Dir k ->
"Dir " ^ String.concat "/" k)
l1
l2
let equal_context_hash_list ?msg l1 l2 =
let pr_persist hash = Printf.sprintf "[%s]" @@ Context_hash.to_string hash in
make_equal_list ?msg Context_hash.( = ) pr_persist l1 l2
src/lib_storage/test/assert.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition fail {A : Type} (expected : string) (given : string) (msg : string)
: A :=
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "expected: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "got: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[%s@ expected: %s@ got: %s@]" % string) msg expected given.
Definition fail_msg {A B : Type}
(fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
Format.kasprintf (fail "" % string "" % string) fmt.
Definition default_printer {A : Type} (function_parameter : A) : string :=
let '_ := function_parameter in
"" % string.
Definition equal {A : Type} (op_staroptstar : option (A -> A -> bool))
: (option (A -> string)) -> (option string) -> A -> A -> unit :=
let eq :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => equiv_decb
end in
fun op_staroptstar =>
let prn :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_printer
end in
fun op_staroptstar =>
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
fun y =>
if negb (eq x y) then
fail (prn x) (prn y) msg
else
tt.
Definition equal_string (msg : option string) (s1 : string) (s2 : string)
: unit := equal None (Some (fun s => s)) msg s1 s2.
Definition equal_string_option
(msg : option string) (o1 : option string) (o2 : option string) : unit :=
let prn (function_parameter : option string) : string :=
match function_parameter with
| None => "None" % string
| Some s => s
end in
equal None (Some prn) msg o1 o2.
Definition is_none {A : Type} (op_staroptstar : option string)
: (option A) -> unit :=
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
if nequiv_decb x None then
fail "None" % string "Some _" % string msg
else
tt.
Definition make_equal_list {A : Type}
(eq : A -> A -> bool) (prn : A -> string) (op_staroptstar : option string)
: (list A) -> (list A) -> unit :=
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
fun y =>
let fix iter (i : Z) (x : list A) (y : list A) : unit :=
match (x, y) with
| (cons hd_x tl_x, cons hd_y tl_y) =>
if eq hd_x hd_y then
iter (Z.succ i) tl_x tl_y
else
let fm :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (at index " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))
"%s (at index %d)" % string) msg i in
fail (prn hd_x) (prn hd_y) fm
| (cons _ _, []) | ([], cons _ _) =>
let fm :=
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (lists of different sizes)" % string
CamlinternalFormatBasics.End_of_format))
"%s (lists of different sizes)" % string) msg in
fail_msg
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) fm
| ([], []) => tt
end in
iter 0 x y.
Definition equal_string_list
(msg : option string) (l1 : list string) (l2 : list string) : unit :=
make_equal_list equiv_decb (fun x => x) msg l1 l2.
Definition equal_string_list_list
(msg : option string) (l1 : list (list string)) (l2 : list (list string))
: unit :=
let pr_persist (l : list string) : string :=
let res :=
String.concat ";" % string
(List.map
(fun s =>
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%S" % string) s) l)
in
Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "]" % char
CamlinternalFormatBasics.End_of_format))) "[%s]" % string) res in
make_equal_list equiv_decb pr_persist msg l1 l2.
Definition equal_key_dir_list
(msg : option string) (l1 : list variant) (l2 : list variant) : unit :=
make_equal_list equiv_decb
(fun function_parameter =>
match function_parameter with
| Key k => String.append "Key " % string (String.concat "/" % string k)
| Dir k => String.append "Dir " % string (String.concat "/" % string k)
end) msg l1 l2.
Definition equal_context_hash_list
(msg : option string) (l1 : list Tezos_base__TzPervasives.Context_hash.t)
(l2 : list Tezos_base__TzPervasives.Context_hash.t) : unit :=
let pr_persist (hash : Tezos_base__TzPervasives.Context_hash.t) : string :=
apply
(Printf.sprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "]" % char
CamlinternalFormatBasics.End_of_format))) "[%s]" % string))
(Context_hash.to_string hash) in
make_equal_list Context_hash.op_eq pr_persist msg l1 l2.
src/lib_storage/test/test.ml 4 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let () =
Alcotest.run
"tezos-storage"
[("context", Test_context.tests); ("raw_store", Test_raw_store.tests)]
src/lib_storage/test/test.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations.
src/lib_storage/test/test_context.ml 67 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Context
let ( >>= ) = Lwt.bind
let ( >|= ) = Lwt.( >|= )
let ( // ) = Filename.concat
(** Basic blocks *)
let genesis_block =
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"
let genesis_protocol =
Protocol_hash.of_b58check_exn
"ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"
let genesis_time = Time.Protocol.of_seconds 0L
let chain_id = Chain_id.of_block_hash genesis_block
(** Context creation *)
let commit = commit ~time:Time.Protocol.epoch ~message:""
let block2 =
Block_hash.of_hex_exn
(`Hex "2222222222222222222222222222222222222222222222222222222222222222")
let create_block2 idx genesis_commit =
checkout idx genesis_commit
>>= function
| None ->
Assert.fail_msg "checkout genesis_block"
| Some ctxt ->
set ctxt ["a"; "b"] (Bytes.of_string "Novembre")
>>= fun ctxt ->
set ctxt ["a"; "c"] (Bytes.of_string "Juin")
>>= fun ctxt ->
set ctxt ["version"] (Bytes.of_string "0.0") >>= fun ctxt -> commit ctxt
let block3a =
Block_hash.of_hex_exn
(`Hex "3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a")
let create_block3a idx block2_commit =
checkout idx block2_commit
>>= function
| None ->
Assert.fail_msg "checkout block2"
| Some ctxt ->
del ctxt ["a"; "b"]
>>= fun ctxt ->
set ctxt ["a"; "d"] (Bytes.of_string "Mars") >>= fun ctxt -> commit ctxt
let block3b =
Block_hash.of_hex_exn
(`Hex "3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b")
let block3c =
Block_hash.of_hex_exn
(`Hex "3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c")
let create_block3b idx block2_commit =
checkout idx block2_commit
>>= function
| None ->
Assert.fail_msg "checkout block3b"
| Some ctxt ->
del ctxt ["a"; "c"]
>>= fun ctxt ->
set ctxt ["a"; "d"] (Bytes.of_string "Février")
>>= fun ctxt -> commit ctxt
type t = {
idx : Context.index;
genesis : Context_hash.t;
block2 : Context_hash.t;
block3a : Context_hash.t;
block3b : Context_hash.t;
}
let wrap_context_init f _ () =
Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
let root = base_dir // "context" in
Context.init ~mapsize:4_096_000L root
>>= fun idx ->
Context.commit_genesis
idx
~chain_id
~time:genesis_time
~protocol:genesis_protocol
>>= fun genesis ->
create_block2 idx genesis
>>= fun block2 ->
create_block3a idx block2
>>= fun block3a ->
create_block3b idx block2
>>= fun block3b ->
f {idx; genesis; block2; block3a; block3b}
>>= fun result -> Lwt.return result)
(** Simple test *)
let c = function None -> None | Some s -> Some (Bytes.to_string s)
let test_simple {idx; block2; _} =
checkout idx block2
>>= function
| None ->
Assert.fail_msg "checkout block2"
| Some ctxt ->
get ctxt ["version"]
>>= fun version ->
Assert.equal_string_option ~msg:__LOC__ (c version) (Some "0.0") ;
get ctxt ["a"; "b"]
>>= fun novembre ->
Assert.equal_string_option (Some "Novembre") (c novembre) ;
get ctxt ["a"; "c"]
>>= fun juin ->
Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
Lwt.return_unit
let test_continuation {idx; block3a; _} =
checkout idx block3a
>>= function
| None ->
Assert.fail_msg "checkout block3a"
| Some ctxt ->
get ctxt ["version"]
>>= fun version ->
Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ;
get ctxt ["a"; "b"]
>>= fun novembre ->
Assert.is_none ~msg:__LOC__ (c novembre) ;
get ctxt ["a"; "c"]
>>= fun juin ->
Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
get ctxt ["a"; "d"]
>>= fun mars ->
Assert.equal_string_option ~msg:__LOC__ (Some "Mars") (c mars) ;
Lwt.return_unit
let test_fork {idx; block3b; _} =
checkout idx block3b
>>= function
| None ->
Assert.fail_msg "checkout block3b"
| Some ctxt ->
get ctxt ["version"]
>>= fun version ->
Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ;
get ctxt ["a"; "b"]
>>= fun novembre ->
Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
get ctxt ["a"; "c"]
>>= fun juin ->
Assert.is_none ~msg:__LOC__ (c juin) ;
get ctxt ["a"; "d"]
>>= fun mars ->
Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ;
Lwt.return_unit
let test_replay {idx; genesis; _} =
checkout idx genesis
>>= function
| None ->
Assert.fail_msg "checkout genesis_block"
| Some ctxt0 ->
set ctxt0 ["version"] (Bytes.of_string "0.0")
>>= fun ctxt1 ->
set ctxt1 ["a"; "b"] (Bytes.of_string "Novembre")
>>= fun ctxt2 ->
set ctxt2 ["a"; "c"] (Bytes.of_string "Juin")
>>= fun ctxt3 ->
set ctxt3 ["a"; "d"] (Bytes.of_string "July")
>>= fun ctxt4a ->
set ctxt3 ["a"; "d"] (Bytes.of_string "Juillet")
>>= fun ctxt4b ->
set ctxt4a ["a"; "b"] (Bytes.of_string "November")
>>= fun ctxt5a ->
get ctxt4a ["a"; "b"]
>>= fun novembre ->
Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
get ctxt5a ["a"; "b"]
>>= fun november ->
Assert.equal_string_option ~msg:__LOC__ (Some "November") (c november) ;
get ctxt5a ["a"; "d"]
>>= fun july ->
Assert.equal_string_option ~msg:__LOC__ (Some "July") (c july) ;
get ctxt4b ["a"; "b"]
>>= fun novembre ->
Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
get ctxt4b ["a"; "d"]
>>= fun juillet ->
Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ;
Lwt.return_unit
let fold_keys s k ~init ~f =
let rec loop k acc =
fold s k ~init:acc ~f:(fun file acc ->
match file with `Key k -> f k acc | `Dir k -> loop k acc)
in
loop k init
let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
let test_fold {idx; genesis; _} =
checkout idx genesis
>>= function
| None ->
Assert.fail_msg "checkout genesis_block"
| Some ctxt ->
set ctxt ["a"; "b"] (Bytes.of_string "Novembre")
>>= fun ctxt ->
set ctxt ["a"; "c"] (Bytes.of_string "Juin")
>>= fun ctxt ->
set ctxt ["a"; "d"; "e"] (Bytes.of_string "Septembre")
>>= fun ctxt ->
set ctxt ["f"] (Bytes.of_string "Avril")
>>= fun ctxt ->
set ctxt ["g"; "h"] (Bytes.of_string "Avril")
>>= fun ctxt ->
keys ctxt []
>>= fun l ->
Assert.equal_string_list_list
~msg:__LOC__
[["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]; ["f"]; ["g"; "h"]]
(List.sort compare l) ;
keys ctxt ["a"]
>>= fun l ->
Assert.equal_string_list_list
~msg:__LOC__
[["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]]
(List.sort compare l) ;
keys ctxt ["f"]
>>= fun l ->
Assert.equal_string_list_list ~msg:__LOC__ [] l ;
keys ctxt ["g"]
>>= fun l ->
Assert.equal_string_list_list ~msg:__LOC__ [["g"; "h"]] l ;
keys ctxt ["i"]
>>= fun l ->
Assert.equal_string_list_list ~msg:__LOC__ [] l ;
Lwt.return_unit
let test_dump {idx; block3b; _} =
Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir2 ->
let dumpfile = base_dir2 // "dump" in
let ctxt_hash = block3b in
let history_mode = Tezos_shell_services.History_mode.Full in
let empty_block_header context =
Block_header.
{
protocol_data = Bytes.empty;
shell =
{
level = 0l;
proto_level = 0;
predecessor = Block_hash.zero;
timestamp = Time.Protocol.epoch;
validation_passes = 0;
operations_hash = Operation_list_list_hash.zero;
fitness = [];
context;
};
}
in
let _empty_pruned_block =
( {
block_header = empty_block_header Context_hash.zero;
operations = [];
operation_hashes = [];
}
: Context.Pruned_block.t )
in
let empty =
{
Context.Block_data.block_header = empty_block_header Context_hash.zero;
operations = [[]];
}
in
let bhs =
(fun context ->
( empty_block_header context,
empty,
history_mode,
fun _ -> return (None, None) ))
ctxt_hash
in
Context.dump_contexts idx bhs ~filename:dumpfile
>>=? fun () ->
let root = base_dir2 // "context" in
Context.init ?patch_context:None root
>>= fun idx2 ->
Context.restore_contexts
idx2
~filename:dumpfile
(fun _ -> return_unit)
(fun _ _ _ -> return_unit)
>>=? fun imported ->
let (bh, _, _, _, _, _) = imported in
let expected_ctxt_hash = bh.Block_header.shell.context in
assert (Context_hash.equal ctxt_hash expected_ctxt_hash) ;
return ())
>>= function
| Error err ->
Error_monad.pp_print_error Format.err_formatter err ;
assert false
| Ok () ->
Lwt.return_unit
(******************************************************************************)
let tests : (string * (t -> unit Lwt.t)) list =
[ ("simple", test_simple);
("continuation", test_continuation);
("fork", test_fork);
("replay", test_replay);
("fold", test_fold);
("dump", test_dump) ]
let tests =
List.map
(fun (s, f) -> Alcotest_lwt.test_case s `Quick (wrap_context_init f))
tests
src/lib_storage/test/test_context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Context.
Definition op_gtgteq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
Lwt.bind.
Definition op_gtpipeeq {A B : Type} : (Lwt.t A) -> (A -> B) -> Lwt.t B :=
Lwt.op_gtpipeeq.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.
Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
Protocol_hash.of_b58check_exn
"ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.
Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
Time.Protocol.of_seconds
(* ❌ Constant of type int64 is converted to int *)
0.
Definition chain_id : Tezos_base__TzPervasives.Chain_id.t :=
Chain_id.of_block_hash genesis_block.
Definition commit
: Tezos_storage.Context.context ->
Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
commit Time.Protocol.epoch (Some "" % string).
Definition block2 : Tezos_base__TzPervasives.Block_hash.t :=
Block_hash.of_hex_exn
(* ❌ Variants not supported *)
variant.
Definition create_block2
(idx : Tezos_storage.Context.index)
(genesis_commit : Tezos_base__TzPervasives.Context_hash.t)
: Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
op_gtgteq (checkout idx genesis_commit)
(fun function_parameter =>
match function_parameter with
| None => op_startypeminuserrorstar "checkout genesis_block" % string
| Some ctxt =>
op_gtgteq
(set ctxt (cons "a" % string (cons "b" % string []))
(Stdlib.Bytes.of_string "Novembre" % string))
(fun ctxt =>
op_gtgteq
(set ctxt (cons "a" % string (cons "c" % string []))
(Stdlib.Bytes.of_string "Juin" % string))
(fun ctxt =>
op_gtgteq
(set ctxt (cons "version" % string [])
(Stdlib.Bytes.of_string "0.0" % string))
(fun ctxt => commit ctxt)))
end).
Definition block3a : Tezos_base__TzPervasives.Block_hash.t :=
Block_hash.of_hex_exn
(* ❌ Variants not supported *)
variant.
Definition create_block3a
(idx : Tezos_storage.Context.index)
(block2_commit : Tezos_base__TzPervasives.Context_hash.t)
: Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
op_gtgteq (checkout idx block2_commit)
(fun function_parameter =>
match function_parameter with
| None => op_startypeminuserrorstar "checkout block2" % string
| Some ctxt =>
op_gtgteq (del ctxt (cons "a" % string (cons "b" % string [])))
(fun ctxt =>
op_gtgteq
(set ctxt (cons "a" % string (cons "d" % string []))
(Stdlib.Bytes.of_string "Mars" % string))
(fun ctxt => commit ctxt))
end).
Definition block3b : Tezos_base__TzPervasives.Block_hash.t :=
Block_hash.of_hex_exn
(* ❌ Variants not supported *)
variant.
Definition block3c : Tezos_base__TzPervasives.Block_hash.t :=
Block_hash.of_hex_exn
(* ❌ Variants not supported *)
variant.
Definition create_block3b
(idx : Tezos_storage.Context.index)
(block2_commit : Tezos_base__TzPervasives.Context_hash.t)
: Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
op_gtgteq (checkout idx block2_commit)
(fun function_parameter =>
match function_parameter with
| None => op_startypeminuserrorstar "checkout block3b" % string
| Some ctxt =>
op_gtgteq (del ctxt (cons "a" % string (cons "c" % string [])))
(fun ctxt =>
op_gtgteq
(set ctxt (cons "a" % string (cons "d" % string []))
(Stdlib.Bytes.of_string "Février" % string))
(fun ctxt => commit ctxt))
end).
Record t := {
idx : Tezos_storage.Context.index;
genesis : Tezos_base__TzPervasives.Context_hash.t;
block2 : Tezos_base__TzPervasives.Context_hash.t;
block3a : Tezos_base__TzPervasives.Context_hash.t;
block3b : Tezos_base__TzPervasives.Context_hash.t }.
Definition wrap_context_init {A B : Type}
(f : t -> Lwt.t A) (function_parameter : B) : unit -> Lwt.t A :=
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.with_tempdir "tezos_test_" % string
(fun base_dir =>
let root := op_divdiv base_dir "context" % string in
op_gtgteq
(Context.init None
(Some
(* ❌ Constant of type int64 is converted to int *)
4096000) None root)
(fun idx =>
op_gtgteq
(Context.commit_genesis idx chain_id genesis_time genesis_protocol)
(fun genesis =>
op_gtgteq (create_block2 idx genesis)
(fun block2 =>
op_gtgteq (create_block3a idx block2)
(fun block3a =>
op_gtgteq (create_block3b idx block2)
(fun block3b =>
op_gtgteq
(f
{| idx := idx; genesis := genesis;
block2 := block2; block3a := block3a;
block3b := block3b |})
(fun result => Lwt._return result))))))).
Definition c (function_parameter : option string) : option string :=
match function_parameter with
| None => None
| Some s => Some (Stdlib.Bytes.to_string s)
end.
Definition test_simple (function_parameter : t) : Lwt.t unit :=
let '{| idx := idx; block2 := block2 |} := function_parameter in
op_gtgteq (checkout idx block2)
(fun function_parameter =>
match function_parameter with
| None => op_startypeminuserrorstar "checkout block2" % string
| Some ctxt =>
op_gtgteq (get ctxt (cons "version" % string []))
(fun version =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ (c version)
(Some "0.0" % string) in
op_gtgteq (get ctxt (cons "a" % string (cons "b" % string [])))
(fun novembre =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar (Some "Novembre" % string)
(c novembre) in
op_gtgteq (get ctxt (cons "a" % string (cons "c" % string [])))
(fun juin =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(Some "Juin" % string) (c juin) in
Lwt.return_unit)))
end).
Definition test_continuation (function_parameter : t) : Lwt.t unit :=
let '{| idx := idx; block3a := block3a |} := function_parameter in
op_gtgteq (checkout idx block3a)
(fun function_parameter =>
match function_parameter with
| None => op_startypeminuserrorstar "checkout block3a" % string
| Some ctxt =>
op_gtgteq (get ctxt (cons "version" % string []))
(fun version =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ (Some "0.0" % string)
(c version) in
op_gtgteq (get ctxt (cons "a" % string (cons "b" % string [])))
(fun novembre =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ (c novembre)
in
op_gtgteq (get ctxt (cons "a" % string (cons "c" % string [])))
(fun juin =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(Some "Juin" % string) (c juin) in
op_gtgteq
(get ctxt (cons "a" % string (cons "d" % string [])))
(fun mars =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(Some "Mars" % string) (c mars) in
Lwt.return_unit))))
end).
Definition test_fork (function_parameter : t) : Lwt.t unit :=
let '{| idx := idx; block3b := block3b |} := function_parameter in
op_gtgteq (checkout idx block3b)
(fun function_parameter =>
match function_parameter with
| None => op_startypeminuserrorstar "checkout block3b" % string
| Some ctxt =>
op_gtgteq (get ctxt (cons "version" % string []))
(fun version =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__ (Some "0.0" % string)
(c version) in
op_gtgteq (get ctxt (cons "a" % string (cons "b" % string [])))
(fun novembre =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(Some "Novembre" % string) (c novembre) in
op_gtgteq (get ctxt (cons "a" % string (cons "c" % string [])))
(fun juin =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar Stdlib.__LOC__ (c juin)
in
op_gtgteq
(get ctxt (cons "a" % string (cons "d" % string [])))
(fun mars =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(Some "Février" % string) (c mars) in
Lwt.return_unit))))
end).
Definition test_replay (function_parameter : t) : Lwt.t unit :=
let '{| idx := idx; genesis := genesis |} := function_parameter in
op_gtgteq (checkout idx genesis)
(fun function_parameter =>
match function_parameter with
| None => op_startypeminuserrorstar "checkout genesis_block" % string
| Some ctxt0 =>
op_gtgteq
(set ctxt0 (cons "version" % string [])
(Stdlib.Bytes.of_string "0.0" % string))
(fun ctxt1 =>
op_gtgteq
(set ctxt1 (cons "a" % string (cons "b" % string []))
(Stdlib.Bytes.of_string "Novembre" % string))
(fun ctxt2 =>
op_gtgteq
(set ctxt2 (cons "a" % string (cons "c" % string []))
(Stdlib.Bytes.of_string "Juin" % string))
(fun ctxt3 =>
op_gtgteq
(set ctxt3 (cons "a" % string (cons "d" % string []))
(Stdlib.Bytes.of_string "July" % string))
(fun ctxt4a =>
op_gtgteq
(set ctxt3 (cons "a" % string (cons "d" % string []))
(Stdlib.Bytes.of_string "Juillet" % string))
(fun ctxt4b =>
op_gtgteq
(set ctxt4a
(cons "a" % string (cons "b" % string []))
(Stdlib.Bytes.of_string "November" % string))
(fun ctxt5a =>
op_gtgteq
(get ctxt4a
(cons "a" % string (cons "b" % string [])))
(fun novembre =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(Some "Novembre" % string) (c novembre)
in
op_gtgteq
(get ctxt5a
(cons "a" % string
(cons "b" % string [])))
(fun november =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(Some "November" % string)
(c november) in
op_gtgteq
(get ctxt5a
(cons "a" % string
(cons "d" % string [])))
(fun july =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(Some "July" % string) (c july)
in
op_gtgteq
(get ctxt4b
(cons "a" % string
(cons "b" % string [])))
(fun novembre =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(Some "Novembre" % string)
(c novembre) in
op_gtgteq
(get ctxt4b
(cons "a" % string
(cons "d" % string [])))
(fun juillet =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(Some "Juillet" % string)
(c juillet) in
Lwt.return_unit)))))))))))
end).
Definition fold_keys {A : Type}
(s : Tezos_storage.Context.context) (k : Tezos_storage.Context.key) (init : A)
(f : Tezos_storage.Context.key -> A -> Lwt.t A) : Lwt.t A :=
let fix loop (k : Tezos_storage.Context.key) (acc : A) : Lwt.t A :=
fold s k acc
(fun file =>
fun acc =>
match file with
| Key k => f k acc
| Dir k => loop k acc
end) in
loop k init.
Definition keys (t : Tezos_storage.Context.context)
: Tezos_storage.Context.key -> Lwt.t (list Tezos_storage.Context.key) :=
fold_keys t
(* ❌ expected an argument *)
expected_argument [] (fun k => fun acc => Lwt._return (cons k acc)).
Definition test_fold (function_parameter : t) : Lwt.t unit :=
let '{| idx := idx; genesis := genesis |} := function_parameter in
op_gtgteq (checkout idx genesis)
(fun function_parameter =>
match function_parameter with
| None => op_startypeminuserrorstar "checkout genesis_block" % string
| Some ctxt =>
op_gtgteq
(set ctxt (cons "a" % string (cons "b" % string []))
(Stdlib.Bytes.of_string "Novembre" % string))
(fun ctxt =>
op_gtgteq
(set ctxt (cons "a" % string (cons "c" % string []))
(Stdlib.Bytes.of_string "Juin" % string))
(fun ctxt =>
op_gtgteq
(set ctxt
(cons "a" % string
(cons "d" % string (cons "e" % string [])))
(Stdlib.Bytes.of_string "Septembre" % string))
(fun ctxt =>
op_gtgteq
(set ctxt (cons "f" % string [])
(Stdlib.Bytes.of_string "Avril" % string))
(fun ctxt =>
op_gtgteq
(set ctxt (cons "g" % string (cons "h" % string []))
(Stdlib.Bytes.of_string "Avril" % string))
(fun ctxt =>
op_gtgteq (keys ctxt [])
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(cons
(cons "a" % string (cons "b" % string []))
(cons
(cons "a" % string
(cons "c" % string []))
(cons
(cons "a" % string
(cons "d" % string
(cons "e" % string [])))
(cons (cons "f" % string [])
(cons
(cons "g" % string
(cons "h" % string [])) [])))))
(List.sort OCaml.Stdlib.compare l) in
op_gtgteq (keys ctxt (cons "a" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(cons
(cons "a" % string
(cons "b" % string []))
(cons
(cons "a" % string
(cons "c" % string []))
(cons
(cons "a" % string
(cons "d" % string
(cons "e" % string []))) [])))
(List.sort OCaml.Stdlib.compare l) in
op_gtgteq (keys ctxt (cons "f" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__ [] l in
op_gtgteq
(keys ctxt (cons "g" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(cons
(cons "g" % string
(cons "h" % string [])) [])
l in
op_gtgteq
(keys ctxt (cons "i" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__ [] l in
Lwt.return_unit))))))))))
end).
Definition test_dump (function_parameter : t) : Lwt.t unit :=
let '{| idx := idx; block3b := block3b |} := function_parameter in
op_gtgteq
(Lwt_utils_unix.with_tempdir "tezos_test_" % string
(fun base_dir2 =>
let dumpfile := op_divdiv base_dir2 "dump" % string in
let ctxt_hash := block3b in
let history_mode := Tezos_shell_services.History_mode.Full in
let empty_block_header (context : Tezos_crypto.Context_hash.t)
: Tezos_base__TzPervasives.Block_header.t :=
{|
shell :=
{|
level :=
(* ❌ Constant of type int32 is converted to int *)
0; proto_level := 0; predecessor := Block_hash.zero;
timestamp := Time.Protocol.epoch; validation_passes := 0;
operations_hash := Operation_list_list_hash.zero; fitness := [];
context := context |}; protocol_data := Stdlib.Bytes.empty |} in
let _empty_pruned_block :=
{| block_header := empty_block_header Context_hash.zero;
operations := []; operation_hashes := [] |} in
let empty :=
{|
Context.Block_data.block_header :=
empty_block_header Context_hash.zero;
Context.Block_data.operations := cons [] [] |} in
let bhs :=
(fun context =>
((empty_block_header context), empty, history_mode,
(fun function_parameter =>
let '_ := function_parameter in
_return (None, None)))) ctxt_hash in
op_gtgteqquestion (Context.dump_contexts idx bhs dumpfile)
(fun function_parameter =>
let 'tt := function_parameter in
let root := op_divdiv base_dir2 "context" % string in
op_gtgteq (Context.init None None None root)
(fun idx2 =>
op_gtgteqquestion
(Context.restore_contexts idx2 dumpfile
(fun function_parameter =>
let '_ := function_parameter in
return_unit)
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
return_unit))
(fun imported =>
let '(bh, _, _, _, _, _) := imported in
let expected_ctxt_hash := context (Block_header.shell bh) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (Context_hash.equal ctxt_hash expected_ctxt_hash)
in
_return tt)))))
(fun function_parameter =>
match function_parameter with
| Stdlib.Error err =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Error_monad.pp_print_error Format.err_formatter err in
(* ❌ Assert instruction is not handled. *)
assert false
| Stdlib.Ok tt => Lwt.return_unit
end).
Definition tests : list (string * (t -> Lwt.t unit)) :=
cons ("simple" % string, test_simple)
(cons ("continuation" % string, test_continuation)
(cons ("fork" % string, test_fork)
(cons ("replay" % string, test_replay)
(cons ("fold" % string, test_fold)
(cons ("dump" % string, test_dump) []))))).
Definition tests {A : Type} : list A :=
List.map
(fun function_parameter =>
let '(s, f) := function_parameter in
op_startypeminuserrorstar s
(* ❌ Variants not supported *)
variant (wrap_context_init f)) tests.
src/lib_storage/test/test_raw_store.ml 35 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Raw_store
let ( >>= ) = Lwt.bind
let ( >|= ) = Lwt.( >|= )
let ( // ) = Filename.concat
let wrap_store_init f _ () =
Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
let root = base_dir // "store" in
init ~mapsize:4_096_000L root
>>= function
| Error _ -> Assert.fail_msg "wrap_store_init" | Ok store -> f store)
let entries s k =
fold s k ~init:[] ~f:(fun e acc -> Lwt.return (e :: acc)) >|= List.rev
let test_fold st =
store st ["a"; "b"] (Bytes.of_string "Novembre")
>>= fun _ ->
store st ["a"; "c"] (Bytes.of_string "Juin")
>>= fun _ ->
store st ["a"; "d"; "e"] (Bytes.of_string "Septembre")
>>= fun _ ->
store st ["f"] (Bytes.of_string "Avril")
>>= fun _ ->
(* The code of '.' is just below the one of '/' ! *)
store st ["g"; ".12"; "a"] (Bytes.of_string "Mai")
>>= fun _ ->
store st ["g"; ".12"; "b"] (Bytes.of_string "Février")
>>= fun _ ->
store st ["g"; "123"; "456"] (Bytes.of_string "Mars")
>>= fun _ ->
store st ["g"; "1230"] (Bytes.of_string "Janvier")
>>= fun _ ->
entries st []
>>= fun l ->
Assert.equal_key_dir_list ~msg:__LOC__ [`Dir ["a"]; `Key ["f"]; `Dir ["g"]] l ;
entries st ["0"]
>>= fun l ->
Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
entries st ["0"; "1"]
>>= fun l ->
Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
entries st ["a"]
>>= fun l ->
Assert.equal_key_dir_list
~msg:__LOC__
[`Key ["a"; "b"]; `Key ["a"; "c"]; `Dir ["a"; "d"]]
l ;
entries st ["a"; "d"]
>>= fun l ->
Assert.equal_key_dir_list ~msg:__LOC__ [`Key ["a"; "d"; "e"]] l ;
entries st ["f"]
>>= fun l ->
Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
entries st ["f"; "z"]
>>= fun l ->
Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
entries st ["g"]
>>= fun l ->
Assert.equal_key_dir_list
~msg:__LOC__
[`Dir ["g"; ".12"]; `Dir ["g"; "123"]; `Key ["g"; "1230"]]
l ;
entries st ["g"; "123"]
>>= fun l ->
Assert.equal_key_dir_list ~msg:__LOC__ [`Key ["g"; "123"; "456"]] l ;
entries st ["z"]
>>= fun l ->
Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
Lwt.return_unit
let tests = [Alcotest_lwt.test_case "fold" `Quick (wrap_store_init test_fold)]
src/lib_storage/test/test_raw_store.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Raw_store.
Definition op_gtgteq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
Lwt.bind.
Definition op_gtpipeeq {A B : Type} : (Lwt.t A) -> (A -> B) -> Lwt.t B :=
Lwt.op_gtpipeeq.
Definition op_divdiv : string -> string -> string := Filename.concat.
Definition wrap_store_init {A B : Type}
(f : Tezos_storage.Raw_store.t -> Lwt.t A) (function_parameter : B)
: unit -> Lwt.t A :=
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Lwt_utils_unix.with_tempdir "tezos_test_" % string
(fun base_dir =>
let root := op_divdiv base_dir "store" % string in
op_gtgteq
(init None
(Some
(* ❌ Constant of type int64 is converted to int *)
4096000) root)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error _ =>
op_startypeminuserrorstar "wrap_store_init" % string
| Stdlib.Ok store => f store
end)).
Definition entries
(s : Tezos_storage.Raw_store.t) (k : Tezos_storage.Raw_store.key)
: Lwt.t (list variant) :=
op_gtpipeeq (fold s k [] (fun e => fun acc => Lwt._return (cons e acc)))
List.rev.
Definition test_fold (st : Tezos_storage.Raw_store.t) : Lwt.t unit :=
op_gtgteq
(store st (cons "a" % string (cons "b" % string []))
(Stdlib.Bytes.of_string "Novembre" % string))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(store st (cons "a" % string (cons "c" % string []))
(Stdlib.Bytes.of_string "Juin" % string))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(store st
(cons "a" % string (cons "d" % string (cons "e" % string [])))
(Stdlib.Bytes.of_string "Septembre" % string))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(store st (cons "f" % string [])
(Stdlib.Bytes.of_string "Avril" % string))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(store st
(cons "g" % string
(cons ".12" % string (cons "a" % string [])))
(Stdlib.Bytes.of_string "Mai" % string))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(store st
(cons "g" % string
(cons ".12" % string (cons "b" % string [])))
(Stdlib.Bytes.of_string "Février" % string))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(store st
(cons "g" % string
(cons "123" % string (cons "456" % string [])))
(Stdlib.Bytes.of_string "Mars" % string))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
(store st
(cons "g" % string (cons "1230" % string []))
(Stdlib.Bytes.of_string "Janvier" % string))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (entries st [])
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar Stdlib.__LOC__
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant []))) l in
op_gtgteq
(entries st (cons "0" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__ [] l in
op_gtgteq
(entries st
(cons "0" % string
(cons "1" % string [])))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__ [] l in
op_gtgteq
(entries st
(cons "a" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant []))) l in
op_gtgteq
(entries st
(cons "a" % string
(cons "d" % string [])))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(cons
(* ❌ Variants not supported *)
variant []) l in
op_gtgteq
(entries st
(cons "f" % string []))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__ []
l in
op_gtgteq
(entries st
(cons "f" % string
(cons
"z" % string
[])))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
[] l in
op_gtgteq
(entries st
(cons
"g" % string
[]))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
(cons
(* ❌ Variants not supported *)
variant
[])))
l in
op_gtgteq
(entries st
(cons
"g" %
string
(cons
"123"
%
string
[])))
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar
Stdlib.__LOC__
(cons
(* ❌ Variants not supported *)
variant
[])
l in
op_gtgteq
(entries
st
(cons
"z"
%
string
[]))
(fun l
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _
:=
op_startypeminuserrorstar
Stdlib.__LOC__
[]
l
in
Lwt.return_unit)))))))))))))))))).
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "fold" % string
(* ❌ Variants not supported *)
variant (wrap_store_init test_fold)) [].
src/lib_validation/block_validation.ml 14 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Block_validator_errors
type validation_store = {
context_hash : Context_hash.t;
message : string option;
max_operations_ttl : int;
last_allowed_fork_level : Int32.t;
}
let validation_store_encoding =
let open Data_encoding in
conv
(fun {context_hash; message; max_operations_ttl; last_allowed_fork_level} ->
(context_hash, message, max_operations_ttl, last_allowed_fork_level))
(fun (context_hash, message, max_operations_ttl, last_allowed_fork_level) ->
{context_hash; message; max_operations_ttl; last_allowed_fork_level})
(obj4
(req "context_hash" Context_hash.encoding)
(req "message" (option string))
(req "max_operations_ttl" int31)
(req "last_allowed_fork_level" int32))
type result = {
validation_store : validation_store;
block_metadata : Bytes.t;
ops_metadata : Bytes.t list list;
forking_testchain : bool;
}
let update_testchain_status ctxt predecessor_header timestamp =
Context.get_test_chain ctxt
>>= function
| Not_running ->
return ctxt
| Running {expiration; _} ->
if Time.Protocol.(expiration <= timestamp) then
Context.set_test_chain ctxt Not_running >>= fun ctxt -> return ctxt
else return ctxt
| Forking {protocol; expiration} ->
let predecessor_hash = Block_header.hash predecessor_header in
let genesis = Context.compute_testchain_genesis predecessor_hash in
let chain_id = Chain_id.of_block_hash genesis in
(* legacy semantics *)
Context.set_test_chain
ctxt
(Running {chain_id; genesis; protocol; expiration})
>>= fun ctxt -> return ctxt
let is_testchain_forking ctxt =
Context.get_test_chain ctxt
>>= function
| Not_running | Running _ -> Lwt.return_false | Forking _ -> Lwt.return_true
let init_test_chain ctxt forked_header =
Context.get_test_chain ctxt
>>= function
| Not_running | Running _ ->
assert false
| Forking {protocol; _} ->
( match Registered_protocol.get protocol with
| Some proto ->
return proto
| None ->
fail (Missing_test_protocol protocol) )
>>=? fun (module Proto_test) ->
let test_ctxt = Shell_context.wrap_disk_context ctxt in
Proto_test.init test_ctxt forked_header.Block_header.shell
>>=? fun {context = test_ctxt; _} ->
let test_ctxt = Shell_context.unwrap_disk_context test_ctxt in
Context.set_test_chain test_ctxt Not_running
>>= fun test_ctxt ->
Context.set_protocol test_ctxt protocol
>>= fun test_ctxt ->
Context.commit_test_chain_genesis test_ctxt forked_header
>>= fun genesis_header -> return genesis_header
let result_encoding =
let open Data_encoding in
conv
(fun {validation_store; block_metadata; ops_metadata; forking_testchain} ->
(validation_store, block_metadata, ops_metadata, forking_testchain))
(fun (validation_store, block_metadata, ops_metadata, forking_testchain) ->
{validation_store; block_metadata; ops_metadata; forking_testchain})
(obj4
(req "validation_store" validation_store_encoding)
(req "block_metadata" bytes)
(req "ops_metadata" (list @@ list @@ bytes))
(req "forking_testchain" bool))
let may_force_protocol_upgrade ~level
(validation_result : Tezos_protocol_environment.validation_result) =
match Block_header.get_forced_protocol_upgrade ~level with
| None ->
Lwt.return validation_result
| Some hash ->
let context =
Shell_context.unwrap_disk_context validation_result.context
in
Context.set_protocol context hash
>>= fun context ->
let context = Shell_context.wrap_disk_context context in
Lwt.return {validation_result with context}
(** Applies user activated updates based either on block level or on
voted protocols *)
let may_patch_protocol ~level
(validation_result : Tezos_protocol_environment.validation_result) =
let context = Shell_context.unwrap_disk_context validation_result.context in
Context.get_protocol context
>>= fun protocol ->
match Block_header.get_voted_protocol_overrides protocol with
| None ->
may_force_protocol_upgrade ~level validation_result
| Some replacement_protocol ->
Context.set_protocol context replacement_protocol
>>= fun context ->
let context = Shell_context.wrap_disk_context context in
Lwt.return {validation_result with context}
module Make (Proto : Registered_protocol.T) = struct
let check_block_header ~(predecessor_block_header : Block_header.t) hash
(block_header : Block_header.t) =
let validation_passes = List.length Proto.validation_passes in
fail_unless
( Int32.succ predecessor_block_header.shell.level
= block_header.shell.level )
( invalid_block hash
@@ Invalid_level
{
expected = Int32.succ predecessor_block_header.shell.level;
found = block_header.shell.level;
} )
>>=? fun () ->
fail_unless
Time.Protocol.(
predecessor_block_header.shell.timestamp < block_header.shell.timestamp)
(invalid_block hash Non_increasing_timestamp)
>>=? fun () ->
fail_unless
Fitness.(
predecessor_block_header.shell.fitness < block_header.shell.fitness)
(invalid_block hash Non_increasing_fitness)
>>=? fun () ->
fail_unless
(block_header.shell.validation_passes = validation_passes)
(invalid_block
hash
(Unexpected_number_of_validation_passes
block_header.shell.validation_passes))
>>=? fun () -> return_unit
let parse_block_header block_hash (block_header : Block_header.t) =
match
Data_encoding.Binary.of_bytes
Proto.block_header_data_encoding
block_header.protocol_data
with
| None ->
fail (invalid_block block_hash Cannot_parse_block_header)
| Some protocol_data ->
return
({shell = block_header.shell; protocol_data} : Proto.block_header)
let check_operation_quota block_hash operations =
let invalid_block = invalid_block block_hash in
iteri2_p
(fun i ops quota ->
fail_unless
(Option.unopt_map
~default:true
~f:(fun max -> List.length ops <= max)
quota.Tezos_protocol_environment.max_op)
(let max = Option.unopt ~default:~-1 quota.max_op in
invalid_block
(Too_many_operations {pass = i + 1; found = List.length ops; max}))
>>=? fun () ->
iter_p
(fun op ->
let size = Data_encoding.Binary.length Operation.encoding op in
fail_unless
(size <= Proto.max_operation_data_length)
(invalid_block
(Oversized_operation
{
operation = Operation.hash op;
size;
max = Proto.max_operation_data_length;
})))
ops
>>=? fun () -> return_unit)
operations
Proto.validation_passes
let parse_operations block_hash operations =
let invalid_block = invalid_block block_hash in
mapi_s
(fun pass ->
map_s (fun op ->
let op_hash = Operation.hash op in
match
Data_encoding.Binary.of_bytes
Proto.operation_data_encoding
op.Operation.proto
with
| None ->
fail (invalid_block (Cannot_parse_operation op_hash))
| Some protocol_data ->
let op = {Proto.shell = op.shell; protocol_data} in
let allowed_pass = Proto.acceptable_passes op in
fail_unless
(List.mem pass allowed_pass)
(invalid_block
(Unallowed_pass {operation = op_hash; pass; allowed_pass}))
>>=? fun () -> return op))
operations
let apply chain_id ~max_operations_ttl
~(predecessor_block_header : Block_header.t) ~predecessor_context
~(block_header : Block_header.t) operations =
let block_hash = Block_header.hash block_header in
let invalid_block = invalid_block block_hash in
check_block_header ~predecessor_block_header block_hash block_header
>>=? fun () ->
parse_block_header block_hash block_header
>>=? fun block_header ->
check_operation_quota block_hash operations
>>=? fun () ->
update_testchain_status
predecessor_context
predecessor_block_header
block_header.shell.timestamp
>>=? fun context ->
parse_operations block_hash operations
>>=? fun operations ->
let context = Shell_context.wrap_disk_context context in
Proto.begin_application
~chain_id
~predecessor_context:context
~predecessor_timestamp:predecessor_block_header.shell.timestamp
~predecessor_fitness:predecessor_block_header.shell.fitness
block_header
>>=? (fun state ->
fold_left_s
(fun (state, acc) ops ->
fold_left_s
(fun (state, acc) op ->
Proto.apply_operation state op
>>=? fun (state, op_metadata) ->
return (state, op_metadata :: acc))
(state, [])
ops
>>=? fun (state, ops_metadata) ->
return (state, List.rev ops_metadata :: acc))
(state, [])
operations
>>=? fun (state, ops_metadata) ->
let ops_metadata = List.rev ops_metadata in
Proto.finalize_block state
>>=? fun (validation_result, block_data) ->
return (validation_result, block_data, ops_metadata))
>>= (function
| Error err ->
fail (invalid_block (Economic_protocol_error err))
| Ok o ->
return o)
>>=? fun (validation_result, block_data, ops_metadata) ->
(* reset_test_chain
* validation_result.context
* current_block_header
* ~start_testchain >>=? fun forked_genesis_header -> *)
let context =
Shell_context.unwrap_disk_context validation_result.context
in
is_testchain_forking context
>>= fun forking_testchain ->
may_patch_protocol ~level:block_header.shell.level validation_result
>>= fun validation_result ->
let context =
Shell_context.unwrap_disk_context validation_result.context
in
Context.get_protocol context
>>= fun new_protocol ->
let expected_proto_level =
if Protocol_hash.equal new_protocol Proto.hash then
predecessor_block_header.shell.proto_level
else (predecessor_block_header.shell.proto_level + 1) mod 256
in
fail_when
(block_header.shell.proto_level <> expected_proto_level)
(invalid_block
(Invalid_proto_level
{
found = block_header.shell.proto_level;
expected = expected_proto_level;
}))
>>=? fun () ->
fail_when
Fitness.(validation_result.fitness <> block_header.shell.fitness)
(invalid_block
(Invalid_fitness
{
expected = block_header.shell.fitness;
found = validation_result.fitness;
}))
>>=? fun () ->
( if Protocol_hash.equal new_protocol Proto.hash then
return validation_result
else
match Registered_protocol.get new_protocol with
| None ->
fail
(Unavailable_protocol {block = block_hash; protocol = new_protocol})
| Some (module NewProto) ->
NewProto.init validation_result.context block_header.shell )
>>=? fun validation_result ->
let max_operations_ttl =
max 0 (min (max_operations_ttl + 1) validation_result.max_operations_ttl)
in
let validation_result = {validation_result with max_operations_ttl} in
let block_metadata =
Data_encoding.Binary.to_bytes_exn
Proto.block_header_metadata_encoding
block_data
in
let ops_metadata =
List.map
(List.map
(Data_encoding.Binary.to_bytes_exn Proto.operation_receipt_encoding))
ops_metadata
in
let context =
Shell_context.unwrap_disk_context validation_result.context
in
Context.commit
~time:block_header.shell.timestamp
?message:validation_result.message
context
>>= fun context_hash ->
let validation_store =
{
context_hash;
message = validation_result.message;
max_operations_ttl = validation_result.max_operations_ttl;
last_allowed_fork_level = validation_result.last_allowed_fork_level;
}
in
return {validation_store; block_metadata; ops_metadata; forking_testchain}
end
let assert_no_duplicate_operations block_hash live_operations operations =
fold_left_s
(fold_left_s (fun live_operations op ->
let oph = Operation.hash op in
fail_when
(Operation_hash.Set.mem oph live_operations)
(invalid_block block_hash @@ Replayed_operation oph)
>>=? fun () -> return (Operation_hash.Set.add oph live_operations)))
live_operations
operations
>>=? fun _ -> return_unit
let assert_operation_liveness block_hash live_blocks operations =
iter_s
(iter_s (fun op ->
fail_unless
(Block_hash.Set.mem op.Operation.shell.branch live_blocks)
( invalid_block block_hash
@@ Outdated_operation
{
operation = Operation.hash op;
originating_block = op.shell.branch;
} )))
operations
let check_liveness ~live_blocks ~live_operations block_hash operations =
assert_no_duplicate_operations block_hash live_operations operations
>>=? fun () ->
assert_operation_liveness block_hash live_blocks operations
>>=? fun () -> return_unit
let apply chain_id ~max_operations_ttl
~(predecessor_block_header : Block_header.t) ~predecessor_context
~(block_header : Block_header.t) operations =
let block_hash = Block_header.hash block_header in
Context.get_protocol predecessor_context
>>= fun pred_protocol_hash ->
( match Registered_protocol.get pred_protocol_hash with
| None ->
fail
(Unavailable_protocol
{block = block_hash; protocol = pred_protocol_hash})
| Some p ->
return p )
>>=? fun (module Proto) ->
let module Block_validation = Make (Proto) in
Block_validation.apply
chain_id
~max_operations_ttl
~predecessor_block_header
~predecessor_context
~block_header
operations
>>= function
| Error (Exn (Unix.Unix_error (errno, fn, msg)) :: _) ->
fail (System_error {errno = Unix.error_message errno; fn; msg})
| (Ok _ | Error _) as res ->
Lwt.return res
src/lib_validation/block_validation.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Block_validator_errors.
Record validation_store := {
context_hash : Tezos_base__TzPervasives.Context_hash.t;
message : option string;
max_operations_ttl : Z;
last_allowed_fork_level : Stdlib.Int32.t }.
Definition validation_store_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding validation_store :=
conv
(fun function_parameter =>
let '{|
context_hash := context_hash;
message := message;
max_operations_ttl := max_operations_ttl;
last_allowed_fork_level := last_allowed_fork_level
|} := function_parameter in
(context_hash, message, max_operations_ttl, last_allowed_fork_level))
(fun function_parameter =>
let
'(context_hash, message, max_operations_ttl, last_allowed_fork_level) :=
function_parameter in
{| context_hash := context_hash; message := message;
max_operations_ttl := max_operations_ttl;
last_allowed_fork_level := last_allowed_fork_level |}) None
(obj4 (req None None "context_hash" % string Context_hash.encoding)
(req None None "message" % string (option string))
(req None None "max_operations_ttl" % string int31)
(req None None "last_allowed_fork_level" % string int32)).
Record result := {
validation_store : validation_store;
block_metadata : Stdlib.Bytes.t;
ops_metadata : list (list Stdlib.Bytes.t);
forking_testchain : bool }.
Definition update_testchain_status
(ctxt : Tezos_storage.Context.context)
(predecessor_header : Tezos_base__TzPervasives.Block_header.t)
(timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_storage.Context.context) :=
op_gtgteq (Context.get_test_chain ctxt)
(fun function_parameter =>
match function_parameter with
| Tezos_base__TzPervasives.Test_chain_status.Not_running => _return ctxt
|
Tezos_base__TzPervasives.Test_chain_status.Running {|
expiration := expiration |} =>
if op_lteq expiration timestamp then
op_gtgteq
(Context.set_test_chain ctxt
Tezos_base__TzPervasives.Test_chain_status.Not_running)
(fun ctxt => _return ctxt)
else
_return ctxt
|
Tezos_base__TzPervasives.Test_chain_status.Forking {|
protocol := protocol; expiration := expiration |} =>
let predecessor_hash := Block_header.hash predecessor_header in
let genesis := Context.compute_testchain_genesis predecessor_hash in
let chain_id := Chain_id.of_block_hash genesis in
op_gtgteq
(Context.set_test_chain ctxt
(Tezos_base__TzPervasives.Test_chain_status.Running
{| chain_id := chain_id; genesis := genesis; protocol := protocol;
expiration := expiration |})) (fun ctxt => _return ctxt)
end).
Definition is_testchain_forking (ctxt : Tezos_storage.Context.context)
: Lwt.t bool :=
op_gtgteq (Context.get_test_chain ctxt)
(fun function_parameter =>
match function_parameter with
|
Tezos_base__TzPervasives.Test_chain_status.Not_running |
Tezos_base__TzPervasives.Test_chain_status.Running _ =>
Lwt.return_false
| Tezos_base__TzPervasives.Test_chain_status.Forking _ => Lwt.return_true
end).
Definition init_test_chain
(ctxt : Tezos_storage.Context.context)
(forked_header : Tezos_base__TzPervasives.Block_header.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_header.t) :=
op_gtgteq (Context.get_test_chain ctxt)
(fun function_parameter =>
match function_parameter with
|
Tezos_base__TzPervasives.Test_chain_status.Not_running |
Tezos_base__TzPervasives.Test_chain_status.Running _ =>
(* ❌ Assert instruction is not handled. *)
assert false
|
Tezos_base__TzPervasives.Test_chain_status.Forking {|
protocol := protocol |} =>
op_gtgteqquestion
match Registered_protocol.get protocol with
| Some proto => _return proto
| None =>
fail (Tezos_base__TzPervasives.Missing_test_protocol protocol)
end
(fun Proto_test =>
let Proto_test := projT2 Proto_test in
let test_ctxt := Shell_context.wrap_disk_context ctxt in
op_gtgteqquestion
(Proto_test.(Tezos_protocol_updater__Registered_protocol.T.init)
test_ctxt (Block_header.shell forked_header))
(fun function_parameter =>
let '{| context := test_ctxt |} := function_parameter in
let test_ctxt := Shell_context.unwrap_disk_context test_ctxt in
op_gtgteq
(Context.set_test_chain test_ctxt
Tezos_base__TzPervasives.Test_chain_status.Not_running)
(fun test_ctxt =>
op_gtgteq (Context.set_protocol test_ctxt protocol)
(fun test_ctxt =>
op_gtgteq
(Context.commit_test_chain_genesis test_ctxt
forked_header)
(fun genesis_header => _return genesis_header)))))
end).
Definition result_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding result :=
conv
(fun function_parameter =>
let '{|
validation_store := validation_store;
block_metadata := block_metadata;
ops_metadata := ops_metadata;
forking_testchain := forking_testchain
|} := function_parameter in
(validation_store, block_metadata, ops_metadata, forking_testchain))
(fun function_parameter =>
let
'(validation_store, block_metadata, ops_metadata, forking_testchain) :=
function_parameter in
{| validation_store := validation_store; block_metadata := block_metadata;
ops_metadata := ops_metadata; forking_testchain := forking_testchain |})
None
(obj4 (req None None "validation_store" % string validation_store_encoding)
(req None None "block_metadata" % string bytes)
(req None None "ops_metadata" % string
(apply
(let arg := list in
fun eta => arg None eta)
(apply
(let arg := list in
fun eta => arg None eta) bytes)))
(req None None "forking_testchain" % string bool)).
Definition may_force_protocol_upgrade
(level : Stdlib.Int32.t)
(validation_result : Tezos_protocol_environment.validation_result)
: Lwt.t Tezos_protocol_environment.validation_result :=
match Block_header.get_forced_protocol_upgrade level with
| None => Lwt._return validation_result
| Some hash =>
let context := Shell_context.unwrap_disk_context (context validation_result)
in
op_gtgteq (Context.set_protocol context hash)
(fun context =>
let context := Shell_context.wrap_disk_context context in
Lwt._return
(* ❌ Record substitution not handled *)
record_substitution)
end.
Definition may_patch_protocol
(level : Stdlib.Int32.t)
(validation_result : Tezos_protocol_environment.validation_result)
: Lwt.t Tezos_protocol_environment.validation_result :=
let context := Shell_context.unwrap_disk_context (context validation_result)
in
op_gtgteq (Context.get_protocol context)
(fun protocol =>
match Block_header.get_voted_protocol_overrides protocol with
| None => may_force_protocol_upgrade level validation_result
| Some replacement_protocol =>
op_gtgteq (Context.set_protocol context replacement_protocol)
(fun context =>
let context := Shell_context.wrap_disk_context context in
Lwt._return
(* ❌ Record substitution not handled *)
record_substitution)
end).
(* ❌ Functors are not handled. *)
functor
Definition assert_no_duplicate_operations
(block_hash : Tezos_base__TzPervasives.Block_hash.t)
(live_operations : Tezos_base__TzPervasives.Operation_hash.Set.t)
(operations : list (list Tezos_base__TzPervasives.Operation.t))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
(fold_left_s
(fold_left_s
(fun live_operations =>
fun op =>
let oph := Operation.hash op in
op_gtgteqquestion
(fail_when (Operation_hash.Set.mem oph live_operations)
(apply (invalid_block block_hash)
(Tezos_shell_services.Block_validator_errors.Replayed_operation
oph)))
(fun function_parameter =>
let 'tt := function_parameter in
_return (Operation_hash.Set.add oph live_operations))))
live_operations operations)
(fun function_parameter =>
let '_ := function_parameter in
return_unit).
Definition assert_operation_liveness
(block_hash : Tezos_base__TzPervasives.Block_hash.t)
(live_blocks : Tezos_base__TzPervasives.Block_hash.Set.t)
(operations : list (list Tezos_base__TzPervasives.Operation.t))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
iter_s
(iter_s
(fun op =>
fail_unless
(Block_hash.Set.mem (branch (Operation.shell op)) live_blocks)
(apply (invalid_block block_hash)
(Tezos_shell_services.Block_validator_errors.Outdated_operation
{| operation := Operation.hash op;
originating_block := branch (shell op) |})))) operations.
Definition check_liveness
(live_blocks : Tezos_base__TzPervasives.Block_hash.Set.t)
(live_operations : Tezos_base__TzPervasives.Operation_hash.Set.t)
(block_hash : Tezos_base__TzPervasives.Block_hash.t)
(operations : list (list Tezos_base__TzPervasives.Operation.t))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
(assert_no_duplicate_operations block_hash live_operations operations)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(assert_operation_liveness block_hash live_blocks operations)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)).
Definition apply
(chain_id : Tezos_base__TzPervasives.Chain_id.t) (max_operations_ttl : Z)
(predecessor_block_header : Tezos_base__TzPervasives.Block_header.t)
(predecessor_context : Tezos_storage.Context.context)
(block_header : Tezos_base__TzPervasives.Block_header.t)
(operations : list (list Tezos_base__TzPervasives.Operation.t))
: Lwt.t (Tezos_base__TzPervasives.tzresult result) :=
let block_hash := Block_header.hash block_header in
op_gtgteq (Context.get_protocol predecessor_context)
(fun pred_protocol_hash =>
op_gtgteqquestion
match Registered_protocol.get pred_protocol_hash with
| None =>
fail
(Tezos_base__TzPervasives.Unavailable_protocol
{| block := block_hash; protocol := pred_protocol_hash |})
| Some p => _return p
end
(fun Proto =>
let Proto := projT2 Proto in
let Block_validation :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
op_gtgteq
(Block_validation.apply chain_id max_operations_ttl
predecessor_block_header predecessor_context block_header
operations)
(fun function_parameter =>
match function_parameter with
|
Stdlib.Error
(cons (Tezos_base__TzPervasives.Exn (Unix_error errno fn msg))
_) =>
fail
(Tezos_base__TzPervasives.System_error
{| errno := Unix.error_message errno; fn := fn; msg := msg
|})
| (Stdlib.Ok _ | Stdlib.Error _) as res => Lwt._return res
end))).
src/lib_validation/external_validation.ml 8 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Labs. <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type parameters = {
context_root : string;
protocol_root : string;
sandbox_parameters : Data_encoding.json option;
}
type request =
| Init
| Validate of {
chain_id : Chain_id.t;
block_header : Block_header.t;
predecessor_block_header : Block_header.t;
operations : Operation.t list list;
max_operations_ttl : int;
}
| Commit_genesis of {
chain_id : Chain_id.t;
genesis_hash : Block_hash.t;
time : Time.Protocol.t;
protocol : Protocol_hash.t;
}
| Fork_test_chain of {
context_hash : Context_hash.t;
forked_header : Block_header.t;
}
| Terminate
let magic = Bytes.of_string "TEZOS_FORK_VALIDATOR_MAGIC_0"
let parameters_encoding =
let open Data_encoding in
conv
(fun {context_root; protocol_root; sandbox_parameters} ->
(context_root, protocol_root, sandbox_parameters))
(fun (context_root, protocol_root, sandbox_parameters) ->
{context_root; protocol_root; sandbox_parameters})
(obj3
(req "context_root" string)
(req "protocol_root" string)
(opt "sandbox_parameters" json))
let request_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"init"
empty
(function
| Init ->
Some ()
| Commit_genesis _ | Validate _ | Fork_test_chain _ | Terminate ->
None)
(fun () -> Init);
case
(Tag 1)
~title:"validate"
(obj5
(req "chain_id" Chain_id.encoding)
(req "block_header" (dynamic_size Block_header.encoding))
(req "pred_header" (dynamic_size Block_header.encoding))
(req "max_operations_ttl" int31)
(req "operations" (list (list (dynamic_size Operation.encoding)))))
(function
| Validate
{ chain_id;
block_header;
predecessor_block_header;
max_operations_ttl;
operations } ->
Some
( chain_id,
block_header,
predecessor_block_header,
max_operations_ttl,
operations )
| Init | Commit_genesis _ | Fork_test_chain _ | Terminate ->
None)
(fun ( chain_id,
block_header,
predecessor_block_header,
max_operations_ttl,
operations ) ->
Validate
{
chain_id;
block_header;
predecessor_block_header;
max_operations_ttl;
operations;
});
case
(Tag 2)
~title:"commit_genesis"
(obj4
(req "chain_id" Chain_id.encoding)
(req "time" Time.Protocol.encoding)
(req "genesis_hash" Block_hash.encoding)
(req "protocol" Protocol_hash.encoding))
(function
| Commit_genesis {chain_id; time; genesis_hash; protocol} ->
Some (chain_id, time, genesis_hash, protocol)
| Init | Validate _ | Fork_test_chain _ | Terminate ->
None)
(fun (chain_id, time, genesis_hash, protocol) ->
Commit_genesis {chain_id; time; genesis_hash; protocol});
case
(Tag 3)
~title:"fork_test_chain"
(obj2
(req "context_hash" Context_hash.encoding)
(req "forked_header" Block_header.encoding))
(function
| Fork_test_chain {context_hash; forked_header} ->
Some (context_hash, forked_header)
| Init | Validate _ | Commit_genesis _ | Terminate ->
None)
(fun (context_hash, forked_header) ->
Fork_test_chain {context_hash; forked_header});
case
(Tag 4)
~title:"terminate"
unit
(function
| Terminate ->
Some ()
| Init | Validate _ | Commit_genesis _ | Fork_test_chain _ ->
None)
(fun () -> Terminate) ]
let send pin encoding data =
let msg = Data_encoding.Binary.to_bytes_exn encoding data in
Lwt_io.write_int pin (Bytes.length msg)
>>= fun () ->
Lwt_io.write pin (Bytes.to_string msg) >>= fun () -> Lwt_io.flush pin
let recv_result pout encoding =
Lwt_io.read_int pout
>>= fun count ->
let buf = Bytes.create count in
Lwt_io.read_into_exactly pout buf 0 count
>>= fun () ->
Lwt.return
(Data_encoding.Binary.of_bytes_exn
(Error_monad.result_encoding encoding)
buf)
let recv pout encoding =
Lwt_io.read_int pout
>>= fun count ->
let buf = Bytes.create count in
Lwt_io.read_into_exactly pout buf 0 count
>>= fun () -> Lwt.return (Data_encoding.Binary.of_bytes_exn encoding buf)
src/lib_validation/external_validation.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record parameters := {
context_root : string;
protocol_root : string;
sandbox_parameters : option Tezos_base__TzPervasives.Data_encoding.json }.
Inductive request : Type :=
| Init : request
| Validate : Tezos_base__TzPervasives.Chain_id.t ->
Tezos_base__TzPervasives.Block_header.t ->
Tezos_base__TzPervasives.Block_header.t ->
(list (list Tezos_base__TzPervasives.Operation.t)) -> Z -> request
| Commit_genesis : Tezos_base__TzPervasives.Chain_id.t ->
Tezos_base__TzPervasives.Block_hash.t ->
Tezos_base__TzPervasives.Time.Protocol.t ->
Tezos_base__TzPervasives.Protocol_hash.t -> request
| Fork_test_chain : Tezos_base__TzPervasives.Context_hash.t ->
Tezos_base__TzPervasives.Block_header.t -> request
| Terminate : request.
Definition magic : string :=
Stdlib.Bytes.of_string "TEZOS_FORK_VALIDATOR_MAGIC_0" % string.
Definition parameters_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding parameters :=
conv
(fun function_parameter =>
let '{|
context_root := context_root;
protocol_root := protocol_root;
sandbox_parameters := sandbox_parameters
|} := function_parameter in
(context_root, protocol_root, sandbox_parameters))
(fun function_parameter =>
let '(context_root, protocol_root, sandbox_parameters) :=
function_parameter in
{| context_root := context_root; protocol_root := protocol_root;
sandbox_parameters := sandbox_parameters |}) None
(obj3 (req None None "context_root" % string string)
(req None None "protocol_root" % string string)
(opt None None "sandbox_parameters" % string json)).
Definition request_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding request :=
union None
(cons
(case "init" % string None (Tezos_base__TzPervasives.Data_encoding.Tag 0)
empty
(fun function_parameter =>
match function_parameter with
| Init => Some tt
| Commit_genesis _ | Validate _ | Fork_test_chain _ | Terminate =>
None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Init))
(cons
(case "validate" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj5 (req None None "chain_id" % string Chain_id.encoding)
(req None None "block_header" % string
(dynamic_size None Block_header.encoding))
(req None None "pred_header" % string
(dynamic_size None Block_header.encoding))
(req None None "max_operations_ttl" % string int31)
(req None None "operations" % string
(list None (list None (dynamic_size None Operation.encoding)))))
(fun function_parameter =>
match function_parameter with
|
Validate {|
chain_id := chain_id;
block_header := block_header;
predecessor_block_header := predecessor_block_header;
operations := operations;
max_operations_ttl := max_operations_ttl
|} =>
Some
(chain_id, block_header, predecessor_block_header,
max_operations_ttl, operations)
| Init | Commit_genesis _ | Fork_test_chain _ | Terminate => None
end)
(fun function_parameter =>
let
'(chain_id, block_header, predecessor_block_header,
max_operations_ttl, operations) := function_parameter in
Validate
{| chain_id := chain_id; block_header := block_header;
predecessor_block_header := predecessor_block_header;
operations := operations;
max_operations_ttl := max_operations_ttl |}))
(cons
(case "commit_genesis" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 2)
(obj4 (req None None "chain_id" % string Chain_id.encoding)
(req None None "time" % string Time.Protocol.encoding)
(req None None "genesis_hash" % string Block_hash.encoding)
(req None None "protocol" % string Protocol_hash.encoding))
(fun function_parameter =>
match function_parameter with
|
Commit_genesis {|
chain_id := chain_id;
genesis_hash := genesis_hash;
time := time;
protocol := protocol
|} => Some (chain_id, time, genesis_hash, protocol)
| Init | Validate _ | Fork_test_chain _ | Terminate => None
end)
(fun function_parameter =>
let '(chain_id, time, genesis_hash, protocol) :=
function_parameter in
Commit_genesis
{| chain_id := chain_id; genesis_hash := genesis_hash;
time := time; protocol := protocol |}))
(cons
(case "fork_test_chain" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 3)
(obj2
(req None None "context_hash" % string Context_hash.encoding)
(req None None "forked_header" % string Block_header.encoding))
(fun function_parameter =>
match function_parameter with
|
Fork_test_chain {|
context_hash := context_hash;
forked_header := forked_header
|} => Some (context_hash, forked_header)
| Init | Validate _ | Commit_genesis _ | Terminate => None
end)
(fun function_parameter =>
let '(context_hash, forked_header) := function_parameter in
Fork_test_chain
{| context_hash := context_hash;
forked_header := forked_header |}))
(cons
(case "terminate" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 4) unit
(fun function_parameter =>
match function_parameter with
| Terminate => Some tt
| Init | Validate _ | Commit_genesis _ | Fork_test_chain _ =>
None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Terminate)) []))))).
Definition send {A : Type}
(pin : Lwt_io.output_channel)
(encoding : Tezos_data_encoding__Data_encoding.Encoding.t A) (data : A)
: Lwt.t unit :=
let msg := Data_encoding.Binary.to_bytes_exn encoding data in
op_gtgteq (Lwt_io.write_int pin (String.length msg))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Lwt_io.write pin (Stdlib.Bytes.to_string msg))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt_io.flush pin)).
Definition recv_result {A : Type}
(pout : Lwt_io.input_channel)
(encoding : Tezos_data_encoding.Data_encoding.t A)
: Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult A) :=
op_gtgteq (Lwt_io.read_int pout)
(fun count =>
let buf := Stdlib.Bytes.create count in
op_gtgteq (Lwt_io.read_into_exactly pout buf 0 count)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return
(Data_encoding.Binary.of_bytes_exn
(Error_monad.result_encoding encoding) buf))).
Definition recv {A : Type}
(pout : Lwt_io.input_channel)
(encoding : Tezos_data_encoding__Data_encoding.Encoding.t A) : Lwt.t A :=
op_gtgteq (Lwt_io.read_int pout)
(fun count =>
let buf := Stdlib.Bytes.create count in
op_gtgteq (Lwt_io.read_into_exactly pout buf 0 count)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return (Data_encoding.Binary.of_bytes_exn encoding buf))).
src/lib_version/current_git_info.ml success
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* When we (or the CI) run "git archive", git substitutes the dollar-format part
because this file is marked as "export-subst" in ".gitattributes".
To know whether we are in a Git repository or in an archive, we check whether
the string was substituted. Thanks to this, we know whether we should get the
hash from Generated_git_info (not available in archives) or not. *)
let raw_commit_hash = "$Format:%H$"
let commit_hash =
if String.equal raw_commit_hash ("$Format" ^ ":%H$") then
Generated_git_info.commit_hash
else raw_commit_hash
let abbreviated_commit_hash =
if String.length commit_hash >= 8 then String.sub commit_hash 0 8
else commit_hash
let raw_committer_date = "$Format:%ci$"
let committer_date =
if String.equal raw_committer_date ("$Format" ^ ":%ci$") then
Generated_git_info.committer_date
else raw_committer_date
src/lib_version/current_git_info.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition raw_commit_hash : string := "$Format:%H$" % string.
Definition commit_hash : string :=
if
Stdlib.String.equal raw_commit_hash
(String.append "$Format" % string ":%H$" % string) then
Generated_git_info.commit_hash
else
raw_commit_hash.
Definition abbreviated_commit_hash : string :=
if OCaml.Stdlib.ge (OCaml.String.length commit_hash) 8 then
Stdlib.String.sub commit_hash 0 8
else
commit_hash.
Definition raw_committer_date : string := "$Format:%ci$" % string.
Definition committer_date : string :=
if
Stdlib.String.equal raw_committer_date
(String.append "$Format" % string ":%ci$" % string) then
Generated_git_info.committer_date
else
raw_committer_date.
src/proto_alpha/bin_accuser/main_accuser_alpha.ml 4 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Log = Internal_event.Legacy_logging.Make (struct
let name = "accuser.main"
end)
let () =
Client_commands.register Protocol.hash
@@ fun _network ->
List.map (Clic.map_command (new Protocol_client_context.wrap_full))
@@ Delegate_commands.accuser_commands ()
let select_commands _ _ =
return
(List.map
(Clic.map_command (new Protocol_client_context.wrap_full))
(Delegate_commands.accuser_commands ()))
let () =
Client_main_run.run
~log:(Log.fatal_error "%s")
(module Client_config)
~select_commands
src/proto_alpha/bin_accuser/main_accuser_alpha.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition select_commands {A B : Type} (function_parameter : A)
: B ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full))) :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
_return
(List.map
(Clic.map_command
(* ❌ Creation of new objects is not handled *)
new) (Delegate_commands.accuser_commands tt)).
src/proto_alpha/bin_baker/main_baker_alpha.ml 4 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Log = Internal_event.Legacy_logging.Make (struct
let name = "baker.main"
end)
let () =
Client_commands.register Protocol.hash
@@ fun _network ->
List.map (Clic.map_command (new Protocol_client_context.wrap_full))
@@ Delegate_commands.delegate_commands ()
let select_commands _ _ =
return
(List.map
(Clic.map_command (new Protocol_client_context.wrap_full))
(Delegate_commands.baker_commands ()))
let () =
Client_main_run.run
~log:(Log.fatal_error "%s")
(module Client_config)
~select_commands
src/proto_alpha/bin_baker/main_baker_alpha.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition select_commands {A B : Type} (function_parameter : A)
: B ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full))) :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
_return
(List.map
(Clic.map_command
(* ❌ Creation of new objects is not handled *)
new) (Delegate_commands.baker_commands tt)).
src/proto_alpha/bin_endorser/main_endorser_alpha.ml 4 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Log = Internal_event.Legacy_logging.Make (struct
let name = "endorser.main"
end)
let () =
Client_commands.register Protocol.hash
@@ fun _network ->
List.map (Clic.map_command (new Protocol_client_context.wrap_full))
@@ Delegate_commands.delegate_commands ()
let select_commands _ _ =
return
(List.map
(Clic.map_command (new Protocol_client_context.wrap_full))
(Delegate_commands.endorser_commands ()))
let () =
Client_main_run.run
~log:(Log.fatal_error "%s")
(module Client_config)
~select_commands
src/proto_alpha/bin_endorser/main_endorser_alpha.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition select_commands {A B : Type} (function_parameter : A)
: B ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_base.Client_context.full))) :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
_return
(List.map
(Clic.map_command
(* ❌ Creation of new objects is not handled *)
new) (Delegate_commands.endorser_commands tt)).
src/proto_alpha/lib_client/client_proto_args.ml 53 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol_client_context
open Protocol
open Alpha_context
open Clic
type error += Bad_tez_arg of string * string (* Arg_name * value *)
type error += Bad_max_priority of string
type error += Bad_minimal_fees of string
type error += Bad_max_waiting_time of string
type error += Bad_endorsement_delay of string
type error += Bad_preserved_levels of string
let () =
register_error_kind
`Permanent
~id:"badTezArg"
~title:"Bad Tez Arg"
~description:"Invalid \xEA\x9C\xA9 notation in parameter."
~pp:(fun ppf (arg_name, literal) ->
Format.fprintf
ppf
"Invalid \xEA\x9C\xA9 notation in parameter %s: '%s'"
arg_name
literal)
Data_encoding.(obj2 (req "parameter" string) (req "literal" string))
(function
| Bad_tez_arg (parameter, literal) ->
Some (parameter, literal)
| _ ->
None)
(fun (parameter, literal) -> Bad_tez_arg (parameter, literal)) ;
register_error_kind
`Permanent
~id:"badMaxPriorityArg"
~title:"Bad -max-priority arg"
~description:"invalid priority in -max-priority"
~pp:(fun ppf literal ->
Format.fprintf ppf "invalid priority '%s' in -max-priority" literal)
Data_encoding.(obj1 (req "parameter" string))
(function Bad_max_priority parameter -> Some parameter | _ -> None)
(fun parameter -> Bad_max_priority parameter) ;
register_error_kind
`Permanent
~id:"badMinimalFeesArg"
~title:"Bad -minimal-fees arg"
~description:"invalid fee threshold in -fee-threshold"
~pp:(fun ppf literal ->
Format.fprintf ppf "invalid minimal fees '%s'" literal)
Data_encoding.(obj1 (req "parameter" string))
(function Bad_minimal_fees parameter -> Some parameter | _ -> None)
(fun parameter -> Bad_minimal_fees parameter) ;
register_error_kind
`Permanent
~id:"badMaxWaitingTimeArg"
~title:"Bad -max-waiting-time arg"
~description:"invalid duration in -max-waiting-time"
~pp:(fun ppf literal ->
Format.fprintf
ppf
"Bad argument value for -max-waiting-time. Expected an integer, but \
given '%s'"
literal)
Data_encoding.(obj1 (req "parameter" string))
(function Bad_max_waiting_time parameter -> Some parameter | _ -> None)
(fun parameter -> Bad_max_waiting_time parameter) ;
register_error_kind
`Permanent
~id:"badEndorsementDelayArg"
~title:"Bad -endorsement-delay arg"
~description:"invalid duration in -endorsement-delay"
~pp:(fun ppf literal ->
Format.fprintf
ppf
"Bad argument value for -endorsement-delay. Expected an integer, but \
given '%s'"
literal)
Data_encoding.(obj1 (req "parameter" string))
(function Bad_endorsement_delay parameter -> Some parameter | _ -> None)
(fun parameter -> Bad_endorsement_delay parameter) ;
register_error_kind
`Permanent
~id:"badPreservedLevelsArg"
~title:"Bad -preserved-levels arg"
~description:"invalid number of levels in -preserved-levels"
~pp:(fun ppf literal ->
Format.fprintf
ppf
"Bad argument value for -preserved_levels. Expected a positive \
integer, but given '%s'"
literal)
Data_encoding.(obj1 (req "parameter" string))
(function Bad_preserved_levels parameter -> Some parameter | _ -> None)
(fun parameter -> Bad_preserved_levels parameter)
let tez_sym = "\xEA\x9C\xA9"
let string_parameter = parameter (fun _ x -> return x)
let int_parameter =
parameter (fun _ p ->
try return (int_of_string p) with _ -> failwith "Cannot read int")
let bytes_parameter =
parameter (fun _ s ->
try
if String.length s < 2 || s.[0] <> '0' || s.[1] <> 'x' then raise Exit
else
return (Hex.to_bytes (`Hex (String.sub s 2 (String.length s - 2))))
with _ ->
failwith
"Invalid bytes, expecting hexadecimal notation (e.g. 0x1234abcd)")
let init_arg =
default_arg
~long:"init"
~placeholder:"data"
~doc:"initial value of the contract's storage"
~default:"Unit"
string_parameter
let arg_arg =
arg
~long:"arg"
~placeholder:"data"
~doc:"argument passed to the contract's script, if needed"
string_parameter
let delegate_arg =
Client_keys.Public_key_hash.source_arg
~long:"delegate"
~placeholder:"address"
~doc:"delegate of the contract\nMust be a known address."
()
let source_arg =
arg
~long:"source"
~placeholder:"address"
~doc:"source of the deposits to be paid\nMust be a known address."
string_parameter
let entrypoint_arg =
arg
~long:"entrypoint"
~placeholder:"name"
~doc:"entrypoint of the smart contract"
string_parameter
let force_switch =
switch
~long:"force"
~short:'f'
~doc:
"disables the node's injection checks\n\
Force the injection of branch-invalid operation or force the \
injection of block without a fitness greater than the current head."
()
let minimal_timestamp_switch =
switch
~long:"minimal-timestamp"
~doc:
"Use the minimal timestamp instead of the current date as timestamp of \
the baked block."
()
let tez_format =
"Text format: `DDDDDDD.DDDDDD`.\n\
Tez and mutez and separated by a period sign. Trailing and pending zeroes \
are allowed."
let tez_parameter param =
parameter (fun _ s ->
match Tez.of_string s with
| Some tez ->
return tez
| None ->
fail (Bad_tez_arg (param, s)))
let tez_arg ~default ~parameter ~doc =
default_arg
~long:parameter
~placeholder:"amount"
~doc
~default
(tez_parameter ("--" ^ parameter))
let tez_param ~name ~desc next =
Clic.param
~name
~desc:(desc ^ " in \xEA\x9C\xA9\n" ^ tez_format)
(tez_parameter name)
next
let fee_arg =
arg
~long:"fee"
~placeholder:"amount"
~doc:"fee in \xEA\x9C\xA9 to pay to the baker"
(tez_parameter "--fee")
let gas_limit_arg =
arg
~long:"gas-limit"
~short:'G'
~placeholder:"amount"
~doc:
"Set the gas limit of the transaction instead of letting the client \
decide based on a simulation"
(parameter (fun _ s ->
try
let v = Z.of_string s in
assert (Compare.Z.(v >= Z.zero)) ;
return v
with _ -> failwith "invalid gas limit (must be a positive number)"))
let storage_limit_arg =
arg
~long:"storage-limit"
~short:'S'
~placeholder:"amount"
~doc:
"Set the storage limit of the transaction instead of letting the client \
decide based on a simulation"
(parameter (fun _ s ->
try
let v = Z.of_string s in
assert (Compare.Z.(v >= Z.zero)) ;
return v
with _ ->
failwith
"invalid storage limit (must be a positive number of bytes)"))
let counter_arg =
arg
~long:"counter"
~short:'C'
~placeholder:"counter"
~doc:"Set the counter to be used by the transaction"
(parameter (fun _ s ->
try
let v = Z.of_string s in
assert (Compare.Z.(v >= Z.zero)) ;
return v
with _ ->
failwith "invalid counter (must be a positive number of bytes)"))
let max_priority_arg =
arg
~long:"max-priority"
~placeholder:"slot"
~doc:"maximum allowed baking slot"
(parameter (fun _ s ->
try return (int_of_string s) with _ -> fail (Bad_max_priority s)))
let default_minimal_fees =
match Tez.of_mutez 100L with None -> assert false | Some t -> t
let default_minimal_nanotez_per_gas_unit = Z.of_int 100
let default_minimal_nanotez_per_byte = Z.of_int 1000
let minimal_fees_arg =
default_arg
~long:"minimal-fees"
~placeholder:"amount"
~doc:"exclude operations with fees lower than this threshold (in tez)"
~default:(Tez.to_string default_minimal_fees)
(parameter (fun _ s ->
match Tez.of_string s with
| Some t ->
return t
| None ->
fail (Bad_minimal_fees s)))
let minimal_nanotez_per_gas_unit_arg =
default_arg
~long:"minimal-nanotez-per-gas-unit"
~placeholder:"amount"
~doc:
"exclude operations with fees per gas lower than this threshold (in \
nanotez)"
~default:(Z.to_string default_minimal_nanotez_per_gas_unit)
(parameter (fun _ s ->
try return (Z.of_string s) with _ -> fail (Bad_minimal_fees s)))
let minimal_nanotez_per_byte_arg =
default_arg
~long:"minimal-nanotez-per-byte"
~placeholder:"amount"
~default:(Z.to_string default_minimal_nanotez_per_byte)
~doc:
"exclude operations with fees per byte lower than this threshold (in \
nanotez)"
(parameter (fun _ s ->
try return (Z.of_string s) with _ -> fail (Bad_minimal_fees s)))
let force_low_fee_arg =
switch
~long:"force-low-fee"
~doc:"Don't check that the fee is lower than the estimated default value"
()
let fee_cap_arg =
default_arg
~long:"fee-cap"
~placeholder:"amount"
~default:"1.0"
~doc:"Set the fee cap"
(parameter (fun _ s ->
match Tez.of_string s with
| Some t ->
return t
| None ->
failwith "Bad fee cap"))
let burn_cap_arg =
default_arg
~long:"burn-cap"
~placeholder:"amount"
~default:"0"
~doc:"Set the burn cap"
(parameter (fun _ s ->
match Tez.of_string s with
| Some t ->
return t
| None ->
failwith "Bad burn cap"))
let no_waiting_for_endorsements_arg =
switch
~long:"no-waiting-for-late-endorsements"
~doc:"Disable waiting for late endorsements"
()
let await_endorsements_arg =
switch
~long:"await-late-endorsements"
~doc:"Await late endorsements when baking a block"
()
let endorsement_delay_arg =
default_arg
~long:"endorsement-delay"
~placeholder:"seconds"
~doc:
"delay before endorsing blocks\n\
Delay between notifications of new blocks from the node and production \
of endorsements for these blocks."
~default:"5"
(parameter (fun _ s ->
try
let i = int_of_string s in
fail_when (i < 0) (Bad_endorsement_delay s)
>>=? fun () -> return (int_of_string s)
with _ -> fail (Bad_endorsement_delay s)))
let preserved_levels_arg =
default_arg
~long:"preserved-levels"
~placeholder:"threshold"
~doc:"Number of effective levels kept in the accuser's memory"
~default:"4096"
(parameter (fun _ s ->
try
let preserved_cycles = int_of_string s in
if preserved_cycles < 0 then fail (Bad_preserved_levels s)
else return preserved_cycles
with _ -> fail (Bad_preserved_levels s)))
let no_print_source_flag =
switch
~long:"no-print-source"
~short:'q'
~doc:
"don't print the source code\n\
If an error is encountered, the client will print the contract's \
source code by default.\n\
This option disables this behaviour."
()
let no_confirmation =
switch
~long:"no-confirmation"
~doc:"don't print wait for the operation to be confirmed."
()
let signature_parameter =
parameter (fun _cctxt s ->
match Signature.of_b58check_opt s with
| Some s ->
return s
| None ->
failwith "Not given a valid signature")
module Daemon = struct
let baking_switch =
switch ~long:"baking" ~short:'B' ~doc:"run the baking daemon" ()
let endorsement_switch =
switch ~long:"endorsement" ~short:'E' ~doc:"run the endorsement daemon" ()
let denunciation_switch =
switch
~long:"denunciation"
~short:'D'
~doc:"run the denunciation daemon"
()
end
src/proto_alpha/lib_client/client_proto_args.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol_client_context.
Import Protocol.
Import Alpha_context.
Import Clic.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition tez_sym : string := "ꜩ" % string.
Definition string_parameter {A : Type}
: Tezos_base__TzPervasives.Clic.parameter string A :=
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x => _return x).
Definition int_parameter {A : Type}
: Tezos_base__TzPervasives.Clic.parameter Z A :=
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun p =>
(* ❌ Try-with are not handled *)
try (_return (OCaml.Stdlib.int_of_string p))).
Definition bytes_parameter {A : Type}
: Tezos_base__TzPervasives.Clic.parameter string A :=
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try
(if
orb (OCaml.Stdlib.lt (String.length s) 2)
(orb (nequiv_decb (String.get s 0) "0" % char)
(nequiv_decb (String.get s 1) "x" % char)) then
Stdlib.raise Exit
else
_return
(Hex.to_bytes
(* ❌ Variants not supported *)
variant))).
Definition init_arg {A : Type} : Tezos_base__TzPervasives.Clic.arg string A :=
default_arg "initial value of the contract's storage" % string None
"init" % string "data" % string "Unit" % string string_parameter.
Definition arg_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg (option string) A :=
arg "argument passed to the contract's script, if needed" % string None
"arg" % string "data" % string string_parameter.
Definition delegate_arg {B a : Type}
: Tezos_base__TzPervasives.Clic.arg
(option Tezos_client_base.Client_keys.Public_key_hash.t)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) :=
Client_keys.Public_key_hash.source_arg (Some "delegate" % string)
(Some "address" % string)
(Some "delegate of the contract
Must be a known address." % string) tt.
Definition source_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg (option string) A :=
arg "source of the deposits to be paid
Must be a known address." % string None
"source" % string "address" % string string_parameter.
Definition entrypoint_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg (option string) A :=
arg "entrypoint of the smart contract" % string None "entrypoint" % string
"name" % string string_parameter.
Definition force_switch {A : Type} : Tezos_base__TzPervasives.Clic.arg bool A :=
switch
"disables the node's injection checks
Force the injection of branch-invalid operation or force the injection of block without a fitness greater than the current head."
% string (Some "f" % char) "force" % string tt.
Definition minimal_timestamp_switch {A : Type}
: Tezos_base__TzPervasives.Clic.arg bool A :=
switch
"Use the minimal timestamp instead of the current date as timestamp of the baked block."
% string None "minimal-timestamp" % string tt.
Definition tez_format : string :=
"Text format: `DDDDDDD.DDDDDD`.
Tez and mutez and separated by a period sign. Trailing and pending zeroes are allowed."
% string.
Definition tez_parameter {A : Type} (param : string)
: Tezos_base__TzPervasives.Clic.parameter
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
match Tez.of_string s with
| Some tez => _return tez
| None => fail (Tezos_base__TzPervasives.Bad_tez_arg param s)
end).
Definition tez_arg {A : Type}
(default : string) (parameter : string) (doc : string)
: Tezos_base__TzPervasives.Clic.arg
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
default_arg doc None parameter "amount" % string default
(tez_parameter (String.append "--" % string parameter)).
Definition tez_param {A B : Type}
(name : string) (desc : string)
(next : Tezos_base__TzPervasives.Clic.params A B)
: Tezos_base__TzPervasives.Clic.params
(Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez -> A) B :=
Clic.param name
(String.append desc (String.append " in ꜩ
" % string tez_format))
(tez_parameter name) next.
Definition fee_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg
(option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) A :=
arg "fee in ꜩ to pay to the baker" % string None "fee" % string
"amount" % string (tez_parameter "--fee" % string).
Definition gas_limit_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg (option Z.t) A :=
arg
"Set the gas limit of the transaction instead of letting the client decide based on a simulation"
% string (Some "G" % char) "gas-limit" % string "amount" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try
(let v := Z.of_string s in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (op_gteq v Z.zero) in
_return v))).
Definition storage_limit_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg (option Z.t) A :=
arg
"Set the storage limit of the transaction instead of letting the client decide based on a simulation"
% string (Some "S" % char) "storage-limit" % string "amount" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try
(let v := Z.of_string s in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (op_gteq v Z.zero) in
_return v))).
Definition counter_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg (option Z.t) A :=
arg "Set the counter to be used by the transaction" % string (Some "C" % char)
"counter" % string "counter" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try
(let v := Z.of_string s in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (op_gteq v Z.zero) in
_return v))).
Definition max_priority_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg (option Z) A :=
arg "maximum allowed baking slot" % string None "max-priority" % string
"slot" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try (_return (OCaml.Stdlib.int_of_string s)))).
Definition default_minimal_fees
: Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
match
Tez.of_mutez
(* ❌ Constant of type int64 is converted to int *)
100 with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some t => t
end.
Definition default_minimal_nanotez_per_gas_unit : Z.t := Z.of_int 100.
Definition default_minimal_nanotez_per_byte : Z.t := Z.of_int 1000.
Definition minimal_fees_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
default_arg
"exclude operations with fees lower than this threshold (in tez)" % string
None "minimal-fees" % string "amount" % string
(Tez.to_string default_minimal_fees)
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
match Tez.of_string s with
| Some t => _return t
| None => fail (Tezos_base__TzPervasives.Bad_minimal_fees s)
end)).
Definition minimal_nanotez_per_gas_unit_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg Z.t A :=
default_arg
"exclude operations with fees per gas lower than this threshold (in nanotez)"
% string None "minimal-nanotez-per-gas-unit" % string "amount" % string
(Z.to_string default_minimal_nanotez_per_gas_unit)
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try (_return (Z.of_string s)))).
Definition minimal_nanotez_per_byte_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg Z.t A :=
default_arg
"exclude operations with fees per byte lower than this threshold (in nanotez)"
% string None "minimal-nanotez-per-byte" % string "amount" % string
(Z.to_string default_minimal_nanotez_per_byte)
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try (_return (Z.of_string s)))).
Definition force_low_fee_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg bool A :=
switch
"Don't check that the fee is lower than the estimated default value" %
string None "force-low-fee" % string tt.
Definition fee_cap_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
default_arg "Set the fee cap" % string None "fee-cap" % string
"amount" % string "1.0" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
match Tez.of_string s with
| Some t => _return t
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Bad fee cap" % string
CamlinternalFormatBasics.End_of_format) "Bad fee cap" % string)
end)).
Definition burn_cap_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
default_arg "Set the burn cap" % string None "burn-cap" % string
"amount" % string "0" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
match Tez.of_string s with
| Some t => _return t
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Bad burn cap" % string
CamlinternalFormatBasics.End_of_format)
"Bad burn cap" % string)
end)).
Definition no_waiting_for_endorsements_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg bool A :=
switch "Disable waiting for late endorsements" % string None
"no-waiting-for-late-endorsements" % string tt.
Definition await_endorsements_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg bool A :=
switch "Await late endorsements when baking a block" % string None
"await-late-endorsements" % string tt.
Definition endorsement_delay_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg Z A :=
default_arg
"delay before endorsing blocks
Delay between notifications of new blocks from the node and production of endorsements for these blocks."
% string None "endorsement-delay" % string "seconds" % string "5" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try
(let i := OCaml.Stdlib.int_of_string s in
op_gtgteqquestion
(fail_when (OCaml.Stdlib.lt i 0)
(Tezos_base__TzPervasives.Bad_endorsement_delay s))
(fun function_parameter =>
let 'tt := function_parameter in
_return (OCaml.Stdlib.int_of_string s))))).
Definition preserved_levels_arg {A : Type}
: Tezos_base__TzPervasives.Clic.arg Z A :=
default_arg "Number of effective levels kept in the accuser's memory" % string
None "preserved-levels" % string "threshold" % string "4096" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try
(let preserved_cycles := OCaml.Stdlib.int_of_string s in
if OCaml.Stdlib.lt preserved_cycles 0 then
fail (Tezos_base__TzPervasives.Bad_preserved_levels s)
else
_return preserved_cycles))).
Definition no_print_source_flag {A : Type}
: Tezos_base__TzPervasives.Clic.arg bool A :=
switch
"don't print the source code
If an error is encountered, the client will print the contract's source code by default.
This option disables this behaviour."
% string (Some "q" % char) "no-print-source" % string tt.
Definition no_confirmation {A : Type}
: Tezos_base__TzPervasives.Clic.arg bool A :=
switch "don't print wait for the operation to be confirmed." % string None
"no-confirmation" % string tt.
Definition signature_parameter {A : Type}
: Tezos_base__TzPervasives.Clic.parameter Tezos_base__TzPervasives.Signature.t
A :=
parameter None
(fun _cctxt =>
fun s =>
match Signature.of_b58check_opt s with
| Some s => _return s
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Not given a valid signature" % string
CamlinternalFormatBasics.End_of_format)
"Not given a valid signature" % string)
end).
Module Daemon.
Definition baking_switch {A : Type}
: Tezos_base__TzPervasives.Clic.arg bool A :=
switch "run the baking daemon" % string (Some "B" % char) "baking" % string
tt.
Definition endorsement_switch {A : Type}
: Tezos_base__TzPervasives.Clic.arg bool A :=
switch "run the endorsement daemon" % string (Some "E" % char)
"endorsement" % string tt.
Definition denunciation_switch {A : Type}
: Tezos_base__TzPervasives.Clic.arg bool A :=
switch "run the denunciation daemon" % string (Some "D" % char)
"denunciation" % string tt.
End Daemon.
src/proto_alpha/lib_client/client_proto_context.ml 1572 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Protocol_client_context
open Tezos_micheline
open Client_proto_contracts
open Client_keys
let get_balance (rpc : #rpc_context) ~chain ~block contract =
Alpha_services.Contract.balance rpc (chain, block) contract
let get_storage (rpc : #rpc_context) ~chain ~block contract =
Alpha_services.Contract.storage_opt rpc (chain, block) contract
let get_big_map_value (rpc : #rpc_context) ~chain ~block id key =
Alpha_services.Contract.big_map_get rpc (chain, block) id key
let get_contract_big_map_value (rpc : #rpc_context) ~chain ~block contract key
=
Alpha_services.Contract.contract_big_map_get_opt
rpc
(chain, block)
contract
key
let get_script (rpc : #rpc_context) ~chain ~block contract =
Alpha_services.Contract.script_opt rpc (chain, block) contract
let parse_expression arg =
Lwt.return
(Micheline_parser.no_parsing_error
(Michelson_v1_parser.parse_expression arg))
let transfer (cctxt : #full) ~chain ~block ?confirmations ?dry_run
?verbose_signing ?branch ~source ~src_pk ~src_sk ~destination
?(entrypoint = "default") ?arg ~amount ?fee ?gas_limit ?storage_limit
?counter ~fee_parameter () =
( match arg with
| Some arg ->
parse_expression arg >>=? fun {expanded = arg; _} -> return_some arg
| None ->
return_none )
>>=? fun parameters ->
let parameters =
Option.unopt_map
~f:Script.lazy_expr
~default:Script.unit_parameter
parameters
in
let contents = Transaction {amount; parameters; destination; entrypoint} in
Injection.inject_manager_operation
cctxt
~chain
~block
?confirmations
?dry_run
?verbose_signing
?branch
~source
?fee
?gas_limit
?storage_limit
?counter
~src_pk
~src_sk
~fee_parameter
contents
>>=? fun ((_oph, _op, result) as res) ->
Lwt.return (Injection.originated_contracts (Single_result result))
>>=? fun contracts -> return (res, contracts)
let reveal cctxt ~chain ~block ?confirmations ?dry_run ?verbose_signing ?branch
~source ~src_pk ~src_sk ?fee ~fee_parameter () =
let (compute_fee, fee) =
match fee with None -> (true, Tez.zero) | Some fee -> (false, fee)
in
Alpha_services.Contract.counter cctxt (chain, block) source
>>=? fun pcounter ->
let counter = Z.succ pcounter in
Alpha_services.Contract.manager_key cctxt (chain, block) source
>>=? fun key ->
match key with
| Some _ ->
failwith "The manager key was previously revealed."
| None -> (
let contents =
Single
(Manager_operation
{
source;
fee;
counter;
gas_limit = Z.of_int ~-1;
storage_limit = Z.zero;
operation = Reveal src_pk;
})
in
Injection.inject_operation
cctxt
~chain
~block
?confirmations
?dry_run
?verbose_signing
?branch
~src_sk
~compute_fee
~fee_parameter
contents
>>=? fun (oph, op, result) ->
match Apply_results.pack_contents_list op result with
| Apply_results.Single_and_result ((Manager_operation _ as op), result)
->
return (oph, op, result) )
let delegate_contract cctxt ~chain ~block ?branch ?confirmations ?dry_run
?verbose_signing ~source ~src_pk ~src_sk ?fee ~fee_parameter delegate_opt =
let operation = Delegation delegate_opt in
Injection.inject_manager_operation
cctxt
~chain
~block
?confirmations
?dry_run
?verbose_signing
?branch
~source
?fee
~storage_limit:Z.zero
~src_pk
~src_sk
~fee_parameter
operation
>>=? fun res -> return res
let list_contract_labels cctxt ~chain ~block =
Alpha_services.Contract.list cctxt (chain, block)
>>=? fun contracts ->
rev_map_s
(fun h ->
( match Contract.is_implicit h with
| Some m -> (
Public_key_hash.rev_find cctxt m
>>=? function
| None ->
return ""
| Some nm -> (
RawContractAlias.find_opt cctxt nm
>>=? function
| None ->
return (" (known as " ^ nm ^ ")")
| Some _ ->
return (" (known as key:" ^ nm ^ ")") ) )
| None -> (
RawContractAlias.rev_find cctxt h
>>=? function
| None -> return "" | Some nm -> return (" (known as " ^ nm ^ ")") )
)
>>=? fun nm ->
let kind =
match Contract.is_implicit h with
| Some _ ->
" (implicit)"
| None ->
""
in
let h_b58 = Contract.to_b58check h in
return (nm, h_b58, kind))
contracts
>>|? List.rev
let message_added_contract (cctxt : #full) name =
cctxt#message "Contract memorized as %s." name
let set_delegate cctxt ~chain ~block ?confirmations ?dry_run ?verbose_signing
?fee contract ~src_pk ~manager_sk ~fee_parameter opt_delegate =
delegate_contract
cctxt
~chain
~block
?confirmations
?dry_run
?verbose_signing
~source:contract
~src_pk
~src_sk:manager_sk
?fee
~fee_parameter
opt_delegate
let register_as_delegate cctxt ~chain ~block ?confirmations ?dry_run
?verbose_signing ?fee ~manager_sk ~fee_parameter src_pk =
let source = Signature.Public_key.hash src_pk in
delegate_contract
cctxt
~chain
~block
?confirmations
?dry_run
?verbose_signing
~source
~src_pk
~src_sk:manager_sk
?fee
~fee_parameter
(Some source)
let save_contract ~force cctxt alias_name contract =
RawContractAlias.add ~force cctxt alias_name contract
>>=? fun () ->
message_added_contract cctxt alias_name >>= fun () -> return_unit
let originate_contract (cctxt : #full) ~chain ~block ?confirmations ?dry_run
?verbose_signing ?branch ?fee ?gas_limit ?storage_limit ~delegate
~initial_storage ~balance ~source ~src_pk ~src_sk ~code ~fee_parameter () =
(* With the change of making implicit accounts delegatable, the following
3 arguments are being defaulted before they can be safely removed. *)
Lwt.return (Michelson_v1_parser.parse_expression initial_storage)
>>= fun result ->
Lwt.return (Micheline_parser.no_parsing_error result)
>>=? fun {Michelson_v1_parser.expanded = storage; _} ->
let code = Script.lazy_expr code and storage = Script.lazy_expr storage in
let origination =
Origination
{
delegate;
script = {code; storage};
credit = balance;
preorigination = None;
}
in
Injection.inject_manager_operation
cctxt
~chain
~block
?confirmations
?dry_run
?verbose_signing
?branch
~source
?fee
?gas_limit
?storage_limit
~src_pk
~src_sk
~fee_parameter
origination
>>=? fun ((_oph, _op, result) as res) ->
Lwt.return (Injection.originated_contracts (Single_result result))
>>=? function
| [contract] ->
return (res, contract)
| contracts ->
failwith
"The origination introduced %d contracts instead of one."
(List.length contracts)
type activation_key = {
pkh : Ed25519.Public_key_hash.t;
amount : Tez.t;
activation_code : Blinded_public_key_hash.activation_code;
mnemonic : string list;
password : string;
email : string;
}
let raw_activation_key_encoding =
let open Data_encoding in
obj6
(req "pkh" Ed25519.Public_key_hash.encoding)
(req "amount" Tez.encoding)
(req "activation_code" Blinded_public_key_hash.activation_code_encoding)
(req "mnemonic" (list string))
(req "password" string)
(req "email" string)
let activation_key_encoding =
(* Hack: allow compatibility with older encoding *)
let open Data_encoding in
conv
(fun {pkh; amount; activation_code; mnemonic; password; email} ->
(pkh, amount, activation_code, mnemonic, password, email))
(fun (pkh, amount, activation_code, mnemonic, password, email) ->
{pkh; amount; activation_code; mnemonic; password; email})
@@ splitted
~binary:raw_activation_key_encoding
~json:
(union
[ case
~title:"Activation"
Json_only
raw_activation_key_encoding
(fun x -> Some x)
(fun x -> x);
case
~title:"Deprecated_activation"
Json_only
(obj6
(req "pkh" Ed25519.Public_key_hash.encoding)
(req "amount" Tez.encoding)
(req
"secret"
Blinded_public_key_hash.activation_code_encoding)
(req "mnemonic" (list string))
(req "password" string)
(req "email" string))
(fun _ -> None)
(fun x -> x) ])
let read_key key =
match Bip39.of_words key.mnemonic with
| None ->
failwith ""
| Some t ->
(* TODO: unicode normalization (NFKD)... *)
let passphrase =
Bigstring.(concat "" [of_string key.email; of_string key.password])
in
let sk = Bip39.to_seed ~passphrase t in
let sk = Bigstring.sub_bytes sk 0 32 in
let sk : Signature.Secret_key.t =
Ed25519
(Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk)
in
let pk = Signature.Secret_key.to_public_key sk in
let pkh = Signature.Public_key.hash pk in
return (pkh, pk, sk)
let inject_activate_operation cctxt ~chain ~block ?confirmations ?dry_run alias
pkh activation_code =
let contents = Single (Activate_account {id = pkh; activation_code}) in
Injection.inject_operation
cctxt
?confirmations
?dry_run
~chain
~block
~fee_parameter:Injection.dummy_fee_parameter
contents
>>=? fun (oph, op, result) ->
( match confirmations with
| None ->
return_unit
| Some _confirmations ->
Alpha_services.Contract.balance
cctxt
(chain, block)
(Contract.implicit_contract (Ed25519 pkh))
>>=? fun balance ->
cctxt#message
"Account %s (%a) activated with %s%a."
alias
Ed25519.Public_key_hash.pp
pkh
Client_proto_args.tez_sym
Tez.pp
balance
>>= fun () -> return_unit )
>>=? fun () ->
match Apply_results.pack_contents_list op result with
| Apply_results.Single_and_result ((Activate_account _ as op), result) ->
return (oph, op, result)
let activate_account (cctxt : #full) ~chain ~block ?confirmations ?dry_run
?(encrypted = false) ?force key name =
read_key key
>>=? fun (pkh, pk, sk) ->
fail_unless
(Signature.Public_key_hash.equal pkh (Ed25519 key.pkh))
(failure
"@[<v 2>Inconsistent activation key:@ Computed pkh: %a@ Embedded pkh: \
%a @]"
Signature.Public_key_hash.pp
pkh
Ed25519.Public_key_hash.pp
key.pkh)
>>=? fun () ->
let pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in
( if encrypted then Tezos_signer_backends.Encrypted.encrypt cctxt sk
else return (Tezos_signer_backends.Unencrypted.make_sk sk) )
>>=? fun sk_uri ->
Client_keys.register_key cctxt ?force (pkh, pk_uri, sk_uri) name
>>=? fun () ->
inject_activate_operation
cctxt
~chain
~block
?confirmations
?dry_run
name
key.pkh
key.activation_code
let activate_existing_account (cctxt : #full) ~chain ~block ?confirmations
?dry_run alias activation_code =
Client_keys.alias_keys cctxt alias
>>=? function
| Some (Ed25519 pkh, _, _) ->
inject_activate_operation
cctxt
~chain
~block
?confirmations
?dry_run
alias
pkh
activation_code
| Some _ ->
failwith "Only Ed25519 accounts can be activated"
| None ->
failwith "Unknown account"
type period_info = {
current_period_kind : Voting_period.kind;
position : Int32.t;
remaining : Int32.t;
current_proposal : Protocol_hash.t option;
}
type ballots_info = {
current_quorum : Int32.t;
participation : Int32.t;
supermajority : Int32.t;
ballots : Vote.ballots;
}
let get_ballots_info (cctxt : #full) ~chain ~block =
(* Get the next level, not the current *)
let cb = (chain, block) in
Alpha_services.Voting.ballots cctxt cb
>>=? fun ballots ->
Alpha_services.Voting.current_quorum cctxt cb
>>=? fun current_quorum ->
Alpha_services.Voting.listings cctxt cb
>>=? fun listings ->
let max_participation =
List.fold_left (fun acc (_, w) -> Int32.add w acc) 0l listings
in
let all_votes = Int32.(add (add ballots.yay ballots.nay) ballots.pass) in
let participation = Int32.(div (mul all_votes 100_00l) max_participation) in
let supermajority = Int32.(div (mul 8l (add ballots.yay ballots.nay)) 10l) in
return {current_quorum; participation; supermajority; ballots}
let get_period_info (cctxt : #full) ~chain ~block =
(* Get the next level, not the current *)
let cb = (chain, block) in
Alpha_services.Helpers.current_level cctxt ~offset:1l cb
>>=? fun level ->
Alpha_services.Constants.all cctxt cb
>>=? fun constants ->
Alpha_services.Voting.current_proposal cctxt cb
>>=? fun current_proposal ->
let position = level.voting_period_position in
let remaining =
Int32.(sub constants.parametric.blocks_per_voting_period position)
in
Alpha_services.Voting.current_period_kind cctxt cb
>>=? fun current_period_kind ->
return {current_period_kind; position; remaining; current_proposal}
let get_proposals (cctxt : #full) ~chain ~block =
let cb = (chain, block) in
Alpha_services.Voting.proposals cctxt cb
let submit_proposals ?dry_run ?verbose_signing (cctxt : #full) ~chain ~block
?confirmations ~src_sk source proposals =
(* We need the next level, not the current *)
Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, block)
>>=? fun (level : Level.t) ->
let period = level.voting_period in
let contents = Single (Proposals {source; period; proposals}) in
Injection.inject_operation
cctxt
~chain
~block
?confirmations
~fee_parameter:Injection.dummy_fee_parameter
?dry_run
~src_sk
contents
?verbose_signing
let submit_ballot ?dry_run ?verbose_signing (cctxt : #full) ~chain ~block
?confirmations ~src_sk source proposal ballot =
(* The user must provide the proposal explicitly to make himself sure
for what he is voting. *)
Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, block)
>>=? fun (level : Level.t) ->
let period = level.voting_period in
let contents = Single (Ballot {source; period; proposal; ballot}) in
Injection.inject_operation
cctxt
~chain
~block
?confirmations
~fee_parameter:Injection.dummy_fee_parameter
?dry_run
~src_sk
contents
?verbose_signing
let pp_operation formatter (a : Alpha_block_services.operation) =
match (a.receipt, a.protocol_data) with
| (Apply_results.Operation_metadata omd, Operation_data od) -> (
match Apply_results.kind_equal_list od.contents omd.contents with
| Some Apply_results.Eq ->
Operation_result.pp_operation_result
formatter
(od.contents, omd.contents)
| None ->
Pervasives.failwith "Unexpected result." )
| _ ->
Pervasives.failwith "Unexpected result."
let get_operation_from_block (cctxt : #full) ~chain predecessors operation_hash
=
Client_confirmations.lookup_operation_in_previous_blocks
cctxt
~chain
~predecessors
operation_hash
>>=? function
| None ->
return_none
| Some (block, i, j) ->
cctxt#message
"Operation found in block: %a (pass: %d, offset: %d)"
Block_hash.pp
block
i
j
>>= fun () ->
Protocol_client_context.Alpha_block_services.Operations.operation
cctxt
~chain
~block:(`Hash (block, 0))
i
j
>>=? fun op' -> return_some op'
let display_receipt_for_operation (cctxt : #full) ~chain ?(predecessors = 10)
operation_hash =
get_operation_from_block cctxt ~chain predecessors operation_hash
>>=? function
| None ->
failwith "Couldn't find operation"
| Some op ->
cctxt#message "%a" pp_operation op >>= fun () -> return_unit
src/proto_alpha/lib_client/client_proto_context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Import Protocol_client_context.
Import Tezos_micheline.
Import Client_proto_contracts.
Import Client_keys.
Definition get_balance {D F H J L M N a b c i o p q : Type}
(rpc :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
(Uri.t *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json))) *
N)))))))) * N)
(chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
Alpha_services.Contract.balance rpc (chain, block) contract.
Definition get_storage {D F H J L M N a b c i o p q : Type}
(rpc :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
(Uri.t *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json))) *
N)))))))) * N)
(chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
Alpha_services.Contract.storage_opt rpc (chain, block) contract.
Definition get_big_map_value {D F H J L M N a b c i o p q : Type}
(rpc :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
(Uri.t *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json))) *
N)))))))) * N)
(chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block)
(id : Tezos_protocol_environment_alpha__Environment.Z.t)
(key : Tezos_raw_protocol_alpha.Script_expr_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
Alpha_services.Contract.big_map_get rpc (chain, block) id key.
Definition get_contract_big_map_value {D F H J L M N a b c i o p q : Type}
(rpc :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
(Uri.t *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json))) *
N)))))))) * N)
(chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
(key :
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
Alpha_services.Contract.contract_big_map_get_opt rpc (chain, block) contract
key.
Definition get_script {D F H J L M N a b c i o p q : Type}
(rpc :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
(Uri.t *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json))) *
N)))))))) * N)
(chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(option Tezos_raw_protocol_alpha.Alpha_context.Script.t)) :=
Alpha_services.Contract.script_opt rpc (chain, block) contract.
Definition parse_expression (arg : string)
: Lwt.t
(Tezos_error_monad.Error_monad.tzresult
Tezos_client_alpha.Michelson_v1_parser.parsed) :=
Lwt._return
(Micheline_parser.no_parsing_error
(Michelson_v1_parser.parse_expression None arg)).
Definition transfer {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
(dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
(source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(src_pk : Tezos_base__TzPervasives.Signature.public_key)
(src_sk : Tezos_client_base.Client_keys.sk_uri)
(destination : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
(op_staroptstar : option string)
: (option string) ->
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
(option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
(option Z.t) ->
(option Z.t) ->
(option Z.t) ->
Tezos_client_alpha.Injection.fee_parameter ->
unit ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
((Tezos_base__TzPervasives.Operation_hash.t *
(Tezos_protocol_alpha.Protocol.Alpha_context.contents
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction))
*
(Tezos_protocol_alpha.Protocol.Apply_results.contents_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction)))
*
(list
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))) :=
let entrypoint :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "default" % string
end in
fun arg =>
fun amount =>
fun fee =>
fun gas_limit =>
fun storage_limit =>
fun counter =>
fun fee_parameter =>
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
match arg with
| Some arg =>
op_gtgteqquestion (parse_expression arg)
(fun function_parameter =>
let '{| expanded := arg |} := function_parameter in
return_some arg)
| None => return_none
end
(fun parameters =>
let parameters :=
Option.unopt_map Script.lazy_expr Script.unit_parameter
parameters in
let contents :=
Tezos_protocol_alpha.Protocol.Alpha_context.Transaction
{| amount := amount; parameters := parameters;
entrypoint := entrypoint; destination := destination
|} in
op_gtgteqquestion
(Injection.inject_manager_operation cctxt chain block
branch confirmations dry_run verbose_signing source
src_pk src_sk fee gas_limit storage_limit counter
fee_parameter contents)
(fun function_parameter =>
let '(_oph, _op, result) as res := function_parameter
in
op_gtgteqquestion
(Lwt._return
(Injection.originated_contracts
(Tezos_protocol_alpha.Protocol.Apply_results.Single_result
result)))
(fun contracts => _return (res, contracts)))).
Definition reveal {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
*
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
(a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))
*
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block))
(chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
(dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
(source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
(src_pk : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
(src_sk : Tezos_client_base.Client_keys.sk_uri)
(fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
(fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
(function_parameter : unit)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Operation_hash.t *
(Tezos_protocol_alpha.Protocol.Alpha_context.contents
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.reveal)) *
(Tezos_protocol_alpha.Protocol.Apply_results.contents_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.reveal)))) :=
let 'tt := function_parameter in
let '(compute_fee, fee) :=
match fee with
| None => (true, Tez.zero)
| Some fee => (false, fee)
end in
op_gtgteqquestion
(Alpha_services.Contract.counter cctxt (chain, block) source)
(fun pcounter =>
let counter := Z.succ pcounter in
op_gtgteqquestion
(Alpha_services.Contract.manager_key cctxt (chain, block) source)
(fun key =>
match key with
| Some _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The manager key was previously revealed." % string
CamlinternalFormatBasics.End_of_format)
"The manager key was previously revealed." % string)
| None =>
let contents :=
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
{| source := source; fee := fee; counter := counter;
operation :=
Tezos_protocol_alpha.Protocol.Alpha_context.Reveal src_pk;
gas_limit := Z.of_int (Z.opp 1); storage_limit := Z.zero |})
in
op_gtgteqquestion
(Injection.inject_operation cctxt chain block confirmations
dry_run branch (Some src_sk) verbose_signing fee_parameter
(Some compute_fee) contents)
(fun function_parameter =>
let '(oph, op, result) := function_parameter in
let
'Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
_) as op) result :=
Apply_results.pack_contents_list op result in
_return (oph, op, result))
end)).
Definition delegate_contract {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (branch : option Z)
(confirmations : option Z) (dry_run : option bool)
(verbose_signing : option bool)
(source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(src_pk : Tezos_base__TzPervasives.Signature.public_key)
(src_sk : Tezos_client_base.Client_keys.sk_uri)
(fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
(delegate_opt :
option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_client_alpha.Injection.result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.delegation))) :=
let operation :=
Tezos_protocol_alpha.Protocol.Alpha_context.Delegation delegate_opt in
op_gtgteqquestion
(Injection.inject_manager_operation cctxt chain block branch confirmations
dry_run verbose_signing source src_pk src_sk fee None (Some Z.zero) None
fee_parameter operation) (fun res => _return res).
Definition list_contract_labels {D E F H J L M a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(D * E) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(D * E) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(D * E) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(D * E) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (L * a * b * c * q * i * o)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a))
* M))))))))) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * M)))))
* (D * E)) (chain : D) (block : E)
: Lwt.t (Tezos_base__TzPervasives.tzresult (list (string * string * string))) :=
op_gtgteqquestion (Alpha_services.Contract.list cctxt (chain, block))
(fun contracts =>
op_gtgtpipequestion
(rev_map_s
(fun h =>
op_gtgteqquestion
match Contract.is_implicit h with
| Some m =>
op_gtgteqquestion (Public_key_hash.rev_find cctxt m)
(fun function_parameter =>
match function_parameter with
| None => _return "" % string
| Some nm =>
op_gtgteqquestion (RawContractAlias.find_opt cctxt nm)
(fun function_parameter =>
match function_parameter with
| None =>
_return
(String.append " (known as " % string
(String.append nm ")" % string))
| Some _ =>
_return
(String.append " (known as key:" % string
(String.append nm ")" % string))
end)
end)
| None =>
op_gtgteqquestion (RawContractAlias.rev_find cctxt h)
(fun function_parameter =>
match function_parameter with
| None => _return "" % string
| Some nm =>
_return
(String.append " (known as " % string
(String.append nm ")" % string))
end)
end
(fun nm =>
let kind :=
match Contract.is_implicit h with
| Some _ => " (implicit)" % string
| None => "" % string
end in
let h_b58 := Contract.to_b58check h in
_return (nm, h_b58, kind))) contracts) List.rev).
Definition message_added_contract {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (name : string) : Lwt.t unit :=
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Contract memorized as " % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))
"Contract memorized as %s." % string) name.
Definition set_delegate {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
(dry_run : option bool) (verbose_signing : option bool)
(fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(contract : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(src_pk : Tezos_base__TzPervasives.Signature.public_key)
(manager_sk : Tezos_client_base.Client_keys.sk_uri)
(fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
(opt_delegate :
option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_client_alpha.Injection.result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.delegation))) :=
delegate_contract cctxt chain block None confirmations dry_run verbose_signing
contract src_pk manager_sk fee fee_parameter opt_delegate.
Definition register_as_delegate {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
(dry_run : option bool) (verbose_signing : option bool)
(fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(manager_sk : Tezos_client_base.Client_keys.sk_uri)
(fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
(src_pk : Tezos_base__TzPervasives.Signature.Public_key.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_client_alpha.Injection.result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.delegation))) :=
let source := Signature.Public_key.hash src_pk in
delegate_contract cctxt chain block None confirmations dry_run verbose_signing
source src_pk manager_sk fee fee_parameter (Some source).
Definition save_contract {E F H J L M N a b c i o p q : Type}
(force : bool)
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) * b) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) * b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o)
->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) *
(M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format
a b) -> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option
Tezos_data_encoding.Data_encoding.json)
->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) * N)))))))))))))))))))))))))
*
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a)
* b) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t *
a) * b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json)
->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) * N)))))))))))))))))))))
(alias_name : string)
(contract : Tezos_client_alpha.Client_proto_contracts.RawContractAlias.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (RawContractAlias.add force cctxt alias_name contract)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (message_added_contract cctxt alias_name)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)).
Definition originate_contract {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
(dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
(fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(gas_limit : option Z.t) (storage_limit : option Z.t)
(delegate :
option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(initial_storage : string)
(balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
(source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(src_pk : Tezos_base__TzPervasives.Signature.public_key)
(src_sk : Tezos_client_base.Client_keys.sk_uri)
(code : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
(fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
(function_parameter : unit)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
((Tezos_base__TzPervasives.Operation_hash.t *
(Tezos_protocol_alpha.Protocol.Alpha_context.contents
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.origination)) *
(Tezos_protocol_alpha.Protocol.Apply_results.contents_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.origination))) *
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)) :=
let 'tt := function_parameter in
op_gtgteq
(Lwt._return (Michelson_v1_parser.parse_expression None initial_storage))
(fun result =>
op_gtgteqquestion (Lwt._return (Micheline_parser.no_parsing_error result))
(fun function_parameter =>
let '{| Michelson_v1_parser.expanded := storage |} :=
function_parameter in
let code
: Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr :=
Script.lazy_expr code
with storage
: Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr :=
Script.lazy_expr storage in
let origination :=
Tezos_protocol_alpha.Protocol.Alpha_context.Origination
{| delegate := delegate;
script := {| code := code; storage := storage |};
credit := balance; preorigination := None |} in
op_gtgteqquestion
(Injection.inject_manager_operation cctxt chain block branch
confirmations dry_run verbose_signing source src_pk src_sk fee
gas_limit storage_limit None fee_parameter origination)
(fun function_parameter =>
let '(_oph, _op, result) as res := function_parameter in
op_gtgteqquestion
(Lwt._return
(Injection.originated_contracts
(Tezos_protocol_alpha.Protocol.Apply_results.Single_result
result)))
(fun function_parameter =>
match function_parameter with
| cons contract [] => _return (res, contract)
| contracts =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The origination introduced " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" contracts instead of one." % string
CamlinternalFormatBasics.End_of_format)))
"The origination introduced %d contracts instead of one."
% string) (List.length contracts)
end)))).
Record activation_key := {
pkh : Tezos_base__TzPervasives.Ed25519.Public_key_hash.t;
amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
activation_code :
Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code;
mnemonic : list string;
password : string;
email : string }.
Definition raw_activation_key_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
(Tezos_base__TzPervasives.Ed25519.Public_key_hash.t *
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t *
Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code *
(list string) * string * string) :=
obj6 (req None None "pkh" % string Ed25519.Public_key_hash.encoding)
(req None None "amount" % string Tez.encoding)
(req None None "activation_code" % string
Blinded_public_key_hash.activation_code_encoding)
(req None None "mnemonic" % string (list None string))
(req None None "password" % string string)
(req None None "email" % string string).
Definition activation_key_encoding
: Tezos_base__TzPervasives.Data_encoding.encoding activation_key :=
apply
(let arg :=
conv
(fun function_parameter =>
let '{|
pkh := pkh;
amount := amount;
activation_code := activation_code;
mnemonic := mnemonic;
password := password;
email := email
|} := function_parameter in
(pkh, amount, activation_code, mnemonic, password, email))
(fun function_parameter =>
let '(pkh, amount, activation_code, mnemonic, password, email) :=
function_parameter in
{| pkh := pkh; amount := amount; activation_code := activation_code;
mnemonic := mnemonic; password := password; email := email |}) in
fun eta => arg None eta)
(splitted
(union None
(cons
(case "Activation" % string None
Tezos_base__TzPervasives.Data_encoding.Json_only
raw_activation_key_encoding (fun x => Some x) (fun x => x))
(cons
(case "Deprecated_activation" % string None
Tezos_base__TzPervasives.Data_encoding.Json_only
(obj6
(req None None "pkh" % string Ed25519.Public_key_hash.encoding)
(req None None "amount" % string Tez.encoding)
(req None None "secret" % string
Blinded_public_key_hash.activation_code_encoding)
(req None None "mnemonic" % string (list None string))
(req None None "password" % string string)
(req None None "email" % string string))
(fun function_parameter =>
let '_ := function_parameter in
None) (fun x => x)) []))) raw_activation_key_encoding).
Definition read_key (key : activation_key)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_crypto__Signature.Public_key_hash.t *
Tezos_crypto__Signature.Public_key.t *
Tezos_base__TzPervasives.Signature.Secret_key.t)) :=
match Bip39.of_words (mnemonic key) with
| None =>
failwith
(CamlinternalFormatBasics.Format CamlinternalFormatBasics.End_of_format
"" % string)
| Some t =>
let passphrase :=
concat "" % string
(cons (of_string (email key)) (cons (of_string (password key)) [])) in
let sk := Bip39.to_seed (Some passphrase) t in
let sk := Bigstring.sub_bytes sk 0 32 in
let sk :=
Tezos_crypto__Signature.Ed25519
(Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk) in
let pk := Signature.Secret_key.to_public_key sk in
let pkh := Signature.Public_key.hash pk in
_return (pkh, pk, sk)
end.
Definition inject_activate_operation {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
(dry_run : option bool) (alias : string)
(pkh : Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.t)
(activation_code :
Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Operation_hash.t *
(Tezos_protocol_alpha.Protocol.Alpha_context.contents
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account) *
(Tezos_protocol_alpha.Protocol.Apply_results.contents_result
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account))) :=
let contents :=
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Activate_account
{| id := pkh; activation_code := activation_code |}) in
op_gtgteqquestion
(Injection.inject_operation cctxt chain block confirmations dry_run None
None None Injection.dummy_fee_parameter None contents)
(fun function_parameter =>
let '(oph, op, result) := function_parameter in
op_gtgteqquestion
match confirmations with
| None => return_unit
| Some _confirmations =>
op_gtgteqquestion
(Alpha_services.Contract.balance cctxt (chain, block)
(Contract.implicit_contract
(Tezos_protocol_environment_alpha__Environment.Signature.Ed25519
pkh)))
(fun balance =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Account " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
") activated with " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format))))))))
"Account %s (%a) activated with %s%a." % string) alias
Ed25519.Public_key_hash.pp pkh Client_proto_args.tez_sym
Tez.pp balance)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))
end
(fun function_parameter =>
let 'tt := function_parameter in
let
'Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
((Tezos_protocol_alpha.Protocol.Alpha_context.Activate_account _)
as op) result := Apply_results.pack_contents_list op result in
_return (oph, op, result))).
Definition activate_account {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
(dry_run : option bool) (op_staroptstar : option bool)
: (option bool) ->
activation_key ->
string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Operation_hash.t *
(Tezos_protocol_alpha.Protocol.Alpha_context.contents
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account)
*
(Tezos_protocol_alpha.Protocol.Apply_results.contents_result
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account))) :=
let encrypted :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun force =>
fun key =>
fun name =>
op_gtgteqquestion (read_key key)
(fun function_parameter =>
let '(pkh, pk, sk) := function_parameter in
op_gtgteqquestion
(fail_unless
(Signature.Public_key_hash.equal pkh
(Tezos_crypto__Signature.Ed25519 (pkh key)))
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Inconsistent activation key:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"Computed pkh: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1
0)
(CamlinternalFormatBasics.String_literal
"Embedded pkh: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" " % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))
"@[<v 2>Inconsistent activation key:@ Computed pkh: %a@ Embedded pkh: %a @]"
% string) Signature.Public_key_hash.pp pkh
Ed25519.Public_key_hash.pp (pkh key)))
(fun function_parameter =>
let 'tt := function_parameter in
let pk_uri := Tezos_signer_backends.Unencrypted.make_pk pk in
op_gtgteqquestion
(if encrypted then
Tezos_signer_backends.Encrypted.encrypt cctxt sk
else
_return (Tezos_signer_backends.Unencrypted.make_sk sk))
(fun sk_uri =>
op_gtgteqquestion
(Client_keys.register_key cctxt force
(pkh, pk_uri, sk_uri) None name)
(fun function_parameter =>
let 'tt := function_parameter in
inject_activate_operation cctxt chain block
confirmations dry_run name (pkh key)
(activation_code key))))).
Definition activate_existing_account {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
(dry_run : option bool) (alias : string)
(activation_code :
Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Operation_hash.t *
(Tezos_protocol_alpha.Protocol.Alpha_context.contents
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account) *
(Tezos_protocol_alpha.Protocol.Apply_results.contents_result
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account))) :=
op_gtgteqquestion (Client_keys.alias_keys cctxt alias)
(fun function_parameter =>
match function_parameter with
| Some (Tezos_crypto__Signature.Ed25519 pkh, _, _) =>
inject_activate_operation cctxt chain block confirmations dry_run alias
pkh activation_code
| Some _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Only Ed25519 accounts can be activated" % string
CamlinternalFormatBasics.End_of_format)
"Only Ed25519 accounts can be activated" % string)
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Unknown account" % string
CamlinternalFormatBasics.End_of_format) "Unknown account" % string)
end).
Record period_info := {
current_period_kind :
Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.kind;
position : Stdlib.Int32.t;
remaining : Stdlib.Int32.t;
current_proposal : option Tezos_base__TzPervasives.Protocol_hash.t }.
Record ballots_info := {
current_quorum : Stdlib.Int32.t;
participation : Stdlib.Int32.t;
supermajority : Stdlib.Int32.t;
ballots : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots }.
Definition get_ballots_info {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block)
: Lwt.t (Tezos_base__TzPervasives.tzresult ballots_info) :=
let cb := (chain, block) in
op_gtgteqquestion (Alpha_services.Voting.ballots cctxt cb)
(fun ballots =>
op_gtgteqquestion (Alpha_services.Voting.current_quorum cctxt cb)
(fun current_quorum =>
op_gtgteqquestion (Alpha_services.Voting.listings cctxt cb)
(fun listings =>
let max_participation :=
List.fold_left
(fun acc =>
fun function_parameter =>
let '(_, w) := function_parameter in
Int32.add w acc)
(* ❌ Constant of type int32 is converted to int *)
0 listings in
let all_votes :=
add (add (yay ballots) (nay ballots)) (pass ballots) in
let participation :=
div
(mul all_votes
(* ❌ Constant of type int32 is converted to int *)
10000) max_participation in
let supermajority :=
div
(mul
(* ❌ Constant of type int32 is converted to int *)
8 (add (yay ballots) (nay ballots)))
(* ❌ Constant of type int32 is converted to int *)
10 in
_return
{| current_quorum := current_quorum;
participation := participation;
supermajority := supermajority; ballots := ballots |}))).
Definition get_period_info {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block)
: Lwt.t (Tezos_base__TzPervasives.tzresult period_info) :=
let cb := (chain, block) in
op_gtgteqquestion
(Alpha_services.Helpers.current_level cctxt
(Some
(* ❌ Constant of type int32 is converted to int *)
1) cb)
(fun level =>
op_gtgteqquestion (Alpha_services.Constants.all cctxt cb)
(fun constants =>
op_gtgteqquestion (Alpha_services.Voting.current_proposal cctxt cb)
(fun current_proposal =>
let position := voting_period_position level in
let remaining :=
sub (blocks_per_voting_period (parametric constants)) position
in
op_gtgteqquestion
(Alpha_services.Voting.current_period_kind cctxt cb)
(fun current_period_kind =>
_return
{| current_period_kind := current_period_kind;
position := position; remaining := remaining;
current_proposal := current_proposal |})))).
Definition get_proposals {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t
Tezos_protocol_environment_alpha__Environment.Int32.t)) :=
let cb := (chain, block) in
Alpha_services.Voting.proposals cctxt cb.
Definition submit_proposals {D F H J L M N a b c i o p q : Type}
(dry_run : option bool) (verbose_signing : option bool)
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
(src_sk : Tezos_client_base.Client_keys.sk_uri)
(source :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(proposals :
list
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_client_alpha.Injection.result_list
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.proposals)) :=
op_gtgteqquestion
(Alpha_services.Helpers.current_level cctxt
(Some
(* ❌ Constant of type int32 is converted to int *)
1) (chain, block))
(fun level =>
let period := voting_period level in
let contents :=
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Proposals
{| source := source; period := period; proposals := proposals |}) in
Injection.inject_operation cctxt chain block confirmations dry_run None
(Some src_sk) verbose_signing Injection.dummy_fee_parameter None
contents).
Definition submit_ballot {D F H J L M N a b c i o p q : Type}
(dry_run : option bool) (verbose_signing : option bool)
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
(src_sk : Tezos_client_base.Client_keys.sk_uri)
(source :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(proposal :
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(ballot : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballot)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_client_alpha.Injection.result_list
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.ballot)) :=
op_gtgteqquestion
(Alpha_services.Helpers.current_level cctxt
(Some
(* ❌ Constant of type int32 is converted to int *)
1) (chain, block))
(fun level =>
let period := voting_period level in
let contents :=
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Ballot
{| source := source; period := period; proposal := proposal;
ballot := ballot |}) in
Injection.inject_operation cctxt chain block confirmations dry_run None
(Some src_sk) verbose_signing Injection.dummy_fee_parameter None
contents).
Definition pp_operation
(formatter : Stdlib.Format.formatter)
(a : Tezos_client_alpha.Protocol_client_context.Alpha_block_services.operation)
: unit :=
match ((receipt a), (protocol_data a)) with
|
(Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata omd,
Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data od) =>
match Apply_results.kind_equal_list (contents od) (contents omd) with
| Some Tezos_protocol_alpha.Protocol.Apply_results.Eq =>
Operation_result.pp_operation_result formatter
((contents od), (contents omd))
| None => Pervasives.failwith "Unexpected result." % string
end
| _ => Pervasives.failwith "Unexpected result." % string
end.
Definition get_operation_from_block {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Block_services.chain)
(predecessors : Z)
(operation_hash : Tezos_base__TzPervasives.Operation_list_hash.elt)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option
Tezos_client_alpha__Protocol_client_context.Alpha_block_services.operation)) :=
op_gtgteqquestion
(Client_confirmations.lookup_operation_in_previous_blocks cctxt chain
predecessors operation_hash)
(fun function_parameter =>
match function_parameter with
| None => return_none
| Some (block, i, j) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Operation found in block: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (pass: " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
", offset: " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))))
"Operation found in block: %a (pass: %d, offset: %d)" % string)
Block_hash.pp block i j)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Protocol_client_context.Alpha_block_services.Operations.operation
cctxt (Some chain)
(Some
(* ❌ Variants not supported *)
variant) i j) (fun op' => return_some op'))
end).
Definition display_receipt_for_operation {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Block_services.chain)
(op_staroptstar : option Z)
: Tezos_base__TzPervasives.Operation_list_hash.elt ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let predecessors :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 10
end in
fun operation_hash =>
op_gtgteqquestion
(get_operation_from_block cctxt chain predecessors operation_hash)
(fun function_parameter =>
match function_parameter with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Couldn't find operation" % string
CamlinternalFormatBasics.End_of_format)
"Couldn't find operation" % string)
| Some op =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
pp_operation op)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end).
src/proto_alpha/lib_client/client_proto_contracts.ml 157 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
module ContractEntity = struct
type t = Contract.t
let encoding = Contract.encoding
let of_source s =
match Contract.of_b58check s with
| Error _ as err ->
Lwt.return (Environment.wrap_error err)
|> trace (failure "bad contract notation")
| Ok s ->
return s
let to_source s = return (Contract.to_b58check s)
let name = "contract"
end
module RawContractAlias = Client_aliases.Alias (ContractEntity)
module ContractAlias = struct
let find cctxt s =
RawContractAlias.find_opt cctxt s
>>=? function
| Some v ->
return (s, v)
| None -> (
Client_keys.Public_key_hash.find_opt cctxt s
>>=? function
| Some v ->
return (s, Contract.implicit_contract v)
| None ->
failwith "no contract or key named %s" s )
let find_key cctxt name =
Client_keys.Public_key_hash.find cctxt name
>>=? fun v -> return (name, Contract.implicit_contract v)
let rev_find cctxt c =
match Contract.is_implicit c with
| Some hash -> (
Client_keys.Public_key_hash.rev_find cctxt hash
>>=? function
| Some name -> return_some ("key:" ^ name) | None -> return_none )
| None ->
RawContractAlias.rev_find cctxt c
let get_contract cctxt s =
match String.split ~limit:1 ':' s with
| ["key"; key] ->
find_key cctxt key
| _ ->
find cctxt s
let autocomplete cctxt =
Client_keys.Public_key_hash.autocomplete cctxt
>>=? fun keys ->
RawContractAlias.autocomplete cctxt
>>=? fun contracts -> return (List.map (( ^ ) "key:") keys @ contracts)
let alias_param ?(name = "name") ?(desc = "existing contract alias") next =
let desc =
desc ^ "\n"
^ "Can be a contract alias or a key alias (autodetected in order).\n\
Use 'key:name' to force the later."
in
Clic.(
param
~name
~desc
(parameter ~autocomplete (fun cctxt p -> get_contract cctxt p))
next)
let destination_parameter () =
Clic.parameter
~autocomplete:(fun cctxt ->
autocomplete cctxt
>>=? fun list1 ->
Client_keys.Public_key_hash.autocomplete cctxt
>>=? fun list2 -> return (list1 @ list2))
(fun cctxt s ->
match String.split ~limit:1 ':' s with
| ["alias"; alias] ->
find cctxt alias
| ["key"; text] ->
Client_keys.Public_key_hash.find cctxt text
>>=? fun v -> return (s, Contract.implicit_contract v)
| _ -> (
find cctxt s
>>= function
| Ok v ->
return v
| Error k_errs -> (
ContractEntity.of_source s
>>= function
| Ok v ->
return (s, v)
| Error c_errs ->
Lwt.return_error (k_errs @ c_errs) ) ))
let destination_param ?(name = "dst") ?(desc = "destination contract") next =
let desc =
String.concat
"\n"
[ desc;
"Can be an alias, a key, or a literal (autodetected in order).\n\
Use 'text:literal', 'alias:name', 'key:name' to force." ]
in
Clic.param ~name ~desc (destination_parameter ()) next
let destination_arg ?(name = "dst") ?(doc = "destination contract") () =
let doc =
String.concat
"\n"
[ doc;
"Can be an alias, a key, or a literal (autodetected in order).\n\
Use 'text:literal', 'alias:name', 'key:name' to force." ]
in
Clic.arg ~long:name ~doc ~placeholder:name (destination_parameter ())
let name cctxt contract =
rev_find cctxt contract
>>=? function
| None -> return (Contract.to_b58check contract) | Some name -> return name
end
let list_contracts cctxt =
RawContractAlias.load cctxt
>>=? fun raw_contracts ->
Lwt_list.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts
>>= fun contracts ->
Client_keys.Public_key_hash.load cctxt
>>=? fun keys ->
(* List accounts (implicit contracts of identities) *)
map_s
(fun (n, v) ->
RawContractAlias.mem cctxt n
>>=? fun mem ->
let p = if mem then "key:" else "" in
let v' = Contract.implicit_contract v in
return (p, n, v'))
keys
>>=? fun accounts -> return (contracts @ accounts)
let get_delegate cctxt ~chain ~block source =
Alpha_services.Contract.delegate_opt cctxt (chain, block) source
src/proto_alpha/lib_client/client_proto_contracts.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Module ContractEntity.
Definition t := Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.t
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t :=
Contract.encoding.
Definition of_source (s : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract) :=
match Contract.of_b58check s with
| (Stdlib.Error _) as err =>
OCaml.Stdlib.reverse_apply (Lwt._return (Environment.wrap_error err))
(trace
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"bad contract notation" % string
CamlinternalFormatBasics.End_of_format)
"bad contract notation" % string)))
| Stdlib.Ok s => _return s
end.
Definition to_source
(s : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
: Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
_return (Contract.to_b58check s).
Definition name : string := "contract" % string.
End ContractEntity.
(* ❌ Applications of functors are not handled. *)
functor_application
Module ContractAlias.
Definition find {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (s : string)
: Lwt.t (Tezos_base__TzPervasives.tzresult (string * RawContractAlias.t)) :=
op_gtgteqquestion (RawContractAlias.find_opt cctxt s)
(fun function_parameter =>
match function_parameter with
| Some v => _return (s, v)
| None =>
op_gtgteqquestion (Client_keys.Public_key_hash.find_opt cctxt s)
(fun function_parameter =>
match function_parameter with
| Some v => _return (s, (Contract.implicit_contract v))
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"no contract or key named " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"no contract or key named %s" % string) s
end)
end).
Definition find_key {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (name : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(string * Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)) :=
op_gtgteqquestion (Client_keys.Public_key_hash.find cctxt name)
(fun v => _return (name, (Contract.implicit_contract v))).
Definition rev_find {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (c : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
: Lwt.t (Tezos_base__TzPervasives.tzresult (option string)) :=
match Contract.is_implicit c with
| Some hash =>
op_gtgteqquestion (Client_keys.Public_key_hash.rev_find cctxt hash)
(fun function_parameter =>
match function_parameter with
| Some name => return_some (String.append "key:" % string name)
| None => return_none
end)
| None => RawContractAlias.rev_find cctxt c
end.
Definition get_contract {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (s : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(string * Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)) :=
match String.split ":" % char None (Some 1) s with
| cons "key" % string (cons key []) => find_key cctxt key
| _ => find cctxt s
end.
Definition autocomplete {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) : Lwt.t (Tezos_base__TzPervasives.tzresult (list string)) :=
op_gtgteqquestion (Client_keys.Public_key_hash.autocomplete cctxt)
(fun keys =>
op_gtgteqquestion (RawContractAlias.autocomplete cctxt)
(fun contracts =>
_return
(OCaml.Stdlib.app (List.map (String.append "key:" % string) keys)
contracts))).
Definition alias_param {A C a : Type} (op_staroptstar : option string)
: (option string) ->
(Tezos_base__TzPervasives.Clic.params A
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
* C)) ->
Tezos_base__TzPervasives.Clic.params
((string *
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract) -> A)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
C))))) * C) :=
let name :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "name" % string
end in
fun op_staroptstar =>
let desc :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "existing contract alias" % string
end in
fun next =>
let desc :=
String.append desc
(String.append "
" % string
"Can be a contract alias or a key alias (autodetected in order).
Use 'key:name' to force the later."
% string) in
param name desc
(parameter (Some autocomplete)
(fun cctxt => fun p => get_contract cctxt p)) next.
Definition destination_parameter {B a : Type} (function_parameter : unit)
: Tezos_base__TzPervasives.Clic.parameter (string * RawContractAlias.t)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) :=
let 'tt := function_parameter in
Clic.parameter
(Some
(fun cctxt =>
op_gtgteqquestion (autocomplete cctxt)
(fun list1 =>
op_gtgteqquestion (Client_keys.Public_key_hash.autocomplete cctxt)
(fun list2 => _return (OCaml.Stdlib.app list1 list2)))))
(fun cctxt =>
fun s =>
match String.split ":" % char None (Some 1) s with
| cons "alias" % string (cons alias []) => find cctxt alias
| cons "key" % string (cons text []) =>
op_gtgteqquestion (Client_keys.Public_key_hash.find cctxt text)
(fun v => _return (s, (Contract.implicit_contract v)))
| _ =>
op_gtgteq (find cctxt s)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok v => _return v
| Stdlib.Error k_errs =>
op_gtgteq (ContractEntity.of_source s)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok v => _return (s, v)
| Stdlib.Error c_errs =>
Lwt.return_error (OCaml.Stdlib.app k_errs c_errs)
end)
end)
end).
Definition destination_param {A C a : Type} (op_staroptstar : option string)
: (option string) ->
(Tezos_base__TzPervasives.Clic.params A
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
* C)) ->
Tezos_base__TzPervasives.Clic.params
((string * RawContractAlias.t) -> A)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
C))))) * C) :=
let name :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "dst" % string
end in
fun op_staroptstar =>
let desc :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "destination contract" % string
end in
fun next =>
let desc :=
String.concat "
" % string
(cons desc
(cons
"Can be an alias, a key, or a literal (autodetected in order).
Use 'text:literal', 'alias:name', 'key:name' to force."
% string [])) in
Clic.param name desc (destination_parameter tt) next.
Definition destination_arg {B a : Type} (op_staroptstar : option string)
: (option string) ->
unit ->
Tezos_base__TzPervasives.Clic.arg (option (string * RawContractAlias.t))
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
B))))) * B) :=
let name :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "dst" % string
end in
fun op_staroptstar =>
let doc :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "destination contract" % string
end in
fun function_parameter =>
let 'tt := function_parameter in
let doc :=
String.concat "
" % string
(cons doc
(cons
"Can be an alias, a key, or a literal (autodetected in order).
Use 'text:literal', 'alias:name', 'key:name' to force."
% string [])) in
Clic.arg doc None name name (destination_parameter tt).
Definition name {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B)
(contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
: Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
op_gtgteqquestion (rev_find cctxt contract)
(fun function_parameter =>
match function_parameter with
| None => _return (Contract.to_b58check contract)
| Some name => _return name
end).
End ContractAlias.
Definition list_contracts {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list (string * string * RawContractAlias.t))) :=
op_gtgteqquestion (RawContractAlias.load cctxt)
(fun raw_contracts =>
op_gtgteq
(Lwt_list.map_s
(fun function_parameter =>
let '(n, v) := function_parameter in
Lwt._return ("" % string, n, v)) raw_contracts)
(fun contracts =>
op_gtgteqquestion (Client_keys.Public_key_hash.load cctxt)
(fun keys =>
op_gtgteqquestion
(map_s
(fun function_parameter =>
let '(n, v) := function_parameter in
op_gtgteqquestion (RawContractAlias.mem cctxt n)
(fun mem =>
let p :=
if mem then
"key:" % string
else
"" % string in
let v' := Contract.implicit_contract v in
_return (p, n, v'))) keys)
(fun accounts => _return (OCaml.Stdlib.app contracts accounts))))).
Definition get_delegate {D E F H J L M a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(D * E) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(D * E) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(D * E) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(D * E) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (L * a * b * c * q * i * o)) * M)))) * M *
(D * E)) (chain : D) (block : E)
(source : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)) :=
Alpha_services.Contract.delegate_opt cctxt (chain, block) source.
src/proto_alpha/lib_client/client_proto_multisig.ml 508 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol_client_context
open Protocol
open Alpha_context
type error += Contract_has_no_script of Contract.t
type error +=
| Not_a_supported_multisig_contract of (Script_expr_hash.t * Script.expr)
type error += Contract_has_no_storage of Contract.t
type error += Contract_has_unexpected_storage of Contract.t
type error += Invalid_signature of signature
type error += Not_enough_signatures of int * int
type error += Action_deserialisation_error of Script.expr
type error += Bytes_deserialisation_error of Bytes.t
type error += Bad_deserialized_contract of (Contract.t * Contract.t)
type error += Bad_deserialized_counter of (counter * counter)
type error += Non_positive_threshold of int
type error += Threshold_too_high of int * int
let () =
register_error_kind
`Permanent
~id:"contractHasNoScript"
~title:
"The given contract is not a multisig contract because it has no script"
~description:
"A multisig command has referenced a scriptless smart contract instead \
of a multisig smart contract."
~pp:(fun ppf contract ->
Format.fprintf ppf "Contract has no script %a." Contract.pp contract)
Data_encoding.(obj1 (req "contract" Contract.encoding))
(function Contract_has_no_script c -> Some c | _ -> None)
(fun c -> Contract_has_no_script c) ;
register_error_kind
`Permanent
~id:"notASupportedMultisigContract"
~title:"The given contract is not one of the supported contracts"
~description:
"A multisig command has referenced a smart contract whose script is not \
one of the known multisig contract scripts."
~pp:(fun ppf (hash, script) ->
Format.fprintf
ppf
"Not a supported multisig contract %a.@\n\
The hash of this script is 0x%a, it was not found among in the list \
of known multisig script hashes."
Michelson_v1_printer.print_expr
script
Hex.pp
(Script_expr_hash.to_bytes hash |> Hex.of_bytes))
Data_encoding.(
obj2
(req "hash" Script_expr_hash.encoding)
(req "script" Script.expr_encoding))
(function
| Not_a_supported_multisig_contract (h, c) -> Some (h, c) | _ -> None)
(fun (h, c) -> Not_a_supported_multisig_contract (h, c)) ;
register_error_kind
`Permanent
~id:"contractHasNoStorage"
~title:
"The given contract is not a multisig contract because it has no storage"
~description:
"A multisig command has referenced a smart contract without storage \
instead of a multisig smart contract."
~pp:(fun ppf contract ->
Format.fprintf ppf "Contract has no storage %a." Contract.pp contract)
Data_encoding.(obj1 (req "contract" Contract.encoding))
(function Contract_has_no_storage c -> Some c | _ -> None)
(fun c -> Contract_has_no_storage c) ;
register_error_kind
`Permanent
~id:"contractHasUnexpectedStorage"
~title:
"The storage of the given contract is not of the shape expected for a \
multisig contract"
~description:
"A multisig command has referenced a smart contract whose storage is of \
a different shape than the expected one."
~pp:(fun ppf contract ->
Format.fprintf
ppf
"Contract has unexpected storage %a."
Contract.pp
contract)
Data_encoding.(obj1 (req "contract" Contract.encoding))
(function Contract_has_unexpected_storage c -> Some c | _ -> None)
(fun c -> Contract_has_unexpected_storage c) ;
register_error_kind
`Permanent
~id:"invalidSignature"
~title:
"The following signature did not match a public key in the given \
multisig contract"
~description:
"A signature was given for a multisig contract that matched none of the \
public keys of the contract signers"
~pp:(fun ppf s ->
Format.fprintf ppf "Invalid signature %s." (Signature.to_b58check s))
Data_encoding.(obj1 (req "invalid_signature" Signature.encoding))
(function Invalid_signature s -> Some s | _ -> None)
(fun s -> Invalid_signature s) ;
register_error_kind
`Permanent
~id:"notEnoughSignatures"
~title:"Not enough signatures were provided for this multisig action"
~description:
"To run an action on a multisig contract, you should provide at least \
as many signatures as indicated by the threshold stored in the \
multisig contract."
~pp:(fun ppf (threshold, nsigs) ->
Format.fprintf
ppf
"Not enough signatures: only %d signatures were given but the \
threshold is currently %d"
nsigs
threshold)
Data_encoding.(obj1 (req "threshold_nsigs" (tup2 int31 int31)))
(function
| Not_enough_signatures (threshold, nsigs) ->
Some (threshold, nsigs)
| _ ->
None)
(fun (threshold, nsigs) -> Not_enough_signatures (threshold, nsigs)) ;
register_error_kind
`Permanent
~id:"actionDeserialisation"
~title:"The expression is not a valid multisig action"
~description:
"When trying to deserialise an action from a sequence of bytes, we got \
an expression that does not correspond to a known multisig action"
~pp:(fun ppf e ->
Format.fprintf
ppf
"Action deserialisation error %a."
Michelson_v1_printer.print_expr
e)
Data_encoding.(obj1 (req "expr" Script.expr_encoding))
(function Action_deserialisation_error e -> Some e | _ -> None)
(fun e -> Action_deserialisation_error e) ;
register_error_kind
`Permanent
~id:"bytesDeserialisation"
~title:"The byte sequence is not a valid multisig action"
~description:
"When trying to deserialise an action from a sequence of bytes, we got \
an error"
~pp:(fun ppf b ->
Format.fprintf ppf "Bytes deserialisation error %s." (Bytes.to_string b))
Data_encoding.(obj1 (req "expr" bytes))
(function Bytes_deserialisation_error b -> Some b | _ -> None)
(fun b -> Bytes_deserialisation_error b) ;
register_error_kind
`Permanent
~id:"badDeserializedContract"
~title:"The byte sequence is not for the given multisig contract"
~description:
"When trying to deserialise an action from a sequence of bytes, we got \
an action for another multisig contract"
~pp:(fun ppf (recieved, expected) ->
Format.fprintf
ppf
"Bad deserialized contract, recieved %a expected %a."
Contract.pp
recieved
Contract.pp
expected)
Data_encoding.(
obj1 (req "recieved_expected" (tup2 Contract.encoding Contract.encoding)))
(function Bad_deserialized_contract b -> Some b | _ -> None)
(fun b -> Bad_deserialized_contract b) ;
register_error_kind
`Permanent
~id:"Bad deserialized counter"
~title:"Deserialized counter does not match the stored one"
~description:
"The byte sequence references a multisig counter that does not match \
the one currently stored in the given multisig contract"
~pp:(fun ppf (recieved, expected) ->
Format.fprintf
ppf
"Bad deserialized counter, recieved %d expected %d."
recieved
expected)
Data_encoding.(obj1 (req "recieved_expected" (tup2 int31 int31)))
(function
| Bad_deserialized_counter (c1, c2) ->
Some (Z.to_int c1, Z.to_int c2)
| _ ->
None)
(fun (c1, c2) -> Bad_deserialized_counter (Z.of_int c1, Z.of_int c2)) ;
register_error_kind
`Permanent
~id:"thresholdTooHigh"
~title:"Given threshold is too high"
~description:
"The given threshold is higher than the number of keys, this would lead \
to a frozen multisig contract"
~pp:(fun ppf (threshold, nkeys) ->
Format.fprintf
ppf
"Threshold too high: %d expected at most %d."
threshold
nkeys)
Data_encoding.(obj1 (req "recieved_expected" (tup2 int31 int31)))
(function Threshold_too_high (c1, c2) -> Some (c1, c2) | _ -> None)
(fun (c1, c2) -> Threshold_too_high (c1, c2)) ;
register_error_kind
`Permanent
~id:"nonPositiveThreshold"
~title:"Given threshold is not positive"
~description:"A multisig threshold should be a positive number"
~pp:(fun ppf threshold ->
Format.fprintf ppf "Multisig threshold %d should be positive." threshold)
Data_encoding.(obj1 (req "threshold" int31))
(function Non_positive_threshold t -> Some t | _ -> None)
(fun t -> Non_positive_threshold t)
(* The multisig contract script written by Arthur Breitman
https://github.com/murbard/smart-contracts/blob/master/multisig/michelson/multisig.tz *)
(* Updated to take the chain id into account *)
let multisig_script_string =
"parameter (pair\n\
\ (pair :payload\n\
\ (nat %counter) # counter, used to prevent replay attacks\n\
\ (or :action # payload to sign, represents the requested \
action\n\
\ (pair :transfer # transfer tokens\n\
\ (mutez %amount) # amount to transfer\n\
\ (contract %dest unit)) # destination to transfer to\n\
\ (or\n\
\ (option %delegate key_hash) # change the delegate to \
this address\n\
\ (pair %change_keys # change the keys \
controlling the multisig\n\
\ (nat %threshold) # new threshold\n\
\ (list %keys key))))) # new list of keys\n\
\ (list %sigs (option signature))); # signatures\n\n\
storage (pair (nat %stored_counter) (pair (nat %threshold) (list %keys \
key))) ;\n\n\
code\n\
\ {\n\
\ UNPAIR ; SWAP ; DUP ; DIP { SWAP } ;\n\
\ DIP\n\
\ {\n\
\ UNPAIR ;\n\
\ # pair the payload with the current contract address, to ensure \
signatures\n\
\ # can't be replayed accross different contracts if a key is reused.\n\
\ DUP ; SELF ; ADDRESS ; CHAIN_ID ; PAIR ; PAIR ;\n\
\ PACK ; # form the binary payload that we expect to be signed\n\
\ DIP { UNPAIR @counter ; DIP { SWAP } } ; SWAP\n\
\ } ;\n\n\
\ # Check that the counters match\n\
\ UNPAIR @stored_counter; DIP { SWAP };\n\
\ ASSERT_CMPEQ ;\n\n\
\ # Compute the number of valid signatures\n\
\ DIP { SWAP } ; UNPAIR @threshold @keys;\n\
\ DIP\n\
\ {\n\
\ # Running count of valid signatures\n\
\ PUSH @valid nat 0; SWAP ;\n\
\ ITER\n\
\ {\n\
\ DIP { SWAP } ; SWAP ;\n\
\ IF_CONS\n\
\ {\n\
\ IF_SOME\n\
\ { SWAP ;\n\
\ DIP\n\
\ {\n\
\ SWAP ; DIIP { DUUP } ;\n\
\ # Checks signatures, fails if invalid\n\
\ { DUUUP; DIP {CHECK_SIGNATURE}; SWAP; IF {DROP} \
{FAILWITH} };\n\
\ PUSH nat 1 ; ADD @valid } }\n\
\ { SWAP ; DROP }\n\
\ }\n\
\ {\n\
\ # There were fewer signatures in the list\n\
\ # than keys. Not all signatures must be present, but\n\
\ # they should be marked as absent using the option type.\n\
\ FAIL\n\
\ } ;\n\
\ SWAP\n\
\ }\n\
\ } ;\n\
\ # Assert that the threshold is less than or equal to the\n\
\ # number of valid signatures.\n\
\ ASSERT_CMPLE ;\n\
\ DROP ; DROP ;\n\n\
\ # Increment counter and place in storage\n\
\ DIP { UNPAIR ; PUSH nat 1 ; ADD @new_counter ; PAIR} ;\n\n\
\ # We have now handled the signature verification part,\n\
\ # produce the operation requested by the signers.\n\
\ NIL operation ; SWAP ;\n\
\ IF_LEFT\n\
\ { # Transfer tokens\n\
\ UNPAIR ; UNIT ; TRANSFER_TOKENS ; CONS }\n\
\ { IF_LEFT {\n\
\ # Change delegate\n\
\ SET_DELEGATE ; CONS }\n\
\ {\n\
\ # Change set of signatures\n\
\ DIP { SWAP ; CAR } ; SWAP ; PAIR ; SWAP }} ;\n\
\ PAIR }\n"
(* Client_proto_context.originate expects the contract script as a Script.expr *)
let multisig_script : Script.expr tzresult =
Tezos_micheline.Micheline_parser.no_parsing_error
@@ Michelson_v1_parser.parse_toplevel
?check:(Some true)
multisig_script_string
>>? fun parsing_result -> ok parsing_result.Michelson_v1_parser.expanded
let multisig_script_hash =
multisig_script
>>? fun mcontract ->
let bytes =
Data_encoding.Binary.to_bytes_exn Script.expr_encoding mcontract
in
let hash = Script_expr_hash.hash_bytes [bytes] in
ok hash
(* The previous multisig script is the only one that the client can
originate but the client knows how to interact with several
versions of the multisig contract. For each version, the description
indicates which features are available and how to interact with
the contract. *)
type multisig_contract_description = {
hash : Script_expr_hash.t;
(* The hash of the contract script *)
requires_chain_id : bool;
(* The signatures should contain the chain identifier *)
generic : bool;
(* False means that the contract uses a custom action type, true
means that the contract expects the action as a (lambda unit
(list operation)). *)
}
let script_hash_of_hex_string s =
Script_expr_hash.of_bytes_exn @@ MBytes.of_hex @@ `Hex s
(* List of known multisig contracts hashes with their kinds *)
let known_multisig_contracts : multisig_contract_description list tzresult =
multisig_script_hash
>>? fun hash ->
ok
[ {hash; requires_chain_id = true; generic = false};
{
hash =
script_hash_of_hex_string
"36cf0b376c2d0e21f0ed42b2974fedaafdcafb9b7f8eb9254ef811b37cb46d94";
requires_chain_id = true;
generic = false;
};
{
hash =
script_hash_of_hex_string
"475e37a6386d0b85890eb446db1faad67f85fc814724ad07473cac8c0a124b31";
requires_chain_id = false;
generic = false;
} ]
let known_multisig_hashes =
known_multisig_contracts
>>? fun l -> ok (List.map (fun descr -> descr.hash) l)
let check_multisig_script script : multisig_contract_description tzresult Lwt.t
=
let bytes = Data_encoding.force_bytes script in
let hash = Script_expr_hash.hash_bytes [bytes] in
Lwt.return known_multisig_contracts
>>=? fun l ->
fold_left_s
(fun descr_opt d ->
return
@@
match descr_opt with
| Some descr ->
Some descr
| None ->
if Script_expr_hash.(d.hash = hash) then Some d else None)
None
l
>>=? function
| None ->
fail
(Not_a_supported_multisig_contract
( hash,
match Data_encoding.force_decode script with
| Some s ->
s
| None ->
assert false ))
| Some d ->
return d
(* Returns [Ok ()] if [~contract] is an originated contract whose code
is [multisig_script] *)
let check_multisig_contract (cctxt : #Protocol_client_context.full) ~chain
~block contract =
Client_proto_context.get_script cctxt ~chain ~block contract
>>=? fun script_opt ->
( match script_opt with
| Some script ->
return script.code
| None ->
fail (Contract_has_no_script contract) )
>>=? check_multisig_script
let seq ~loc l = Tezos_micheline.Micheline.Seq (loc, l)
let pair ~loc a b =
Tezos_micheline.Micheline.Prim (loc, Script.D_Pair, [a; b], [])
let none ~loc () = Tezos_micheline.Micheline.Prim (loc, Script.D_None, [], [])
let some ~loc a = Tezos_micheline.Micheline.Prim (loc, Script.D_Some, [a], [])
let left ~loc a = Tezos_micheline.Micheline.Prim (loc, Script.D_Left, [a], [])
let right ~loc b = Tezos_micheline.Micheline.Prim (loc, Script.D_Right, [b], [])
let int ~loc i = Tezos_micheline.Micheline.Int (loc, i)
let bytes ~loc s = Tezos_micheline.Micheline.Bytes (loc, s)
(** * Actions *)
type multisig_action =
| Transfer of Tez.t * Contract.t
| Change_delegate of public_key_hash option
| Change_keys of Z.t * public_key list
let action_to_expr ~loc = function
| Transfer (amount, destination) ->
left
~loc
(pair
~loc
(int ~loc (Z.of_int64 (Tez.to_mutez amount)))
(bytes
~loc
(Data_encoding.Binary.to_bytes_exn Contract.encoding destination)))
| Change_delegate delegate_opt ->
right
~loc
(left
~loc
( match delegate_opt with
| None ->
none ~loc ()
| Some delegate ->
some
~loc
(bytes
~loc
(Data_encoding.Binary.to_bytes_exn
Signature.Public_key_hash.encoding
delegate)) ))
| Change_keys (threshold, keys) ->
right
~loc
(right
~loc
(pair
~loc
(int ~loc threshold)
(seq
~loc
(List.map
(fun k ->
bytes
~loc
(Data_encoding.Binary.to_bytes_exn
Signature.Public_key.encoding
k))
keys))))
let action_of_expr e =
let fail () =
Error_monad.fail
(Action_deserialisation_error
(Tezos_micheline.Micheline.strip_locations e))
in
match e with
| Tezos_micheline.Micheline.Prim
( _,
Script.D_Left,
[ Tezos_micheline.Micheline.Prim
( _,
Script.D_Pair,
[ Tezos_micheline.Micheline.Int (_, i);
Tezos_micheline.Micheline.Bytes (_, s) ],
[] ) ],
[] ) -> (
match Tez.of_mutez (Z.to_int64 i) with
| None ->
fail ()
| Some amount ->
return
@@ Transfer
(amount, Data_encoding.Binary.of_bytes_exn Contract.encoding s) )
| Tezos_micheline.Micheline.Prim
( _,
Script.D_Right,
[ Tezos_micheline.Micheline.Prim
( _,
Script.D_Left,
[Tezos_micheline.Micheline.Prim (_, Script.D_None, [], [])],
[] ) ],
[] ) ->
return @@ Change_delegate None
| Tezos_micheline.Micheline.Prim
( _,
Script.D_Right,
[ Tezos_micheline.Micheline.Prim
( _,
Script.D_Left,
[ Tezos_micheline.Micheline.Prim
( _,
Script.D_Some,
[Tezos_micheline.Micheline.Bytes (_, s)],
[] ) ],
[] ) ],
[] ) ->
return
@@ Change_delegate
(Some
(Data_encoding.Binary.of_bytes_exn
Signature.Public_key_hash.encoding
s))
| Tezos_micheline.Micheline.Prim
( _,
Script.D_Right,
[ Tezos_micheline.Micheline.Prim
( _,
Script.D_Right,
[ Tezos_micheline.Micheline.Prim
( _,
Script.D_Pair,
[ Tezos_micheline.Micheline.Int (_, threshold);
Tezos_micheline.Micheline.Seq (_, key_bytes) ],
[] ) ],
[] ) ],
[] ) ->
map_s
(function
| Tezos_micheline.Micheline.Bytes (_, s) ->
return
@@ Data_encoding.Binary.of_bytes_exn
Signature.Public_key.encoding
s
| _ ->
fail ())
key_bytes
>>=? fun keys -> return @@ Change_keys (threshold, keys)
| _ ->
fail ()
type key_list = Signature.Public_key.t list
(* The relevant information that we can get about a multisig smart contract *)
type multisig_contract_information = {
counter : Z.t;
threshold : Z.t;
keys : key_list;
}
let multisig_get_information (cctxt : #Protocol_client_context.full) ~chain
~block contract =
let open Client_proto_context in
let open Tezos_micheline.Micheline in
get_storage cctxt ~chain ~block contract
>>=? fun storage_opt ->
match storage_opt with
| None ->
fail (Contract_has_no_storage contract)
| Some storage -> (
match root storage with
| Prim
( _,
D_Pair,
[ Int (_, counter);
Prim (_, D_Pair, [Int (_, threshold); Seq (_, key_nodes)], _) ],
_ ) ->
map_s
(function
| String (_, key_str) ->
return @@ Signature.Public_key.of_b58check_exn key_str
| _ ->
fail (Contract_has_unexpected_storage contract))
key_nodes
>>=? fun keys -> return {counter; threshold; keys}
| _ ->
fail (Contract_has_unexpected_storage contract) )
let multisig_create_storage ~counter ~threshold ~keys () :
Script.expr tzresult Lwt.t =
let loc = Tezos_micheline.Micheline_parser.location_zero in
let open Tezos_micheline.Micheline in
map_s
(fun key ->
let key_str = Signature.Public_key.to_b58check key in
return (String (loc, key_str)))
keys
>>=? fun l ->
return @@ strip_locations
@@ pair ~loc (int ~loc counter) (pair ~loc (int ~loc threshold) (seq ~loc l))
(* Client_proto_context.originate expects the initial storage as a string *)
let multisig_storage_string ~counter ~threshold ~keys () =
multisig_create_storage ~counter ~threshold ~keys ()
>>=? fun expr ->
return @@ Format.asprintf "%a" Michelson_v1_printer.print_expr expr
let multisig_create_param ~counter ~action ~optional_signatures () :
Script.expr tzresult Lwt.t =
let loc = Tezos_micheline.Micheline_parser.location_zero in
let open Tezos_micheline.Micheline in
map_s
(fun sig_opt ->
match sig_opt with
| None ->
return @@ none ~loc ()
| Some signature ->
return @@ some ~loc (String (loc, Signature.to_b58check signature)))
optional_signatures
>>=? fun l ->
return @@ strip_locations
@@ pair
~loc
(pair ~loc (int ~loc counter) (action_to_expr ~loc action))
(Seq (loc, l))
let mutlisig_param_string ~counter ~action ~optional_signatures () =
multisig_create_param ~counter ~action ~optional_signatures ()
>>=? fun expr ->
return @@ Format.asprintf "%a" Michelson_v1_printer.print_expr expr
let get_contract_address_maybe_chain_id ~descr ~loc ~chain_id contract =
let address =
bytes ~loc (Data_encoding.Binary.to_bytes_exn Contract.encoding contract)
in
if descr.requires_chain_id then
let chain_id_bytes =
bytes ~loc (Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id)
in
pair ~loc chain_id_bytes address
else address
let multisig_bytes ~counter ~action ~contract ~chain_id ~descr () =
let loc = Tezos_micheline.Micheline_parser.location_zero in
let triple =
pair
~loc
(get_contract_address_maybe_chain_id ~descr ~loc ~chain_id contract)
(pair ~loc (int ~loc counter) (action_to_expr ~loc action))
in
let bytes =
Data_encoding.Binary.to_bytes_exn Script.expr_encoding
@@ Tezos_micheline.Micheline.strip_locations @@ triple
in
return @@ Bytes.concat (Bytes.of_string "") [Bytes.of_string "\005"; bytes]
let check_threshold ~threshold ~keys () =
let nkeys = List.length keys in
let threshold = Z.to_int threshold in
if Compare.Int.(List.length keys < threshold) then
fail (Threshold_too_high (threshold, nkeys))
else if Compare.Int.(threshold <= 0) then
fail (Non_positive_threshold threshold)
else return_unit
let originate_multisig (cctxt : #Protocol_client_context.full) ~chain ~block
?confirmations ?dry_run ?branch ?fee ?gas_limit ?storage_limit ~delegate
~threshold ~keys ~balance ~source ~src_pk ~src_sk ~fee_parameter () =
Lwt.return multisig_script
>>=? fun code ->
multisig_storage_string ~counter:Z.zero ~threshold ~keys ()
>>=? fun initial_storage ->
check_threshold ~threshold ~keys ()
>>=? fun () ->
Client_proto_context.originate_contract
cctxt
~chain
~block
?branch
?confirmations
?dry_run
?fee
?gas_limit
?storage_limit
~delegate
~initial_storage
~balance
~source
~src_pk
~src_sk
~code
~fee_parameter
()
type multisig_prepared_action = {
bytes : Bytes.t;
threshold : Z.t;
keys : public_key list;
counter : Z.t;
}
let check_action ~action () =
match action with
| Change_keys (threshold, keys) ->
check_threshold ~threshold ~keys ()
| _ ->
return_unit
let prepare_multisig_transaction (cctxt : #Protocol_client_context.full) ~chain
~block ~multisig_contract ~action () =
let contract = multisig_contract in
check_multisig_contract cctxt ~chain ~block contract
>>=? fun descr ->
check_action ~action ()
>>=? fun () ->
multisig_get_information cctxt ~chain ~block contract
>>=? fun {counter; threshold; keys} ->
Chain_services.chain_id cctxt ~chain ()
>>=? fun chain_id ->
multisig_bytes ~counter ~action ~contract ~descr ~chain_id ()
>>=? fun bytes -> return {bytes; threshold; keys; counter}
let check_multisig_signatures ~bytes ~threshold ~keys signatures =
let key_array = Array.of_list keys in
let nkeys = Array.length key_array in
let opt_sigs_arr = Array.make nkeys None in
let matching_key_found = ref false in
let check_signature_against_key_number signature i key =
_when (Signature.check key signature bytes) (fun () ->
return
@@
( matching_key_found := true ;
opt_sigs_arr.(i) <- Some signature ))
in
iter_p
(fun signature ->
return @@ (matching_key_found := false)
>>=? fun () ->
iteri_p (check_signature_against_key_number signature) keys
>>=? fun () ->
fail_unless !matching_key_found (Invalid_signature signature))
signatures
>>=? fun () ->
let opt_sigs = Array.to_list opt_sigs_arr in
let signature_count =
List.fold_left
(fun n sig_opt -> match sig_opt with Some _ -> n + 1 | None -> n)
0
opt_sigs
in
let threshold_int = Z.to_int threshold in
if signature_count >= threshold_int then return opt_sigs
else fail (Not_enough_signatures (threshold_int, signature_count))
let call_multisig (cctxt : #Protocol_client_context.full) ~chain ~block
?confirmations ?dry_run ?branch ~source ~src_pk ~src_sk ~multisig_contract
~action ~signatures ~amount ?fee ?gas_limit ?storage_limit ?counter
~fee_parameter () =
prepare_multisig_transaction
cctxt
~chain
~block
~multisig_contract
~action
()
>>=? fun {bytes; threshold; keys; counter = stored_counter} ->
check_multisig_signatures ~bytes ~threshold ~keys signatures
>>=? fun optional_signatures ->
mutlisig_param_string ~counter:stored_counter ~action ~optional_signatures ()
>>=? fun arg ->
Client_proto_context.transfer
cctxt
~chain
~block
?confirmations
?dry_run
?branch
~source
~src_pk
~src_sk
~destination:multisig_contract
~arg
~amount
?fee
?gas_limit
?storage_limit
?counter
~fee_parameter
()
let action_of_bytes ~multisig_contract ~stored_counter ~descr ~chain_id bytes =
if
Compare.Int.(Bytes.length bytes >= 1)
&& Compare.Int.(TzEndian.get_uint8 bytes 0 = 0x05)
then
let nbytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in
match Data_encoding.Binary.of_bytes Script.expr_encoding nbytes with
| None ->
fail (Bytes_deserialisation_error bytes)
| Some e -> (
match Tezos_micheline.Micheline.root e with
| Tezos_micheline.Micheline.Prim
( _,
Script.D_Pair,
[ Tezos_micheline.Micheline.Bytes (_, contract_bytes);
Tezos_micheline.Micheline.Prim
( _,
Script.D_Pair,
[Tezos_micheline.Micheline.Int (_, counter); e],
[] ) ],
[] )
when not descr.requires_chain_id ->
let contract =
Data_encoding.Binary.of_bytes_exn Contract.encoding contract_bytes
in
if counter = stored_counter then
if multisig_contract = contract then action_of_expr e
else fail (Bad_deserialized_contract (contract, multisig_contract))
else fail (Bad_deserialized_counter (counter, stored_counter))
| Tezos_micheline.Micheline.Prim
( _,
Script.D_Pair,
[ Tezos_micheline.Micheline.Prim
( _,
Script.D_Pair,
[ Tezos_micheline.Micheline.Bytes (_, chain_id_bytes);
Tezos_micheline.Micheline.Bytes (_, contract_bytes) ],
[] );
Tezos_micheline.Micheline.Prim
( _,
Script.D_Pair,
[Tezos_micheline.Micheline.Int (_, counter); e],
[] ) ],
[] )
when descr.requires_chain_id ->
let contract =
Data_encoding.Binary.of_bytes_exn Contract.encoding contract_bytes
in
let cid =
Data_encoding.Binary.of_bytes_exn Chain_id.encoding chain_id_bytes
in
if counter = stored_counter then
if multisig_contract = contract && chain_id = cid then
action_of_expr e
else fail (Bad_deserialized_contract (contract, multisig_contract))
else fail (Bad_deserialized_counter (counter, stored_counter))
| _ ->
fail (Bytes_deserialisation_error bytes) )
else fail (Bytes_deserialisation_error bytes)
let call_multisig_on_bytes (cctxt : #Protocol_client_context.full) ~chain
~block ?confirmations ?dry_run ?branch ~source ~src_pk ~src_sk
~multisig_contract ~bytes ~signatures ~amount ?fee ?gas_limit
?storage_limit ?counter ~fee_parameter () =
multisig_get_information cctxt ~chain ~block multisig_contract
>>=? fun info ->
check_multisig_contract cctxt ~chain ~block multisig_contract
>>=? fun descr ->
Chain_services.chain_id cctxt ~chain ()
>>=? fun chain_id ->
action_of_bytes
~multisig_contract
~stored_counter:info.counter
~chain_id
~descr
bytes
>>=? fun action ->
call_multisig
cctxt
~chain
~block
?confirmations
?dry_run
?branch
~source
~src_pk
~src_sk
~multisig_contract
~action
~signatures
~amount
?fee
?gas_limit
?storage_limit
?counter
~fee_parameter
()
src/proto_alpha/lib_client/client_proto_multisig.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol_client_context.
Import Protocol.
Import Alpha_context.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition multisig_script_string : string :=
"parameter (pair
(pair :payload
(nat %counter) # counter, used to prevent replay attacks
(or :action # payload to sign, represents the requested action
(pair :transfer # transfer tokens
(mutez %amount) # amount to transfer
(contract %dest unit)) # destination to transfer to
(or
(option %delegate key_hash) # change the delegate to this address
(pair %change_keys # change the keys controlling the multisig
(nat %threshold) # new threshold
(list %keys key))))) # new list of keys
(list %sigs (option signature))); # signatures
storage (pair (nat %stored_counter) (pair (nat %threshold) (list %keys key))) ;
code
{
UNPAIR ; SWAP ; DUP ; DIP { SWAP } ;
DIP
{
UNPAIR ;
# pair the payload with the current contract address, to ensure signatures
# can't be replayed accross different contracts if a key is reused.
DUP ; SELF ; ADDRESS ; CHAIN_ID ; PAIR ; PAIR ;
PACK ; # form the binary payload that we expect to be signed
DIP { UNPAIR @counter ; DIP { SWAP } } ; SWAP
} ;
# Check that the counters match
UNPAIR @stored_counter; DIP { SWAP };
ASSERT_CMPEQ ;
# Compute the number of valid signatures
DIP { SWAP } ; UNPAIR @threshold @keys;
DIP
{
# Running count of valid signatures
PUSH @valid nat 0; SWAP ;
ITER
{
DIP { SWAP } ; SWAP ;
IF_CONS
{
IF_SOME
{ SWAP ;
DIP
{
SWAP ; DIIP { DUUP } ;
# Checks signatures, fails if invalid
{ DUUUP; DIP {CHECK_SIGNATURE}; SWAP; IF {DROP} {FAILWITH} };
PUSH nat 1 ; ADD @valid } }
{ SWAP ; DROP }
}
{
# There were fewer signatures in the list
# than keys. Not all signatures must be present, but
# they should be marked as absent using the option type.
FAIL
} ;
SWAP
}
} ;
# Assert that the threshold is less than or equal to the
# number of valid signatures.
ASSERT_CMPLE ;
DROP ; DROP ;
# Increment counter and place in storage
DIP { UNPAIR ; PUSH nat 1 ; ADD @new_counter ; PAIR} ;
# We have now handled the signature verification part,
# produce the operation requested by the signers.
NIL operation ; SWAP ;
IF_LEFT
{ # Transfer tokens
UNPAIR ; UNIT ; TRANSFER_TOKENS ; CONS }
{ IF_LEFT {
# Change delegate
SET_DELEGATE ; CONS }
{
# Change set of signatures
DIP { SWAP ; CAR } ; SWAP ; PAIR ; SWAP }} ;
PAIR }
"
% string.
Definition multisig_script
: Tezos_base__TzPervasives.tzresult
Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr :=
op_gtgtquestion
(apply Tezos_micheline.Micheline_parser.no_parsing_error
(Michelson_v1_parser.parse_toplevel (Some true) multisig_script_string))
(fun parsing_result => ok (Michelson_v1_parser.expanded parsing_result)).
Definition multisig_script_hash
: Tezos_base__TzPervasives.tzresult
Tezos_protocol_alpha.Protocol.Script_expr_hash.t :=
op_gtgtquestion multisig_script
(fun mcontract =>
let bytes :=
Data_encoding.Binary.to_bytes_exn Script.expr_encoding mcontract in
let hash := Script_expr_hash.hash_bytes None (cons string []) in
ok hash).
Record multisig_contract_description := {
hash : Tezos_protocol_alpha.Protocol.Script_expr_hash.t;
requires_chain_id : bool;
generic : bool }.
Definition script_hash_of_hex_string (s : string)
: Tezos_protocol_alpha.Protocol.Script_expr_hash.t :=
apply Script_expr_hash.of_bytes_exn
(apply MBytes.of_hex
(* ❌ Variants not supported *)
variant).
Definition known_multisig_contracts
: Tezos_base__TzPervasives.tzresult (list multisig_contract_description) :=
op_gtgtquestion multisig_script_hash
(fun hash =>
ok
(cons {| hash := hash; requires_chain_id := true; generic := false |}
(cons
{|
hash :=
script_hash_of_hex_string
"36cf0b376c2d0e21f0ed42b2974fedaafdcafb9b7f8eb9254ef811b37cb46d94"
% string; requires_chain_id := true; generic := false |}
(cons
{|
hash :=
script_hash_of_hex_string
"475e37a6386d0b85890eb446db1faad67f85fc814724ad07473cac8c0a124b31"
% string; requires_chain_id := false; generic := false |}
[])))).
Definition known_multisig_hashes
: Tezos_base__TzPervasives.tzresult
(list Tezos_protocol_alpha.Protocol.Script_expr_hash.t) :=
op_gtgtquestion known_multisig_contracts
(fun l => ok (List.map (fun descr => hash descr) l)).
Definition check_multisig_script
(script :
Tezos_base__TzPervasives.Data_encoding.lazy_t
Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
: Lwt.t (Tezos_base__TzPervasives.tzresult multisig_contract_description) :=
let bytes := Data_encoding.force_bytes script in
let hash := Script_expr_hash.hash_bytes None (cons string []) in
op_gtgteqquestion (Lwt._return known_multisig_contracts)
(fun l =>
op_gtgteqquestion
(fold_left_s
(fun descr_opt =>
fun d =>
apply _return
match descr_opt with
| Some descr => Some descr
| None =>
if op_eq (hash d) hash then
Some d
else
None
end) None l)
(fun function_parameter =>
match function_parameter with
| None =>
fail
(Tezos_base__TzPervasives.Not_a_supported_multisig_contract
(hash,
match Data_encoding.force_decode script with
| Some s => s
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
end))
| Some d => _return d
end)).
Definition check_multisig_contract {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block)
(contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult multisig_contract_description) :=
op_gtgteqquestion (Client_proto_context.get_script cctxt chain block contract)
(fun script_opt =>
op_gtgteqquestion
match script_opt with
| Some script => _return (code script)
| None =>
fail (Tezos_base__TzPervasives.Contract_has_no_script contract)
end check_multisig_script).
Definition seq {A B : Type}
(loc : A) (l : list (Tezos_micheline.Micheline.node A B))
: Tezos_micheline.Micheline.node A B := Tezos_micheline.Micheline.Seq loc l.
Definition pair {A : Type}
(loc : A)
(a :
Tezos_micheline.Micheline.node A
Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
(b :
Tezos_micheline.Micheline.node A
Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
: Tezos_micheline.Micheline.node A
Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
Tezos_micheline.Micheline.Prim loc
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
(cons a (cons b [])) [].
Definition none {A : Type} (loc : A) (function_parameter : unit)
: Tezos_micheline.Micheline.node A
Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
let 'tt := function_parameter in
Tezos_micheline.Micheline.Prim loc
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_None [] [].
Definition some {A : Type}
(loc : A)
(a :
Tezos_micheline.Micheline.node A
Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
: Tezos_micheline.Micheline.node A
Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
Tezos_micheline.Micheline.Prim loc
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Some (cons a []) [].
Definition left {A : Type}
(loc : A)
(a :
Tezos_micheline.Micheline.node A
Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
: Tezos_micheline.Micheline.node A
Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
Tezos_micheline.Micheline.Prim loc
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Left (cons a []) [].
Definition right {A : Type}
(loc : A)
(b :
Tezos_micheline.Micheline.node A
Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
: Tezos_micheline.Micheline.node A
Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
Tezos_micheline.Micheline.Prim loc
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Right (cons b []) [].
Definition int {A B : Type} (loc : A) (i : Z.t)
: Tezos_micheline.Micheline.node A B := Tezos_micheline.Micheline.Int loc i.
Definition bytes {A B : Type} (loc : A) (s : Stdlib.Bytes.t)
: Tezos_micheline.Micheline.node A B := Tezos_micheline.Micheline.Bytes loc s.
Inductive multisig_action : Type :=
| Transfer : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t -> multisig_action
| Change_delegate :
(option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash) ->
multisig_action
| Change_keys : Z.t ->
(list Tezos_protocol_alpha.Protocol.Alpha_context.public_key) ->
multisig_action.
Definition action_to_expr {A : Type}
(loc : A) (function_parameter : multisig_action)
: Tezos_micheline.Micheline.node A
Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
match function_parameter with
| Transfer amount destination =>
left loc
(pair loc (Z loc (Z.of_int64 (Tez.to_mutez amount)))
(string loc
(Data_encoding.Binary.to_bytes_exn Contract.encoding destination)))
| Change_delegate delegate_opt =>
right loc
(left loc
match delegate_opt with
| None => none loc tt
| Some delegate =>
some loc
(string loc
(Data_encoding.Binary.to_bytes_exn
Signature.Public_key_hash.encoding delegate))
end)
| Change_keys threshold keys =>
right loc
(right loc
(pair loc (Z loc threshold)
(seq loc
(List.map
(fun k =>
string loc
(Data_encoding.Binary.to_bytes_exn
Signature.Public_key.encoding k)) keys))))
end.
Definition action_of_expr {A : Type}
(e :
Tezos_micheline.Micheline.node A
Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
: Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult multisig_action) :=
let fail {B : Type} (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult B) :=
let 'tt := function_parameter in
Error_monad.fail
(Tezos_base__TzPervasives.Action_deserialisation_error
(Tezos_micheline.Micheline.strip_locations e)) in
match e with
|
Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Left
(cons
(Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
(cons (Tezos_micheline.Micheline.Int _ i)
(cons (Tezos_micheline.Micheline.Bytes _ s) [])) []) []) [] =>
match Tez.of_mutez (Z.to_int64 i) with
| None => fail tt
| Some amount =>
apply _return
(Transfer amount (Data_encoding.Binary.of_bytes_exn Contract.encoding s))
end
|
Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Right
(cons
(Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Left
(cons
(Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_None [] [])
[]) []) []) [] => apply _return (Change_delegate None)
|
Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Right
(cons
(Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Left
(cons
(Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Some
(cons (Tezos_micheline.Micheline.Bytes _ s) []) []) []) []) []) []
=>
apply _return
(Change_delegate
(Some
(Data_encoding.Binary.of_bytes_exn Signature.Public_key_hash.encoding
s)))
|
Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Right
(cons
(Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Right
(cons
(Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
(cons (Tezos_micheline.Micheline.Int _ threshold)
(cons (Tezos_micheline.Micheline.Seq _ key_bytes) [])) []) [])
[]) []) [] =>
op_gtgteqquestion
(map_s
(fun function_parameter =>
match function_parameter with
| Tezos_micheline.Micheline.Bytes _ s =>
apply _return
(Data_encoding.Binary.of_bytes_exn Signature.Public_key.encoding s)
| _ => fail tt
end) key_bytes)
(fun keys => apply _return (Change_keys threshold keys))
| _ => fail tt
end.
Definition key_list := list Tezos_base__TzPervasives.Signature.Public_key.t.
Record multisig_contract_information := {
counter : Z.t;
threshold : Z.t;
keys : key_list }.
Definition multisig_get_information {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block)
(contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult multisig_contract_information) :=
op_gtgteqquestion (get_storage cctxt chain block contract)
(fun storage_opt =>
match storage_opt with
| None => fail (Tezos_base__TzPervasives.Contract_has_no_storage contract)
| Some storage =>
match root storage with
|
Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
(cons (Tezos_micheline.Micheline.Int _ counter)
(cons
(Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
(cons (Tezos_micheline.Micheline.Int _ threshold)
(cons (Tezos_micheline.Micheline.Seq _ key_nodes) [])) _) []))
_ =>
op_gtgteqquestion
(map_s
(fun function_parameter =>
match function_parameter with
| Tezos_micheline.Micheline.String _ key_str =>
apply _return (Signature.Public_key.of_b58check_exn key_str)
| _ =>
fail
(Tezos_base__TzPervasives.Contract_has_unexpected_storage
contract)
end) key_nodes)
(fun keys =>
_return
{| counter := counter; threshold := threshold; keys := keys |})
| _ =>
fail
(Tezos_base__TzPervasives.Contract_has_unexpected_storage contract)
end
end).
Definition multisig_create_storage
(counter : Z.t) (threshold : Z.t)
(keys : list Tezos_base__TzPervasives.Signature.Public_key.t)
(function_parameter : unit)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr) :=
let 'tt := function_parameter in
let loc := Tezos_micheline.Micheline_parser.location_zero in
op_gtgteqquestion
(map_s
(fun key =>
let key_str := Signature.Public_key.to_b58check key in
_return (Tezos_micheline.Micheline.String loc key_str)) keys)
(fun l =>
apply _return
(apply strip_locations
(pair loc (Z loc counter) (pair loc (Z loc threshold) (seq loc l))))).
Definition multisig_storage_string
(counter : Z.t) (threshold : Z.t)
(keys : list Tezos_base__TzPervasives.Signature.Public_key.t)
(function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
let 'tt := function_parameter in
op_gtgteqquestion (multisig_create_storage counter threshold keys tt)
(fun expr =>
apply _return
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Michelson_v1_printer.print_expr expr)).
Definition multisig_create_param
(counter : Z.t) (action : multisig_action)
(optional_signatures : list (option Tezos_base__TzPervasives.Signature.t))
(function_parameter : unit)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr) :=
let 'tt := function_parameter in
let loc := Tezos_micheline.Micheline_parser.location_zero in
op_gtgteqquestion
(map_s
(fun sig_opt =>
match sig_opt with
| None => apply _return (none loc tt)
| Some signature =>
apply _return
(some loc
(Tezos_micheline.Micheline.String loc
(Signature.to_b58check signature)))
end) optional_signatures)
(fun l =>
apply _return
(apply strip_locations
(pair loc (pair loc (Z loc counter) (action_to_expr loc action))
(Tezos_micheline.Micheline.Seq loc l)))).
Definition mutlisig_param_string
(counter : Z.t) (action : multisig_action)
(optional_signatures : list (option Tezos_base__TzPervasives.Signature.t))
(function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
let 'tt := function_parameter in
op_gtgteqquestion
(multisig_create_param counter action optional_signatures tt)
(fun expr =>
apply _return
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Michelson_v1_printer.print_expr expr)).
Definition get_contract_address_maybe_chain_id {A : Type}
(descr : multisig_contract_description) (loc : A)
(chain_id : Tezos_base__TzPervasives.Chain_id.t)
(contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
: Tezos_micheline.Micheline.node A
Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
let address :=
string loc (Data_encoding.Binary.to_bytes_exn Contract.encoding contract) in
if requires_chain_id descr then
let chain_id_bytes :=
string loc (Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id)
in
pair loc chain_id_bytes address
else
address.
Definition multisig_bytes
(counter : Z.t) (action : multisig_action)
(contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
(chain_id : Tezos_base__TzPervasives.Chain_id.t)
(descr : multisig_contract_description) (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
let 'tt := function_parameter in
let loc := Tezos_micheline.Micheline_parser.location_zero in
let triple :=
pair loc (get_contract_address_maybe_chain_id descr loc chain_id contract)
(pair loc (Z loc counter) (action_to_expr loc action)) in
let bytes :=
apply (Data_encoding.Binary.to_bytes_exn Script.expr_encoding)
(apply Tezos_micheline.Micheline.strip_locations triple) in
apply _return
(String.concat (Stdlib.Bytes.of_string "" % string)
(cons (Stdlib.Bytes.of_string "" % string) (cons string []))).
Definition check_threshold {A : Type}
(threshold : Z.t) (keys : list A) (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let 'tt := function_parameter in
let nkeys := List.length keys in
let threshold := Z.to_int threshold in
if op_lt (List.length keys) threshold then
fail (Tezos_base__TzPervasives.Threshold_too_high threshold nkeys)
else
if op_lteq threshold 0 then
fail (Tezos_base__TzPervasives.Non_positive_threshold threshold)
else
return_unit.
Definition originate_multisig {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
(dry_run : option bool) (branch : option Z)
(fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(gas_limit : option Z.t) (storage_limit : option Z.t)
(delegate : option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
(threshold : Z.t)
(keys : list Tezos_base__TzPervasives.Signature.Public_key.t)
(balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(source : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
(src_pk : Tezos_protocol_alpha.Protocol.Alpha_context.public_key)
(src_sk : Tezos_client_base.Client_keys.sk_uri)
(fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
(function_parameter : unit)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
((Tezos_client_alpha.Injection.result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.origination)) *
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)) :=
let 'tt := function_parameter in
op_gtgteqquestion (Lwt._return multisig_script)
(fun code =>
op_gtgteqquestion (multisig_storage_string Z.zero threshold keys tt)
(fun initial_storage =>
op_gtgteqquestion (check_threshold threshold keys tt)
(fun function_parameter =>
let 'tt := function_parameter in
Client_proto_context.originate_contract cctxt chain block
confirmations dry_run None branch fee gas_limit storage_limit
delegate initial_storage balance source src_pk src_sk code
fee_parameter tt))).
Record multisig_prepared_action := {
bytes : Stdlib.Bytes.t;
threshold : Z.t;
keys : list Tezos_protocol_alpha.Protocol.Alpha_context.public_key;
counter : Z.t }.
Definition check_action (action : multisig_action) (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let 'tt := function_parameter in
match action with
| Change_keys threshold keys => check_threshold threshold keys tt
| _ => return_unit
end.
Definition prepare_multisig_transaction {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block)
(multisig_contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
(action : multisig_action) (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult multisig_prepared_action) :=
let 'tt := function_parameter in
let contract := multisig_contract in
op_gtgteqquestion (check_multisig_contract cctxt chain block contract)
(fun descr =>
op_gtgteqquestion (check_action action tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(multisig_get_information cctxt chain block contract)
(fun function_parameter =>
let '{|
counter := counter; threshold := threshold; keys := keys |} :=
function_parameter in
op_gtgteqquestion (Chain_services.chain_id cctxt (Some chain) tt)
(fun chain_id =>
op_gtgteqquestion
(multisig_bytes counter action contract chain_id descr tt)
(fun bytes =>
_return
{| bytes := string; threshold := threshold;
keys := keys; counter := counter |}))))).
Definition check_multisig_signatures
(bytes : Stdlib.Bytes.t) (threshold : Z.t)
(keys : list Tezos_base__TzPervasives.Signature.Public_key.t)
(signatures : list Tezos_base__TzPervasives.Signature.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list (option Tezos_base__TzPervasives.Signature.t))) :=
let key_array := Array.of_list keys in
let nkeys := Array.length key_array in
let opt_sigs_arr := Array.make nkeys None in
let matching_key_found := Stdlib.ref false in
let check_signature_against_key_number
(signature : Tezos_base__TzPervasives.Signature.t) (i : Z) (key :
Tezos_base__TzPervasives.Signature.Public_key.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
_when (Signature.check None key signature string)
(fun function_parameter =>
let 'tt := function_parameter in
apply _return
(* ❌ Sequences of instructions are not handled (operator ";") *)
(let _ := Stdlib.op_coloneq matching_key_found true in
Array.set opt_sigs_arr i (Some signature))) in
op_gtgteqquestion
(iter_p
(fun signature =>
op_gtgteqquestion
(apply _return (Stdlib.op_coloneq matching_key_found false))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(iteri_p (check_signature_against_key_number signature) keys)
(fun function_parameter =>
let 'tt := function_parameter in
fail_unless (Stdlib.op_exclamation matching_key_found)
(Tezos_base__TzPervasives.Invalid_signature signature))))
signatures)
(fun function_parameter =>
let 'tt := function_parameter in
let opt_sigs := Array.to_list opt_sigs_arr in
let signature_count :=
List.fold_left
(fun n =>
fun sig_opt =>
match sig_opt with
| Some _ => Z.add n 1
| None => n
end) 0 opt_sigs in
let threshold_int := Z.to_int threshold in
if OCaml.Stdlib.ge signature_count threshold_int then
_return opt_sigs
else
fail
(Tezos_base__TzPervasives.Not_enough_signatures threshold_int
signature_count)).
Definition call_multisig {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
(dry_run : option bool) (branch : option Z)
(source : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
(src_pk : Tezos_protocol_alpha.Protocol.Alpha_context.public_key)
(src_sk : Tezos_client_base.Client_keys.sk_uri)
(multisig_contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
(action : multisig_action)
(signatures : list Tezos_base__TzPervasives.Signature.t)
(amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(gas_limit : option Z.t) (storage_limit : option Z.t) (counter : option Z.t)
(fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
(function_parameter : unit)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
((Tezos_client_alpha.Injection.result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction)) *
(list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))) :=
let 'tt := function_parameter in
op_gtgteqquestion
(prepare_multisig_transaction cctxt chain block multisig_contract action tt)
(fun function_parameter =>
let '{|
bytes := bytes;
threshold := threshold;
keys := keys;
counter := stored_counter
|} := function_parameter in
op_gtgteqquestion
(check_multisig_signatures string threshold keys signatures)
(fun optional_signatures =>
op_gtgteqquestion
(mutlisig_param_string stored_counter action optional_signatures tt)
(fun arg =>
Client_proto_context.transfer cctxt chain block confirmations
dry_run None branch source src_pk src_sk multisig_contract None
(Some arg) amount fee gas_limit storage_limit counter
fee_parameter tt))).
Definition action_of_bytes
(multisig_contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
(stored_counter : Tezos_protocol_alpha.Protocol.Alpha_context.counter)
(descr : multisig_contract_description)
(chain_id : Tezos_base__TzPervasives.Chain_id.t) (bytes : Stdlib.Bytes.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult multisig_action) :=
if
andb (op_gteq (String.length string) 1)
(op_eq (TzEndian.get_uint8 string 0) 5) then
let nbytes := String.sub string 1 (Z.sub (String.length string) 1) in
match Data_encoding.Binary.of_bytes Script.expr_encoding nbytes with
| None => fail (Tezos_base__TzPervasives.Bytes_deserialisation_error string)
| Some e =>
match Tezos_micheline.Micheline.root e with
|
Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
(cons (Tezos_micheline.Micheline.Bytes _ contract_bytes)
(cons
(Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
(cons (Tezos_micheline.Micheline.Int _ counter) (cons e [])) [])
[])) [] =>
let contract :=
Data_encoding.Binary.of_bytes_exn Contract.encoding contract_bytes in
if equiv_decb counter stored_counter then
if equiv_decb multisig_contract contract then
action_of_expr e
else
fail
(Tezos_base__TzPervasives.Bad_deserialized_contract
(contract, multisig_contract))
else
fail
(Tezos_base__TzPervasives.Bad_deserialized_counter
(counter, stored_counter))
|
Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
(cons
(Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
(cons (Tezos_micheline.Micheline.Bytes _ chain_id_bytes)
(cons (Tezos_micheline.Micheline.Bytes _ contract_bytes) [])) [])
(cons
(Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
(cons (Tezos_micheline.Micheline.Int _ counter) (cons e [])) [])
[])) [] =>
let contract :=
Data_encoding.Binary.of_bytes_exn Contract.encoding contract_bytes in
let cid :=
Data_encoding.Binary.of_bytes_exn Chain_id.encoding chain_id_bytes in
if equiv_decb counter stored_counter then
if
andb (equiv_decb multisig_contract contract)
(equiv_decb chain_id cid) then
action_of_expr e
else
fail
(Tezos_base__TzPervasives.Bad_deserialized_contract
(contract, multisig_contract))
else
fail
(Tezos_base__TzPervasives.Bad_deserialized_counter
(counter, stored_counter))
| _ => fail (Tezos_base__TzPervasives.Bytes_deserialisation_error string)
end
end
else
fail (Tezos_base__TzPervasives.Bytes_deserialisation_error string).
Definition call_multisig_on_bytes {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
(dry_run : option bool) (branch : option Z)
(source : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
(src_pk : Tezos_protocol_alpha.Protocol.Alpha_context.public_key)
(src_sk : Tezos_client_base.Client_keys.sk_uri)
(multisig_contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
(bytes : Stdlib.Bytes.t)
(signatures : list Tezos_base__TzPervasives.Signature.t)
(amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(gas_limit : option Z.t) (storage_limit : option Z.t) (counter : option Z.t)
(fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
(function_parameter : unit)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
((Tezos_client_alpha.Injection.result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction)) *
(list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))) :=
let 'tt := function_parameter in
op_gtgteqquestion
(multisig_get_information cctxt chain block multisig_contract)
(fun info =>
op_gtgteqquestion
(check_multisig_contract cctxt chain block multisig_contract)
(fun descr =>
op_gtgteqquestion (Chain_services.chain_id cctxt (Some chain) tt)
(fun chain_id =>
op_gtgteqquestion
(action_of_bytes multisig_contract (counter info) descr chain_id
string)
(fun action =>
call_multisig cctxt chain block confirmations dry_run branch
source src_pk src_sk multisig_contract action signatures
amount fee gas_limit storage_limit counter fee_parameter tt)))).
src/proto_alpha/lib_client/client_proto_programs.ml 290 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Tezos_micheline
open Michelson_v1_printer
module Program = Client_aliases.Alias (struct
type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result
let encoding =
Data_encoding.conv
(fun ({Michelson_v1_parser.source; _}, _) -> source)
(fun source -> Michelson_v1_parser.parse_toplevel source)
Data_encoding.string
let of_source source = return (Michelson_v1_parser.parse_toplevel source)
let to_source ({Michelson_v1_parser.source; _}, _) = return source
let name = "script"
end)
let print_errors (cctxt : #Client_context.printer) errs ~show_source ~parsed =
cctxt#warning
"%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source
~parsed)
errs
>>= fun () -> cctxt#error "error running script" >>= fun () -> return_unit
let print_run_result (cctxt : #Client_context.printer) ~show_source ~parsed =
function
| Ok (storage, operations, maybe_diff) ->
cctxt#message
"@[<v 0>@[<v 2>storage@,\
%a@]@,\
@[<v 2>emitted operations@,\
%a@]@,\
@[<v 2>big_map diff@,\
%a@]@]@."
print_expr
storage
(Format.pp_print_list Operation_result.pp_internal_operation)
operations
(fun ppf -> function None -> () | Some diff ->
print_big_map_diff ppf diff)
maybe_diff
>>= fun () -> return_unit
| Error errs ->
print_errors cctxt errs ~show_source ~parsed
let print_trace_result (cctxt : #Client_context.printer) ~show_source ~parsed =
function
| Ok (storage, operations, trace, maybe_big_map_diff) ->
cctxt#message
"@[<v 0>@[<v 2>storage@,\
%a@]@,\
@[<v 2>emitted operations@,\
%a@]@,\
@[<v 2>big_map diff@,\
%a@]@,\
@[<v 2>trace@,\
%a@]@]@."
print_expr
storage
(Format.pp_print_list Operation_result.pp_internal_operation)
operations
(fun ppf -> function None -> () | Some diff ->
print_big_map_diff ppf diff)
maybe_big_map_diff
print_execution_trace
trace
>>= fun () -> return_unit
| Error errs ->
print_errors cctxt errs ~show_source ~parsed
let run (cctxt : #Protocol_client_context.rpc_context)
~(chain : Chain_services.chain) ~block ?(amount = Tez.fifty_cents)
~(program : Michelson_v1_parser.parsed)
~(storage : Michelson_v1_parser.parsed)
~(input : Michelson_v1_parser.parsed) ?source ?payer ?gas
?(entrypoint = "default") () =
Chain_services.chain_id cctxt ~chain ()
>>=? fun chain_id ->
Alpha_services.Helpers.Scripts.run_code
cctxt
(chain, block)
program.expanded
( storage.expanded,
input.expanded,
amount,
chain_id,
source,
payer,
gas,
entrypoint )
let trace (cctxt : #Protocol_client_context.rpc_context)
~(chain : Chain_services.chain) ~block ?(amount = Tez.fifty_cents)
~(program : Michelson_v1_parser.parsed)
~(storage : Michelson_v1_parser.parsed)
~(input : Michelson_v1_parser.parsed) ?source ?payer ?gas
?(entrypoint = "default") () =
Chain_services.chain_id cctxt ~chain ()
>>=? fun chain_id ->
Alpha_services.Helpers.Scripts.trace_code
cctxt
(chain, block)
program.expanded
( storage.expanded,
input.expanded,
amount,
chain_id,
source,
payer,
gas,
entrypoint )
let typecheck_data cctxt ~(chain : Chain_services.chain) ~block ?gas
~(data : Michelson_v1_parser.parsed) ~(ty : Michelson_v1_parser.parsed) ()
=
Alpha_services.Helpers.Scripts.typecheck_data
cctxt
(chain, block)
(data.expanded, ty.expanded, gas)
let typecheck_program cctxt ~(chain : Chain_services.chain) ~block ?gas
(program : Michelson_v1_parser.parsed) =
Alpha_services.Helpers.Scripts.typecheck_code
cctxt
(chain, block)
(program.expanded, gas)
let print_typecheck_result ~emacs ~show_types ~print_source_on_error program
res (cctxt : #Client_context.printer) =
if emacs then
let (type_map, errs, _gas) =
match res with
| Ok (type_map, gas) ->
(type_map, [], Some gas)
| Error
( Environment.Ecoproto_error
(Script_tc_errors.Ill_typed_contract (_, type_map))
:: _ as errs ) ->
(type_map, errs, None)
| Error errs ->
([], errs, None)
in
cctxt#message
"(@[<v 0>(types . %a)@ (errors . %a)@])"
Michelson_v1_emacs.print_type_map
(program, type_map)
Michelson_v1_emacs.report_errors
(program, errs)
>>= fun () -> return_unit
else
match res with
| Ok (type_map, gas) ->
let program = Michelson_v1_printer.inject_types type_map program in
cctxt#message "@[<v 0>Well typed@,Gas remaining: %a@]" Gas.pp gas
>>= fun () ->
if show_types then
cctxt#message "%a" Micheline_printer.print_expr program
>>= fun () -> return_unit
else return_unit
| Error errs ->
cctxt#warning
"%a"
(Michelson_v1_error_reporter.report_errors
~details:show_types
~show_source:print_source_on_error
~parsed:program)
errs
>>= fun () -> cctxt#error "ill-typed script"
let entrypoint_type cctxt ~(chain : Chain_services.chain) ~block
(program : Michelson_v1_parser.parsed) ~entrypoint =
Michelson_v1_entrypoints.script_entrypoint_type
cctxt
~chain
~block
program.expanded
~entrypoint
let print_entrypoint_type (cctxt : #Client_context.printer) ~emacs ?script_name
~show_source ~parsed ~entrypoint ty =
Michelson_v1_entrypoints.print_entrypoint_type
cctxt
~entrypoint
~emacs
?script_name
~on_errors:(print_errors cctxt ~show_source ~parsed)
ty
let list_entrypoints cctxt ~(chain : Chain_services.chain) ~block
(program : Michelson_v1_parser.parsed) =
Michelson_v1_entrypoints.list_entrypoints
cctxt
~chain
~block
program.expanded
let print_entrypoints_list (cctxt : #Client_context.printer) ~emacs
?script_name ~show_source ~parsed ty =
Michelson_v1_entrypoints.print_entrypoints_list
cctxt
~emacs
?script_name
~on_errors:(print_errors cctxt ~show_source ~parsed)
ty
let list_unreachables cctxt ~(chain : Chain_services.chain) ~block
(program : Michelson_v1_parser.parsed) =
Michelson_v1_entrypoints.list_unreachables
cctxt
~chain
~block
program.expanded
let print_unreachables (cctxt : #Client_context.printer) ~emacs ?script_name
~show_source ~parsed ty =
Michelson_v1_entrypoints.print_unreachables
cctxt
~emacs
?script_name
~on_errors:(print_errors cctxt ~show_source ~parsed)
ty
src/proto_alpha/lib_client/client_proto_programs.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Import Tezos_micheline.
Import Michelson_v1_printer.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition print_errors {C a b : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C)
(errs : list Tezos_base__TzPervasives.Error_monad.error) (show_source : bool)
(parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string)
(Michelson_v1_error_reporter.report_errors false show_source (Some parsed))
errs)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"error running script" % string
CamlinternalFormatBasics.End_of_format)
"error running script" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)).
Definition print_run_result {C a b : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C) (show_source : bool)
(parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
(function_parameter :
sum
(Tezos_protocol_alpha.Protocol.Script_repr.expr *
(list
Tezos_protocol_alpha.Protocol.Alpha_context.packed_internal_operation)
*
(option
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.big_map_diff))
(list Tezos_base__TzPervasives.Error_monad.error))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match function_parameter with
| Stdlib.Ok (storage, operations, maybe_diff) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "storage" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"emitted operations" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"big_map diff" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))))))))))))))
"@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>emitted operations@,%a@]@,@[<v 2>big_map diff@,%a@]@]@."
% string) print_expr storage
(Format.pp_print_list None Operation_result.pp_internal_operation)
operations
(fun ppf =>
fun function_parameter =>
match function_parameter with
| None => tt
| Some diff => print_big_map_diff ppf diff
end) maybe_diff)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error errs => print_errors cctxt errs show_source parsed
end.
Definition print_trace_result {C a b : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C) (show_source : bool)
(parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
(function_parameter :
sum
(Tezos_protocol_alpha.Protocol.Script_repr.expr *
(list
Tezos_protocol_alpha.Protocol.Alpha_context.packed_internal_operation)
*
(list
(Tezos_protocol_alpha.Protocol.Alpha_context.Script.location *
Tezos_protocol_alpha.Protocol.Alpha_context.Gas.t *
(list
(Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr *
(option string))))) *
(option
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.big_map_diff))
(list Tezos_base__TzPervasives.Error_monad.error))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match function_parameter with
| Stdlib.Ok (storage, operations, trace, maybe_big_map_diff) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "storage" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"emitted operations" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"big_map diff" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"trace" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))))))))))))))))))))
"@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>emitted operations@,%a@]@,@[<v 2>big_map diff@,%a@]@,@[<v 2>trace@,%a@]@]@."
% string) print_expr storage
(Format.pp_print_list None Operation_result.pp_internal_operation)
operations
(fun ppf =>
fun function_parameter =>
match function_parameter with
| None => tt
| Some diff => print_big_map_diff ppf diff
end) maybe_big_map_diff print_execution_trace trace)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error errs => print_errors cctxt errs show_source parsed
end.
Definition run {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
(Uri.t *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json))) *
N)))))))) * N)
(chain : Tezos_shell_services.Chain_services.chain)
(block : Tezos_shell_services.Shell_services.block)
(op_staroptstar : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
: Tezos_client_alpha.Michelson_v1_parser.parsed ->
Tezos_client_alpha.Michelson_v1_parser.parsed ->
Tezos_client_alpha.Michelson_v1_parser.parsed ->
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
(option Tezos_protocol_environment_alpha__Environment.Z.t) ->
(option string) ->
unit ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(list
Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
*
(option
Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
let amount :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Tez.fifty_cents
end in
fun program =>
fun storage =>
fun input =>
fun source =>
fun payer =>
fun gas =>
fun op_staroptstar =>
let entrypoint :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "default" % string
end in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Chain_services.chain_id cctxt (Some chain) tt)
(fun chain_id =>
Alpha_services.Helpers.Scripts.run_code cctxt
(chain, block) (expanded program)
((expanded storage), (expanded input), amount, chain_id,
source, payer, gas, entrypoint)).
Definition trace {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
(Uri.t *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json))) *
N)))))))) * N)
(chain : Tezos_shell_services.Chain_services.chain)
(block : Tezos_shell_services.Shell_services.block)
(op_staroptstar : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
: Tezos_client_alpha.Michelson_v1_parser.parsed ->
Tezos_client_alpha.Michelson_v1_parser.parsed ->
Tezos_client_alpha.Michelson_v1_parser.parsed ->
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
(option Tezos_protocol_environment_alpha__Environment.Z.t) ->
(option string) ->
unit ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(list
Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
*
Tezos_raw_protocol_alpha.Script_interpreter.execution_trace
*
(option
Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
let amount :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Tez.fifty_cents
end in
fun program =>
fun storage =>
fun input =>
fun source =>
fun payer =>
fun gas =>
fun op_staroptstar =>
let entrypoint :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "default" % string
end in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Chain_services.chain_id cctxt (Some chain) tt)
(fun chain_id =>
Alpha_services.Helpers.Scripts.trace_code cctxt
(chain, block) (expanded program)
((expanded storage), (expanded input), amount, chain_id,
source, payer, gas, entrypoint)).
Definition typecheck_data {D E G I K L a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L *
(Tezos_shell_services.Chain_services.chain * D))
(chain : Tezos_shell_services.Chain_services.chain) (block : D)
(gas : option Tezos_protocol_environment_alpha__Environment.Z.t)
(data : Tezos_client_alpha.Michelson_v1_parser.parsed)
(ty : Tezos_client_alpha.Michelson_v1_parser.parsed)
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Gas.t) :=
let 'tt := function_parameter in
Alpha_services.Helpers.Scripts.typecheck_data cctxt (chain, block)
((expanded data), (expanded ty), gas).
Definition typecheck_program {D E G I K L a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L *
(Tezos_shell_services.Chain_services.chain * D))
(chain : Tezos_shell_services.Chain_services.chain) (block : D)
(gas : option Tezos_protocol_environment_alpha__Environment.Z.t)
(program : Tezos_client_alpha.Michelson_v1_parser.parsed)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(Tezos_raw_protocol_alpha.Script_tc_errors.type_map *
Tezos_raw_protocol_alpha.Alpha_context.Gas.t)) :=
Alpha_services.Helpers.Scripts.typecheck_code cctxt (chain, block)
((expanded program), gas).
Definition print_typecheck_result {C a b : Type}
(emacs : bool) (show_types : bool) (print_source_on_error : bool)
(program : Tezos_client_alpha.Michelson_v1_parser.parsed)
(res :
sum
(Tezos_protocol_alpha.Protocol.Script_tc_errors.type_map *
Tezos_protocol_alpha.Protocol.Alpha_context.Gas.t)
(list Tezos_base__TzPervasives.Error_monad.error))
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if emacs then
let '(type_map, errs, _gas) :=
match res with
| Stdlib.Ok (type_map, gas) => (type_map, [], (Some gas))
|
Stdlib.Error
((cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
_ type_map)) _) as errs) => (type_map, errs, None)
| Stdlib.Error errs => ([], errs, None)
end in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal "(types . " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"(errors . " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))))))))
"(@[<v 0>(types . %a)@ (errors . %a)@])" % string)
Michelson_v1_emacs.print_type_map (program, type_map)
Michelson_v1_emacs.report_errors (program, errs))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
else
match res with
| Stdlib.Ok (type_map, gas) =>
let program := Michelson_v1_printer.inject_types type_map program in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal "Well typed" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Gas remaining: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@[<v 0>Well typed@,Gas remaining: %a@]" % string) Gas.pp gas)
(fun function_parameter =>
let 'tt := function_parameter in
if show_types then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Micheline_printer.print_expr program)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
else
return_unit)
| Stdlib.Error errs =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
(Michelson_v1_error_reporter.report_errors show_types
print_source_on_error (Some program)) errs)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"ill-typed script" % string
CamlinternalFormatBasics.End_of_format)
"ill-typed script" % string))
end.
Definition entrypoint_type {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
(Uri.t *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json))) *
N)))))))) * N)
(chain : Tezos_shell_services.Chain_services.chain)
(block : Tezos_shell_services.Block_services.block)
(program : Tezos_client_alpha.Michelson_v1_parser.parsed)
(entrypoint : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)) :=
Michelson_v1_entrypoints.script_entrypoint_type cctxt chain block
(expanded program) entrypoint.
Definition print_entrypoint_type {C a b : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C) (emacs : bool) (script_name : option string)
(show_source : bool) (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
(entrypoint : string)
(ty :
Tezos_base__TzPervasives.tzresult
(option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
Michelson_v1_entrypoints.print_entrypoint_type cctxt
(Some
(print_errors cctxt
(* ❌ expected an argument *)
expected_argument show_source parsed)) emacs None script_name entrypoint
ty.
Definition list_entrypoints {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
(Uri.t *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json))) *
N)))))))) * N)
(chain : Tezos_shell_services.Chain_services.chain)
(block : Tezos_shell_services.Block_services.block)
(program : Tezos_client_alpha.Michelson_v1_parser.parsed)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr))) :=
Michelson_v1_entrypoints.list_entrypoints cctxt chain block (expanded program).
Definition print_entrypoints_list {C a b : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C) (emacs : bool) (script_name : option string)
(show_source : bool) (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
(ty :
Tezos_base__TzPervasives.tzresult
(list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
Michelson_v1_entrypoints.print_entrypoints_list cctxt
(Some
(print_errors cctxt
(* ❌ expected an argument *)
expected_argument show_source parsed)) emacs None script_name ty.
Definition list_unreachables {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
(Uri.t *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json))) *
N)))))))) * N)
(chain : Tezos_shell_services.Chain_services.chain)
(block : Tezos_shell_services.Block_services.block)
(program : Tezos_client_alpha.Michelson_v1_parser.parsed)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list (list Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim))) :=
Michelson_v1_entrypoints.list_unreachables cctxt chain block
(expanded program).
Definition print_unreachables {C a b : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C) (emacs : bool) (script_name : option string)
(show_source : bool) (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
(ty :
Tezos_base__TzPervasives.tzresult
(list (list Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim)))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
Michelson_v1_entrypoints.print_unreachables cctxt
(Some
(print_errors cctxt
(* ❌ expected an argument *)
expected_argument show_source parsed)) emacs None script_name ty.
src/proto_alpha/lib_client/injection.ml 651 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Apply_results
open Protocol_client_context
let get_branch (rpc_config : #Protocol_client_context.full) ~chain
~(block : Block_services.block) branch =
let branch = Option.unopt ~default:0 branch in
(* TODO export parameter *)
( match block with
| `Head n ->
return (`Head (n + branch))
| `Hash (h, n) ->
return (`Hash (h, n + branch))
| `Alias (a, n) ->
return (`Alias (a, n))
| `Genesis ->
return `Genesis
| `Level i ->
return (`Level i) )
>>=? fun block ->
Shell_services.Blocks.hash rpc_config ~chain ~block ()
>>=? fun hash ->
Shell_services.Chain.chain_id rpc_config ~chain ()
>>=? fun chain_id -> return (chain_id, hash)
type 'kind preapply_result =
Operation_hash.t * 'kind operation * 'kind operation_metadata
type 'kind result_list =
Operation_hash.t * 'kind contents_list * 'kind contents_result_list
type 'kind result = Operation_hash.t * 'kind contents * 'kind contents_result
let get_manager_operation_gas_and_fee contents =
let open Operation in
let l = to_list (Contents_list contents) in
List.fold_left
(fun acc -> function
| Contents (Manager_operation {fee; gas_limit; _}) -> (
match acc with
| Error _ as e ->
e
| Ok (total_fee, total_gas) -> (
match Tez.(total_fee +? fee) with
| Ok total_fee ->
Ok (total_fee, Z.add total_gas gas_limit)
| Error _ as e ->
e ) ) | _ -> acc)
(Ok (Tez.zero, Z.zero))
l
type fee_parameter = {
minimal_fees : Tez.t;
minimal_nanotez_per_byte : Z.t;
minimal_nanotez_per_gas_unit : Z.t;
force_low_fee : bool;
fee_cap : Tez.t;
burn_cap : Tez.t;
}
let dummy_fee_parameter =
{
minimal_fees = Tez.zero;
minimal_nanotez_per_byte = Z.zero;
minimal_nanotez_per_gas_unit = Z.zero;
force_low_fee = false;
fee_cap = Tez.one;
burn_cap = Tez.zero;
}
let check_fees :
type t.
#Protocol_client_context.full ->
fee_parameter ->
t contents_list ->
int ->
unit Lwt.t =
fun cctxt config op size ->
match get_manager_operation_gas_and_fee op with
| Error _ ->
assert false (* FIXME *)
| Ok (fee, gas) ->
if Tez.compare fee config.fee_cap > 0 then
cctxt#error
"The proposed fee (%s%a) are higher than the configured fee cap \
(%s%a).@\n\
\ Use `--fee-cap %a` to emit this operation anyway."
Client_proto_args.tez_sym
Tez.pp
fee
Client_proto_args.tez_sym
Tez.pp
config.fee_cap
Tez.pp
fee
>>= fun () -> exit 1
else
(* *)
let fees_in_nanotez =
Z.mul (Z.of_int64 (Tez.to_mutez fee)) (Z.of_int 1000)
in
let minimal_fees_in_nanotez =
Z.mul (Z.of_int64 (Tez.to_mutez config.minimal_fees)) (Z.of_int 1000)
in
let minimal_fees_for_gas_in_nanotez =
Z.mul config.minimal_nanotez_per_gas_unit gas
in
let minimal_fees_for_size_in_nanotez =
Z.mul config.minimal_nanotez_per_byte (Z.of_int size)
in
let estimated_fees_in_nanotez =
Z.add
minimal_fees_in_nanotez
(Z.add
minimal_fees_for_gas_in_nanotez
minimal_fees_for_size_in_nanotez)
in
let estimated_fees =
match
Tez.of_mutez
(Z.to_int64
(Z.div
(Z.add (Z.of_int 999) estimated_fees_in_nanotez)
(Z.of_int 1000)))
with
| None ->
assert false
| Some fee ->
fee
in
if
(not config.force_low_fee)
&& Z.compare fees_in_nanotez estimated_fees_in_nanotez < 0
then
cctxt#error
"The proposed fee (%s%a) are lower than the fee that baker expect \
by default (%s%a).@\n\
\ Use `--force-low-fee` to emit this operation anyway."
Client_proto_args.tez_sym
Tez.pp
fee
Client_proto_args.tez_sym
Tez.pp
estimated_fees
>>= fun () -> exit 1
else Lwt.return_unit
let print_for_verbose_signing ppf ~watermark ~bytes ~branch ~contents =
let open Format in
pp_open_vbox ppf 0 ;
let item f =
pp_open_hovbox ppf 4 ;
pp_print_string ppf " * " ;
f ppf () ;
pp_close_box ppf () ;
pp_print_cut ppf ()
in
let hash_pp l =
fprintf ppf "%s" (Base58.raw_encode Blake2B.(hash_bytes l |> to_string))
in
item (fun ppf () ->
pp_print_text ppf "Branch: " ;
Block_hash.pp ppf branch) ;
item (fun ppf () ->
fprintf
ppf
"Watermark: `%a` (0x%s)"
Signature.pp_watermark
watermark
(Hex.of_bytes (Signature.bytes_of_watermark watermark) |> Hex.show)) ;
item (fun ppf () ->
pp_print_text ppf "Operation bytes: " ;
TzString.fold_left (* We split the bytes into lines for display: *)
(fun n c ->
pp_print_char ppf c ;
if
n < 72
(* is the email-body standard width, ideal for copy-pasting. *)
then n + 1
else (pp_print_space ppf () ; 0))
0
(Hex.of_bytes bytes |> Hex.show)
|> ignore) ;
item (fun ppf () ->
pp_print_text ppf "Blake 2B Hash (raw): " ;
hash_pp [bytes]) ;
item (fun ppf () ->
pp_print_text
ppf
"Blake 2B Hash (ledger-style, with operation watermark): " ;
hash_pp [Signature.bytes_of_watermark watermark; bytes]) ;
let json =
Data_encoding.Json.construct
Operation.unsigned_encoding
({branch}, Contents_list contents)
in
item (fun ppf () ->
pp_print_text ppf "JSON encoding: " ;
Data_encoding.Json.pp ppf json) ;
pp_close_box ppf ()
let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block
?(verbose_signing = false) ?fee_parameter ?branch ?src_sk
(contents : t contents_list) =
get_branch cctxt ~chain ~block branch
>>=? fun (chain_id, branch) ->
let bytes =
Data_encoding.Binary.to_bytes_exn
Operation.unsigned_encoding
({branch}, Contents_list contents)
in
( match src_sk with
| None ->
return_none
| Some src_sk ->
let watermark =
match contents with
| Single (Endorsement _) ->
Signature.(Endorsement chain_id)
| _ ->
Signature.Generic_operation
in
( if verbose_signing then
cctxt#message
"Pre-signature information (verbose signing):@.%t%!"
(print_for_verbose_signing ~watermark ~bytes ~branch ~contents)
else Lwt.return_unit )
>>= fun () ->
Client_keys.sign cctxt ~watermark src_sk bytes
>>=? fun signature -> return_some signature )
>>=? fun signature ->
let op : _ Operation.t =
{shell = {branch}; protocol_data = {contents; signature}}
in
let oph = Operation.hash op in
let size = Bytes.length bytes + Signature.size in
( match fee_parameter with
| Some fee_parameter ->
check_fees cctxt fee_parameter contents size
| None ->
Lwt.return_unit )
>>= fun () ->
Protocol_client_context.Alpha_block_services.Helpers.Preapply.operations
cctxt
~chain
~block
[Operation.pack op]
>>=? function
| [(Operation_data op', Operation_metadata result)] -> (
match
( Operation.equal op {shell = {branch}; protocol_data = op'},
Apply_results.kind_equal_list contents result.contents )
with
| (Some Operation.Eq, Some Apply_results.Eq) ->
return ((oph, op, result) : t preapply_result)
| _ ->
failwith "Unexpected result" )
| _ ->
failwith "Unexpected result"
let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block
?branch (contents : t contents_list) =
get_branch cctxt ~chain ~block branch
>>=? fun (_chain_id, branch) ->
let op : _ Operation.t =
{shell = {branch}; protocol_data = {contents; signature = None}}
in
let oph = Operation.hash op in
Chain_services.chain_id cctxt ~chain ()
>>=? fun chain_id ->
Alpha_services.Helpers.Scripts.run_operation
cctxt
(chain, block)
(Operation.pack op, chain_id)
>>=? function
| (Operation_data op', Operation_metadata result) -> (
match
( Operation.equal op {shell = {branch}; protocol_data = op'},
Apply_results.kind_equal_list contents result.contents )
with
| (Some Operation.Eq, Some Apply_results.Eq) ->
return ((oph, op, result) : t preapply_result)
| _ ->
failwith "Unexpected result" )
| _ ->
failwith "Unexpected result"
let estimated_gas_single (type kind)
(Manager_operation_result {operation_result; internal_operation_results; _} :
kind Kind.manager contents_result) =
let consumed_gas (type kind) (result : kind manager_operation_result) =
match result with
| Applied (Transaction_result {consumed_gas; _}) ->
Ok consumed_gas
| Applied (Origination_result {consumed_gas; _}) ->
Ok consumed_gas
| Applied (Reveal_result {consumed_gas}) ->
Ok consumed_gas
| Applied (Delegation_result {consumed_gas}) ->
Ok consumed_gas
| Skipped _ ->
assert false
| Backtracked (_, None) ->
Ok Z.zero (* there must be another error for this to happen *)
| Backtracked (_, Some errs) ->
Environment.wrap_error (Error errs)
| Failed (_, errs) ->
Environment.wrap_error (Error errs)
in
List.fold_left
(fun acc (Internal_operation_result (_, r)) ->
acc >>? fun acc -> consumed_gas r >>? fun gas -> Ok (Z.add acc gas))
(consumed_gas operation_result)
internal_operation_results
let estimated_storage_single (type kind) origination_size
(Manager_operation_result {operation_result; internal_operation_results; _} :
kind Kind.manager contents_result) =
let storage_size_diff (type kind) (result : kind manager_operation_result) =
match result with
| Applied
(Transaction_result
{paid_storage_size_diff; allocated_destination_contract; _}) ->
if allocated_destination_contract then
Ok (Z.add paid_storage_size_diff origination_size)
else Ok paid_storage_size_diff
| Applied (Origination_result {paid_storage_size_diff; _}) ->
Ok (Z.add paid_storage_size_diff origination_size)
| Applied (Reveal_result _) ->
Ok Z.zero
| Applied (Delegation_result _) ->
Ok Z.zero
| Skipped _ ->
assert false
| Backtracked (_, None) ->
Ok Z.zero (* there must be another error for this to happen *)
| Backtracked (_, Some errs) ->
Environment.wrap_error (Error errs)
| Failed (_, errs) ->
Environment.wrap_error (Error errs)
in
List.fold_left
(fun acc (Internal_operation_result (_, r)) ->
acc
>>? fun acc ->
storage_size_diff r >>? fun storage -> Ok (Z.add acc storage))
(storage_size_diff operation_result)
internal_operation_results
let estimated_storage origination_size res =
let rec estimated_storage : type kind. kind contents_result_list -> _ =
function
| Single_result (Manager_operation_result _ as res) ->
estimated_storage_single origination_size res
| Single_result _ ->
Ok Z.zero
| Cons_result (res, rest) ->
estimated_storage_single origination_size res
>>? fun storage1 ->
estimated_storage rest >>? fun storage2 -> Ok (Z.add storage1 storage2)
in
estimated_storage res >>? fun diff -> Ok (Z.max Z.zero diff)
let originated_contracts_single (type kind)
(Manager_operation_result {operation_result; internal_operation_results; _} :
kind Kind.manager contents_result) =
let originated_contracts (type kind) (result : kind manager_operation_result)
=
match result with
| Applied (Transaction_result {originated_contracts; _}) ->
Ok originated_contracts
| Applied (Origination_result {originated_contracts; _}) ->
Ok originated_contracts
| Applied (Reveal_result _) ->
Ok []
| Applied (Delegation_result _) ->
Ok []
| Skipped _ ->
assert false
| Backtracked (_, None) ->
Ok [] (* there must be another error for this to happen *)
| Backtracked (_, Some errs) ->
Environment.wrap_error (Error errs)
| Failed (_, errs) ->
Environment.wrap_error (Error errs)
in
List.fold_left
(fun acc (Internal_operation_result (_, r)) ->
acc
>>? fun acc ->
originated_contracts r
>>? fun contracts -> Ok (List.rev_append contracts acc))
(originated_contracts operation_result >|? List.rev)
internal_operation_results
let rec originated_contracts : type kind. kind contents_result_list -> _ =
function
| Single_result (Manager_operation_result _ as res) ->
originated_contracts_single res >|? List.rev
| Single_result _ ->
Ok []
| Cons_result (res, rest) ->
originated_contracts_single res
>>? fun contracts1 ->
originated_contracts rest
>>? fun contracts2 -> Ok (List.rev_append contracts1 contracts2)
let detect_script_failure : type kind. kind operation_metadata -> _ =
let rec detect_script_failure : type kind. kind contents_result_list -> _ =
let detect_script_failure_single (type kind)
(Manager_operation_result
{operation_result; internal_operation_results; _} :
kind Kind.manager contents_result) =
let detect_script_failure (type kind)
(result : kind manager_operation_result) =
match result with
| Applied _ ->
Ok ()
| Skipped _ ->
assert false
| Backtracked (_, None) ->
(* there must be another error for this to happen *)
Ok ()
| Backtracked (_, Some errs) ->
record_trace
(failure "The transfer simulation failed.")
(Environment.wrap_error (Error errs))
| Failed (_, errs) ->
record_trace
(failure "The transfer simulation failed.")
(Environment.wrap_error (Error errs))
in
List.fold_left
(fun acc (Internal_operation_result (_, r)) ->
acc >>? fun () -> detect_script_failure r)
(detect_script_failure operation_result)
internal_operation_results
in
function
| Single_result (Manager_operation_result _ as res) ->
detect_script_failure_single res
| Single_result _ ->
Ok ()
| Cons_result (res, rest) ->
detect_script_failure_single res
>>? fun () -> detect_script_failure rest
in
fun {contents} -> detect_script_failure contents
let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full)
~fee_parameter ~chain ~block ?branch ?(compute_fee = false)
(contents : kind contents_list) : kind contents_list tzresult Lwt.t =
Alpha_services.Constants.all cctxt (chain, block)
>>=? fun { parametric =
{ hard_gas_limit_per_operation = gas_limit;
hard_storage_limit_per_operation = storage_limit;
origination_size;
cost_per_byte;
_ };
_ } ->
let may_need_patching_single :
type kind. kind contents -> kind contents option = function
| Manager_operation c
when compute_fee || c.gas_limit < Z.zero || gas_limit <= c.gas_limit
|| c.storage_limit < Z.zero
|| storage_limit <= c.storage_limit ->
let gas_limit =
if c.gas_limit < Z.zero || gas_limit <= c.gas_limit then gas_limit
else c.gas_limit
in
let storage_limit =
if c.storage_limit < Z.zero || storage_limit <= c.storage_limit then
storage_limit
else c.storage_limit
in
Some (Manager_operation {c with gas_limit; storage_limit})
| _ ->
None
in
let rec may_need_patching :
type kind. kind contents_list -> kind contents_list option = function
| Single (Manager_operation _ as c) -> (
match may_need_patching_single c with
| None ->
None
| Some op ->
Some (Single op) )
| Single _ ->
None
| Cons ((Manager_operation _ as c), rest) -> (
match (may_need_patching_single c, may_need_patching rest) with
| (None, None) ->
None
| (Some c, None) ->
Some (Cons (c, rest))
| (None, Some rest) ->
Some (Cons (c, rest))
| (Some c, Some rest) ->
Some (Cons (c, rest)) )
in
let rec patch_fee : type kind. bool -> kind contents -> kind contents =
fun first -> function
| Manager_operation c as op -> (
let gas_limit = c.gas_limit in
let size =
if first then
Data_encoding.Binary.fixed_length_exn
Tezos_base.Operation.shell_header_encoding
+ Data_encoding.Binary.length
Operation.contents_encoding
(Contents op)
+ Signature.size
else
Data_encoding.Binary.length
Operation.contents_encoding
(Contents op)
in
let minimal_fees_in_nanotez =
Z.mul
(Z.of_int64 (Tez.to_mutez fee_parameter.minimal_fees))
(Z.of_int 1000)
in
let minimal_fees_for_gas_in_nanotez =
Z.mul fee_parameter.minimal_nanotez_per_gas_unit gas_limit
in
let minimal_fees_for_size_in_nanotez =
Z.mul fee_parameter.minimal_nanotez_per_byte (Z.of_int size)
in
let fees_in_nanotez =
Z.add minimal_fees_in_nanotez
@@ Z.add
minimal_fees_for_gas_in_nanotez
minimal_fees_for_size_in_nanotez
in
match
Tez.of_mutez
(Z.to_int64
(Z.div (Z.add (Z.of_int 999) fees_in_nanotez) (Z.of_int 1000)))
with
| None ->
assert false
| Some fee ->
if fee <= c.fee then op
else patch_fee first (Manager_operation {c with fee}) )
| c ->
c
in
let patch :
type kind.
bool ->
kind contents * kind contents_result ->
kind contents tzresult Lwt.t =
fun first -> function
| (Manager_operation c, (Manager_operation_result _ as result)) ->
( if c.gas_limit < Z.zero || gas_limit <= c.gas_limit then
Lwt.return (estimated_gas_single result)
>>=? fun gas ->
if Z.equal gas Z.zero then
cctxt#message "Estimated gas: none" >>= fun () -> return Z.zero
else
cctxt#message
"Estimated gas: %s units (will add 100 for safety)"
(Z.to_string gas)
>>= fun () -> return (Z.min (Z.add gas (Z.of_int 100)) gas_limit)
else return c.gas_limit )
>>=? fun gas_limit ->
( if c.storage_limit < Z.zero || storage_limit <= c.storage_limit then
Lwt.return
(estimated_storage_single (Z.of_int origination_size) result)
>>=? fun storage ->
if Z.equal storage Z.zero then
cctxt#message "Estimated storage: no bytes added"
>>= fun () -> return Z.zero
else
cctxt#message
"Estimated storage: %s bytes added (will add 20 for safety)"
(Z.to_string storage)
>>= fun () ->
return (Z.min (Z.add storage (Z.of_int 20)) storage_limit)
else return c.storage_limit )
>>=? fun storage_limit ->
let c = Manager_operation {c with gas_limit; storage_limit} in
if compute_fee then return (patch_fee first c) else return c
| (c, _) ->
return c
in
let rec patch_list :
type kind.
bool ->
kind contents_and_result_list ->
kind contents_list tzresult Lwt.t =
fun first -> function
| Single_and_result
((Manager_operation _ as op), (Manager_operation_result _ as res)) ->
patch first (op, res) >>=? fun op -> return (Single op)
| Single_and_result (op, _) ->
return (Single op)
| Cons_and_result
((Manager_operation _ as op), (Manager_operation_result _ as res), rest)
->
patch first (op, res)
>>=? fun op ->
patch_list false rest >>=? fun rest -> return (Cons (op, rest))
in
match may_need_patching contents with
| Some contents ->
simulate cctxt ~chain ~block ?branch contents
>>=? fun (_, _, result) ->
( match detect_script_failure result with
| Ok () ->
return_unit
| Error _ ->
cctxt#message
"@[<v 2>This simulation failed:@,%a@]"
Operation_result.pp_operation_result
(contents, result.contents)
>>= fun () -> return_unit )
>>=? fun () ->
Lwt.return
(estimated_storage (Z.of_int origination_size) result.contents)
>>=? (fun storage ->
Lwt.return
(Environment.wrap_error
Tez.(cost_per_byte *? Z.to_int64 storage))
>>=? fun burn ->
if Tez.(burn > fee_parameter.burn_cap) then
cctxt#error
"The operation will burn %s%a which is higher than the \
configured burn cap (%s%a).@\n\
\ Use `--burn-cap %a` to emit this operation."
Client_proto_args.tez_sym
Tez.pp
burn
Client_proto_args.tez_sym
Tez.pp
fee_parameter.burn_cap
Tez.pp
burn
>>= fun () -> exit 1
else return_unit)
>>=? fun () ->
let res = pack_contents_list contents result.contents in
patch_list true res
| None ->
return contents
let inject_operation (type kind) cctxt ~chain ~block ?confirmations
?(dry_run = false) ?branch ?src_sk ?verbose_signing ~fee_parameter
?compute_fee (contents : kind contents_list) =
Tezos_client_base.Client_confirmations.wait_for_bootstrapped cctxt
>>=? fun () ->
may_patch_limits
cctxt
~chain
~block
?branch
~fee_parameter
?compute_fee
contents
>>=? fun contents ->
preapply
cctxt
~chain
~block
~fee_parameter
?verbose_signing
?branch
?src_sk
contents
>>=? fun (_oph, op, result) ->
( match detect_script_failure result with
| Ok () ->
return_unit
| Error _ as res ->
cctxt#message
"@[<v 2>This simulation failed:@,%a@]"
Operation_result.pp_operation_result
(op.protocol_data.contents, result.contents)
>>= fun () -> Lwt.return res )
>>=? fun () ->
let bytes =
Data_encoding.Binary.to_bytes_exn Operation.encoding (Operation.pack op)
in
if dry_run then
let oph = Operation_hash.hash_bytes [bytes] in
cctxt#message
"@[<v 0>Operation: 0x%a@,Operation hash is '%a'@]"
Hex.pp
(Hex.of_bytes bytes)
Operation_hash.pp
oph
>>= fun () ->
cctxt#message
"@[<v 2>Simulation result:@,%a@]"
Operation_result.pp_operation_result
(op.protocol_data.contents, result.contents)
>>= fun () -> return (oph, op.protocol_data.contents, result.contents)
else
Shell_services.Injection.operation cctxt ~chain bytes
>>=? fun oph ->
cctxt#message "Operation successfully injected in the node."
>>= fun () ->
cctxt#message "Operation hash is '%a'" Operation_hash.pp oph
>>= fun () ->
( match confirmations with
| None ->
cctxt#message
"@[<v 0>NOT waiting for the operation to be included.@,\
Use command@,\
\ tezos-client wait for %a to be included --confirmations 30 \
--branch %a@,\
and/or an external block explorer to make sure that it has been \
included.@]"
Operation_hash.pp
oph
Block_hash.pp
op.shell.branch
>>= fun () -> return result
| Some confirmations -> (
cctxt#message "Waiting for the operation to be included..."
>>= fun () ->
Client_confirmations.wait_for_operation_inclusion
~branch:op.shell.branch
~confirmations
cctxt
~chain
oph
>>=? fun (h, i, j) ->
Alpha_block_services.Operations.operation
cctxt
~chain
~block:(`Hash (h, 0))
i
j
>>=? fun op' ->
match op'.receipt with
| No_operation_metadata ->
failwith "Internal error: unexpected receipt."
| Operation_metadata receipt -> (
match Apply_results.kind_equal_list contents receipt.contents with
| Some Apply_results.Eq ->
return (receipt : kind operation_metadata)
| None ->
failwith "Internal error: unexpected receipt." ) ) )
>>=? fun result ->
cctxt#message
"@[<v 2>This sequence of operations was run:@,%a@]"
Operation_result.pp_operation_result
(op.protocol_data.contents, result.contents)
>>= fun () ->
Lwt.return (originated_contracts result.contents)
>>=? fun contracts ->
Lwt_list.iter_s
(fun c -> cctxt#message "New contract %a originated." Contract.pp c)
contracts
>>= fun () ->
( match confirmations with
| None ->
Lwt.return_unit
| Some number ->
if number >= 30 then
cctxt#message
"The operation was included in a block %d blocks ago."
number
else
cctxt#message
"@[<v 0>The operation has only been included %d blocks ago.@,\
We recommend to wait more.@,\
Use command@,\
\ tezos-client wait for %a to be included --confirmations 30 \
--branch %a@,\
and/or an external block explorer.@]"
number
Operation_hash.pp
oph
Block_hash.pp
op.shell.branch )
>>= fun () -> return (oph, op.protocol_data.contents, result.contents)
let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations
?dry_run ?verbose_signing ~source ~src_pk ~src_sk ?fee
?(gas_limit = Z.minus_one) ?(storage_limit = Z.of_int (-1)) ?counter
~fee_parameter (type kind) (operation : kind manager_operation) :
( Operation_hash.t
* kind Kind.manager contents
* kind Kind.manager contents_result )
tzresult
Lwt.t =
( match counter with
| None ->
Alpha_services.Contract.counter cctxt (chain, block) source
>>=? fun pcounter ->
let counter = Z.succ pcounter in
return counter
| Some counter ->
return counter )
>>=? fun counter ->
Alpha_services.Contract.manager_key cctxt (chain, block) source
>>=? fun key ->
let is_reveal : type kind. kind manager_operation -> bool = function
| Reveal _ ->
true
| _ ->
false
in
let (compute_fee, fee) =
match fee with None -> (true, Tez.zero) | Some fee -> (false, fee)
in
match key with
| None when not (is_reveal operation) -> (
let contents =
Cons
( Manager_operation
{
source;
fee = Tez.zero;
counter;
gas_limit = Z.of_int 10_000;
storage_limit = Z.zero;
operation = Reveal src_pk;
},
Single
(Manager_operation
{
source;
fee;
counter = Z.succ counter;
gas_limit;
storage_limit;
operation;
}) )
in
inject_operation
cctxt
~chain
~block
?confirmations
?dry_run
~fee_parameter
~compute_fee
?verbose_signing
?branch
~src_sk
contents
>>=? fun (oph, op, result) ->
match pack_contents_list op result with
| Cons_and_result (_, _, Single_and_result (op, result)) ->
return (oph, op, result)
| Single_and_result (Manager_operation _, _) ->
.
| _ ->
assert false
(* Grrr... *) )
| _ -> (
let contents =
Single
(Manager_operation
{source; fee; counter; gas_limit; storage_limit; operation})
in
inject_operation
cctxt
~chain
~block
?confirmations
?dry_run
?verbose_signing
~compute_fee
~fee_parameter
?branch
~src_sk
contents
>>=? fun (oph, op, result) ->
match pack_contents_list op result with
| Single_and_result ((Manager_operation _ as op), result) ->
return (oph, op, result)
| _ ->
assert false )
(* Grrr... *)
src/proto_alpha/lib_client/injection.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Import Apply_results.
Import Protocol_client_context.
Definition get_branch {D F H J L M N a b c i o p q : Type}
(rpc_config :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services__Block_services.chain)
(block : Tezos_shell_services.Block_services.block) (branch : option Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Chain_id.t *
Tezos_base__TzPervasives.Block_hash.t)) :=
let branch := Option.unopt 0 branch in
op_gtgteqquestion
match block with
| Head n =>
_return
(* ❌ Variants not supported *)
variant
| Hash (h, n) =>
_return
(* ❌ Variants not supported *)
variant
| Alias (a, n) =>
_return
(* ❌ Variants not supported *)
variant
| Genesis =>
_return
(* ❌ Variants not supported *)
variant
| Level i =>
_return
(* ❌ Variants not supported *)
variant
end
(fun block =>
op_gtgteqquestion
(Shell_services.Blocks.hash rpc_config (Some chain) (Some block) tt)
(fun hash =>
op_gtgteqquestion
(Shell_services.Chain.chain_id rpc_config (Some chain) tt)
(fun chain_id => _return (chain_id, hash)))).
Definition preapply_result (kind : Type) :=
Tezos_base__TzPervasives.Operation_hash.t *
(Tezos_protocol_alpha.Protocol.Alpha_context.operation kind) *
(Tezos_protocol_alpha.Protocol.Apply_results.operation_metadata kind).
Definition result_list (kind : Type) :=
Tezos_base__TzPervasives.Operation_hash.t *
(Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind) *
(Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind).
Definition result (kind : Type) :=
Tezos_base__TzPervasives.Operation_hash.t *
(Tezos_protocol_alpha.Protocol.Alpha_context.contents kind) *
(Tezos_protocol_alpha.Protocol.Apply_results.contents_result kind).
Definition get_manager_operation_gas_and_fee {A : Type}
(contents : Tezos_protocol_alpha.Protocol.Alpha_context.contents_list A)
: sum (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez * Z.t)
(list Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
let l :=
to_list (Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list contents)
in
List.fold_left
(fun acc =>
fun function_parameter =>
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Alpha_context.Contents
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation {|
fee := fee; gas_limit := gas_limit |}) =>
match acc with
| (Stdlib.Error _) as e => e
| Stdlib.Ok (total_fee, total_gas) =>
match op_plusquestion total_fee fee with
| Stdlib.Ok total_fee =>
Stdlib.Ok (total_fee, (Z.add total_gas gas_limit))
| (Stdlib.Error _) as e => e
end
end
| _ => acc
end) (Stdlib.Ok (Tez.zero, Z.zero)) l.
Record fee_parameter := {
minimal_fees : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
minimal_nanotez_per_byte : Z.t;
minimal_nanotez_per_gas_unit : Z.t;
force_low_fee : bool;
fee_cap : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
burn_cap : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t }.
Definition dummy_fee_parameter : fee_parameter :=
{| minimal_fees := Tez.zero; minimal_nanotez_per_byte := Z.zero;
minimal_nanotez_per_gas_unit := Z.zero; force_low_fee := false;
fee_cap := Tez.one; burn_cap := Tez.zero |}.
Definition check_fees {D F H J L M N a b c i o p q t : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (config : fee_parameter)
(op : Tezos_protocol_alpha.Protocol.Alpha_context.contents_list t) (size : Z)
: Lwt.t unit :=
match get_manager_operation_gas_and_fee op with
| Stdlib.Error _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| Stdlib.Ok (fee, gas) =>
if OCaml.Stdlib.gt (Tez.compare fee (fee_cap config)) 0 then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The proposed fee (" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
") are higher than the configured fee cap (" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ")." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.String_literal
" Use `--fee-cap " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"` to emit this operation anyway." % string
CamlinternalFormatBasics.End_of_format)))))))))))
"The proposed fee (%s%a) are higher than the configured fee cap (%s%a).@
Use `--fee-cap %a` to emit this operation anyway."
% string) Client_proto_args.tez_sym Tez.pp fee
Client_proto_args.tez_sym Tez.pp (fee_cap config) Tez.pp fee)
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.exit 1)
else
let fees_in_nanotez :=
Z.mul (Z.of_int64 (Tez.to_mutez fee)) (Z.of_int 1000) in
let minimal_fees_in_nanotez :=
Z.mul (Z.of_int64 (Tez.to_mutez (minimal_fees config))) (Z.of_int 1000)
in
let minimal_fees_for_gas_in_nanotez :=
Z.mul (minimal_nanotez_per_gas_unit config) gas in
let minimal_fees_for_size_in_nanotez :=
Z.mul (minimal_nanotez_per_byte config) (Z.of_int size) in
let estimated_fees_in_nanotez :=
Z.add minimal_fees_in_nanotez
(Z.add minimal_fees_for_gas_in_nanotez
minimal_fees_for_size_in_nanotez) in
let estimated_fees :=
match
Tez.of_mutez
(Z.to_int64
(Z.div (Z.add (Z.of_int 999) estimated_fees_in_nanotez)
(Z.of_int 1000))) with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some fee => fee
end in
if
andb (negb (force_low_fee config))
(OCaml.Stdlib.lt (Z.compare fees_in_nanotez estimated_fees_in_nanotez)
0) then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The proposed fee (" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
") are lower than the fee that baker expect by default ("
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal ")." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.String_literal
" Use `--force-low-fee` to emit this operation anyway."
% string
CamlinternalFormatBasics.End_of_format)))))))))
"The proposed fee (%s%a) are lower than the fee that baker expect by default (%s%a).@
Use `--force-low-fee` to emit this operation anyway."
% string) Client_proto_args.tez_sym Tez.pp fee
Client_proto_args.tez_sym Tez.pp estimated_fees)
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.exit 1)
else
Lwt.return_unit
end.
Definition print_for_verbose_signing {A : Type}
(ppf : Stdlib.Format.formatter)
(watermark : Tezos_base__TzPervasives.Signature.watermark) (bytes : string)
(branch : Tezos_base__TzPervasives.Block_hash.t)
(contents : Tezos_protocol_alpha.Protocol.Alpha_context.contents_list A)
: unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_open_vbox ppf 0 in
let item (f : Stdlib.Format.formatter -> unit -> unit) : unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_open_hovbox ppf 4 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_print_string ppf " * " % string in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := f ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_close_box ppf tt in
pp_print_cut ppf tt in
let hash_pp (l : list Stdlib.Bytes.t) : unit :=
fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
(Base58.raw_encode None
(OCaml.Stdlib.reverse_apply (hash_bytes None l) to_string)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
item
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_print_text ppf "Branch: " % string in
Block_hash.pp ppf branch) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
item
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Watermark: `" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "` (0x" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"Watermark: `%a` (0x%s)" % string) Signature.pp_watermark
watermark
(OCaml.Stdlib.reverse_apply
(Hex.of_bytes None (Signature.bytes_of_watermark watermark))
Hex.show)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
item
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_print_text ppf "Operation bytes: " % string in
OCaml.Stdlib.reverse_apply
(TzString.fold_left
(fun n =>
fun c =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_print_char ppf c in
if OCaml.Stdlib.lt n 72 then
Z.add n 1
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_print_space ppf tt in
0) 0
(OCaml.Stdlib.reverse_apply (Hex.of_bytes None string) Hex.show))
OCaml.Stdlib.ignore) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
item
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_print_text ppf "Blake 2B Hash (raw): " % string in
hash_pp (cons string [])) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
item
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
pp_print_text ppf
"Blake 2B Hash (ledger-style, with operation watermark): " %
string in
hash_pp
(cons (Signature.bytes_of_watermark watermark) (cons string []))) in
let json :=
Data_encoding.Json.construct Operation.unsigned_encoding
({| branch := branch |},
(Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list contents)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
item
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_print_text ppf "JSON encoding: " % string in
Data_encoding.Json.pp ppf json) in
pp_close_box ppf tt.
Definition preapply {D F H J L M N O a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services__Block_services.chain)
(block : Tezos_shell_services.Block_services.block)
(op_staroptstar : option bool)
: (option fee_parameter) ->
(option Z) ->
(option Tezos_client_base.Client_keys.sk_uri) ->
(Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O) ->
Lwt.t (Tezos_base__TzPervasives.tzresult (preapply_result O)) :=
let verbose_signing :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun fee_parameter =>
fun branch =>
fun src_sk =>
fun contents =>
op_gtgteqquestion (get_branch cctxt chain block branch)
(fun function_parameter =>
let '(chain_id, branch) := function_parameter in
let bytes :=
Data_encoding.Binary.to_bytes_exn Operation.unsigned_encoding
({| branch := branch |},
(Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
contents)) in
op_gtgteqquestion
match src_sk with
| None => return_none
| Some src_sk =>
let watermark :=
match contents with
|
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Endorsement
_) =>
Tezos_base__TzPervasives.Signature.Endorsement chain_id
| _ => Tezos_base__TzPervasives.Signature.Generic_operation
end in
op_gtgteq
(if verbose_signing then
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Pre-signature information (verbose signing):" %
string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.Theta
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format))))
"Pre-signature information (verbose signing):@.%t%!" %
string)
(print_for_verbose_signing
(* ❌ expected an argument *)
expected_argument watermark string branch contents)
else
Lwt.return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_keys.sign cctxt (Some watermark) src_sk string)
(fun signature => return_some signature))
end
(fun signature =>
let op :=
{| shell := {| branch := branch |};
protocol_data :=
{| contents := contents; signature := signature |} |} in
let oph := Operation.hash op in
let size := Z.add (String.length string) Signature.size in
op_gtgteq
match fee_parameter with
| Some fee_parameter =>
check_fees cctxt fee_parameter contents size
| None => Lwt.return_unit
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Protocol_client_context.Alpha_block_services.Helpers.Preapply.operations
cctxt (Some chain) (Some block)
(cons (Operation.pack op) []))
(fun function_parameter =>
match function_parameter with
|
cons
(Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data
op',
Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata
result) [] =>
match
((Operation.equal op
{| shell := {| branch := branch |};
protocol_data := op' |}),
(Apply_results.kind_equal_list contents
(contents result))) with
|
(Some
Tezos_protocol_alpha.Protocol.Alpha_context.Operation.Eq,
Some
Tezos_protocol_alpha.Protocol.Apply_results.Eq)
=> _return (oph, op, result)
| _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unexpected result" % string
CamlinternalFormatBasics.End_of_format)
"Unexpected result" % string)
end
| _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unexpected result" % string
CamlinternalFormatBasics.End_of_format)
"Unexpected result" % string)
end)))).
Definition simulate {D F H J L M N O a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services__Block_services.chain)
(block : Tezos_shell_services.Block_services.block) (branch : option Z)
(contents : Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O)
: Lwt.t (Tezos_base__TzPervasives.tzresult (preapply_result O)) :=
op_gtgteqquestion (get_branch cctxt chain block branch)
(fun function_parameter =>
let '(_chain_id, branch) := function_parameter in
let op :=
{| shell := {| branch := branch |};
protocol_data := {| contents := contents; signature := None |} |} in
let oph := Operation.hash op in
op_gtgteqquestion (Chain_services.chain_id cctxt (Some chain) tt)
(fun chain_id =>
op_gtgteqquestion
(Alpha_services.Helpers.Scripts.run_operation cctxt (chain, block)
((Operation.pack op), chain_id))
(fun function_parameter =>
match function_parameter with
|
(Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data op',
Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata
result) =>
match
((Operation.equal op
{| shell := {| branch := branch |}; protocol_data := op' |}),
(Apply_results.kind_equal_list contents (contents result)))
with
|
(Some Tezos_protocol_alpha.Protocol.Alpha_context.Operation.Eq,
Some Tezos_protocol_alpha.Protocol.Apply_results.Eq) =>
_return (oph, op, result)
| _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unexpected result" % string
CamlinternalFormatBasics.End_of_format)
"Unexpected result" % string)
end
| _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unexpected result" % string
CamlinternalFormatBasics.End_of_format)
"Unexpected result" % string)
end))).
Definition estimated_gas_single {A : Type}
(function_parameter :
Tezos_protocol_alpha.Protocol.Apply_results.contents_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager A))
: Tezos_base__TzPervasives.tzresult
Tezos_protocol_environment_alpha__Environment.Z.t :=
let
'Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result {|
operation_result := operation_result;
internal_operation_results := internal_operation_results
|} := function_parameter in
let consumed_gas {B : Type}
(result :
Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result B)
: sum Tezos_protocol_environment_alpha__Environment.Z.t
Tezos_base__TzPervasives.Error_monad.trace :=
match result with
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Transaction_result {|
consumed_gas := consumed_gas |}) => Stdlib.Ok consumed_gas
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Origination_result {|
consumed_gas := consumed_gas |}) => Stdlib.Ok consumed_gas
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Reveal_result {|
consumed_gas := consumed_gas |}) => Stdlib.Ok consumed_gas
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Delegation_result {|
consumed_gas := consumed_gas |}) => Stdlib.Ok consumed_gas
| Tezos_protocol_alpha.Protocol.Apply_results.Skipped _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ None =>
Stdlib.Ok Z.zero
| Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ (Some errs) =>
Environment.wrap_error (Stdlib.Error errs)
| Tezos_protocol_alpha.Protocol.Apply_results.Failed _ errs =>
Environment.wrap_error (Stdlib.Error errs)
end in
List.fold_left
(fun acc =>
fun function_parameter =>
let
'Tezos_protocol_alpha.Protocol.Apply_results.Internal_operation_result
_ r := function_parameter in
op_gtgtquestion acc
(fun acc =>
op_gtgtquestion (consumed_gas r)
(fun gas => Stdlib.Ok (Z.add acc gas))))
(consumed_gas operation_result) internal_operation_results.
Definition estimated_storage_single {A : Type}
(origination_size : Z.t)
(function_parameter :
Tezos_protocol_alpha.Protocol.Apply_results.contents_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager A))
: Tezos_base__TzPervasives.tzresult
Tezos_protocol_environment_alpha__Environment.Z.t :=
let
'Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result {|
operation_result := operation_result;
internal_operation_results := internal_operation_results
|} := function_parameter in
let storage_size_diff {B : Type}
(result :
Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result B)
: sum Tezos_protocol_environment_alpha__Environment.Z.t
Tezos_base__TzPervasives.Error_monad.trace :=
match result with
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Transaction_result {|
paid_storage_size_diff := paid_storage_size_diff;
allocated_destination_contract := allocated_destination_contract
|}) =>
if allocated_destination_contract then
Stdlib.Ok (Z.add paid_storage_size_diff origination_size)
else
Stdlib.Ok paid_storage_size_diff
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Origination_result {|
paid_storage_size_diff := paid_storage_size_diff |}) =>
Stdlib.Ok (Z.add paid_storage_size_diff origination_size)
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Reveal_result _) =>
Stdlib.Ok Z.zero
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Delegation_result _) =>
Stdlib.Ok Z.zero
| Tezos_protocol_alpha.Protocol.Apply_results.Skipped _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ None =>
Stdlib.Ok Z.zero
| Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ (Some errs) =>
Environment.wrap_error (Stdlib.Error errs)
| Tezos_protocol_alpha.Protocol.Apply_results.Failed _ errs =>
Environment.wrap_error (Stdlib.Error errs)
end in
List.fold_left
(fun acc =>
fun function_parameter =>
let
'Tezos_protocol_alpha.Protocol.Apply_results.Internal_operation_result
_ r := function_parameter in
op_gtgtquestion acc
(fun acc =>
op_gtgtquestion (storage_size_diff r)
(fun storage => Stdlib.Ok (Z.add acc storage))))
(storage_size_diff operation_result) internal_operation_results.
Definition estimated_storage {A : Type}
(origination_size : Z.t)
(res : Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list A)
: Tezos_base__TzPervasives.tzresult Z.t :=
let fix estimated_storage {kind : Type}
(function_parameter :
Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind)
: Tezos_base__TzPervasives.tzresult
Tezos_protocol_environment_alpha__Environment.Z.t :=
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_result
((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result _)
as res) => estimated_storage_single origination_size res
| Tezos_protocol_alpha.Protocol.Apply_results.Single_result _ =>
Stdlib.Ok Z.zero
| Tezos_protocol_alpha.Protocol.Apply_results.Cons_result res rest =>
op_gtgtquestion (estimated_storage_single origination_size res)
(fun storage1 =>
op_gtgtquestion (estimated_storage rest)
(fun storage2 => Stdlib.Ok (Z.add storage1 storage2)))
end in
op_gtgtquestion (estimated_storage res)
(fun diff => Stdlib.Ok (Z.max Z.zero diff)).
Definition originated_contracts_single {A : Type}
(function_parameter :
Tezos_protocol_alpha.Protocol.Apply_results.contents_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager A))
: Tezos_base__TzPervasives.tzresult
(list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) :=
let
'Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result {|
operation_result := operation_result;
internal_operation_results := internal_operation_results
|} := function_parameter in
let originated_contracts {B : Type}
(result :
Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result B)
: sum (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
Tezos_base__TzPervasives.Error_monad.trace :=
match result with
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Transaction_result {|
originated_contracts := originated_contracts |}) =>
Stdlib.Ok originated_contracts
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Origination_result {|
originated_contracts := originated_contracts |}) =>
Stdlib.Ok originated_contracts
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Reveal_result _) =>
Stdlib.Ok []
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Delegation_result _) =>
Stdlib.Ok []
| Tezos_protocol_alpha.Protocol.Apply_results.Skipped _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ None =>
Stdlib.Ok []
| Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ (Some errs) =>
Environment.wrap_error (Stdlib.Error errs)
| Tezos_protocol_alpha.Protocol.Apply_results.Failed _ errs =>
Environment.wrap_error (Stdlib.Error errs)
end in
List.fold_left
(fun acc =>
fun function_parameter =>
let
'Tezos_protocol_alpha.Protocol.Apply_results.Internal_operation_result
_ r := function_parameter in
op_gtgtquestion acc
(fun acc =>
op_gtgtquestion (originated_contracts r)
(fun contracts => Stdlib.Ok (List.rev_append contracts acc))))
(op_gtpipequestion (originated_contracts operation_result) List.rev)
internal_operation_results.
Fixpoint originated_contracts {kind : Type}
(function_parameter :
Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind)
: Tezos_base__TzPervasives.tzresult
(list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) :=
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_result
((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result _)
as res) => op_gtpipequestion (originated_contracts_single res) List.rev
| Tezos_protocol_alpha.Protocol.Apply_results.Single_result _ => Stdlib.Ok []
| Tezos_protocol_alpha.Protocol.Apply_results.Cons_result res rest =>
op_gtgtquestion (originated_contracts_single res)
(fun contracts1 =>
op_gtgtquestion (originated_contracts rest)
(fun contracts2 => Stdlib.Ok (List.rev_append contracts1 contracts2)))
end.
Definition detect_script_failure {kind : Type}
: (Tezos_protocol_alpha.Protocol.Apply_results.operation_metadata kind) ->
Tezos_base__TzPervasives.tzresult unit :=
let detect_script_failure :=
let detect_script_failure_single {B : Type}
(function_parameter :
Tezos_protocol_alpha.Protocol.Apply_results.contents_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager B))
: Tezos_base__TzPervasives.tzresult unit :=
let
'Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result {|
operation_result := operation_result;
internal_operation_results := internal_operation_results
|} := function_parameter in
let detect_script_failure {C : Type}
(result :
Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result C)
: sum unit Tezos_base__TzPervasives.trace :=
match result with
| Tezos_protocol_alpha.Protocol.Apply_results.Applied _ => Stdlib.Ok tt
| Tezos_protocol_alpha.Protocol.Apply_results.Skipped _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ None =>
Stdlib.Ok tt
| Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ (Some errs)
=>
record_trace
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The transfer simulation failed." % string
CamlinternalFormatBasics.End_of_format)
"The transfer simulation failed." % string))
(Environment.wrap_error (Stdlib.Error errs))
| Tezos_protocol_alpha.Protocol.Apply_results.Failed _ errs =>
record_trace
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The transfer simulation failed." % string
CamlinternalFormatBasics.End_of_format)
"The transfer simulation failed." % string))
(Environment.wrap_error (Stdlib.Error errs))
end in
List.fold_left
(fun acc =>
fun function_parameter =>
let
'Tezos_protocol_alpha.Protocol.Apply_results.Internal_operation_result
_ r := function_parameter in
op_gtgtquestion acc
(fun function_parameter =>
let 'tt := function_parameter in
detect_script_failure r))
(detect_script_failure operation_result) internal_operation_results in
fun function_parameter =>
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_result
((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
_) as res) => detect_script_failure_single res
| Tezos_protocol_alpha.Protocol.Apply_results.Single_result _ =>
Stdlib.Ok tt
| Tezos_protocol_alpha.Protocol.Apply_results.Cons_result res rest =>
op_gtgtquestion (detect_script_failure_single res)
(fun function_parameter =>
let 'tt := function_parameter in
detect_script_failure rest)
end in
fun function_parameter =>
let '{| contents := contents |} := function_parameter in
detect_script_failure contents.
Definition may_patch_limits {D F H J L M N O a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (fee_parameter : fee_parameter)
(chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (branch : option Z)
(op_staroptstar : option bool)
: (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O)) :=
let compute_fee :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun contents =>
op_gtgteqquestion (Alpha_services.Constants.all cctxt (chain, block))
(fun function_parameter =>
let '{|
parametric := {|
hard_gas_limit_per_operation := gas_limit;
origination_size := origination_size;
cost_per_byte := cost_per_byte;
hard_storage_limit_per_operation := storage_limit
|}
|} := function_parameter in
let may_need_patching_single {kind : Type}
(function_parameter :
Tezos_protocol_alpha.Protocol.Alpha_context.contents kind)
: option (Tezos_protocol_alpha.Protocol.Alpha_context.contents kind) :=
match function_parameter with
| Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation c =>
let gas_limit :=
if
orb (OCaml.Stdlib.lt (gas_limit c) Z.zero)
(OCaml.Stdlib.le gas_limit (gas_limit c)) then
gas_limit
else
gas_limit c in
let storage_limit :=
if
orb (OCaml.Stdlib.lt (storage_limit c) Z.zero)
(OCaml.Stdlib.le storage_limit (storage_limit c)) then
storage_limit
else
storage_limit c in
Some
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
(* ❌ Record substitution not handled *)
record_substitution)
| _ => None
end in
let fix may_need_patching {kind : Type}
(function_parameter :
Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind)
: option
(Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind) :=
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Alpha_context.Single
((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation _)
as c) =>
match may_need_patching_single c with
| None => None
| Some op =>
Some (Tezos_protocol_alpha.Protocol.Alpha_context.Single op)
end
| Tezos_protocol_alpha.Protocol.Alpha_context.Single _ => None
|
Tezos_protocol_alpha.Protocol.Alpha_context.Cons
((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation _)
as c) rest =>
match ((may_need_patching_single c), (may_need_patching rest)) with
| (None, None) => None
| (Some c, None) =>
Some (Tezos_protocol_alpha.Protocol.Alpha_context.Cons c rest)
| (None, Some rest) =>
Some (Tezos_protocol_alpha.Protocol.Alpha_context.Cons c rest)
| (Some c, Some rest) =>
Some (Tezos_protocol_alpha.Protocol.Alpha_context.Cons c rest)
end
end in
let fix patch_fee {kind : Type}
(first : bool) (function_parameter :
Tezos_protocol_alpha.Protocol.Alpha_context.contents kind)
: Tezos_protocol_alpha.Protocol.Alpha_context.contents kind :=
match function_parameter with
|
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation c) as
op =>
let gas_limit := gas_limit c in
let size :=
if first then
Z.add
(Z.add
(Data_encoding.Binary.fixed_length_exn
Tezos_base.Operation.shell_header_encoding)
(Data_encoding.Binary.length Operation.contents_encoding
(Tezos_protocol_alpha.Protocol.Alpha_context.Contents op)))
Signature.size
else
Data_encoding.Binary.length Operation.contents_encoding
(Tezos_protocol_alpha.Protocol.Alpha_context.Contents op) in
let minimal_fees_in_nanotez :=
Z.mul (Z.of_int64 (Tez.to_mutez (minimal_fees fee_parameter)))
(Z.of_int 1000) in
let minimal_fees_for_gas_in_nanotez :=
Z.mul (minimal_nanotez_per_gas_unit fee_parameter) gas_limit in
let minimal_fees_for_size_in_nanotez :=
Z.mul (minimal_nanotez_per_byte fee_parameter) (Z.of_int size) in
let fees_in_nanotez :=
apply (Z.add minimal_fees_in_nanotez)
(Z.add minimal_fees_for_gas_in_nanotez
minimal_fees_for_size_in_nanotez) in
match
Tez.of_mutez
(Z.to_int64
(Z.div (Z.add (Z.of_int 999) fees_in_nanotez) (Z.of_int 1000)))
with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some fee =>
if OCaml.Stdlib.le fee (fee c) then
op
else
patch_fee first
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
(* ❌ Record substitution not handled *)
record_substitution)
end
| c => c
end in
let patch {kind : Type}
(first : bool) (function_parameter :
(Tezos_protocol_alpha.Protocol.Alpha_context.contents kind) *
(Tezos_protocol_alpha.Protocol.Apply_results.contents_result kind))
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_protocol_alpha.Protocol.Alpha_context.contents kind)) :=
match function_parameter with
|
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation c,
(Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
_) as result) =>
op_gtgteqquestion
(if
orb (OCaml.Stdlib.lt (gas_limit c) Z.zero)
(OCaml.Stdlib.le gas_limit (gas_limit c)) then
op_gtgteqquestion (Lwt._return (estimated_gas_single result))
(fun gas =>
if Z.equal gas Z.zero then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Estimated gas: none" % string
CamlinternalFormatBasics.End_of_format)
"Estimated gas: none" % string))
(fun function_parameter =>
let 'tt := function_parameter in
_return Z.zero)
else
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Estimated gas: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" units (will add 100 for safety)" % string
CamlinternalFormatBasics.End_of_format)))
"Estimated gas: %s units (will add 100 for safety)"
% string) (Z.to_string gas))
(fun function_parameter =>
let 'tt := function_parameter in
_return (Z.min (Z.add gas (Z.of_int 100)) gas_limit)))
else
_return (gas_limit c))
(fun gas_limit =>
op_gtgteqquestion
(if
orb (OCaml.Stdlib.lt (storage_limit c) Z.zero)
(OCaml.Stdlib.le storage_limit (storage_limit c)) then
op_gtgteqquestion
(Lwt._return
(estimated_storage_single (Z.of_int origination_size)
result))
(fun storage =>
if Z.equal storage Z.zero then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Estimated storage: no bytes added" % string
CamlinternalFormatBasics.End_of_format)
"Estimated storage: no bytes added" % string))
(fun function_parameter =>
let 'tt := function_parameter in
_return Z.zero)
else
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Estimated storage: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" bytes added (will add 20 for safety)" %
string
CamlinternalFormatBasics.End_of_format)))
"Estimated storage: %s bytes added (will add 20 for safety)"
% string) (Z.to_string storage))
(fun function_parameter =>
let 'tt := function_parameter in
_return
(Z.min (Z.add storage (Z.of_int 20))
storage_limit)))
else
_return (storage_limit c))
(fun storage_limit =>
let c :=
Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
(* ❌ Record substitution not handled *)
record_substitution in
if compute_fee then
_return (patch_fee first c)
else
_return c))
| (c, _) => _return c
end in
let fix patch_list {kind : Type}
(first : bool) (function_parameter :
Tezos_protocol_alpha.Protocol.Apply_results.contents_and_result_list
kind)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind)) :=
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation _)
as op)
((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
_) as res) =>
op_gtgteqquestion (patch first (op, res))
(fun op =>
_return (Tezos_protocol_alpha.Protocol.Alpha_context.Single op))
| Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result op _
=> _return (Tezos_protocol_alpha.Protocol.Alpha_context.Single op)
|
Tezos_protocol_alpha.Protocol.Apply_results.Cons_and_result
((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation _)
as op)
((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
_) as res) rest =>
op_gtgteqquestion (patch first (op, res))
(fun op =>
op_gtgteqquestion (patch_list false rest)
(fun rest =>
_return
(Tezos_protocol_alpha.Protocol.Alpha_context.Cons op rest)))
end in
match may_need_patching contents with
| Some contents =>
op_gtgteqquestion (simulate cctxt chain block branch contents)
(fun function_parameter =>
let '(_, _, result) := function_parameter in
op_gtgteqquestion
match detect_script_failure result with
| Stdlib.Ok tt => return_unit
| Stdlib.Error _ =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"This simulation failed:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>This simulation failed:@,%a@]" % string)
Operation_result.pp_operation_result
(contents, (contents result)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_gtgteqquestion
(Lwt._return
(estimated_storage (Z.of_int origination_size)
(contents result)))
(fun storage =>
op_gtgteqquestion
(Lwt._return
(Environment.wrap_error
(op_starquestion cost_per_byte
(Z.to_int64 storage))))
(fun burn =>
if op_gt burn (burn_cap fee_parameter) then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The operation will burn " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" which is higher than the configured burn cap ("
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
")." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.String_literal
" Use `--burn-cap " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"` to emit this operation."
% string
CamlinternalFormatBasics.End_of_format)))))))))))
"The operation will burn %s%a which is higher than the configured burn cap (%s%a).@
Use `--burn-cap %a` to emit this operation."
% string) Client_proto_args.tez_sym Tez.pp
burn Client_proto_args.tez_sym Tez.pp
(burn_cap fee_parameter) Tez.pp burn)
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.exit 1)
else
return_unit)))
(fun function_parameter =>
let 'tt := function_parameter in
let res := pack_contents_list contents (contents result)
in
patch_list true res)))
| None => _return contents
end).
Definition inject_operation {F G I J K M N O a b c i o p q : Type}
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
q i o) ->
(Tezos_shell_services.Shell_services.chain
*
Tezos_shell_services.Shell_services.block)
->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (I * q * i * o))
*
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) q i o) ->
(Tezos_shell_services.Shell_services.chain
*
Tezos_shell_services.Shell_services.block)
->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) *
(J * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) * b) q i o) ->
(Tezos_shell_services.Shell_services.chain
*
Tezos_shell_services.Shell_services.block)
->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) *
(K * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) * b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain
*
Tezos_shell_services.Shell_services.block)
->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) *
(M * a * b * c * q * i * o))
* N)))))))))))))))))))))))))
*
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (I * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (K * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (M * a * b * c * q * i * o)) * N)))))
(chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
(op_staroptstar : option bool)
: (option Z) ->
(option Tezos_client_base.Client_keys.sk_uri) ->
(option bool) ->
fee_parameter ->
(option bool) ->
(Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Operation_hash.t *
(Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O)
*
(Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list
O))) :=
let dry_run :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun branch =>
fun src_sk =>
fun verbose_signing =>
fun fee_parameter =>
fun compute_fee =>
fun contents =>
op_gtgteqquestion
(Tezos_client_base.Client_confirmations.wait_for_bootstrapped
cctxt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(may_patch_limits cctxt fee_parameter chain block branch
compute_fee contents)
(fun contents =>
op_gtgteqquestion
(preapply cctxt chain block verbose_signing
(Some fee_parameter) branch src_sk contents)
(fun function_parameter =>
let '(_oph, op, result) := function_parameter in
op_gtgteqquestion
match detect_script_failure result with
| Stdlib.Ok tt => return_unit
| (Stdlib.Error _) as res =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"This simulation failed:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>This simulation failed:@,%a@]" %
string)
Operation_result.pp_operation_result
((contents (protocol_data op)),
(contents result)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return res)
end
(fun function_parameter =>
let 'tt := function_parameter in
let bytes :=
Data_encoding.Binary.to_bytes_exn
Operation.encoding (Operation.pack op) in
if dry_run then
let oph :=
Operation_hash.hash_bytes None
(cons string []) in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Operation: 0x" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Operation hash is '" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"'" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))
"@[<v 0>Operation: 0x%a@,Operation hash is '%a'@]"
% string) Hex.pp
(Hex.of_bytes None string) Operation_hash.pp
oph)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Simulation result:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>Simulation result:@,%a@]" %
string)
Operation_result.pp_operation_result
((contents (protocol_data op)),
(contents result)))
(fun function_parameter =>
let 'tt := function_parameter in
_return
(oph, (contents (protocol_data op)),
(contents result))))
else
op_gtgteqquestion
(Shell_services.Injection.operation cctxt None
(Some chain) string)
(fun oph =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Operation successfully injected in the node."
% string
CamlinternalFormatBasics.End_of_format)
"Operation successfully injected in the node."
% string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Operation hash is '" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))
"Operation hash is '%a'" % string)
Operation_hash.pp oph)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
match confirmations with
| None =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"NOT waiting for the operation to be included."
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Use command" %
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string
0 0)
(CamlinternalFormatBasics.String_literal
" tezos-client wait for "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" to be included --confirmations 30 --branch "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@,"
%
string
0 0)
(CamlinternalFormatBasics.String_literal
"and/or an external block explorer to make sure that it has been included."
%
string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))
"@[<v 0>NOT waiting for the operation to be included.@,Use command@, tezos-client wait for %a to be included --confirmations 30 --branch %a@,and/or an external block explorer to make sure that it has been included.@]"
% string)
Operation_hash.pp oph
Block_hash.pp
(branch (shell op)))
(fun function_parameter =>
let 'tt :=
function_parameter in
_return result)
| Some confirmations =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Waiting for the operation to be included..."
% string
CamlinternalFormatBasics.End_of_format)
"Waiting for the operation to be included..."
% string))
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteqquestion
(Client_confirmations.wait_for_operation_inclusion
cctxt chain None
(Some confirmations)
(Some
(branch (shell op)))
oph)
(fun function_parameter =>
let '(h, i, j) :=
function_parameter in
op_gtgteqquestion
(Alpha_block_services.Operations.operation
cctxt (Some chain)
(Some
(* ❌ Variants not supported *)
variant) i j)
(fun op' =>
match receipt op'
with
|
Tezos_protocol_alpha.Protocol.Apply_results.No_operation_metadata
=>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Internal error: unexpected receipt."
% string
CamlinternalFormatBasics.End_of_format)
"Internal error: unexpected receipt."
% string)
|
Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata
receipt =>
match
Apply_results.kind_equal_list
contents
(contents
receipt)
with
|
Some
Tezos_protocol_alpha.Protocol.Apply_results.Eq
=>
_return receipt
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Internal error: unexpected receipt."
% string
CamlinternalFormatBasics.End_of_format)
"Internal error: unexpected receipt."
% string)
end
end)))
end
(fun result =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"This sequence of operations was run:"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>This sequence of operations was run:@,%a@]"
% string)
Operation_result.pp_operation_result
((contents
(protocol_data op)),
(contents result)))
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteqquestion
(Lwt._return
(originated_contracts
(contents result)))
(fun contracts =>
op_gtgteq
(Lwt_list.iter_s
(fun c =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"New contract "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" originated."
%
string
CamlinternalFormatBasics.End_of_format)))
"New contract %a originated."
% string)
Contract.pp c)
contracts)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
match
confirmations
with
| None =>
Lwt.return_unit
| Some number =>
if
OCaml.Stdlib.ge
number 30
then
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"The operation was included in a block "
%
string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" blocks ago."
%
string
CamlinternalFormatBasics.End_of_format)))
"The operation was included in a block %d blocks ago."
% string)
number
else
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>"
%
string
CamlinternalFormatBasics.End_of_format)
"<v 0>"
%
string))
(CamlinternalFormatBasics.String_literal
"The operation has only been included "
%
string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" blocks ago."
%
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@,"
%
string
0
0)
(CamlinternalFormatBasics.String_literal
"We recommend to wait more."
%
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@,"
%
string
0
0)
(CamlinternalFormatBasics.String_literal
"Use command"
%
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@,"
%
string
0
0)
(CamlinternalFormatBasics.String_literal
" tezos-client wait for "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" to be included --confirmations 30 --branch "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@,"
%
string
0
0)
(CamlinternalFormatBasics.String_literal
"and/or an external block explorer."
%
string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))))
"@[<v 0>The operation has only been included %d blocks ago.@,We recommend to wait more.@,Use command@, tezos-client wait for %a to be included --confirmations 30 --branch %a@,and/or an external block explorer.@]"
% string)
number
Operation_hash.pp
oph
Block_hash.pp
(branch
(shell op))
end
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
_return
(oph,
(contents
(protocol_data
op)),
(contents
result)))))))))))))).
Definition inject_manager_operation {D F H J L M N O a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
*
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
(a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) *
(a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))
*
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block))
(chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block) (branch : option Z)
(confirmations : option Z) (dry_run : option bool)
(verbose_signing : option bool)
(source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
(src_pk : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
(src_sk : Tezos_client_base.Client_keys.sk_uri)
(fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
(op_staroptstar : option Z.t)
: (option Z.t) ->
(option Z.t) ->
fee_parameter ->
(Tezos_protocol_alpha.Protocol.Alpha_context.manager_operation O) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Operation_hash.t *
(Tezos_protocol_alpha.Protocol.Alpha_context.contents
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager O))
*
(Tezos_protocol_alpha.Protocol.Apply_results.contents_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager O)))) :=
let gas_limit :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Z.minus_one
end in
fun op_staroptstar =>
let storage_limit :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Z.of_int (-1)
end in
fun counter =>
fun fee_parameter =>
fun operation =>
op_gtgteqquestion
match counter with
| None =>
op_gtgteqquestion
(Alpha_services.Contract.counter cctxt (chain, block) source)
(fun pcounter =>
let counter := Z.succ pcounter in
_return counter)
| Some counter => _return counter
end
(fun counter =>
op_gtgteqquestion
(Alpha_services.Contract.manager_key cctxt (chain, block) source)
(fun key =>
let is_reveal {kind : Type}
(function_parameter :
Tezos_protocol_alpha.Protocol.Alpha_context.manager_operation
kind) : bool :=
match function_parameter with
| Tezos_protocol_alpha.Protocol.Alpha_context.Reveal _ =>
true
| _ => false
end in
let '(compute_fee, fee) :=
match fee with
| None => (true, Tez.zero)
| Some fee => (false, fee)
end in
match key with
| None =>
let contents :=
Tezos_protocol_alpha.Protocol.Alpha_context.Cons
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
{| source := source; fee := Tez.zero;
counter := counter;
operation :=
Tezos_protocol_alpha.Protocol.Alpha_context.Reveal
src_pk; gas_limit := Z.of_int 10000;
storage_limit := Z.zero |})
(Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
{| source := source; fee := fee;
counter := Z.succ counter; operation := operation;
gas_limit := gas_limit;
storage_limit := storage_limit |})) in
op_gtgteqquestion
(inject_operation cctxt chain block confirmations dry_run
branch (Some src_sk) verbose_signing fee_parameter
(Some compute_fee) contents)
(fun function_parameter =>
let '(oph, op, result) := function_parameter in
match pack_contents_list op result with
|
Tezos_protocol_alpha.Protocol.Apply_results.Cons_and_result
_ _
(Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
op result) => _return (oph, op, result)
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
_) _ =>
(* ❌ Unreachable expressions are not supported *)
unreachable
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end)
| _ =>
let contents :=
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
{| source := source; fee := fee; counter := counter;
operation := operation; gas_limit := gas_limit;
storage_limit := storage_limit |}) in
op_gtgteqquestion
(inject_operation cctxt chain block confirmations dry_run
branch (Some src_sk) verbose_signing fee_parameter
(Some compute_fee) contents)
(fun function_parameter =>
let '(oph, op, result) := function_parameter in
match pack_contents_list op result with
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
_) as op) result => _return (oph, op, result)
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end)
end)).
src/proto_alpha/lib_client/managed_contract.ml 254 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Protocol_client_context
open Tezos_micheline
open Client_proto_context
let get_contract_manager (cctxt : #full) contract =
let open Micheline in
let open Michelson_v1_primitives in
get_storage cctxt ~chain:cctxt#chain ~block:cctxt#block contract
>>=? function
| None ->
cctxt#error "This is not a smart contract."
| Some storage -> (
match root storage with
| Prim (_, D_Pair, [Bytes (_, bytes); _], _) | Bytes (_, bytes) -> (
match
Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding bytes
with
| Some k ->
return k
| None ->
cctxt#error
"Cannot find a manager key in contracts storage (decoding bytes \
failed).\n\
Transfer from scripted contract are currently only supported for \
\"manager\" contract." )
| Prim (_, D_Pair, [String (_, value); _], _) | String (_, value) -> (
match Signature.Public_key_hash.of_b58check_opt value with
| Some k ->
return k
| None ->
cctxt#error
"Cannot find a manager key in contracts storage (\"%s\" is not a \
valid key).\n\
Transfer from scripted contract are currently only supported for \
\"manager\" contract."
value )
| _raw_storage ->
cctxt#error
"Cannot find a manager key in contracts storage (wrong storage \
format : @[%a@]).\n\
Transfer from scripted contract are currently only supported for \
\"manager\" contract."
Michelson_v1_printer.print_expr
storage )
let parse code =
Lwt.return
( Micheline_parser.no_parsing_error
@@ Michelson_v1_parser.parse_expression code
>>? fun exp ->
Error_monad.ok @@ Script.lazy_expr Michelson_v1_parser.(exp.expanded) )
let set_delegate (cctxt : #full) ~chain ~block ?confirmations ?dry_run
?verbose_signing ?branch ~fee_parameter ?fee ~source ~src_pk ~src_sk
contract (* the KT1 to delegate *)
(delegate : Signature.public_key_hash option) =
let entrypoint = "do" in
Michelson_v1_entrypoints.contract_entrypoint_type
cctxt
~chain
~block
~contract
~entrypoint
>>=? (function
| Some _ ->
(* their is a "do" entrypoint (we could check its type here)*)
let lambda =
match delegate with
| Some delegate ->
let (`Hex delegate) =
Signature.Public_key_hash.to_hex delegate
in
Format.asprintf
"{ DROP ; NIL operation ; PUSH key_hash 0x%s ; SOME ; \
SET_DELEGATE ; CONS }"
delegate
| None ->
"{ DROP ; NIL operation ; NONE key_hash ; SET_DELEGATE ; \
CONS }"
in
parse lambda >>=? fun param -> return (param, entrypoint)
| None -> (
(* their is no "do" entrypoint trying "set/remove_delegate" *)
let entrypoint =
match delegate with
| Some _ ->
"set_delegate"
| None ->
"remove_delegate"
in
Michelson_v1_entrypoints.contract_entrypoint_type
cctxt
~chain
~block
~contract
~entrypoint
>>=? function
| Some _ ->
(* their is a "set/remove_delegate" entrypoint *)
let delegate_data =
match delegate with
| Some delegate ->
let (`Hex delegate) =
Signature.Public_key_hash.to_hex delegate
in
"0x" ^ delegate
| None ->
"Unit"
in
parse delegate_data
>>=? fun param -> return (param, entrypoint)
| None ->
cctxt#error
"Cannot find a %%do or %%set_delegate entrypoint in \
contract@." ))
>>=? fun (parameters, entrypoint) ->
let operation =
Transaction
{amount = Tez.zero; parameters; entrypoint; destination = contract}
in
Injection.inject_manager_operation
cctxt
~chain
~block
?confirmations
?dry_run
?verbose_signing
?branch
~source
?fee
~storage_limit:Z.zero
~src_pk
~src_sk
~fee_parameter
operation
>>=? fun res -> return res
let d_unit =
Micheline.strip_locations (Prim (0, Michelson_v1_primitives.D_Unit, [], []))
let t_unit =
Micheline.strip_locations (Prim (0, Michelson_v1_primitives.T_unit, [], []))
let build_lambda_for_implicit ~delegate ~amount =
let (`Hex delegate) = Signature.Public_key_hash.to_hex delegate in
Format.asprintf
"{ DROP ; NIL operation ;PUSH key_hash 0x%s; IMPLICIT_ACCOUNT;PUSH mutez \
%Ld ;UNIT;TRANSFER_TOKENS ; CONS }"
delegate
(Tez.to_mutez amount)
let build_lambda_for_originated ~destination ~entrypoint ~amount
~parameter_type ~parameter =
let destination =
Data_encoding.Binary.to_bytes_exn Contract.encoding destination
in
let amount = Tez.to_mutez amount in
let (`Hex destination) = MBytes.to_hex destination in
let entrypoint = match entrypoint with "default" -> "" | s -> "%" ^ s in
if parameter_type = t_unit then
Format.asprintf
"{ DROP ; NIL operation ;PUSH address 0x%s; CONTRACT %s %a; \
ASSERT_SOME;PUSH mutez %Ld ;UNIT;TRANSFER_TOKENS ; CONS }"
destination
entrypoint
Michelson_v1_printer.print_expr
parameter_type
amount
else
Format.asprintf
"{ DROP ; NIL operation ;PUSH address 0x%s; CONTRACT %s %a; \
ASSERT_SOME;PUSH mutez %Ld ;PUSH %a %a;TRANSFER_TOKENS ; CONS }"
destination
entrypoint
Michelson_v1_printer.print_expr
parameter_type
amount
Michelson_v1_printer.print_expr
parameter_type
Michelson_v1_printer.print_expr
parameter
let transfer (cctxt : #full) ~chain ~block ?confirmations ?dry_run
?verbose_signing ?branch ~source ~src_pk ~src_sk ~contract ~destination
?(entrypoint = "default") ?arg ~amount ?fee ?gas_limit ?storage_limit
?counter ~fee_parameter () :
(Kind.transaction Kind.manager Injection.result * Contract.t list) tzresult
Lwt.t =
( match Alpha_context.Contract.is_implicit destination with
| Some delegate when entrypoint = "default" ->
return @@ build_lambda_for_implicit ~delegate ~amount
| Some _ ->
cctxt#error
"Implicit accounts have no entrypoints. (targeted entrypoint %%%s on \
contract %a)"
entrypoint
Contract.pp
destination
| None ->
Michelson_v1_entrypoints.contract_entrypoint_type
cctxt
~chain
~block
~contract:destination
~entrypoint
>>=? (function
| None ->
cctxt#error
"Contract %a has no entrypoint named %s"
Contract.pp
destination
entrypoint
| Some parameter_type ->
return parameter_type)
>>=? fun parameter_type ->
( match arg with
| Some arg ->
Lwt.return @@ Micheline_parser.no_parsing_error
@@ Michelson_v1_parser.parse_expression arg
>>=? fun {expanded = arg; _} -> return_some arg
| None ->
return_none )
>>=? fun parameter ->
let parameter = Option.unopt ~default:d_unit parameter in
return
@@ build_lambda_for_originated
~destination
~entrypoint
~amount
~parameter_type
~parameter )
>>=? fun lambda ->
parse lambda
>>=? fun parameters ->
let entrypoint = "do" in
let operation =
Transaction
{amount = Tez.zero; parameters; entrypoint; destination = contract}
in
Injection.inject_manager_operation
cctxt
~chain
~block
?confirmations
?dry_run
?verbose_signing
?branch
~source
?fee
?gas_limit
?storage_limit
?counter
~src_pk
~src_sk
~fee_parameter
operation
>>=? fun ((_oph, _op, result) as res) ->
Lwt.return (Injection.originated_contracts (Single_result result))
>>=? fun contracts -> return (res, contracts)
src/proto_alpha/lib_client/managed_contract.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Import Protocol_client_context.
Import Tezos_micheline.
Import Client_proto_context.
Definition get_contract_manager {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Signature.Public_key_hash.t) :=
op_gtgteqquestion
(get_storage cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send contract)
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This is not a smart contract." % string
CamlinternalFormatBasics.End_of_format)
"This is not a smart contract." % string)
| Some storage =>
match root storage with
|
Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.D_Pair
(cons (Tezos_micheline.Micheline.Bytes _ bytes) (cons _ [])) _ |
Tezos_micheline.Micheline.Bytes _ bytes =>
match
Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding
string with
| Some k => _return k
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot find a manager key in contracts storage (decoding bytes failed).
Transfer from scripted contract are currently only supported for ""manager"" contract."
% string CamlinternalFormatBasics.End_of_format)
"Cannot find a manager key in contracts storage (decoding bytes failed).
Transfer from scripted contract are currently only supported for ""manager"" contract."
% string)
end
|
Tezos_micheline.Micheline.Prim _
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.D_Pair
(cons (Tezos_micheline.Micheline.String _ value) (cons _ [])) _ |
Tezos_micheline.Micheline.String _ value =>
match Signature.Public_key_hash.of_b58check_opt value with
| Some k => _return k
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot find a manager key in contracts storage (""" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
""" is not a valid key).
Transfer from scripted contract are currently only supported for ""manager"" contract."
% string CamlinternalFormatBasics.End_of_format)))
"Cannot find a manager key in contracts storage (""%s"" is not a valid key).
Transfer from scripted contract are currently only supported for ""manager"" contract."
% string) value
end
| _raw_storage =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot find a manager key in contracts storage (wrong storage format : "
% string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.String_literal
").
Transfer from scripted contract are currently only supported for ""manager"" contract."
% string CamlinternalFormatBasics.End_of_format)))))
"Cannot find a manager key in contracts storage (wrong storage format : @[%a@]).
Transfer from scripted contract are currently only supported for ""manager"" contract."
% string) Michelson_v1_printer.print_expr storage
end
end).
Definition parse (code : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr) :=
Lwt._return
(op_gtgtquestion
(apply Micheline_parser.no_parsing_error
(Michelson_v1_parser.parse_expression None code))
(fun exp => apply Error_monad.ok (Script.lazy_expr (expanded exp)))).
Definition set_delegate {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Chain_services.chain)
(block : Tezos_shell_services.Block_services.block) (confirmations : option Z)
(dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
(fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
(fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(src_pk : Tezos_base__TzPervasives.Signature.public_key)
(src_sk : Tezos_client_base.Client_keys.sk_uri)
(contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
(delegate : option Tezos_base__TzPervasives.Signature.public_key_hash)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_client_alpha.Injection.result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction))) :=
let entrypoint := "do" % string in
op_gtgteqquestion
(op_gtgteqquestion
(Michelson_v1_entrypoints.contract_entrypoint_type cctxt chain block
contract entrypoint)
(fun function_parameter =>
match function_parameter with
| Some _ =>
let lambda :=
match delegate with
| Some delegate =>
let 'Hex delegate := Signature.Public_key_hash.to_hex delegate in
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"{ DROP ; NIL operation ; PUSH key_hash 0x" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" ; SOME ; SET_DELEGATE ; CONS }" % string
CamlinternalFormatBasics.End_of_format)))
"{ DROP ; NIL operation ; PUSH key_hash 0x%s ; SOME ; SET_DELEGATE ; CONS }"
% string) delegate
| None =>
"{ DROP ; NIL operation ; NONE key_hash ; SET_DELEGATE ; CONS }" %
string
end in
op_gtgteqquestion (parse lambda)
(fun param => _return (param, entrypoint))
| None =>
let entrypoint :=
match delegate with
| Some _ => "set_delegate" % string
| None => "remove_delegate" % string
end in
op_gtgteqquestion
(Michelson_v1_entrypoints.contract_entrypoint_type cctxt chain block
contract entrypoint)
(fun function_parameter =>
match function_parameter with
| Some _ =>
let delegate_data :=
match delegate with
| Some delegate =>
let 'Hex delegate :=
Signature.Public_key_hash.to_hex delegate in
String.append "0x" % string delegate
| None => "Unit" % string
end in
op_gtgteqquestion (parse delegate_data)
(fun param => _return (param, entrypoint))
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot find a " % string
(CamlinternalFormatBasics.Char_literal "%" % char
(CamlinternalFormatBasics.String_literal
"do or " % string
(CamlinternalFormatBasics.Char_literal "%" % char
(CamlinternalFormatBasics.String_literal
"set_delegate entrypoint in contract" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"Cannot find a %%do or %%set_delegate entrypoint in contract@."
% string)
end)
end))
(fun function_parameter =>
let '(parameters, entrypoint) := function_parameter in
let operation :=
Tezos_protocol_alpha.Protocol.Alpha_context.Transaction
{| amount := Tez.zero; parameters := parameters;
entrypoint := entrypoint; destination := contract |} in
op_gtgteqquestion
(Injection.inject_manager_operation cctxt chain block branch
confirmations dry_run verbose_signing source src_pk src_sk fee None
(Some Z.zero) None fee_parameter operation) (fun res => _return res)).
Definition d_unit
: Tezos_micheline.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim :=
Micheline.strip_locations
(Tezos_micheline.Micheline.Prim 0
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.D_Unit [] []).
Definition t_unit
: Tezos_micheline.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim :=
Micheline.strip_locations
(Tezos_micheline.Micheline.Prim 0
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.T_unit [] []).
Definition build_lambda_for_implicit
(delegate : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) : string :=
let 'Hex delegate := Signature.Public_key_hash.to_hex delegate in
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"{ DROP ; NIL operation ;PUSH key_hash 0x" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"; IMPLICIT_ACCOUNT;PUSH mutez " % string
(CamlinternalFormatBasics.Int64 CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" ;UNIT;TRANSFER_TOKENS ; CONS }" % string
CamlinternalFormatBasics.End_of_format)))))
"{ DROP ; NIL operation ;PUSH key_hash 0x%s; IMPLICIT_ACCOUNT;PUSH mutez %Ld ;UNIT;TRANSFER_TOKENS ; CONS }"
% string) delegate (Tez.to_mutez amount).
Definition build_lambda_for_originated
(destination : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
(entrypoint : string)
(amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
(parameter_type :
Tezos_micheline.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim)
(parameter : Tezos_protocol_alpha.Protocol.Script_repr.expr) : string :=
let destination :=
Data_encoding.Binary.to_bytes_exn Contract.encoding destination in
let amount := Tez.to_mutez amount in
let 'Hex destination := MBytes.to_hex destination in
let entrypoint :=
match entrypoint with
| "default" % string => "" % string
| s => String.append "%" % string s
end in
if equiv_decb parameter_type t_unit then
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"{ DROP ; NIL operation ;PUSH address 0x" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal "; CONTRACT " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"; ASSERT_SOME;PUSH mutez " % string
(CamlinternalFormatBasics.Int64
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" ;UNIT;TRANSFER_TOKENS ; CONS }" % string
CamlinternalFormatBasics.End_of_format)))))))))
"{ DROP ; NIL operation ;PUSH address 0x%s; CONTRACT %s %a; ASSERT_SOME;PUSH mutez %Ld ;UNIT;TRANSFER_TOKENS ; CONS }"
% string) destination entrypoint Michelson_v1_printer.print_expr
parameter_type amount
else
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"{ DROP ; NIL operation ;PUSH address 0x" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal "; CONTRACT " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"; ASSERT_SOME;PUSH mutez " % string
(CamlinternalFormatBasics.Int64
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" ;PUSH " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
";TRANSFER_TOKENS ; CONS }" % string
CamlinternalFormatBasics.End_of_format)))))))))))))
"{ DROP ; NIL operation ;PUSH address 0x%s; CONTRACT %s %a; ASSERT_SOME;PUSH mutez %Ld ;PUSH %a %a;TRANSFER_TOKENS ; CONS }"
% string) destination entrypoint Michelson_v1_printer.print_expr
parameter_type amount Michelson_v1_printer.print_expr parameter_type
Michelson_v1_printer.print_expr parameter.
Definition transfer {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Chain_services.chain)
(block : Tezos_shell_services.Block_services.block) (confirmations : option Z)
(dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
(source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(src_pk : Tezos_base__TzPervasives.Signature.public_key)
(src_sk : Tezos_client_base.Client_keys.sk_uri)
(contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
(destination : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
(op_staroptstar : option string)
: (option string) ->
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
(option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
(option Z.t) ->
(option Z.t) ->
(option Z.t) ->
Tezos_client_alpha.Injection.fee_parameter ->
unit ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
((Tezos_client_alpha.Injection.result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction))
*
(list
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))) :=
let entrypoint :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "default" % string
end in
fun arg =>
fun amount =>
fun fee =>
fun gas_limit =>
fun storage_limit =>
fun counter =>
fun fee_parameter =>
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
match Alpha_context.Contract.is_implicit destination with
| Some delegate =>
apply _return (build_lambda_for_implicit delegate amount)
| Some _ =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Implicit accounts have no entrypoints. (targeted entrypoint "
% string
(CamlinternalFormatBasics.Char_literal "%" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" on contract " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format))))))
"Implicit accounts have no entrypoints. (targeted entrypoint %%%s on contract %a)"
% string) entrypoint Contract.pp destination
| None =>
op_gtgteqquestion
(op_gtgteqquestion
(Michelson_v1_entrypoints.contract_entrypoint_type
cctxt chain block destination entrypoint)
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Contract " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" has no entrypoint named " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"Contract %a has no entrypoint named %s" %
string) Contract.pp destination entrypoint
| Some parameter_type => _return parameter_type
end))
(fun parameter_type =>
op_gtgteqquestion
match arg with
| Some arg =>
op_gtgteqquestion
(apply Lwt._return
(apply Micheline_parser.no_parsing_error
(Michelson_v1_parser.parse_expression None
arg)))
(fun function_parameter =>
let '{| expanded := arg |} :=
function_parameter in
return_some arg)
| None => return_none
end
(fun parameter =>
let parameter := Option.unopt d_unit parameter in
apply _return
(build_lambda_for_originated destination
entrypoint amount parameter_type parameter)))
end
(fun lambda =>
op_gtgteqquestion (parse lambda)
(fun parameters =>
let entrypoint := "do" % string in
let operation :=
Tezos_protocol_alpha.Protocol.Alpha_context.Transaction
{| amount := Tez.zero; parameters := parameters;
entrypoint := entrypoint;
destination := contract |} in
op_gtgteqquestion
(Injection.inject_manager_operation cctxt chain
block branch confirmations dry_run verbose_signing
source src_pk src_sk fee gas_limit storage_limit
counter fee_parameter operation)
(fun function_parameter =>
let '(_oph, _op, result) as res :=
function_parameter in
op_gtgteqquestion
(Lwt._return
(Injection.originated_contracts
(Tezos_protocol_alpha.Protocol.Apply_results.Single_result
result)))
(fun contracts => _return (res, contracts))))).
src/proto_alpha/lib_client/michelson_v1_emacs.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Tezos_micheline
open Micheline
let print_expr ppf expr =
let print_annot ppf = function
| [] ->
()
| annots ->
Format.fprintf ppf " %s" (String.concat " " annots)
in
let rec print_expr ppf = function
| Int (_, value) ->
Format.fprintf ppf "%s" (Z.to_string value)
| String (_, value) ->
Micheline_printer.print_string ppf value
| Bytes (_, value) ->
Format.fprintf ppf "0x%a" Hex.pp (Hex.of_bytes value)
| Seq (_, items) ->
Format.fprintf
ppf
"(seq %a)"
(Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
items
| Prim (_, name, [], []) ->
Format.fprintf ppf "%s" name
| Prim (_, name, items, annot) ->
Format.fprintf
ppf
"(%s%a%s%a)"
name
print_annot
annot
(if items = [] then "" else " ")
(Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
items
in
let root = root (Michelson_v1_primitives.strings_of_prims expr) in
Format.fprintf ppf "@[<h>%a@]" print_expr root
let print_var_annots ppf = List.iter (Format.fprintf ppf "%s ")
let print_annot_expr ppf (expr, annot) =
Format.fprintf ppf "(%a%a)" print_var_annots annot print_expr expr
open Micheline_parser
open Script_tc_errors
let print_type_map ppf (parsed, type_map) =
let rec print_expr_types ppf = function
| Seq (loc, [])
| Prim (loc, _, [], _)
| Int (loc, _)
| Bytes (loc, _)
| String (loc, _) ->
print_item ppf loc
| Seq (loc, items) | Prim (loc, _, items, _) ->
print_item ppf loc ;
List.iter (print_expr_types ppf) items
and print_stack ppf items =
Format.fprintf
ppf
"(%a)"
(Format.pp_print_list ~pp_sep:Format.pp_print_space print_annot_expr)
items
and print_item ppf loc =
try
let ({start = {point = s; _}; stop = {point = e; _}}, locs) =
List.assoc loc parsed.Michelson_v1_parser.expansion_table
in
let locs = List.sort compare locs in
let (bef, aft) = List.assoc (List.hd locs) type_map in
Format.fprintf
ppf
"(@[<h>%d %d %a %a@])@,"
s
e
print_stack
bef
print_stack
aft
with Not_found -> ()
in
Format.fprintf ppf "(@[<v 0>%a@])" print_expr_types (root parsed.unexpanded)
let first_error_location errs =
let rec find = function
| [] ->
0
| ( Inconsistent_type_annotations (loc, _, _)
| Unexpected_annotation loc
| Ill_formed_type (_, _, loc)
| Invalid_arity (loc, _, _, _)
| Invalid_namespace (loc, _, _, _)
| Invalid_primitive (loc, _, _)
| Invalid_kind (loc, _, _)
| Fail_not_in_tail_position loc
| Undefined_binop (loc, _, _, _)
| Undefined_unop (loc, _, _)
| Bad_return (loc, _, _)
| Bad_stack (loc, _, _, _)
| Unmatched_branches (loc, _, _)
| Invalid_constant (loc, _, _)
| Invalid_syntactic_constant (loc, _, _)
| Invalid_contract (loc, _)
| Comparable_type_expected (loc, _)
| Michelson_v1_primitives.Invalid_primitive_name (_, loc) )
:: _ ->
loc
| _ :: rest ->
find rest
in
find errs
let report_errors ppf (parsed, errs) =
let (eco, out) =
List.fold_left
(fun (eco, out) -> function Environment.Ecoproto_error err ->
(err :: eco, out) | err -> (eco, err :: out))
([], [])
errs
in
let (eco, out) = (List.rev eco, List.rev out) in
Format.fprintf
ppf
"(@[<v 0>%a@,%a@])"
(fun ppf errs ->
let find_location loc =
let oloc =
List.assoc loc parsed.Michelson_v1_parser.unexpansion_table
in
fst (List.assoc oloc parsed.expansion_table)
in
match errs with
| top :: errs ->
let (errs, loc) =
( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs),
match top with
| Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) ->
if expr = parsed.expanded then
find_location (first_error_location (top :: errs))
else find_location 0
| Michelson_v1_primitives.Invalid_primitive_name (expr, loc) ->
if
Micheline.strip_locations
(Michelson_v1_macros.unexpand_rec (Micheline.root expr))
= parsed.Michelson_v1_parser.unexpanded
then find_location loc
else find_location 0
| _ ->
find_location 0 )
in
let message =
Format.asprintf
"%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source:false
~parsed)
errs
in
let {start = {point = s; _}; stop = {point = e; _}} = loc in
Format.fprintf ppf "(%d %d %S)" (s + 1) (e + 1) message
| [] ->
())
eco
(Format.pp_print_list (fun ppf err ->
let find_location loc =
let oloc =
List.assoc loc parsed.Michelson_v1_parser.unexpansion_table
in
fst (List.assoc oloc parsed.expansion_table)
in
let loc =
match err with
| Invalid_utf8_sequence (point, _)
| Unexpected_character (point, _)
| Undefined_escape_sequence (point, _)
| Missing_break_after_number point ->
{start = point; stop = point}
| Unterminated_string loc
| Unterminated_integer loc
| Unterminated_comment loc
| Odd_lengthed_bytes loc
| Unclosed {loc; _}
| Unexpected {loc; _}
| Extra {loc; _} ->
loc
| Misaligned node ->
location node
| _ ->
find_location 0
in
let message =
Format.asprintf
"%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source:false
~parsed)
[err]
in
let {start = {point = s; _}; stop = {point = e; _}} = loc in
Format.fprintf ppf "(%d %d %S)" (s + 1) (e + 1) message))
out
src/proto_alpha/lib_client/michelson_v1_emacs.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Tezos_micheline.
Import Micheline.
Definition print_expr
(ppf : Stdlib.Format.formatter)
(expr :
Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) : unit :=
let print_annot
(ppf : Stdlib.Format.formatter) (function_parameter : list string) : unit :=
match function_parameter with
| [] => tt
| annots =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) " %s" % string)
(String.concat " " % string annots)
end in
let fix print_expr {A : Type}
(ppf : Stdlib.Format.formatter) (function_parameter :
Tezos_micheline.Micheline.node A string) : unit :=
match function_parameter with
| Tezos_micheline.Micheline.Int _ value =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
(Z.to_string value)
| Tezos_micheline.Micheline.String _ value =>
Micheline_printer.print_string ppf value
| Tezos_micheline.Micheline.Bytes _ value =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "0x" % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "0x%a" % string) Hex.pp
(Hex.of_bytes None value)
| Tezos_micheline.Micheline.Seq _ items =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "(seq " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))) "(seq %a)" % string)
(Format.pp_print_list (Some Format.pp_print_space) print_expr) items
| Tezos_micheline.Micheline.Prim _ name [] [] =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) name
| Tezos_micheline.Micheline.Prim _ name items annot =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))))))
"(%s%a%s%a)" % string) name print_annot annot
(if equiv_decb items [] then
"" % string
else
" " % string)
(Format.pp_print_list (Some Format.pp_print_space) print_expr) items
end in
let root := root (Michelson_v1_primitives.strings_of_prims expr) in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<h>" % string
CamlinternalFormatBasics.End_of_format) "<h>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))) "@[<h>%a@]" % string)
print_expr root.
Definition print_var_annots (ppf : Stdlib.Format.formatter)
: (list string) -> unit :=
List.iter
(Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
CamlinternalFormatBasics.End_of_format)) "%s " % string)).
Definition print_annot_expr
(ppf : Stdlib.Format.formatter)
(function_parameter :
(Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
(list string)) : unit :=
let '(expr, annot) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))) "(%a%a)" % string)
print_var_annots annot print_expr expr.
Import Micheline_parser.
Import Script_tc_errors.
Definition print_type_map
(ppf : Stdlib.Format.formatter)
(function_parameter :
Tezos_client_alpha.Michelson_v1_parser.parsed *
(list
(Z *
((list
((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
(list string))) *
(list
((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
(list string))))))) : unit :=
let '(parsed, type_map) := function_parameter in
let fix print_expr_types {A : Type}
(ppf : Stdlib.Format.formatter) (function_parameter :
Tezos_micheline.Micheline.node Z A) : unit :=
match function_parameter with
|
Tezos_micheline.Micheline.Seq loc [] |
Tezos_micheline.Micheline.Prim loc _ [] _ |
Tezos_micheline.Micheline.Int loc _ |
Tezos_micheline.Micheline.Bytes loc _ |
Tezos_micheline.Micheline.String loc _ => print_item ppf loc
|
Tezos_micheline.Micheline.Seq loc items |
Tezos_micheline.Micheline.Prim loc _ items _ =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := print_item ppf loc in
List.iter (print_expr_types ppf) items
end
with print_stack
(ppf : Stdlib.Format.formatter) (items :
list
((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
(list string))) : unit :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))) "(%a)" % string)
(Format.pp_print_list (Some Format.pp_print_space) print_annot_expr) items
with print_item (ppf : Stdlib.Format.formatter) (loc : Z) : unit :=
(* ❌ Try-with are not handled *)
try
(let '({| start := {| point := s |}; stop := {| point := e |} |}, locs) :=
List.assoc loc (Michelson_v1_parser.expansion_table parsed) in
let locs := List.sort OCaml.Stdlib.compare locs in
let '(bef, aft) := List.assoc (List.hd locs) type_map in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<h>" % string
CamlinternalFormatBasics.End_of_format) "<h>" % string))
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Char_literal ")" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string
0 0) CamlinternalFormatBasics.End_of_format))))))))))))
"(@[<h>%d %d %a %a@])@," % string) s e print_stack bef print_stack aft)
in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"(@[<v 0>%a@])" % string) print_expr_types (root (unexpanded parsed)).
Definition first_error_location
(errs : list Tezos_protocol_environment_alpha__Environment.Error_monad.error)
: Z :=
let fix find
(function_parameter :
list Tezos_protocol_environment_alpha__Environment.Error_monad.error) : Z :=
match function_parameter with
| [] => 0
|
cons
(Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_type_annotations
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc |
Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
_ _ loc |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc _ _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_namespace
loc _ _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Fail_not_in_tail_position
loc |
Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_binop
loc _ _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_unop
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_return
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc _ _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Unmatched_branches
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_constant
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_syntactic_constant
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
loc _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Comparable_type_expected
loc _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive_name
_ loc) _ => loc
| cons _ rest => find rest
end in
find errs.
Definition report_errors
(ppf : Stdlib.Format.formatter)
(function_parameter :
Tezos_client_alpha.Michelson_v1_parser.parsed *
(list Tezos_base__TzPervasives.Error_monad.error)) : unit :=
let '(parsed, errs) := function_parameter in
let '(eco, out) :=
List.fold_left
(fun function_parameter =>
let '(eco, out) := function_parameter in
fun function_parameter =>
match function_parameter with
| Tezos_base__TzPervasives.Error_monad.Ecoproto_error err =>
((cons err eco), out)
| err => (eco, (cons err out))
end) ([], []) errs in
let '(eco, out) := ((List.rev eco), (List.rev out)) in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))))
"(@[<v 0>%a@,%a@])" % string)
(fun ppf =>
fun errs =>
let find_location (loc : Z)
: Tezos_micheline.Micheline_parser.location :=
let oloc :=
List.assoc loc (Michelson_v1_parser.unexpansion_table parsed) in
fst (List.assoc oloc (expansion_table parsed)) in
match errs with
| cons top errs =>
let '(errs, loc) :=
((List.map
(fun e => Tezos_base__TzPervasives.Error_monad.Ecoproto_error e)
(cons top errs)),
match top with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
expr _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_data
_ expr _ =>
if equiv_decb expr (expanded parsed) then
find_location (first_error_location (cons top errs))
else
find_location 0
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive_name
expr loc =>
if
equiv_decb
(Micheline.strip_locations
(Michelson_v1_macros.unexpand_rec (Micheline.root expr)))
(Michelson_v1_parser.unexpanded parsed) then
find_location loc
else
find_location 0
| _ => find_location 0
end) in
let message :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
(Michelson_v1_error_reporter.report_errors false false
(Some parsed)) errs in
let '{| start := {| point := s |}; stop := {| point := e |} |} := loc
in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))))
"(%d %d %S)" % string) (Z.add s 1) (Z.add e 1) message
| [] => tt
end) eco
(Format.pp_print_list None
(fun ppf =>
fun err =>
let find_location (loc : Z)
: Tezos_micheline.Micheline_parser.location :=
let oloc :=
List.assoc loc (Michelson_v1_parser.unexpansion_table parsed) in
fst (List.assoc oloc (expansion_table parsed)) in
let loc :=
match err with
|
Tezos_error_monad.Error_monad.Invalid_utf8_sequence point _ |
Tezos_error_monad.Error_monad.Unexpected_character point _ |
Tezos_error_monad.Error_monad.Undefined_escape_sequence point _
| Tezos_error_monad.Error_monad.Missing_break_after_number point
=> {| start := point; stop := point |}
|
Tezos_error_monad.Error_monad.Unterminated_string loc |
Tezos_error_monad.Error_monad.Unterminated_integer loc |
Tezos_error_monad.Error_monad.Unterminated_comment loc |
Tezos_error_monad.Error_monad.Odd_lengthed_bytes loc |
Tezos_error_monad.Error_monad.Unclosed {| loc := loc |} |
Tezos_error_monad.Error_monad.Unexpected {| loc := loc |} |
Tezos_error_monad.Error_monad.Extra {| loc := loc |} => loc
| Tezos_error_monad.Error_monad.Misaligned node => location node
| _ => find_location 0
end in
let message :=
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
(Michelson_v1_error_reporter.report_errors false false
(Some parsed)) (cons err []) in
let '{| start := {| point := s |}; stop := {| point := e |} |} := loc
in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Caml_string
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))))
"(%d %d %S)" % string) (Z.add s 1) (Z.add e 1) message)) out.
src/proto_alpha/lib_client/michelson_v1_entrypoints.ml 168 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Protocol_client_context
open Alpha_context
type error += Contract_without_code of Contract.t
let () =
register_error_kind
`Permanent
~id:"contractWithoutCode"
~title:"The given contract has no code"
~description:
"Attempt to get the code of a contract failed because it has nocode. No \
scriptless contract should remain."
~pp:(fun ppf contract ->
Format.fprintf ppf "Contract has no code %a." Contract.pp contract)
Data_encoding.(obj1 (req "contract" Contract.encoding))
(function Contract_without_code c -> Some c | _ -> None)
(fun c -> Contract_without_code c)
let print_errors (cctxt : #Client_context.printer) errs =
cctxt#error "%a" Error_monad.pp_print_error errs >>= fun () -> return_unit
let script_entrypoint_type cctxt ~(chain : Chain_services.chain) ~block
(program : Script.expr) ~entrypoint =
Alpha_services.Helpers.Scripts.entrypoint_type
cctxt
(chain, block)
(program, entrypoint)
>>= function
| Ok ty ->
return_some ty
| Error
(Environment.Ecoproto_error (Script_tc_errors.No_such_entrypoint _) :: _)
->
return None
| Error _ as err ->
Lwt.return err
let contract_entrypoint_type cctxt ~(chain : Chain_services.chain) ~block
~contract ~entrypoint =
Alpha_services.Contract.entrypoint_type
cctxt
(chain, block)
contract
entrypoint
>>= function
| Ok ty ->
return_some ty
| Error (RPC_context.Not_found _ :: _) ->
return None
| Error _ as err ->
Lwt.return err
let print_entrypoint_type (cctxt : #Client_context.printer)
?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name ~entrypoint
= function
| Ok (Some ty) ->
( if emacs then
cctxt#message
"@[<v 2>((entrypoint . %s) (type . %a))@]@."
entrypoint
Michelson_v1_emacs.print_expr
ty
else
cctxt#message
"@[<v 2>Entrypoint %s: %a@]@."
entrypoint
Michelson_v1_printer.print_expr
ty )
>>= fun () -> return_unit
| Ok None ->
cctxt#message
"@[<v 2>No entrypoint named %s%a%a@]@."
entrypoint
(Option.pp ~default:"" (fun ppf ->
Format.fprintf ppf " for contract %a" Contract.pp))
contract
(Option.pp ~default:"" (fun ppf -> Format.fprintf ppf " for script %s"))
script_name
>>= fun () -> return_unit
| Error errs ->
on_errors errs
let list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract =
Alpha_services.Contract.list_entrypoints cctxt (chain, block) contract
let list_contract_unreachables cctxt ~chain ~block ~contract =
list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract
>>=? fun (unreachables, _) -> return unreachables
let list_contract_entrypoints cctxt ~chain ~block ~contract =
list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract
>>=? fun (_, entrypoints) ->
if not @@ List.mem_assoc "default" entrypoints then
contract_entrypoint_type
cctxt
~chain
~block
~contract
~entrypoint:"default"
>>= function
| Ok (Some ty) ->
return (("default", ty) :: entrypoints)
| _ ->
return entrypoints
else return entrypoints
let list_unreachables cctxt ~chain ~block (program : Script.expr) =
Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block) program
>>=? fun (unreachables, _) -> return unreachables
let list_entrypoints cctxt ~chain ~block (program : Script.expr) =
Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block) program
>>=? fun (_, entrypoints) ->
if not @@ List.mem_assoc "default" entrypoints then
script_entrypoint_type cctxt ~chain ~block program ~entrypoint:"default"
>>= function
| Ok (Some ty) ->
return (("default", ty) :: entrypoints)
| _ ->
return entrypoints
else return entrypoints
let print_entrypoints_list (cctxt : #Client_context.printer)
?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function
| Ok entrypoint_list ->
( if emacs then
cctxt#message
"@[<v 2>(@[%a@])@."
(Format.pp_print_list
~pp_sep:Format.pp_print_cut
(fun ppf (entrypoint, ty) ->
Format.fprintf
ppf
"@[<v 2>( ( entrypoint . %s ) ( type . @[%a@]))@]"
entrypoint
Michelson_v1_emacs.print_expr
ty))
entrypoint_list
else
cctxt#message
"@[<v 2>Entrypoints%a%a: @,%a@]@."
(Option.pp ~default:"" (fun ppf ->
Format.fprintf ppf " for contract %a" Contract.pp))
contract
(Option.pp ~default:"" (fun ppf ->
Format.fprintf ppf " for script %s"))
script_name
(Format.pp_print_list
~pp_sep:Format.pp_print_cut
(fun ppf (entrypoint, ty) ->
Format.fprintf
ppf
"@[<v 2>%s: @[%a@]@]"
entrypoint
Michelson_v1_printer.print_expr
ty))
entrypoint_list )
>>= fun () -> return_unit
| Error errs ->
on_errors errs
let print_unreachables (cctxt : #Client_context.printer)
?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function
| Ok unreachable ->
( if emacs then
cctxt#message
"@[<v 2>(@[%a@])@."
(Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path ->
Format.fprintf
ppf
"@[<h>( unreachable-path . %a )@]"
(Format.pp_print_list
~pp_sep:Format.pp_print_space
(fun ppf prim ->
Format.pp_print_string ppf
@@ Michelson_v1_primitives.string_of_prim prim))
path))
unreachable
else
match unreachable with
| [] ->
cctxt#message "@[<v 2>None.@]@."
| _ ->
cctxt#message
"@[<v 2>Unreachable paths in the argument%a%a: @[%a@]@."
(Option.pp ~default:"" (fun ppf ->
Format.fprintf ppf " of contract %a" Contract.pp))
contract
(Option.pp ~default:"" (fun ppf ->
Format.fprintf ppf " of script %s"))
script_name
(Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf ->
Format.fprintf
ppf
"@[<h> %a @]"
(Format.pp_print_list
~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/")
(fun ppf prim ->
Format.pp_print_string ppf
@@ Michelson_v1_primitives.string_of_prim prim))))
unreachable )
>>= fun () -> return_unit
| Error errs ->
on_errors errs
src/proto_alpha/lib_client/michelson_v1_entrypoints.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Protocol_client_context.
Import Alpha_context.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition print_errors {C a b : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C) (errs : Tezos_base__TzPervasives.Error_monad.trace)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) Error_monad.pp_print_error errs)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit).
Definition script_entrypoint_type {D E G I K L a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L *
(Tezos_shell_services.Chain_services.chain * D))
(chain : Tezos_shell_services.Chain_services.chain) (block : D)
(program : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
(entrypoint : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
op_gtgteq
(Alpha_services.Helpers.Scripts.entrypoint_type cctxt (chain, block)
(program, entrypoint))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok ty => return_some ty
|
Stdlib.Error
(cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.No_such_entrypoint
_)) _) => _return None
| (Stdlib.Error _) as err => Lwt._return err
end).
Definition contract_entrypoint_type {D E G I K L a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L *
(Tezos_shell_services.Chain_services.chain * D))
(chain : Tezos_shell_services.Chain_services.chain) (block : D)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
(entrypoint : string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
op_gtgteq
(Alpha_services.Contract.entrypoint_type cctxt (chain, block) contract
entrypoint)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok ty => return_some ty
| Stdlib.Error (cons (Tezos_error_monad.Error_monad.Not_found _) _) =>
_return None
| (Stdlib.Error _) as err => Lwt._return err
end).
Definition print_entrypoint_type {C a b : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C)
(op_staroptstar :
option
(Tezos_base__TzPervasives.Error_monad.trace ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)))
: bool ->
(option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
(option string) ->
string ->
(sum (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
Tezos_base__TzPervasives.Error_monad.trace) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let on_errors :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => print_errors cctxt
end in
fun emacs =>
fun contract =>
fun script_name =>
fun entrypoint =>
fun function_parameter =>
match function_parameter with
| Stdlib.Ok (Some ty) =>
op_gtgteq
(if emacs then
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"((entrypoint . " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
") (type . " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"))" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))
"@[<v 2>((entrypoint . %s) (type . %a))@]@." % string)
entrypoint Michelson_v1_emacs.print_expr ty
else
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Entrypoint " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 2>Entrypoint %s: %a@]@." % string) entrypoint
Michelson_v1_printer.print_expr ty)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Ok None =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"No entrypoint named " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 2>No entrypoint named %s%a%a@]@." % string) entrypoint
(Option.pp (Some "" % string)
(fun ppf =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" for contract " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
" for contract %a" % string) Contract.pp)) contract
(Option.pp (Some "" % string)
(fun ppf =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" for script " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
" for script %s" % string))) script_name)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error errs => on_errors errs
end.
Definition list_contract_unreachables_and_entrypoints
{D E F H J L M a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(D * E) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(D * E) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(D * E) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(D * E) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (L * a * b * c * q * i * o)) * M)))) * M *
(D * E)) (chain : D) (block : E)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
(list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr)))) :=
Alpha_services.Contract.list_entrypoints cctxt (chain, block) contract.
Definition list_contract_unreachables {D E F H J L M a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(D * E) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(D * E) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(D * E) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(D * E) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (L * a * b * c * q * i * o)) * M)))) * M *
(D * E)) (chain : D) (block : E)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim))) :=
op_gtgteqquestion
(list_contract_unreachables_and_entrypoints cctxt chain block contract)
(fun function_parameter =>
let '(unreachables, _) := function_parameter in
_return unreachables).
Definition list_contract_entrypoints {D E G I K L a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L *
(Tezos_shell_services.Chain_services.chain * D))
(chain : Tezos_shell_services.Chain_services.chain) (block : D)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr))) :=
op_gtgteqquestion
(list_contract_unreachables_and_entrypoints cctxt chain block contract)
(fun function_parameter =>
let '(_, entrypoints) := function_parameter in
if apply negb (List.mem_assoc "default" % string entrypoints) then
op_gtgteq
(contract_entrypoint_type cctxt chain block contract
"default" % string)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok (Some ty) =>
_return (cons ("default" % string, ty) entrypoints)
| _ => _return entrypoints
end)
else
_return entrypoints).
Definition list_unreachables {D E F H J L M a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(D * E) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(D * E) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(D * E) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(D * E) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (L * a * b * c * q * i * o)) * M)))) * M *
(D * E)) (chain : D) (block : E)
(program : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim))) :=
op_gtgteqquestion
(Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block)
program)
(fun function_parameter =>
let '(unreachables, _) := function_parameter in
_return unreachables).
Definition list_entrypoints {D E G I K L a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(Tezos_shell_services.Chain_services.chain * D) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L *
(Tezos_shell_services.Chain_services.chain * D))
(chain : Tezos_shell_services.Chain_services.chain) (block : D)
(program : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr))) :=
op_gtgteqquestion
(Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block)
program)
(fun function_parameter =>
let '(_, entrypoints) := function_parameter in
if apply negb (List.mem_assoc "default" % string entrypoints) then
op_gtgteq
(script_entrypoint_type cctxt chain block program "default" % string)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok (Some ty) =>
_return (cons ("default" % string, ty) entrypoints)
| _ => _return entrypoints
end)
else
_return entrypoints).
Definition print_entrypoints_list {C a b : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C)
(op_staroptstar :
option
(Tezos_base__TzPervasives.Error_monad.trace ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)))
: bool ->
(option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
(option string) ->
(sum (list (string * Tezos_protocol_alpha.Protocol.Script_repr.expr))
Tezos_base__TzPervasives.Error_monad.trace) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let on_errors :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => print_errors cctxt
end in
fun emacs =>
fun contract =>
fun script_name =>
fun function_parameter =>
match function_parameter with
| Stdlib.Ok entrypoint_list =>
op_gtgteq
(if emacs then
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Char_literal ")" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 2>(@[%a@])@." % string)
(Format.pp_print_list (Some Format.pp_print_cut)
(fun ppf =>
fun function_parameter =>
let '(entrypoint, ty) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"( ( entrypoint . " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" ) ( type . " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.String_literal
"))" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[<v 2>( ( entrypoint . %s ) ( type . @[%a@]))@]" %
string) entrypoint Michelson_v1_emacs.print_expr
ty)) entrypoint_list
else
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Entrypoints" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0
0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))
"@[<v 2>Entrypoints%a%a: @,%a@]@." % string)
(Option.pp (Some "" % string)
(fun ppf =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" for contract " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
" for contract %a" % string) Contract.pp)) contract
(Option.pp (Some "" % string)
(fun ppf =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" for script " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
" for script %s" % string))) script_name
(Format.pp_print_list (Some Format.pp_print_cut)
(fun ppf =>
fun function_parameter =>
let '(entrypoint, ty) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 2>%s: @[%a@]@]" % string) entrypoint
Michelson_v1_printer.print_expr ty)) entrypoint_list)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error errs => on_errors errs
end.
Definition print_unreachables {C a b : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C)
(op_staroptstar :
option
(Tezos_base__TzPervasives.Error_monad.trace ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)))
: bool ->
(option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
(option string) ->
(sum
(list
(list Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim))
Tezos_base__TzPervasives.Error_monad.trace) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let on_errors :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => print_errors cctxt
end in
fun emacs =>
fun contract =>
fun script_name =>
fun function_parameter =>
match function_parameter with
| Stdlib.Ok unreachable =>
op_gtgteq
(if emacs then
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Char_literal ")" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 2>(@[%a@])@." % string)
(Format.pp_print_list (Some Format.pp_print_cut)
(fun ppf =>
fun path =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<h>" % string
CamlinternalFormatBasics.End_of_format)
"<h>" % string))
(CamlinternalFormatBasics.String_literal
"( unreachable-path . " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" )" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<h>( unreachable-path . %a )@]" % string)
(Format.pp_print_list (Some Format.pp_print_space)
(fun ppf =>
fun prim =>
apply (Format.pp_print_string ppf)
(Michelson_v1_primitives.string_of_prim prim)))
path)) unreachable
else
match unreachable with
| [] =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"None." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"@[<v 2>None.@]@." % string)
| _ =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Unreachable paths in the argument" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))
"@[<v 2>Unreachable paths in the argument%a%a: @[%a@]@." %
string)
(Option.pp (Some "" % string)
(fun ppf =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" of contract " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
" of contract %a" % string) Contract.pp)) contract
(Option.pp (Some "" % string)
(fun ppf =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" of script " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
" of script %s" % string))) script_name
(Format.pp_print_list (Some Format.pp_print_cut)
(fun ppf =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<h>" % string
CamlinternalFormatBasics.End_of_format)
"<h>" % string))
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" " % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<h> %a @]" % string)
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let '_ := function_parameter in
Format.pp_print_string ppf "/" % string))
(fun ppf =>
fun prim =>
apply (Format.pp_print_string ppf)
(Michelson_v1_primitives.string_of_prim prim)))))
unreachable
end)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error errs => on_errors errs
end.
src/proto_alpha/lib_client/michelson_v1_error_reporter.ml 65 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Tezos_micheline
open Script_tc_errors
open Script_interpreter
open Michelson_v1_printer
let print_ty ppf ty = Michelson_v1_printer.print_expr_unwrapped ppf ty
let print_var_annot ppf annot = List.iter (Format.fprintf ppf "@ %s") annot
let print_stack_ty ?(depth = max_int) ppf s =
let rec loop depth ppf = function
| [] ->
()
| _ when depth <= 0 ->
Format.fprintf ppf "..."
| [(last, annot)] ->
Format.fprintf ppf "%a%a" print_ty last print_var_annot annot
| (last, annot) :: rest ->
Format.fprintf
ppf
"%a%a@ :@ %a"
print_ty
last
print_var_annot
annot
(loop (depth - 1))
rest
in
match s with
| [] ->
Format.fprintf ppf "[]"
| sty ->
Format.fprintf ppf "@[<hov 2>[ %a ]@]" (loop depth) sty
let rec print_enumeration ppf = function
| [single] ->
Format.fprintf ppf "%a" Format.pp_print_text single
| [prev; last] ->
Format.fprintf
ppf
"%a@ or@ %a"
Format.pp_print_text
prev
Format.pp_print_text
last
| first :: rest ->
Format.fprintf
ppf
"%a,@ %a"
Format.pp_print_text
first
print_enumeration
rest
| [] ->
assert false
let collect_error_locations errs =
let rec collect acc = function
| Environment.Ecoproto_error
( Ill_formed_type (_, _, _)
| No_such_entrypoint _
| Duplicate_entrypoint _
| Unreachable_entrypoint _
| Runtime_contract_error (_, _)
| Michelson_v1_primitives.Invalid_primitive_name (_, _)
| Ill_typed_data (_, _, _)
| Ill_typed_contract (_, _) )
:: _
| [] ->
acc
| Environment.Ecoproto_error
( Invalid_arity (loc, _, _, _)
| Inconsistent_type_annotations (loc, _, _)
| Unexpected_annotation loc
| Ungrouped_annotations loc
| Type_too_large (loc, _, _)
| Invalid_namespace (loc, _, _, _)
| Invalid_primitive (loc, _, _)
| Invalid_kind (loc, _, _)
| Duplicate_field (loc, _)
| Unexpected_big_map loc
| Unexpected_operation loc
| Fail_not_in_tail_position loc
| Undefined_binop (loc, _, _, _)
| Undefined_unop (loc, _, _)
| Bad_return (loc, _, _)
| Bad_stack (loc, _, _, _)
| Unmatched_branches (loc, _, _)
| Self_in_lambda loc
| Invalid_constant (loc, _, _)
| Invalid_syntactic_constant (loc, _, _)
| Invalid_contract (loc, _)
| Comparable_type_expected (loc, _)
| Overflow (loc, _)
| Reject (loc, _, _) )
:: rest ->
collect (loc :: acc) rest
| _ :: rest ->
collect acc rest
in
collect [] errs
let report_errors ~details ~show_source ?parsed ppf errs =
let rec print_trace locations errs =
let print_loc ppf loc =
match locations loc with
| None ->
Format.fprintf ppf "At (unshown) location %d, " loc
| Some loc ->
Format.fprintf
ppf
"%s,@ "
(String.capitalize_ascii
(Format.asprintf "%a" Micheline_parser.print_location loc))
in
let parsed_locations parsed loc =
try
let oloc =
List.assoc loc parsed.Michelson_v1_parser.unexpansion_table
in
let (ploc, _) = List.assoc oloc parsed.expansion_table in
Some ploc
with Not_found -> None
in
let print_source ppf (parsed, _hilights (* TODO *)) =
let lines =
String.split_on_char '\n' parsed.Michelson_v1_parser.source
in
let cols = String.length (string_of_int (List.length lines)) in
Format.fprintf
ppf
"@[<v 0>%a@]"
(Format.pp_print_list (fun ppf (i, l) ->
Format.fprintf ppf "%0*d: %s" cols i l))
(List.mapi (fun i l -> (i + 1, l)) lines)
in
match errs with
| [] ->
()
| Environment.Ecoproto_error
(Michelson_v1_primitives.Invalid_primitive_name (expr, loc))
:: rest ->
let parsed =
match parsed with
| Some parsed ->
if
Micheline.strip_locations
(Michelson_v1_macros.unexpand_rec (Micheline.root expr))
= parsed.Michelson_v1_parser.unexpanded
then parsed
else Michelson_v1_printer.unparse_invalid expr
| None ->
Michelson_v1_printer.unparse_invalid expr
in
let hilights = loc :: collect_error_locations rest in
if show_source then
Format.fprintf
ppf
"@[<hov 0>@[<hov 2>Invalid primitive:@ %a@]@]"
print_source
(parsed, hilights)
else Format.fprintf ppf "Invalid primitive." ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace (parsed_locations parsed) rest
| Environment.Ecoproto_error (Ill_typed_data (name, expr, ty)) :: rest ->
let parsed =
match parsed with
| Some parsed when expr = parsed.Michelson_v1_parser.expanded ->
parsed
| Some _ | None ->
Michelson_v1_printer.unparse_expression expr
in
let hilights = collect_error_locations rest in
Format.fprintf
ppf
"@[<hov 0>@[<hov 2>Ill typed %adata:@ %a@]@ @[<hov 2>is not an \
expression of type@ %a@]@]"
(fun ppf -> function None -> () | Some s ->
Format.fprintf ppf "%s " s)
name
print_source
(parsed, hilights)
print_ty
ty ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace (parsed_locations parsed) rest
| Environment.Ecoproto_error (No_such_entrypoint entrypoint) :: rest ->
Format.fprintf ppf "Contract has no entrypoint named %s" entrypoint ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error (Duplicate_entrypoint entrypoint) :: rest ->
Format.fprintf ppf "Contract has two entrypoints named %s" entrypoint ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error (Unreachable_entrypoint path) :: rest ->
let path =
String.concat
"/"
(List.map Michelson_v1_primitives.string_of_prim path)
in
Format.fprintf ppf "Entrypoint at path %s is not reachable" path ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error (Ill_formed_type (_, expr, loc)) :: rest ->
let parsed =
match parsed with
| Some parsed when expr = parsed.Michelson_v1_parser.expanded ->
parsed
| Some _ | None ->
Michelson_v1_printer.unparse_expression expr
in
let hilights = loc :: collect_error_locations errs in
if show_source then
Format.fprintf
ppf
"@[<v 2>%aill formed type:@ %a@]"
print_loc
loc
print_source
(parsed, hilights)
else Format.fprintf ppf "Ill formed type." ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace (parsed_locations parsed) rest
| Environment.Ecoproto_error (Ill_typed_contract (expr, type_map)) :: rest
->
let parsed =
match parsed with
| Some parsed
when (not details) && expr = parsed.Michelson_v1_parser.expanded ->
parsed
| Some _ | None ->
Michelson_v1_printer.unparse_toplevel ~type_map expr
in
let hilights = collect_error_locations rest in
if show_source then
Format.fprintf
ppf
"@[<v 0>Ill typed contract:@, %a@]"
print_source
(parsed, hilights)
else Format.fprintf ppf "Ill typed contract." ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace (parsed_locations parsed) rest
| Environment.Ecoproto_error Apply.Gas_quota_exceeded_init_deserialize
:: rest ->
Format.fprintf
ppf
"@[<v 0>Not enough gas to deserialize the operation.@,\
Injecting such a transaction could have you banned from mempools.@]" ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error Cannot_serialize_error :: rest ->
Format.fprintf
ppf
"Error too big to serialize within the provided gas bounds." ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error (Deprecated_instruction prim) :: rest ->
Format.fprintf
ppf
"@[<v 0>Use of deprecated instruction: %s@]"
(Michelson_v1_primitives.string_of_prim prim) ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error Cannot_serialize_storage :: rest ->
Format.fprintf
ppf
"Cannot serialize the resulting storage value within the provided \
gas bounds." ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error (Missing_field prim) :: rest ->
Format.fprintf
ppf
"@[<v 0>Missing contract field: %s@]"
(Michelson_v1_primitives.string_of_prim prim) ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error (Duplicate_field (loc, prim)) :: rest ->
Format.fprintf
ppf
"@[<v 0>%aduplicate contract field: %s@]"
print_loc
loc
(Michelson_v1_primitives.string_of_prim prim) ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error (Unexpected_big_map loc) :: rest ->
Format.fprintf
ppf
"%abig_map type not allowed inside another big_map"
print_loc
loc ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error (Unexpected_operation loc) :: rest ->
Format.fprintf
ppf
"%aoperation type forbidden in parameter, storage and constants"
print_loc
loc ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error (Unexpected_contract loc) :: rest ->
Format.fprintf
ppf
"%acontract type forbidden in storage and constants"
print_loc
loc ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error (Runtime_contract_error (contract, expr))
:: rest ->
let parsed =
match parsed with
| Some parsed when expr = parsed.Michelson_v1_parser.expanded ->
parsed
| Some _ | None ->
Michelson_v1_printer.unparse_toplevel expr
in
let hilights = collect_error_locations rest in
Format.fprintf
ppf
"@[<v 2>Runtime error in contract %a:@ %a@]"
Contract.pp
contract
print_source
(parsed, hilights) ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace (parsed_locations parsed) rest
| Environment.Ecoproto_error (Apply.Internal_operation_replay op) :: rest
->
Format.fprintf
ppf
"@[<v 2>Internal operation replay attempt:@,%a@]"
Operation_result.pp_internal_operation
op ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error Gas.Gas_limit_too_high :: rest ->
Format.fprintf
ppf
"Gas limit for the operation is out of the protocol hard bounds." ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error Gas.Block_quota_exceeded :: rest ->
Format.fprintf
ppf
"Gas limit for the block exceeded during typechecking or execution." ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error Gas.Operation_quota_exceeded :: rest ->
Format.fprintf
ppf
"@[<v 0>Gas limit exceeded during typechecking or execution.@,\
Try again with a higher gas limit.@]" ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| Environment.Ecoproto_error Fees.Operation_quota_exceeded :: rest ->
Format.fprintf
ppf
"@[<v 0>Storage limit exceeded during typechecking or execution.@,\
Try again with a higher storage limit.@]" ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| [Environment.Ecoproto_error (Script_interpreter.Bad_contract_parameter c)]
->
Format.fprintf
ppf
"@[<v 0>Account %a is not a smart contract, it does not take \
arguments.@,\
The `-arg' flag should not be used when transferring to an \
account.@]"
Contract.pp
c
| Environment.Ecoproto_error err :: rest ->
( match err with
| Script_interpreter.Bad_contract_parameter c ->
Format.fprintf
ppf
"Invalid argument passed to contract %a."
Contract.pp
c
| Invalid_arity (loc, name, exp, got) ->
Format.fprintf
ppf
"%aprimitive %s expects %d arguments but is given %d."
print_loc
loc
(Michelson_v1_primitives.string_of_prim name)
exp
got
| Invalid_namespace (loc, name, exp, got) ->
let human_namespace = function
| Instr_namespace ->
("an", "instruction")
| Type_namespace ->
("a", "type name")
| Constant_namespace ->
("a", "constant constructor")
| Keyword_namespace ->
("a", "keyword")
in
Format.fprintf
ppf
"@[%aunexpected %s %s, only %s %s can be used here."
print_loc
loc
(snd (human_namespace got))
(Michelson_v1_primitives.string_of_prim name)
(fst (human_namespace exp))
(snd (human_namespace exp))
| Invalid_primitive (loc, exp, got) ->
Format.fprintf
ppf
"@[%ainvalid primitive %s, only %a can be used here."
print_loc
loc
(Michelson_v1_primitives.string_of_prim got)
print_enumeration
(List.map Michelson_v1_primitives.string_of_prim exp)
| Invalid_kind (loc, exp, got) ->
let human_kind = function
| Seq_kind ->
("a", "sequence")
| Prim_kind ->
("a", "primitive")
| Int_kind ->
("an", "int")
| String_kind ->
("a", "string")
| Bytes_kind ->
("a", "byte sequence")
in
Format.fprintf
ppf
"@[%aunexpected %s, only@ %a@ can be used here."
print_loc
loc
(snd (human_kind got))
print_enumeration
(List.map
(fun k ->
let (a, n) = human_kind k in
a ^ " " ^ n)
exp)
| Duplicate_map_keys (_, expr) ->
Format.fprintf
ppf
"@[<v 2>Map literals cannot contain duplicate keys, however a \
duplicate key was found:@ @[%a@]"
print_expr
expr
| Unordered_map_keys (_, expr) ->
Format.fprintf
ppf
"@[<v 2>Keys in a map literal must be in strictly ascending \
order, but they were unordered in literal:@ @[%a@]"
print_expr
expr
| Duplicate_set_values (_, expr) ->
Format.fprintf
ppf
"@[<v 2>Set literals cannot contain duplicate values, however a \
duplicate value was found:@ @[%a@]"
print_expr
expr
| Unordered_set_values (_, expr) ->
Format.fprintf
ppf
"@[<v 2>Values in a set literal must be in strictly ascending \
order, but they were unordered in literal:@ @[%a@]"
print_expr
expr
| Fail_not_in_tail_position loc ->
Format.fprintf
ppf
"%aThe FAIL instruction must appear in a tail position."
print_loc
loc
| Undefined_binop (loc, name, tya, tyb) ->
Format.fprintf
ppf
"@[<hov 0>@[<hov 2>%aoperator %s is undefined between@ %a@]@ \
@[<hov 2>and@ %a.@]@]"
print_loc
loc
(Michelson_v1_primitives.string_of_prim name)
print_ty
tya
print_ty
tyb
| Undefined_unop (loc, name, ty) ->
Format.fprintf
ppf
"@[<hov 0>@[<hov 2>%aoperator %s is undefined on@ %a@]@]"
print_loc
loc
(Michelson_v1_primitives.string_of_prim name)
print_ty
ty
| Bad_return (loc, got, exp) ->
Format.fprintf
ppf
"@[<v 2>%awrong stack type at end of body:@,\
- @[<v 0>expected return stack type:@ %a,@]@,\
- @[<v 0>actual stack type:@ %a.@]@]"
print_loc
loc
(fun ppf -> print_stack_ty ppf)
[(exp, [])]
(fun ppf -> print_stack_ty ppf)
got
| Bad_stack (loc, name, depth, sty) ->
Format.fprintf
ppf
"@[<hov 2>%awrong stack type for instruction %s:@ %a.@]"
print_loc
loc
(Michelson_v1_primitives.string_of_prim name)
(print_stack_ty ~depth)
sty
| Unmatched_branches (loc, sta, stb) ->
Format.fprintf
ppf
"@[<v 2>%atwo branches don't end with the same stack type:@,\
- @[<hov>first stack type:@ %a,@]@,\
- @[<hov>other stack type:@ %a.@]@]"
print_loc
loc
(fun ppf -> print_stack_ty ppf)
sta
(fun ppf -> print_stack_ty ppf)
stb
| Inconsistent_annotations (annot1, annot2) ->
Format.fprintf
ppf
"@[<v 2>The two annotations do not match:@,\
- @[<v>%s@]@,\
- @[<v>%s@]@]"
annot1
annot2
| Inconsistent_field_annotations (annot1, annot2) ->
Format.fprintf
ppf
"@[<v 2>The field access annotation does not match:@,\
- @[<v>%s@]@,\
- @[<v>%s@]@]"
annot1
annot2
| Inconsistent_type_annotations (loc, ty1, ty2) ->
Format.fprintf
ppf
"@[<v 2>%athe two types contain incompatible annotations:@,\
- @[<hov>%a@]@,\
- @[<hov>%a@]@]"
print_loc
loc
print_ty
ty1
print_ty
ty2
| Unexpected_annotation loc ->
Format.fprintf ppf "@[<v 2>%aunexpected annotation." print_loc loc
| Ungrouped_annotations loc ->
Format.fprintf
ppf
"@[<v 2>%aAnnotations of the same kind must be grouped."
print_loc
loc
| Type_too_large (loc, size, maximum_size) ->
Format.fprintf
ppf
"@[<v 2>%atype size (%d) exceeded maximum type size (%d)."
print_loc
loc
size
maximum_size
| Self_in_lambda loc ->
Format.fprintf
ppf
"%aThe SELF instruction cannot appear in a lambda."
print_loc
loc
| Bad_stack_length ->
Format.fprintf ppf "Bad stack length."
| Bad_stack_item lvl ->
Format.fprintf ppf "Bad stack item %d." lvl
| Invalid_constant (loc, got, exp) ->
Format.fprintf
ppf
"@[<hov 0>@[<hov 2>%avalue@ %a@]@ @[<hov 2>is invalid for type@ \
%a.@]@]"
print_loc
loc
print_expr
got
print_ty
exp
| Invalid_syntactic_constant (loc, got, exp) ->
Format.fprintf
ppf
"@[<hov 0>@[<hov 2>%avalue@ %a@]@ @[<hov 2>is invalid, \
expected@ %s@]@]"
print_loc
loc
print_expr
got
exp
| Invalid_contract (loc, contract) ->
Format.fprintf
ppf
"%ainvalid contract %a."
print_loc
loc
Contract.pp
contract
| Comparable_type_expected (loc, ty) ->
Format.fprintf ppf "%acomparable type expected." print_loc loc ;
Format.fprintf
ppf
"@[<hov 0>@[<hov 2>Type@ %a@]@ is not comparable.@]"
print_ty
ty
| Inconsistent_types (tya, tyb) ->
Format.fprintf
ppf
"@[<hov 0>@[<hov 2>Type@ %a@]@ @[<hov 2>is not compatible with \
type@ %a.@]@]"
print_ty
tya
print_ty
tyb
| Reject (loc, v, trace) ->
Format.fprintf
ppf
"%ascript reached FAILWITH instruction@ @[<hov 2>with@ %a@]%a"
print_loc
loc
print_expr
v
(fun ppf -> function None -> () | Some trace ->
Format.fprintf
ppf
"@,@[<v 2>trace@,%a@]"
print_execution_trace
trace)
trace
| Overflow (loc, trace) ->
Format.fprintf
ppf
"%aunexpected arithmetic overflow%a"
print_loc
loc
(fun ppf -> function None -> () | Some trace ->
Format.fprintf
ppf
"@,@[<v 2>trace@,%a@]"
print_execution_trace
trace)
trace
| err ->
Format.fprintf ppf "%a" Environment.Error_monad.pp err ) ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
| err :: rest ->
Format.fprintf ppf "%a" Error_monad.pp err ;
if rest <> [] then Format.fprintf ppf "@," ;
print_trace locations rest
in
Format.fprintf ppf "@[<v 0>" ;
print_trace (fun _ -> None) errs ;
Format.fprintf ppf "@]"
src/proto_alpha/lib_client/michelson_v1_error_reporter.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Import Tezos_micheline.
Import Script_tc_errors.
Import Script_interpreter.
Import Michelson_v1_printer.
Definition print_ty
(ppf : Stdlib.Format.formatter)
(ty : Tezos_protocol_alpha.Protocol.Script_repr.expr) : unit :=
Michelson_v1_printer.print_expr_unwrapped ppf ty.
Definition print_var_annot (ppf : Stdlib.Format.formatter) (annot : list string)
: unit :=
List.iter
(Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)) "@ %s" % string)) annot.
Definition print_stack_ty (op_staroptstar : option Z)
: Stdlib.Format.formatter ->
(list (Tezos_protocol_alpha.Protocol.Script_repr.expr * (list string))) ->
unit :=
let depth :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Stdlib.max_int
end in
fun ppf =>
fun s =>
let fix loop
(depth : Z) (ppf : Stdlib.Format.formatter) (function_parameter :
list (Tezos_protocol_alpha.Protocol.Script_repr.expr * (list string)))
: unit :=
match function_parameter with
| [] => tt
| _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "..." % string
CamlinternalFormatBasics.End_of_format) "..." % string)
| cons (last, annot) [] =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "%a%a" % string)
print_ty last print_var_annot annot
| cons (last, annot) rest =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))))
"%a%a@ :@ %a" % string) print_ty last print_var_annot annot
(loop (Z.sub depth 1)) rest
end in
match s with
| [] =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "[]" % string
CamlinternalFormatBasics.End_of_format) "[]" % string)
| sty =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<hov 2>" % string
CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
(CamlinternalFormatBasics.String_literal "[ " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " ]" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<hov 2>[ %a ]@]" % string) (loop depth) sty
end.
Fixpoint print_enumeration
(ppf : Stdlib.Format.formatter) (function_parameter : list string) : unit :=
match function_parameter with
| cons single [] =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) Format.pp_print_text single
| cons prev (cons last []) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "or" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))))
"%a@ or@ %a" % string) Format.pp_print_text prev Format.pp_print_text
last
| cons first rest =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "," % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))) "%a,@ %a" % string)
Format.pp_print_text first print_enumeration rest
| [] =>
(* ❌ Assert instruction is not handled. *)
assert false
end.
Definition collect_error_locations
(errs : list Tezos_base__TzPervasives.Error_monad.error)
: list Tezos_raw_protocol_alpha.Alpha_context.Script.location :=
let fix collect
(acc : list Tezos_raw_protocol_alpha.Alpha_context.Script.location)
(function_parameter : list Tezos_base__TzPervasives.Error_monad.error)
: list Tezos_raw_protocol_alpha.Alpha_context.Script.location :=
match function_parameter with
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
_ _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.No_such_entrypoint
_ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_entrypoint
_ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Unreachable_entrypoint
_ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Runtime_contract_error
_ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive_name
_ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_data
_ _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
_ _)) _ | [] => acc
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc _ _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_type_annotations
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc |
Tezos_protocol_environment_alpha__Environment.Error_monad.Ungrouped_annotations
loc |
Tezos_protocol_environment_alpha__Environment.Error_monad.Type_too_large
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_namespace
loc _ _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_field
loc _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_big_map
loc |
Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_operation
loc |
Tezos_protocol_environment_alpha__Environment.Error_monad.Fail_not_in_tail_position
loc |
Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_binop
loc _ _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_unop
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_return
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc _ _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Unmatched_branches
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Self_in_lambda
loc |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_constant
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_syntactic_constant
loc _ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
loc _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Comparable_type_expected
loc _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Overflow
loc _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Reject loc
_ _)) rest => collect (cons loc acc) rest
| cons _ rest => collect acc rest
end in
collect [] errs.
Definition report_errors
(details : bool) (show_source : bool)
(parsed : option Tezos_client_alpha.Michelson_v1_parser.parsed)
(ppf : Stdlib.Format.formatter)
(errs : list Tezos_base__TzPervasives.Error_monad.error) : unit :=
let fix print_trace
(locations : Z -> option Tezos_micheline.Micheline_parser.location) (errs :
list Tezos_base__TzPervasives.Error_monad.error) : unit :=
let print_loc (ppf : Stdlib.Format.formatter) (loc : Z) : unit :=
match locations loc with
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"At (unshown) location " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ", " % string
CamlinternalFormatBasics.End_of_format)))
"At (unshown) location %d, " % string) loc
| Some loc =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "," % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
CamlinternalFormatBasics.End_of_format))) "%s,@ " % string)
(String.capitalize_ascii
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Micheline_parser.print_location loc))
end in
let parsed_locations
(parsed : Tezos_client_alpha.Michelson_v1_parser.parsed) (loc : Z)
: option Tezos_micheline.Micheline_parser.location :=
(* ❌ Try-with are not handled *)
try
(let oloc :=
List.assoc loc (Michelson_v1_parser.unexpansion_table parsed) in
let '(ploc, _) := List.assoc oloc (expansion_table parsed) in
Some ploc) in
let print_source {A : Type}
(ppf : Stdlib.Format.formatter) (function_parameter :
Tezos_client_alpha.Michelson_v1_parser.parsed * A) : unit :=
let '(parsed, _hilights) := function_parameter in
let lines :=
String.split_on_char "010" % char (Michelson_v1_parser.source parsed) in
let cols := String.length (OCaml.Stdlib.string_of_int (List.length lines))
in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))) "@[<v 0>%a@]" % string)
(Format.pp_print_list None
(fun ppf =>
fun function_parameter =>
let '(i, l) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
(CamlinternalFormatBasics.Arg_padding
CamlinternalFormatBasics.Zeros)
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"%0*d: %s" % string) cols i l))
(List.mapi (fun i => fun l => ((Z.add i 1), l)) lines) in
match errs with
| [] => tt
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive_name
expr loc)) rest =>
let parsed :=
match parsed with
| Some parsed =>
if
equiv_decb
(Micheline.strip_locations
(Michelson_v1_macros.unexpand_rec (Micheline.root expr)))
(Michelson_v1_parser.unexpanded parsed) then
parsed
else
Michelson_v1_printer.unparse_invalid expr
| None => Michelson_v1_printer.unparse_invalid expr
end in
let hilights := cons loc (collect_error_locations rest) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if show_source then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<hov 0>" % string
CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 2>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 2>" % string))
(CamlinternalFormatBasics.String_literal
"Invalid primitive:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[<hov 0>@[<hov 2>Invalid primitive:@ %a@]@]" % string)
print_source (parsed, hilights)
else
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid primitive." % string
CamlinternalFormatBasics.End_of_format)
"Invalid primitive." % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace (parsed_locations parsed) rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_data
name expr ty)) rest =>
let parsed :=
match parsed with
| Some parsed => parsed
| Some _ | None => Michelson_v1_printer.unparse_expression expr
end in
let hilights := collect_error_locations rest in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<hov 0>" % string
CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<hov 2>" % string
CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
(CamlinternalFormatBasics.String_literal "Ill typed " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "data:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 2>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 2>" % string))
(CamlinternalFormatBasics.String_literal
"is not an expression of type" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))))
"@[<hov 0>@[<hov 2>Ill typed %adata:@ %a@]@ @[<hov 2>is not an expression of type@ %a@]@]"
% string)
(fun ppf =>
fun function_parameter =>
match function_parameter with
| None => tt
| Some s =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
CamlinternalFormatBasics.End_of_format)) "%s " % string)
s
end) name print_source (parsed, hilights) print_ty ty in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace (parsed_locations parsed) rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.No_such_entrypoint
entrypoint)) rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Contract has no entrypoint named " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Contract has no entrypoint named %s" % string) entrypoint in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_entrypoint
entrypoint)) rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Contract has two entrypoints named " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Contract has two entrypoints named %s" % string) entrypoint in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unreachable_entrypoint
path)) rest =>
let path :=
String.concat "/" % string
(List.map Michelson_v1_primitives.string_of_prim path) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Entrypoint at path " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" is not reachable" % string
CamlinternalFormatBasics.End_of_format)))
"Entrypoint at path %s is not reachable" % string) path in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
_ expr loc)) rest =>
let parsed :=
match parsed with
| Some parsed => parsed
| Some _ | None => Michelson_v1_printer.unparse_expression expr
end in
let hilights := cons loc (collect_error_locations errs) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if show_source then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"ill formed type:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@[<v 2>%aill formed type:@ %a@]" % string) print_loc loc
print_source (parsed, hilights)
else
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Ill formed type." % string
CamlinternalFormatBasics.End_of_format)
"Ill formed type." % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace (parsed_locations parsed) rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
expr type_map)) rest =>
let parsed :=
match parsed with
| Some parsed => parsed
| Some _ | None =>
Michelson_v1_printer.unparse_toplevel (Some type_map) expr
end in
let hilights := collect_error_locations rest in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if show_source then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Ill typed contract:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal " " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@[<v 0>Ill typed contract:@, %a@]" % string) print_source
(parsed, hilights)
else
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Ill typed contract." % string
CamlinternalFormatBasics.End_of_format)
"Ill typed contract." % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace (parsed_locations parsed) rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Not enough gas to deserialize the operation." % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Injecting such a transaction could have you banned from mempools."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 0>Not enough gas to deserialize the operation.@,Injecting such a transaction could have you banned from mempools.@]"
% string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_error)
rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error too big to serialize within the provided gas bounds." %
string CamlinternalFormatBasics.End_of_format)
"Error too big to serialize within the provided gas bounds." %
string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Deprecated_instruction
prim)) rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Use of deprecated instruction: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))
"@[<v 0>Use of deprecated instruction: %s@]" % string)
(Michelson_v1_primitives.string_of_prim prim) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_storage)
rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot serialize the resulting storage value within the provided gas bounds."
% string CamlinternalFormatBasics.End_of_format)
"Cannot serialize the resulting storage value within the provided gas bounds."
% string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Missing_field
prim)) rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Missing contract field: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))
"@[<v 0>Missing contract field: %s@]" % string)
(Michelson_v1_primitives.string_of_prim prim) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_field
loc prim)) rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"duplicate contract field: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 0>%aduplicate contract field: %s@]" % string) print_loc loc
(Michelson_v1_primitives.string_of_prim prim) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_big_map
loc)) rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"big_map type not allowed inside another big_map" % string
CamlinternalFormatBasics.End_of_format))
"%abig_map type not allowed inside another big_map" % string)
print_loc loc in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_operation
loc)) rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"operation type forbidden in parameter, storage and constants" %
string CamlinternalFormatBasics.End_of_format))
"%aoperation type forbidden in parameter, storage and constants" %
string) print_loc loc in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_contract
loc)) rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"contract type forbidden in storage and constants" % string
CamlinternalFormatBasics.End_of_format))
"%acontract type forbidden in storage and constants" % string)
print_loc loc in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Runtime_contract_error
contract expr)) rest =>
let parsed :=
match parsed with
| Some parsed => parsed
| Some _ | None => Michelson_v1_printer.unparse_toplevel None expr
end in
let hilights := collect_error_locations rest in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Runtime error in contract " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 2>Runtime error in contract %a:@ %a@]" % string) Contract.pp
contract print_source (parsed, hilights) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace (parsed_locations parsed) rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Internal_operation_replay
op)) rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Internal operation replay attempt:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>Internal operation replay attempt:@,%a@]" % string)
Operation_result.pp_internal_operation op in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_limit_too_high)
rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Gas limit for the operation is out of the protocol hard bounds."
% string CamlinternalFormatBasics.End_of_format)
"Gas limit for the operation is out of the protocol hard bounds." %
string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
Tezos_protocol_environment_alpha__Environment.Error_monad.Block_quota_exceeded)
rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Gas limit for the block exceeded during typechecking or execution."
% string CamlinternalFormatBasics.End_of_format)
"Gas limit for the block exceeded during typechecking or execution."
% string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
Tezos_protocol_environment_alpha__Environment.Error_monad.Operation_quota_exceeded)
rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Gas limit exceeded during typechecking or execution." % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Try again with a higher gas limit." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 0>Gas limit exceeded during typechecking or execution.@,Try again with a higher gas limit.@]"
% string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
Tezos_protocol_environment_alpha__Environment.Error_monad.Operation_quota_exceeded)
rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Storage limit exceeded during typechecking or execution." %
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Try again with a higher storage limit." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 0>Storage limit exceeded during typechecking or execution.@,Try again with a higher storage limit.@]"
% string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_contract_parameter
c)) [] =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal "Account " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is not a smart contract, it does not take arguments." %
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"The `-arg' flag should not be used when transferring to an account."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 0>Account %a is not a smart contract, it does not take arguments.@,The `-arg' flag should not be used when transferring to an account.@]"
% string) Contract.pp c
| cons (Tezos_base__TzPervasives.Error_monad.Ecoproto_error err) rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match err with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_contract_parameter
c =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid argument passed to contract " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))
"Invalid argument passed to contract %a." % string) Contract.pp c
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc name exp got =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "primitive " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" expects " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" arguments but is given " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format))))))))
"%aprimitive %s expects %d arguments but is given %d." % string)
print_loc loc (Michelson_v1_primitives.string_of_prim name) exp got
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_namespace
loc name exp got =>
let human_namespace
(function_parameter :
Tezos_protocol_alpha.Protocol.Script_tc_errors.namespace)
: string * string :=
match function_parameter with
| Tezos_protocol_alpha.Protocol.Script_tc_errors.Instr_namespace =>
("an" % string, "instruction" % string)
| Tezos_protocol_alpha.Protocol.Script_tc_errors.Type_namespace =>
("a" % string, "type name" % string)
| Tezos_protocol_alpha.Protocol.Script_tc_errors.Constant_namespace
=> ("a" % string, "constant constructor" % string)
| Tezos_protocol_alpha.Protocol.Script_tc_errors.Keyword_namespace
=> ("a" % string, "keyword" % string)
end in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"unexpected " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
", only " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" can be used here." % string
CamlinternalFormatBasics.End_of_format)))))))))))
"@[%aunexpected %s %s, only %s %s can be used here." % string)
print_loc loc (snd (human_namespace got))
(Michelson_v1_primitives.string_of_prim name)
(fst (human_namespace exp)) (snd (human_namespace exp))
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive
loc exp got =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"invalid primitive " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
", only " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" can be used here." % string
CamlinternalFormatBasics.End_of_format)))))))
"@[%ainvalid primitive %s, only %a can be used here." % string)
print_loc loc (Michelson_v1_primitives.string_of_prim got)
print_enumeration
(List.map Michelson_v1_primitives.string_of_prim exp)
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
loc exp got =>
let human_kind
(function_parameter :
Tezos_protocol_alpha.Protocol.Script_tc_errors.kind)
: string * string :=
match function_parameter with
| Tezos_protocol_alpha.Protocol.Script_tc_errors.Seq_kind =>
("a" % string, "sequence" % string)
| Tezos_protocol_alpha.Protocol.Script_tc_errors.Prim_kind =>
("a" % string, "primitive" % string)
| Tezos_protocol_alpha.Protocol.Script_tc_errors.Int_kind =>
("an" % string, "int" % string)
| Tezos_protocol_alpha.Protocol.Script_tc_errors.String_kind =>
("a" % string, "string" % string)
| Tezos_protocol_alpha.Protocol.Script_tc_errors.Bytes_kind =>
("a" % string, "byte sequence" % string)
end in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"unexpected " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal ", only" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"can be used here." % string
CamlinternalFormatBasics.End_of_format)))))))))
"@[%aunexpected %s, only@ %a@ can be used here." % string)
print_loc loc (snd (human_kind got)) print_enumeration
(List.map
(fun k =>
let '(a, n) := human_kind k in
String.append a (String.append " " % string n)) exp)
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_map_keys
_ expr =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Map literals cannot contain duplicate keys, however a duplicate key was found:"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@[<v 2>Map literals cannot contain duplicate keys, however a duplicate key was found:@ @[%a@]"
% string) print_expr expr
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Unordered_map_keys
_ expr =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Keys in a map literal must be in strictly ascending order, but they were unordered in literal:"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@[<v 2>Keys in a map literal must be in strictly ascending order, but they were unordered in literal:@ @[%a@]"
% string) print_expr expr
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_set_values
_ expr =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Set literals cannot contain duplicate values, however a duplicate value was found:"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@[<v 2>Set literals cannot contain duplicate values, however a duplicate value was found:@ @[%a@]"
% string) print_expr expr
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Unordered_set_values
_ expr =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Values in a set literal must be in strictly ascending order, but they were unordered in literal:"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@[<v 2>Values in a set literal must be in strictly ascending order, but they were unordered in literal:@ @[%a@]"
% string) print_expr expr
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Fail_not_in_tail_position
loc =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"The FAIL instruction must appear in a tail position." %
string CamlinternalFormatBasics.End_of_format))
"%aThe FAIL instruction must appear in a tail position." % string)
print_loc loc
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_binop
loc name tya tyb =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<hov 0>" % string
CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 2>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"operator " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" is undefined between" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string
1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 2>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 2>" % string))
(CamlinternalFormatBasics.String_literal
"and" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))))))
"@[<hov 0>@[<hov 2>%aoperator %s is undefined between@ %a@]@ @[<hov 2>and@ %a.@]@]"
% string) print_loc loc
(Michelson_v1_primitives.string_of_prim name) print_ty tya print_ty
tyb
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_unop
loc name ty =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<hov 0>" % string
CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 2>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"operator " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" is undefined on" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))
"@[<hov 0>@[<hov 2>%aoperator %s is undefined on@ %a@]@]" % string)
print_loc loc (Michelson_v1_primitives.string_of_prim name) print_ty
ty
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_return
loc got exp =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"wrong stack type at end of body:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "- " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"expected return stack type:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"," % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"- " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"actual stack type:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))))))))
"@[<v 2>%awrong stack type at end of body:@,- @[<v 0>expected return stack type:@ %a,@]@,- @[<v 0>actual stack type:@ %a.@]@]"
% string) print_loc loc (fun ppf => print_stack_ty None ppf)
(cons (exp, []) []) (fun ppf => print_stack_ty None ppf) got
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc name depth sty =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<hov 2>" % string
CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"wrong stack type for instruction " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[<hov 2>%awrong stack type for instruction %s:@ %a.@]" % string)
print_loc loc (Michelson_v1_primitives.string_of_prim name)
(print_stack_ty (Some depth)) sty
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Unmatched_branches
loc sta stb =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"two branches don't end with the same stack type:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "- " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov>" % string
CamlinternalFormatBasics.End_of_format)
"<hov>" % string))
(CamlinternalFormatBasics.String_literal
"first stack type:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"," % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"- " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov>" % string
CamlinternalFormatBasics.End_of_format)
"<hov>" % string))
(CamlinternalFormatBasics.String_literal
"other stack type:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))))))))
"@[<v 2>%atwo branches don't end with the same stack type:@,- @[<hov>first stack type:@ %a,@]@,- @[<hov>other stack type:@ %a.@]@]"
% string) print_loc loc (fun ppf => print_stack_ty None ppf) sta
(fun ppf => print_stack_ty None ppf) stb
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_annotations
annot1 annot2 =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"The two annotations do not match:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "- " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v>" % string
CamlinternalFormatBasics.End_of_format)
"<v>" % string))
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"- " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v>" % string
CamlinternalFormatBasics.End_of_format)
"<v>" % string))
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))
"@[<v 2>The two annotations do not match:@,- @[<v>%s@]@,- @[<v>%s@]@]"
% string) annot1 annot2
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_field_annotations
annot1 annot2 =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"The field access annotation does not match:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "- " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v>" % string
CamlinternalFormatBasics.End_of_format)
"<v>" % string))
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"- " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v>" % string
CamlinternalFormatBasics.End_of_format)
"<v>" % string))
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))
"@[<v 2>The field access annotation does not match:@,- @[<v>%s@]@,- @[<v>%s@]@]"
% string) annot1 annot2
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_type_annotations
loc ty1 ty2 =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"the two types contain incompatible annotations:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "- " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov>" % string
CamlinternalFormatBasics.End_of_format)
"<hov>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0
0)
(CamlinternalFormatBasics.String_literal
"- " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov>" % string
CamlinternalFormatBasics.End_of_format)
"<hov>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))
"@[<v 2>%athe two types contain incompatible annotations:@,- @[<hov>%a@]@,- @[<hov>%a@]@]"
% string) print_loc loc print_ty ty1 print_ty ty2
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"unexpected annotation." % string
CamlinternalFormatBasics.End_of_format)))
"@[<v 2>%aunexpected annotation." % string) print_loc loc
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Ungrouped_annotations
loc =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"Annotations of the same kind must be grouped." % string
CamlinternalFormatBasics.End_of_format)))
"@[<v 2>%aAnnotations of the same kind must be grouped." % string)
print_loc loc
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Type_too_large
loc size maximum_size =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"type size (" % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
") exceeded maximum type size (" % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal ")." % string
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 2>%atype size (%d) exceeded maximum type size (%d)." %
string) print_loc loc size maximum_size
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Self_in_lambda
loc =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"The SELF instruction cannot appear in a lambda." % string
CamlinternalFormatBasics.End_of_format))
"%aThe SELF instruction cannot appear in a lambda." % string)
print_loc loc
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack_length
=>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Bad stack length." % string
CamlinternalFormatBasics.End_of_format)
"Bad stack length." % string)
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack_item
lvl =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Bad stack item " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format)))
"Bad stack item %d." % string) lvl
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_constant
loc got exp =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<hov 0>" % string
CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 2>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "value" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 2>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 2>" % string))
(CamlinternalFormatBasics.String_literal
"is invalid for type" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))))
"@[<hov 0>@[<hov 2>%avalue@ %a@]@ @[<hov 2>is invalid for type@ %a.@]@]"
% string) print_loc loc print_expr got print_ty exp
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_syntactic_constant
loc got exp =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<hov 0>" % string
CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 2>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 2>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "value" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 2>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 2>" % string))
(CamlinternalFormatBasics.String_literal
"is invalid, expected" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))
"@[<hov 0>@[<hov 2>%avalue@ %a@]@ @[<hov 2>is invalid, expected@ %s@]@]"
% string) print_loc loc print_expr got exp
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
loc contract =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"invalid contract " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "." % char
CamlinternalFormatBasics.End_of_format))))
"%ainvalid contract %a." % string) print_loc loc Contract.pp
contract
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Comparable_type_expected
loc ty =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"comparable type expected." % string
CamlinternalFormatBasics.End_of_format))
"%acomparable type expected." % string) print_loc loc in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<hov 0>" % string
CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 2>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 2>" % string))
(CamlinternalFormatBasics.String_literal "Type" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"is not comparable." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[<hov 0>@[<hov 2>Type@ %a@]@ is not comparable.@]" % string)
print_ty ty
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_types
tya tyb =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<hov 0>" % string
CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 2>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 2>" % string))
(CamlinternalFormatBasics.String_literal "Type" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 2>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 2>" % string))
(CamlinternalFormatBasics.String_literal
"is not compatible with type" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string
1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))
"@[<hov 0>@[<hov 2>Type@ %a@]@ @[<hov 2>is not compatible with type@ %a.@]@]"
% string) print_ty tya print_ty tyb
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Reject loc v
trace =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"script reached FAILWITH instruction" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov 2>" % string
CamlinternalFormatBasics.End_of_format)
"<hov 2>" % string))
(CamlinternalFormatBasics.String_literal "with" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))))))))
"%ascript reached FAILWITH instruction@ @[<hov 2>with@ %a@]%a" %
string) print_loc loc print_expr v
(fun ppf =>
fun function_parameter =>
match function_parameter with
| None => tt
| Some trace =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"trace" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@,@[<v 2>trace@,%a@]" % string) print_execution_trace
trace
end) trace
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Overflow loc
trace =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"unexpected arithmetic overflow" % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))
"%aunexpected arithmetic overflow%a" % string) print_loc loc
(fun ppf =>
fun function_parameter =>
match function_parameter with
| None => tt
| Some trace =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"trace" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@,@[<v 2>trace@,%a@]" % string) print_execution_trace
trace
end) trace
| err =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Environment.Error_monad.pp err
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
| cons err rest =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Error_monad.pp err in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb rest [] then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string)
else
tt in
print_trace locations rest
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
print_trace
(fun function_parameter =>
let '_ := function_parameter in
None) errs in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format) "@]" % string).
src/proto_alpha/lib_client/michelson_v1_macros.ml 36 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol_client_context
open Tezos_micheline
open Micheline
module IntMap = Map.Make (Compare.Int)
type 'l node = ('l, string) Micheline.node
type error += Unexpected_macro_annotation of string
type error += Sequence_expected of string
type error += Invalid_arity of string * int * int
let rec check_letters str i j f =
i > j || (f str.[i] && check_letters str (i + 1) j f)
let expand_caddadr original =
match original with
| Prim (loc, str, args, annot) ->
let len = String.length str in
if
len > 3
&& str.[0] = 'C'
&& str.[len - 1] = 'R'
&& check_letters str 1 (len - 2) (function
| 'A' | 'D' ->
true
| _ ->
false)
then
( match args with
| [] ->
ok ()
| _ :: _ ->
error (Invalid_arity (str, List.length args, 0)) )
>>? fun () ->
let path_annot =
List.filter (function "@%" | "@%%" -> true | _ -> false) annot
in
let rec parse i acc =
if i = 0 then Seq (loc, acc)
else
let annot = if i = len - 2 then annot else path_annot in
match str.[i] with
| 'A' ->
parse (i - 1) (Prim (loc, "CAR", [], annot) :: acc)
| 'D' ->
parse (i - 1) (Prim (loc, "CDR", [], annot) :: acc)
| _ ->
assert false
in
ok (Some (parse (len - 2) []))
else ok None
| _ ->
ok None
let extract_field_annots annot =
List.partition
(fun a ->
match a.[0] with
| '%' ->
true
| _ ->
false
| exception Invalid_argument _ ->
false)
annot
let expand_set_caddadr original =
match original with
| Prim (loc, str, args, annot) ->
let len = String.length str in
if
len >= 7
&& String.sub str 0 5 = "SET_C"
&& str.[len - 1] = 'R'
&& check_letters str 5 (len - 2) (function
| 'A' | 'D' ->
true
| _ ->
false)
then
( match args with
| [] ->
ok ()
| _ :: _ ->
error (Invalid_arity (str, List.length args, 0)) )
>>? fun () ->
( match extract_field_annots annot with
| ([], annot) ->
ok (None, annot)
| ([f], annot) ->
ok (Some f, annot)
| (_, _) ->
error (Unexpected_macro_annotation str) )
>>? fun (field_annot, annot) ->
let rec parse i acc =
if i = 4 then acc
else
let annot = if i = 5 then annot else [] in
match str.[i] with
| 'A' ->
let acc =
Seq
( loc,
[ Prim (loc, "DUP", [], []);
Prim
( loc,
"DIP",
[Seq (loc, [Prim (loc, "CAR", [], ["@%%"]); acc])],
[] );
Prim (loc, "CDR", [], ["@%%"]);
Prim (loc, "SWAP", [], []);
Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
in
parse (i - 1) acc
| 'D' ->
let acc =
Seq
( loc,
[ Prim (loc, "DUP", [], []);
Prim
( loc,
"DIP",
[Seq (loc, [Prim (loc, "CDR", [], ["@%%"]); acc])],
[] );
Prim (loc, "CAR", [], ["@%%"]);
Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
in
parse (i - 1) acc
| _ ->
assert false
in
match str.[len - 2] with
| 'A' ->
let access_check =
match field_annot with
| None ->
[]
| Some f ->
[ Prim (loc, "DUP", [], []);
Prim (loc, "CAR", [], [f]);
Prim (loc, "DROP", [], []) ]
in
let encoding =
[Prim (loc, "CDR", [], ["@%%"]); Prim (loc, "SWAP", [], [])]
in
let pair =
[ Prim
( loc,
"PAIR",
[],
[Option.unopt field_annot ~default:"%"; "%@"] ) ]
in
let init = Seq (loc, access_check @ encoding @ pair) in
ok (Some (parse (len - 3) init))
| 'D' ->
let access_check =
match field_annot with
| None ->
[]
| Some f ->
[ Prim (loc, "DUP", [], []);
Prim (loc, "CDR", [], [f]);
Prim (loc, "DROP", [], []) ]
in
let encoding = [Prim (loc, "CAR", [], ["@%%"])] in
let pair =
[ Prim
( loc,
"PAIR",
[],
["%@"; Option.unopt field_annot ~default:"%"] ) ]
in
let init = Seq (loc, access_check @ encoding @ pair) in
ok (Some (parse (len - 3) init))
| _ ->
assert false
else ok None
| _ ->
ok None
let expand_map_caddadr original =
match original with
| Prim (loc, str, args, annot) ->
let len = String.length str in
if
len >= 7
&& String.sub str 0 5 = "MAP_C"
&& str.[len - 1] = 'R'
&& check_letters str 5 (len - 2) (function
| 'A' | 'D' ->
true
| _ ->
false)
then
( match args with
| [(Seq _ as code)] ->
ok code
| [_] ->
error (Sequence_expected str)
| [] | _ :: _ :: _ ->
error (Invalid_arity (str, List.length args, 1)) )
>>? fun code ->
( match extract_field_annots annot with
| ([], annot) ->
ok (None, annot)
| ([f], annot) ->
ok (Some f, annot)
| (_, _) ->
error (Unexpected_macro_annotation str) )
>>? fun (field_annot, annot) ->
let rec parse i acc =
if i = 4 then acc
else
let annot = if i = 5 then annot else [] in
match str.[i] with
| 'A' ->
let acc =
Seq
( loc,
[ Prim (loc, "DUP", [], []);
Prim
( loc,
"DIP",
[Seq (loc, [Prim (loc, "CAR", [], ["@%%"]); acc])],
[] );
Prim (loc, "CDR", [], ["@%%"]);
Prim (loc, "SWAP", [], []);
Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
in
parse (i - 1) acc
| 'D' ->
let acc =
Seq
( loc,
[ Prim (loc, "DUP", [], []);
Prim
( loc,
"DIP",
[Seq (loc, [Prim (loc, "CDR", [], ["@%%"]); acc])],
[] );
Prim (loc, "CAR", [], ["@%%"]);
Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
in
parse (i - 1) acc
| _ ->
assert false
in
let cr_annot =
match field_annot with
| None ->
[]
| Some f ->
["@" ^ String.sub f 1 (String.length f - 1)]
in
match str.[len - 2] with
| 'A' ->
let init =
Seq
( loc,
[ Prim (loc, "DUP", [], []);
Prim (loc, "CDR", [], ["@%%"]);
Prim
( loc,
"DIP",
[Seq (loc, [Prim (loc, "CAR", [], cr_annot); code])],
[] );
Prim (loc, "SWAP", [], []);
Prim
( loc,
"PAIR",
[],
[Option.unopt field_annot ~default:"%"; "%@"] ) ] )
in
ok (Some (parse (len - 3) init))
| 'D' ->
let init =
Seq
( loc,
[ Prim (loc, "DUP", [], []);
Prim (loc, "CDR", [], cr_annot);
code;
Prim (loc, "SWAP", [], []);
Prim (loc, "CAR", [], ["@%%"]);
Prim
( loc,
"PAIR",
[],
["%@"; Option.unopt field_annot ~default:"%"] ) ] )
in
ok (Some (parse (len - 3) init))
| _ ->
assert false
else ok None
| _ ->
ok None
exception Not_a_roman
let decimal_of_roman roman =
(* http://rosettacode.org/wiki/Roman_numerals/Decode#OCaml *)
let arabic = ref 0 in
let lastval = ref 0 in
for i = String.length roman - 1 downto 0 do
let n =
match roman.[i] with
| 'M' ->
1000
| 'D' ->
500
| 'C' ->
100
| 'L' ->
50
| 'X' ->
10
| 'V' ->
5
| 'I' ->
1
| _ ->
raise_notrace Not_a_roman
in
if Compare.Int.(n < !lastval) then arabic := !arabic - n
else arabic := !arabic + n ;
lastval := n
done ;
!arabic
let dip ~loc ?(annot = []) depth instr =
assert (depth >= 0) ;
if depth = 1 then Prim (loc, "DIP", [instr], annot)
else Prim (loc, "DIP", [Int (loc, Z.of_int depth); instr], annot)
let expand_deprecated_dxiiivp original =
(* transparently expands deprecated macro [DI...IP] to instruction [DIP n] *)
match original with
| Prim (loc, str, args, annot) ->
let len = String.length str in
if len > 3 && str.[0] = 'D' && str.[len - 1] = 'P' then
try
let depth = decimal_of_roman (String.sub str 1 (len - 2)) in
match args with
| [(Seq (_, _) as arg)] ->
ok @@ Some (dip ~loc ~annot depth arg)
| [_] ->
error (Sequence_expected str)
| [] | _ :: _ :: _ ->
error (Invalid_arity (str, List.length args, 1))
with Not_a_roman -> ok None
else ok None
| _ ->
ok None
exception Not_a_pair
type pair_item = A | I | P of int * pair_item * pair_item
let parse_pair_substr str ~len start =
let rec parse ?left i =
if i = len - 1 then raise_notrace Not_a_pair
else if str.[i] = 'P' then
let (next_i, l) = parse ~left:true (i + 1) in
let (next_i, r) = parse ~left:false next_i in
(next_i, P (i, l, r))
else if str.[i] = 'A' && left = Some true then (i + 1, A)
else if str.[i] = 'I' && left <> Some true then (i + 1, I)
else raise_notrace Not_a_pair
in
let (last, ast) = parse start in
if last <> len - 1 then raise_notrace Not_a_pair else ast
let unparse_pair_item ast =
let rec unparse ast acc =
match ast with
| P (_, l, r) ->
unparse r (unparse l ("P" :: acc))
| A ->
"A" :: acc
| I ->
"I" :: acc
in
List.rev ("R" :: unparse ast []) |> String.concat ""
let pappaiir_annots_pos ast annot =
let rec find_annots_pos p_pos ast annots acc =
match (ast, annots) with
| (_, []) ->
(annots, acc)
| (P (i, left, right), _) ->
let (annots, acc) = find_annots_pos i left annots acc in
find_annots_pos i right annots acc
| (A, a :: annots) ->
let pos =
match IntMap.find_opt p_pos acc with
| None ->
([a], [])
| Some (_, cdr) ->
([a], cdr)
in
(annots, IntMap.add p_pos pos acc)
| (I, a :: annots) ->
let pos =
match IntMap.find_opt p_pos acc with
| None ->
([], [a])
| Some (car, _) ->
(car, [a])
in
(annots, IntMap.add p_pos pos acc)
in
snd (find_annots_pos 0 ast annot IntMap.empty)
let expand_pappaiir original =
match original with
| Prim (loc, str, args, annot) ->
let len = String.length str in
if
len > 4
&& str.[0] = 'P'
&& str.[len - 1] = 'R'
&& check_letters str 1 (len - 2) (function
| 'P' | 'A' | 'I' ->
true
| _ ->
false)
then
try
let (field_annots, annot) = extract_field_annots annot in
let ast = parse_pair_substr str ~len 0 in
let field_annots_pos = pappaiir_annots_pos ast field_annots in
let rec parse p (depth, acc) =
match p with
| P (i, left, right) ->
let annot =
match (i, IntMap.find_opt i field_annots_pos) with
| (0, None) ->
annot
| (_, None) ->
[]
| (0, Some ([], cdr_annot)) ->
("%" :: cdr_annot) @ annot
| (_, Some ([], cdr_annot)) ->
"%" :: cdr_annot
| (0, Some (car_annot, cdr_annot)) ->
car_annot @ cdr_annot @ annot
| (_, Some (car_annot, cdr_annot)) ->
car_annot @ cdr_annot
in
let acc =
if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc
else
dip ~loc depth (Seq (loc, [Prim (loc, "PAIR", [], annot)]))
:: acc
in
(depth, acc) |> parse left |> parse right
| A | I ->
(depth + 1, acc)
in
let (_, expanded) = parse ast (0, []) in
( match args with
| [] ->
ok ()
| _ :: _ ->
error (Invalid_arity (str, List.length args, 0)) )
>>? fun () -> ok (Some (Seq (loc, expanded)))
with Not_a_pair -> ok None
else ok None
| _ ->
ok None
let expand_unpappaiir original =
match original with
| Prim (loc, str, args, annot) ->
let len = String.length str in
if
len >= 6
&& String.sub str 0 3 = "UNP"
&& str.[len - 1] = 'R'
&& check_letters str 3 (len - 2) (function
| 'P' | 'A' | 'I' ->
true
| _ ->
false)
then
try
let unpair car_annot cdr_annot =
Seq
( loc,
[ Prim (loc, "DUP", [], []);
Prim (loc, "CAR", [], car_annot);
dip ~loc 1 (Seq (loc, [Prim (loc, "CDR", [], cdr_annot)])) ]
)
in
let ast = parse_pair_substr str ~len 2 in
let annots_pos = pappaiir_annots_pos ast annot in
let rec parse p (depth, acc) =
match p with
| P (i, left, right) ->
let (car_annot, cdr_annot) =
match IntMap.find_opt i annots_pos with
| None ->
([], [])
| Some (car_annot, cdr_annot) ->
(car_annot, cdr_annot)
in
let acc =
if depth = 0 then unpair car_annot cdr_annot :: acc
else
dip ~loc depth (Seq (loc, [unpair car_annot cdr_annot]))
:: acc
in
(depth, acc) |> parse left |> parse right
| A | I ->
(depth + 1, acc)
in
let (_, rev_expanded) = parse ast (0, []) in
let expanded = Seq (loc, List.rev rev_expanded) in
( match args with
| [] ->
ok ()
| _ :: _ ->
error (Invalid_arity (str, List.length args, 0)) )
>>? fun () -> ok (Some expanded)
with Not_a_pair -> ok None
else ok None
| _ ->
ok None
exception Not_a_dup
let dupn loc nloc n annot =
assert (n > 1) ;
if n = 2 then
(* keep the old expansion, shorter for [DUP 2] *)
Seq
( loc,
[ Prim (loc, "DIP", [Seq (loc, [Prim (nloc, "DUP", [], annot)])], []);
Prim (loc, "SWAP", [], []) ] )
else
Seq
( loc,
[ Prim
( loc,
"DIP",
[ Int (loc, Z.of_int (n - 1));
Seq (loc, [Prim (loc, "DUP", [], annot)]) ],
[] );
Prim (loc, "DIG", [Int (nloc, Z.of_int n)], []) ] )
let expand_dupn original =
match original with
| Prim (loc, "DUP", [Int (nloc, n)], annot) ->
ok (Some (dupn loc nloc (Z.to_int n) annot))
| _ ->
ok None
let expand_deprecated_duuuuup original =
(* transparently expands deprecated macro [DU...UP] to [{ DIP n { DUP } ; DIG n }] *)
match original with
| Prim (loc, str, args, annot) ->
let len = String.length str in
if
len > 3
&& str.[0] = 'D'
&& str.[len - 1] = 'P'
&& check_letters str 1 (len - 2) (( = ) 'U')
then
( match args with
| [] ->
ok ()
| _ :: _ ->
error (Invalid_arity (str, List.length args, 0)) )
>>? fun () ->
try
let rec parse i =
if i = 1 then dupn loc loc (len - 2) annot
else if str.[i] = 'U' then parse (i - 1)
else raise_notrace Not_a_dup
in
ok (Some (parse (len - 2)))
with Not_a_dup -> ok None
else ok None
| _ ->
ok None
let expand_compare original =
let cmp loc is annot =
let is =
match List.rev_map (fun i -> Prim (loc, i, [], [])) is with
| Prim (loc, i, args, _) :: r ->
List.rev (Prim (loc, i, args, annot) :: r)
| is ->
List.rev is
in
ok (Some (Seq (loc, is)))
in
let ifcmp loc is l r annot =
let is =
List.map (fun i -> Prim (loc, i, [], [])) is
@ [Prim (loc, "IF", [l; r], annot)]
in
ok (Some (Seq (loc, is)))
in
match original with
| Prim (loc, "CMPEQ", [], annot) ->
cmp loc ["COMPARE"; "EQ"] annot
| Prim (loc, "CMPNEQ", [], annot) ->
cmp loc ["COMPARE"; "NEQ"] annot
| Prim (loc, "CMPLT", [], annot) ->
cmp loc ["COMPARE"; "LT"] annot
| Prim (loc, "CMPGT", [], annot) ->
cmp loc ["COMPARE"; "GT"] annot
| Prim (loc, "CMPLE", [], annot) ->
cmp loc ["COMPARE"; "LE"] annot
| Prim (loc, "CMPGE", [], annot) ->
cmp loc ["COMPARE"; "GE"] annot
| Prim
( _,
(("CMPEQ" | "CMPNEQ" | "CMPLT" | "CMPGT" | "CMPLE" | "CMPGE") as str),
args,
[] ) ->
error (Invalid_arity (str, List.length args, 0))
| Prim (loc, "IFCMPEQ", [l; r], annot) ->
ifcmp loc ["COMPARE"; "EQ"] l r annot
| Prim (loc, "IFCMPNEQ", [l; r], annot) ->
ifcmp loc ["COMPARE"; "NEQ"] l r annot
| Prim (loc, "IFCMPLT", [l; r], annot) ->
ifcmp loc ["COMPARE"; "LT"] l r annot
| Prim (loc, "IFCMPGT", [l; r], annot) ->
ifcmp loc ["COMPARE"; "GT"] l r annot
| Prim (loc, "IFCMPLE", [l; r], annot) ->
ifcmp loc ["COMPARE"; "LE"] l r annot
| Prim (loc, "IFCMPGE", [l; r], annot) ->
ifcmp loc ["COMPARE"; "GE"] l r annot
| Prim (loc, "IFEQ", [l; r], annot) ->
ifcmp loc ["EQ"] l r annot
| Prim (loc, "IFNEQ", [l; r], annot) ->
ifcmp loc ["NEQ"] l r annot
| Prim (loc, "IFLT", [l; r], annot) ->
ifcmp loc ["LT"] l r annot
| Prim (loc, "IFGT", [l; r], annot) ->
ifcmp loc ["GT"] l r annot
| Prim (loc, "IFLE", [l; r], annot) ->
ifcmp loc ["LE"] l r annot
| Prim (loc, "IFGE", [l; r], annot) ->
ifcmp loc ["GE"] l r annot
| Prim
( _,
( ( "IFCMPEQ"
| "IFCMPNEQ"
| "IFCMPLT"
| "IFCMPGT"
| "IFCMPLE"
| "IFCMPGE"
| "IFEQ"
| "IFNEQ"
| "IFLT"
| "IFGT"
| "IFLE"
| "IFGE" ) as str ),
args,
[] ) ->
error (Invalid_arity (str, List.length args, 2))
| Prim
( _,
( ( "IFCMPEQ"
| "IFCMPNEQ"
| "IFCMPLT"
| "IFCMPGT"
| "IFCMPLE"
| "IFCMPGE"
| "IFEQ"
| "IFNEQ"
| "IFLT"
| "IFGT"
| "IFLE"
| "IFGE" ) as str ),
[],
_ :: _ ) ->
error (Unexpected_macro_annotation str)
| _ ->
ok None
let expand_asserts original =
let may_rename loc = function
| [] ->
Seq (loc, [])
| annot ->
Seq (loc, [Prim (loc, "RENAME", [], annot)])
in
let fail_false ?(annot = []) loc =
[may_rename loc annot; Seq (loc, [Prim (loc, "FAIL", [], [])])]
in
let fail_true ?(annot = []) loc =
[Seq (loc, [Prim (loc, "FAIL", [], [])]); may_rename loc annot]
in
match original with
| Prim (loc, "ASSERT", [], []) ->
ok @@ Some (Seq (loc, [Prim (loc, "IF", fail_false loc, [])]))
| Prim (loc, "ASSERT_NONE", [], []) ->
ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", fail_false loc, [])]))
| Prim (loc, "ASSERT_SOME", [], annot) ->
ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", fail_true ~annot loc, [])]))
| Prim (loc, "ASSERT_LEFT", [], annot) ->
ok
@@ Some (Seq (loc, [Prim (loc, "IF_LEFT", fail_false ~annot loc, [])]))
| Prim (loc, "ASSERT_RIGHT", [], annot) ->
ok @@ Some (Seq (loc, [Prim (loc, "IF_LEFT", fail_true ~annot loc, [])]))
| Prim
( _,
( ( "ASSERT"
| "ASSERT_NONE"
| "ASSERT_SOME"
| "ASSERT_LEFT"
| "ASSERT_RIGHT" ) as str ),
args,
[] ) ->
error (Invalid_arity (str, List.length args, 0))
| Prim (_, (("ASSERT" | "ASSERT_NONE") as str), [], _ :: _) ->
error (Unexpected_macro_annotation str)
| Prim (loc, s, args, annot)
when String.(length s > 7 && equal (sub s 0 7) "ASSERT_") -> (
( match args with
| [] ->
ok ()
| _ :: _ ->
error (Invalid_arity (s, List.length args, 0)) )
>>? fun () ->
( match annot with
| _ :: _ ->
error (Unexpected_macro_annotation s)
| [] ->
ok () )
>>? fun () ->
let remaining = String.(sub s 7 (length s - 7)) in
let remaining_prim = Prim (loc, remaining, [], []) in
match remaining with
| "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" ->
ok
@@ Some
(Seq
(loc, [remaining_prim; Prim (loc, "IF", fail_false loc, [])]))
| _ -> (
expand_compare remaining_prim
>|? function
| None ->
None
| Some seq ->
Some (Seq (loc, [seq; Prim (loc, "IF", fail_false loc, [])])) ) )
| _ ->
ok None
let expand_if_some = function
| Prim (loc, "IF_SOME", [right; left], annot) ->
ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", [left; right], annot)]))
| Prim (_, "IF_SOME", args, _annot) ->
error (Invalid_arity ("IF_SOME", List.length args, 2))
| _ ->
ok @@ None
let expand_if_right = function
| Prim (loc, "IF_RIGHT", [right; left], annot) ->
ok @@ Some (Seq (loc, [Prim (loc, "IF_LEFT", [left; right], annot)]))
| Prim (_, "IF_RIGHT", args, _annot) ->
error (Invalid_arity ("IF_RIGHT", List.length args, 2))
| _ ->
ok @@ None
let expand_fail = function
| Prim (loc, "FAIL", [], []) ->
ok
@@ Some
(Seq
( loc,
[Prim (loc, "UNIT", [], []); Prim (loc, "FAILWITH", [], [])] ))
| _ ->
ok @@ None
let expand original =
let rec try_expansions = function
| [] ->
ok @@ original
| expander :: expanders -> (
expander original
>>? function
| None -> try_expansions expanders | Some rewritten -> ok rewritten )
in
try_expansions
[ expand_caddadr;
expand_set_caddadr;
expand_map_caddadr;
expand_deprecated_dxiiivp;
(* expand_paaiair ; *)
expand_pappaiir;
(* expand_unpaaiair ; *)
expand_unpappaiir;
expand_deprecated_duuuuup;
expand_dupn;
expand_compare;
expand_asserts;
expand_if_some;
expand_if_right;
expand_fail ]
let expand_rec expr =
let rec error_map (expanded, errors) f = function
| [] ->
(List.rev expanded, List.rev errors)
| hd :: tl ->
let (new_expanded, new_errors) = f hd in
error_map
(new_expanded :: expanded, List.rev_append new_errors errors)
f
tl
in
let error_map = error_map ([], []) in
let rec expand_rec expr =
match expand expr with
| Ok expanded -> (
match expanded with
| Seq (loc, items) ->
let (items, errors) = error_map expand_rec items in
(Seq (loc, items), errors)
| Prim (loc, name, args, annot) ->
let (args, errors) = error_map expand_rec args in
(Prim (loc, name, args, annot), errors)
| (Int _ | String _ | Bytes _) as atom ->
(atom, []) )
| Error errors ->
(expr, errors)
in
expand_rec expr
let unexpand_caddadr expanded =
let rec rsteps acc = function
| [] ->
Some acc
| Prim (_, "CAR", [], []) :: rest ->
rsteps ("A" :: acc) rest
| Prim (_, "CDR", [], []) :: rest ->
rsteps ("D" :: acc) rest
| _ ->
None
in
match expanded with
| Seq (loc, (Prim (_, "CAR", [], []) :: _ as nodes))
| Seq (loc, (Prim (_, "CDR", [], []) :: _ as nodes)) -> (
match rsteps [] nodes with
| Some steps ->
let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in
Some (Prim (loc, name, [], []))
| None ->
None )
| _ ->
None
let unexpand_set_caddadr expanded =
let rec steps acc annots = function
| Seq
( loc,
[ Prim (_, "CDR", [], _);
Prim (_, "SWAP", [], _);
Prim (_, "PAIR", [], _) ] ) ->
Some (loc, "A" :: acc, annots)
| Seq
( loc,
[ Prim (_, "DUP", [], []);
Prim (_, "CAR", [], [field_annot]);
Prim (_, "DROP", [], []);
Prim (_, "CDR", [], _);
Prim (_, "SWAP", [], []);
Prim (_, "PAIR", [], _) ] ) ->
Some (loc, "A" :: acc, field_annot :: annots)
| Seq (loc, [Prim (_, "CAR", [], _); Prim (_, "PAIR", [], _)]) ->
Some (loc, "D" :: acc, annots)
| Seq
( loc,
[ Prim (_, "DUP", [], []);
Prim (_, "CDR", [], [field_annot]);
Prim (_, "DROP", [], []);
Prim (_, "CAR", [], _);
Prim (_, "PAIR", [], _) ] ) ->
Some (loc, "D" :: acc, field_annot :: annots)
| Seq
( _,
[ Prim (_, "DUP", [], []);
Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], _); sub])], []);
Prim (_, "CDR", [], _);
Prim (_, "SWAP", [], []);
Prim (_, "PAIR", [], pair_annots) ] ) ->
let (_, pair_annots) = extract_field_annots pair_annots in
steps ("A" :: acc) (List.rev_append pair_annots annots) sub
| Seq
( _,
[ Prim (_, "DUP", [], []);
Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], _); sub])], []);
Prim (_, "CAR", [], _);
Prim (_, "PAIR", [], pair_annots) ] ) ->
let (_, pair_annots) = extract_field_annots pair_annots in
steps ("D" :: acc) (List.rev_append pair_annots annots) sub
| _ ->
None
in
match steps [] [] expanded with
| Some (loc, steps, annots) ->
let name = String.concat "" ("SET_C" :: List.rev ("R" :: steps)) in
Some (Prim (loc, name, [], List.rev annots))
| None ->
None
let unexpand_map_caddadr expanded =
let rec steps acc annots = function
| Seq
( loc,
[ Prim (_, "DUP", [], []);
Prim (_, "CDR", [], _);
Prim (_, "SWAP", [], []);
Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], []); code])], []);
Prim (_, "PAIR", [], _) ] ) ->
Some (loc, "A" :: acc, annots, code)
| Seq
( loc,
[ Prim (_, "DUP", [], []);
Prim (_, "CDR", [], _);
Prim (_, "SWAP", [], []);
Prim
( _,
"DIP",
[Seq (_, [Prim (_, "CAR", [], [field_annot]); code])],
[] );
Prim (_, "PAIR", [], _) ] ) ->
Some (loc, "A" :: acc, field_annot :: annots, code)
| Seq
( loc,
[ Prim (_, "DUP", [], []);
Prim (_, "CDR", [], []);
code;
Prim (_, "SWAP", [], []);
Prim (_, "CAR", [], _);
Prim (_, "PAIR", [], _) ] ) ->
Some (loc, "D" :: acc, annots, code)
| Seq
( loc,
[ Prim (_, "DUP", [], []);
Prim (_, "CDR", [], [field_annot]);
code;
Prim (_, "SWAP", [], []);
Prim (_, "CAR", [], _);
Prim (_, "PAIR", [], _) ] ) ->
Some (loc, "D" :: acc, field_annot :: annots, code)
| Seq
( _,
[ Prim (_, "DUP", [], []);
Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], _); sub])], []);
Prim (_, "CDR", [], _);
Prim (_, "SWAP", [], []);
Prim (_, "PAIR", [], pair_annots) ] ) ->
let (_, pair_annots) = extract_field_annots pair_annots in
steps ("A" :: acc) (List.rev_append pair_annots annots) sub
| Seq
( _,
[ Prim (_, "DUP", [], []);
Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], []); sub])], []);
Prim (_, "CAR", [], []);
Prim (_, "PAIR", [], pair_annots) ] ) ->
let (_, pair_annots) = extract_field_annots pair_annots in
steps ("D" :: acc) (List.rev_append pair_annots annots) sub
| _ ->
None
in
match steps [] [] expanded with
| Some (loc, steps, annots, code) ->
let name = String.concat "" ("MAP_C" :: List.rev ("R" :: steps)) in
Some (Prim (loc, name, [code], List.rev annots))
| None ->
None
let unexpand_deprecated_dxiiivp expanded =
(* transparently turn the old expansion of deprecated [DI...IP] to [DIP n] *)
match expanded with
| Seq
( loc,
[Prim (_, "DIP", [(Seq (_, [Prim (_, "DIP", [_], [])]) as sub)], [])]
) ->
let rec count acc = function
| Seq (_, [Prim (_, "DIP", [sub], [])]) ->
count (acc + 1) sub
| sub ->
(acc, sub)
in
let (depth, sub) = count 1 sub in
Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], []))
| _ ->
None
let unexpand_dupn expanded =
match expanded with
| Seq
( loc,
[ Prim
(_, "DIP", [Int (_, np); Seq (_, [Prim (_, "DUP", [], annot)])], []);
Prim (_, "DIG", [Int (nloc, ng)], []) ] )
when Z.equal np (Z.pred ng) ->
Some (Prim (loc, "DUP", [Int (nloc, ng)], annot))
| _ ->
None
let unexpand_deprecated_duuuuup expanded =
(* transparently turn the old expansion of deprecated [DU...UP] to [DUP n] *)
let rec expand n = function
| Seq (loc, [Prim (nloc, "DUP", [], annot)]) ->
if n = 1 then None
else Some (Prim (loc, "DUP", [Int (nloc, Z.of_int n)], annot))
| Seq (_, [Prim (_, "DIP", [expanded'], []); Prim (_, "SWAP", [], [])]) ->
expand (n + 1) expanded'
| _ ->
None
in
expand 1 expanded
let rec normalize_pair_item ?(right = false) = function
| P (i, a, b) ->
P (i, normalize_pair_item a, normalize_pair_item ~right:true b)
| A when right ->
I
| A ->
A
| I ->
I
let unexpand_pappaiir expanded =
match expanded with
| Seq (_, [Prim (_, "PAIR", [], [])]) ->
Some expanded
| Seq (loc, (_ :: _ as nodes)) -> (
let rec exec stack nodes =
match (nodes, stack) with
| ([], _) ->
stack
(* support new expansion using [DIP n] *)
| ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest,
a :: rstack )
when Z.to_int n > 1 ->
exec
( a
:: exec
rstack
[ Prim
(ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
] )
rest
| (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack)
when Z.to_int n = 1 ->
exec (a :: exec rstack sub) rest
| (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [])
when Z.to_int n > 1 ->
exec
( A
:: exec
[]
[ Prim
(ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
] )
rest
| (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [])
when Z.to_int n = 1 ->
exec (A :: exec [] sub) rest
(* support old expansion using [DIP] *)
| (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) ->
exec (a :: exec rstack sub) rest
| (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) ->
exec (A :: exec [] sub) rest
| (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) ->
exec (P (0, a, b) :: rstack) rest
| (Prim (_, "PAIR", [], []) :: rest, [a]) ->
exec [P (0, a, I)] rest
| (Prim (_, "PAIR", [], []) :: rest, []) ->
exec [P (0, A, I)] rest
| _ ->
raise_notrace Not_a_pair
in
match exec [] nodes with
| [] ->
None
| res :: _ ->
let res = normalize_pair_item res in
let name = unparse_pair_item res in
Some (Prim (loc, name, [], []))
| exception Not_a_pair ->
None )
| _ ->
None
let unexpand_unpappaiir expanded =
match expanded with
| Seq (loc, (_ :: _ as nodes)) -> (
let rec exec stack nodes =
match (nodes, stack) with
| ([], _) ->
stack
(* support new expansion using [DIP n] *)
| ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest,
a :: rstack )
when Z.to_int n > 1 ->
exec
( a
:: exec
rstack
[ Prim
(ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
] )
rest
| (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack)
when Z.to_int n = 1 ->
exec (a :: exec rstack sub) rest
| (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [])
when Z.to_int n > 1 ->
exec
( A
:: exec
[]
[ Prim
(ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
] )
rest
| (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [])
when Z.to_int n = 1 ->
exec (A :: exec [] sub) rest
(* support old expansion using [DIP] *)
| (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) ->
exec (a :: exec rstack sub) rest
| (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) ->
exec (A :: exec [] sub) rest
| ( Seq
( _,
[ Prim (_, "DUP", [], []);
Prim (_, "CAR", [], []);
Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ]
)
:: rest,
a :: b :: rstack ) ->
exec (P (0, a, b) :: rstack) rest
| ( Seq
( _,
[ Prim (_, "DUP", [], []);
Prim (_, "CAR", [], []);
Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ]
)
:: rest,
[a] ) ->
exec [P (0, a, I)] rest
| ( Seq
( _,
[ Prim (_, "DUP", [], []);
Prim (_, "CAR", [], []);
Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ]
)
:: rest,
[] ) ->
exec [P (0, A, I)] rest
| _ ->
raise_notrace Not_a_pair
in
match exec [] (List.rev nodes) with
| [] ->
None
| res :: _ ->
let res = normalize_pair_item res in
let name = "UN" ^ unparse_pair_item res in
Some (Prim (loc, name, [], []))
| exception Not_a_pair ->
None )
| _ ->
None
let unexpand_compare expanded =
match expanded with
| Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "EQ", [], annot)]) ->
Some (Prim (loc, "CMPEQ", [], annot))
| Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "NEQ", [], annot)]) ->
Some (Prim (loc, "CMPNEQ", [], annot))
| Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "LT", [], annot)]) ->
Some (Prim (loc, "CMPLT", [], annot))
| Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "GT", [], annot)]) ->
Some (Prim (loc, "CMPGT", [], annot))
| Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "LE", [], annot)]) ->
Some (Prim (loc, "CMPLE", [], annot))
| Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "GE", [], annot)]) ->
Some (Prim (loc, "CMPGE", [], annot))
| Seq
( loc,
[ Prim (_, "COMPARE", [], _);
Prim (_, "EQ", [], _);
Prim (_, "IF", args, annot) ] ) ->
Some (Prim (loc, "IFCMPEQ", args, annot))
| Seq
( loc,
[ Prim (_, "COMPARE", [], _);
Prim (_, "NEQ", [], _);
Prim (_, "IF", args, annot) ] ) ->
Some (Prim (loc, "IFCMPNEQ", args, annot))
| Seq
( loc,
[ Prim (_, "COMPARE", [], _);
Prim (_, "LT", [], _);
Prim (_, "IF", args, annot) ] ) ->
Some (Prim (loc, "IFCMPLT", args, annot))
| Seq
( loc,
[ Prim (_, "COMPARE", [], _);
Prim (_, "GT", [], _);
Prim (_, "IF", args, annot) ] ) ->
Some (Prim (loc, "IFCMPGT", args, annot))
| Seq
( loc,
[ Prim (_, "COMPARE", [], _);
Prim (_, "LE", [], _);
Prim (_, "IF", args, annot) ] ) ->
Some (Prim (loc, "IFCMPLE", args, annot))
| Seq
( loc,
[ Prim (_, "COMPARE", [], _);
Prim (_, "GE", [], _);
Prim (_, "IF", args, annot) ] ) ->
Some (Prim (loc, "IFCMPGE", args, annot))
| Seq (loc, [Prim (_, "EQ", [], _); Prim (_, "IF", args, annot)]) ->
Some (Prim (loc, "IFEQ", args, annot))
| Seq (loc, [Prim (_, "NEQ", [], _); Prim (_, "IF", args, annot)]) ->
Some (Prim (loc, "IFNEQ", args, annot))
| Seq (loc, [Prim (_, "LT", [], _); Prim (_, "IF", args, annot)]) ->
Some (Prim (loc, "IFLT", args, annot))
| Seq (loc, [Prim (_, "GT", [], _); Prim (_, "IF", args, annot)]) ->
Some (Prim (loc, "IFGT", args, annot))
| Seq (loc, [Prim (_, "LE", [], _); Prim (_, "IF", args, annot)]) ->
Some (Prim (loc, "IFLE", args, annot))
| Seq (loc, [Prim (_, "GE", [], _); Prim (_, "IF", args, annot)]) ->
Some (Prim (loc, "IFGE", args, annot))
| _ ->
None
let unexpand_asserts expanded =
match expanded with
| Seq
( loc,
[ Prim
( _,
"IF",
[ Seq (_, []);
Seq
( _,
[ Seq
( _,
[ Prim (_, "UNIT", [], []);
Prim (_, "FAILWITH", [], []) ] ) ] ) ],
[] ) ] ) ->
Some (Prim (loc, "ASSERT", [], []))
| Seq
( loc,
[ Seq (_, [Prim (_, "COMPARE", [], []); Prim (_, comparison, [], [])]);
Prim
( _,
"IF",
[ Seq (_, []);
Seq
( _,
[ Seq
( _,
[ Prim (_, "UNIT", [], []);
Prim (_, "FAILWITH", [], []) ] ) ] ) ],
[] ) ] ) ->
Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], []))
| Seq
( loc,
[ Prim (_, comparison, [], []);
Prim
( _,
"IF",
[ Seq (_, []);
Seq
( _,
[ Seq
( _,
[ Prim (_, "UNIT", [], []);
Prim (_, "FAILWITH", [], []) ] ) ] ) ],
[] ) ] ) ->
Some (Prim (loc, "ASSERT_" ^ comparison, [], []))
| Seq
( loc,
[ Prim
( _,
"IF_NONE",
[ Seq (_, [Prim (_, "RENAME", [], annot)]);
Seq
( _,
[ Seq
( _,
[ Prim (_, "UNIT", [], []);
Prim (_, "FAILWITH", [], []) ] ) ] ) ],
[] ) ] ) ->
Some (Prim (loc, "ASSERT_NONE", [], annot))
| Seq
( loc,
[ Prim
( _,
"IF_NONE",
[ Seq (_, []);
Seq
( _,
[ Seq
( _,
[ Prim (_, "UNIT", [], []);
Prim (_, "FAILWITH", [], []) ] ) ] ) ],
[] ) ] ) ->
Some (Prim (loc, "ASSERT_NONE", [], []))
| Seq
( loc,
[ Prim
( _,
"IF_NONE",
[ Seq
( _,
[ Seq
( _,
[ Prim (_, "UNIT", [], []);
Prim (_, "FAILWITH", [], []) ] ) ] );
Seq (_, []) ],
[] ) ] ) ->
Some (Prim (loc, "ASSERT_SOME", [], []))
| Seq
( loc,
[ Prim
( _,
"IF_NONE",
[ Seq
( _,
[ Seq
( _,
[ Prim (_, "UNIT", [], []);
Prim (_, "FAILWITH", [], []) ] ) ] );
Seq (_, [Prim (_, "RENAME", [], annot)]) ],
[] ) ] ) ->
Some (Prim (loc, "ASSERT_SOME", [], annot))
| Seq
( loc,
[ Prim
( _,
"IF_LEFT",
[ Seq (_, []);
Seq
( _,
[ Seq
( _,
[ Prim (_, "UNIT", [], []);
Prim (_, "FAILWITH", [], []) ] ) ] ) ],
[] ) ] ) ->
Some (Prim (loc, "ASSERT_LEFT", [], []))
| Seq
( loc,
[ Prim
( _,
"IF_LEFT",
[ Seq (_, [Prim (_, "RENAME", [], annot)]);
Seq
( _,
[ Seq
( _,
[ Prim (_, "UNIT", [], []);
Prim (_, "FAILWITH", [], []) ] ) ] ) ],
[] ) ] ) ->
Some (Prim (loc, "ASSERT_LEFT", [], annot))
| Seq
( loc,
[ Prim
( _,
"IF_LEFT",
[ Seq
( _,
[ Seq
( _,
[ Prim (_, "UNIT", [], []);
Prim (_, "FAILWITH", [], []) ] ) ] );
Seq (_, []) ],
[] ) ] ) ->
Some (Prim (loc, "ASSERT_RIGHT", [], []))
| Seq
( loc,
[ Prim
( _,
"IF_LEFT",
[ Seq
( _,
[ Seq
( _,
[ Prim (_, "UNIT", [], []);
Prim (_, "FAILWITH", [], []) ] ) ] );
Seq (_, [Prim (_, "RENAME", [], annot)]) ],
[] ) ] ) ->
Some (Prim (loc, "ASSERT_RIGHT", [], annot))
| _ ->
None
let unexpand_if_some = function
| Seq (loc, [Prim (_, "IF_NONE", [left; right], annot)]) ->
Some (Prim (loc, "IF_SOME", [right; left], annot))
| _ ->
None
let unexpand_if_right = function
| Seq (loc, [Prim (_, "IF_LEFT", [left; right], annot)]) ->
Some (Prim (loc, "IF_RIGHT", [right; left], annot))
| _ ->
None
let unexpand_fail = function
| Seq (loc, [Prim (_, "UNIT", [], []); Prim (_, "FAILWITH", [], [])]) ->
Some (Prim (loc, "FAIL", [], []))
| _ ->
None
let unexpand original =
let try_unexpansions unexpanders =
match
List.fold_left
(fun acc f ->
match acc with
| None ->
f original
| Some rewritten ->
Some rewritten)
None
unexpanders
with
| None ->
original
| Some rewritten ->
rewritten
in
try_unexpansions
[ unexpand_asserts;
unexpand_caddadr;
unexpand_set_caddadr;
unexpand_map_caddadr;
unexpand_deprecated_dxiiivp;
unexpand_pappaiir;
unexpand_unpappaiir;
unexpand_deprecated_duuuuup;
unexpand_dupn;
unexpand_compare;
unexpand_if_some;
unexpand_if_right;
unexpand_fail ]
(*
If an argument of Prim is a sequence, we do not want to unexpand
its root in case the source already contains an expanded macro. In
which case unexpansion would remove surrounding braces and generate
ill-formed code.
For example, DIIP { DIP { DUP }; SWAP } is not unexpandable but
DIIP {{ DIP { DUP }; SWAP }} (note the double braces) is unexpanded
to DIIP { DUUP }.
unexpand_rec_but_root is the same as unexpand_rec but does not try
to unexpand at root *)
let rec unexpand_rec expr = unexpand_rec_but_root (unexpand expr)
and unexpand_rec_but_root = function
| Seq (loc, items) ->
Seq (loc, List.map unexpand_rec items)
| Prim (loc, name, args, annot) ->
Prim (loc, name, List.map unexpand_rec_but_root args, annot)
| (Int _ | String _ | Bytes _) as atom ->
atom
let () =
let open Data_encoding in
register_error_kind
`Permanent
~id:"michelson.macros.unexpected_annotation"
~title:"Unexpected annotation"
~description:
"A macro had an annotation, but no annotation was permitted on this \
macro."
~pp:(fun ppf -> Format.fprintf ppf "Unexpected annotation on macro %s.")
(obj1 (req "macro_name" string))
(function Unexpected_macro_annotation str -> Some str | _ -> None)
(fun s -> Unexpected_macro_annotation s) ;
register_error_kind
`Permanent
~id:"michelson.macros.sequence_expected"
~title:"Macro expects a sequence"
~description:"An macro expects a sequence, but a sequence was not provided"
~pp:(fun ppf name ->
Format.fprintf
ppf
"Macro %s expects a sequence, but did not receive one."
name)
(obj1 (req "macro_name" string))
(function Sequence_expected name -> Some name | _ -> None)
(fun name -> Sequence_expected name) ;
register_error_kind
`Permanent
~id:"michelson.macros.bas_arity"
~title:"Wrong number of arguments to macro"
~description:"A wrong number of arguments was provided to a macro"
~pp:(fun ppf (name, got, exp) ->
Format.fprintf
ppf
"Macro %s expects %d arguments, was given %d."
name
exp
got)
(obj3
(req "macro_name" string)
(req "given_number_of_arguments" uint16)
(req "expected_number_of_arguments" uint16))
(function
| Invalid_arity (name, got, exp) -> Some (name, got, exp) | _ -> None)
(fun (name, got, exp) -> Invalid_arity (name, got, exp))
src/proto_alpha/lib_client/michelson_v1_macros.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol_client_context.
Import Tezos_micheline.
Import Micheline.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition node (l : Type) := Tezos_micheline.Micheline.node l string.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Fixpoint check_letters (str : string) (i : Z) (j : Z) (f : ascii -> bool)
: bool :=
orb (OCaml.Stdlib.gt i j)
(andb (f (String.get str i)) (check_letters str (Z.add i 1) j f)).
Definition expand_caddadr {A : Type}
(original : Tezos_micheline.Micheline.node A string)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node A string)) :=
match original with
| Tezos_micheline.Micheline.Prim loc str args annot =>
let len := String.length str in
if
andb (OCaml.Stdlib.gt len 3)
(andb (equiv_decb (String.get str 0) "C" % char)
(andb (equiv_decb (String.get str (Z.sub len 1)) "R" % char)
(check_letters str 1 (Z.sub len 2)
(fun function_parameter =>
match function_parameter with
| "A" % char | "D" % char => true
| _ => false
end)))) then
op_gtgtquestion
match args with
| [] => ok tt
| cons _ _ =>
error
(Tezos_base__TzPervasives.Invalid_arity str (List.length args) 0)
end
(fun function_parameter =>
let 'tt := function_parameter in
let path_annot :=
List.filter
(fun function_parameter =>
match function_parameter with
| "@%" % string | "@%%" % string => true
| _ => false
end) annot in
let fix parse
(i : Z) (acc : list (Tezos_micheline.Micheline.node A string))
: Tezos_micheline.Micheline.node A string :=
if equiv_decb i 0 then
Tezos_micheline.Micheline.Seq loc acc
else
let annot :=
if equiv_decb i (Z.sub len 2) then
annot
else
path_annot in
match String.get str i with
| "A" % char =>
parse (Z.sub i 1)
(cons
(Tezos_micheline.Micheline.Prim loc "CAR" % string [] annot)
acc)
| "D" % char =>
parse (Z.sub i 1)
(cons
(Tezos_micheline.Micheline.Prim loc "CDR" % string [] annot)
acc)
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
ok (Some (parse (Z.sub len 2) [])))
else
ok None
| _ => ok None
end.
Definition extract_field_annots (annot : list string)
: (list string) * (list string) :=
List.partition
(fun a =>
match String.get a 0 with
| "%" % char => true
| _ => false
end) annot.
Definition expand_set_caddadr {A : Type}
(original : Tezos_micheline.Micheline.node A string)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node A string)) :=
match original with
| Tezos_micheline.Micheline.Prim loc str args annot =>
let len := String.length str in
if
andb (OCaml.Stdlib.ge len 7)
(andb (equiv_decb (String.sub str 0 5) "SET_C" % string)
(andb (equiv_decb (String.get str (Z.sub len 1)) "R" % char)
(check_letters str 5 (Z.sub len 2)
(fun function_parameter =>
match function_parameter with
| "A" % char | "D" % char => true
| _ => false
end)))) then
op_gtgtquestion
match args with
| [] => ok tt
| cons _ _ =>
error
(Tezos_base__TzPervasives.Invalid_arity str (List.length args) 0)
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
match extract_field_annots annot with
| ([], annot) => ok (None, annot)
| (cons f [], annot) => ok ((Some f), annot)
| (_, _) =>
error (Tezos_base__TzPervasives.Unexpected_macro_annotation str)
end
(fun function_parameter =>
let '(field_annot, annot) := function_parameter in
let fix parse
(i : Z) (acc : Tezos_micheline.Micheline.node A string)
: Tezos_micheline.Micheline.node A string :=
if equiv_decb i 4 then
acc
else
let annot :=
if equiv_decb i 5 then
annot
else
[] in
match String.get str i with
| "A" % char =>
let acc :=
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "DUP" % string []
[])
(cons
(Tezos_micheline.Micheline.Prim loc "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc
"CAR" % string [] (cons "@%%" % string []))
(cons acc []))) []) [])
(cons
(Tezos_micheline.Micheline.Prim loc "CDR" % string
[] (cons "@%%" % string []))
(cons
(Tezos_micheline.Micheline.Prim loc
"SWAP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim loc
"PAIR" % string []
(cons "%@" % string
(cons "%@" % string annot))) []))))) in
parse (Z.sub i 1) acc
| "D" % char =>
let acc :=
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "DUP" % string []
[])
(cons
(Tezos_micheline.Micheline.Prim loc "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc
"CDR" % string [] (cons "@%%" % string []))
(cons acc []))) []) [])
(cons
(Tezos_micheline.Micheline.Prim loc "CAR" % string
[] (cons "@%%" % string []))
(cons
(Tezos_micheline.Micheline.Prim loc
"PAIR" % string []
(cons "%@" % string (cons "%@" % string annot)))
[])))) in
parse (Z.sub i 1) acc
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
match String.get str (Z.sub len 2) with
| "A" % char =>
let access_check :=
match field_annot with
| None => []
| Some f =>
cons
(Tezos_micheline.Micheline.Prim loc "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim loc "CAR" % string []
(cons f []))
(cons
(Tezos_micheline.Micheline.Prim loc "DROP" % string []
[]) []))
end in
let encoding :=
cons
(Tezos_micheline.Micheline.Prim loc "CDR" % string []
(cons "@%%" % string []))
(cons
(Tezos_micheline.Micheline.Prim loc "SWAP" % string [] [])
[]) in
let pair :=
cons
(Tezos_micheline.Micheline.Prim loc "PAIR" % string []
(cons (Option.unopt "%" % string field_annot)
(cons "%@" % string []))) [] in
let init :=
Tezos_micheline.Micheline.Seq loc
(OCaml.Stdlib.app access_check
(OCaml.Stdlib.app encoding pair)) in
ok (Some (parse (Z.sub len 3) init))
| "D" % char =>
let access_check :=
match field_annot with
| None => []
| Some f =>
cons
(Tezos_micheline.Micheline.Prim loc "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim loc "CDR" % string []
(cons f []))
(cons
(Tezos_micheline.Micheline.Prim loc "DROP" % string []
[]) []))
end in
let encoding :=
cons
(Tezos_micheline.Micheline.Prim loc "CAR" % string []
(cons "@%%" % string [])) [] in
let pair :=
cons
(Tezos_micheline.Micheline.Prim loc "PAIR" % string []
(cons "%@" % string
(cons (Option.unopt "%" % string field_annot) []))) []
in
let init :=
Tezos_micheline.Micheline.Seq loc
(OCaml.Stdlib.app access_check
(OCaml.Stdlib.app encoding pair)) in
ok (Some (parse (Z.sub len 3) init))
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end))
else
ok None
| _ => ok None
end.
Definition expand_map_caddadr {A : Type}
(original : Tezos_micheline.Micheline.node A string)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node A string)) :=
match original with
| Tezos_micheline.Micheline.Prim loc str args annot =>
let len := String.length str in
if
andb (OCaml.Stdlib.ge len 7)
(andb (equiv_decb (String.sub str 0 5) "MAP_C" % string)
(andb (equiv_decb (String.get str (Z.sub len 1)) "R" % char)
(check_letters str 5 (Z.sub len 2)
(fun function_parameter =>
match function_parameter with
| "A" % char | "D" % char => true
| _ => false
end)))) then
op_gtgtquestion
match args with
| cons ((Tezos_micheline.Micheline.Seq _ _) as code) [] => ok code
| cons _ [] => error (Tezos_base__TzPervasives.Sequence_expected str)
| [] | cons _ (cons _ _) =>
error
(Tezos_base__TzPervasives.Invalid_arity str (List.length args) 1)
end
(fun code =>
op_gtgtquestion
match extract_field_annots annot with
| ([], annot) => ok (None, annot)
| (cons f [], annot) => ok ((Some f), annot)
| (_, _) =>
error (Tezos_base__TzPervasives.Unexpected_macro_annotation str)
end
(fun function_parameter =>
let '(field_annot, annot) := function_parameter in
let fix parse
(i : Z) (acc : Tezos_micheline.Micheline.node A string)
: Tezos_micheline.Micheline.node A string :=
if equiv_decb i 4 then
acc
else
let annot :=
if equiv_decb i 5 then
annot
else
[] in
match String.get str i with
| "A" % char =>
let acc :=
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "DUP" % string []
[])
(cons
(Tezos_micheline.Micheline.Prim loc "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc
"CAR" % string [] (cons "@%%" % string []))
(cons acc []))) []) [])
(cons
(Tezos_micheline.Micheline.Prim loc "CDR" % string
[] (cons "@%%" % string []))
(cons
(Tezos_micheline.Micheline.Prim loc
"SWAP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim loc
"PAIR" % string []
(cons "%@" % string
(cons "%@" % string annot))) []))))) in
parse (Z.sub i 1) acc
| "D" % char =>
let acc :=
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "DUP" % string []
[])
(cons
(Tezos_micheline.Micheline.Prim loc "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc
"CDR" % string [] (cons "@%%" % string []))
(cons acc []))) []) [])
(cons
(Tezos_micheline.Micheline.Prim loc "CAR" % string
[] (cons "@%%" % string []))
(cons
(Tezos_micheline.Micheline.Prim loc
"PAIR" % string []
(cons "%@" % string (cons "%@" % string annot)))
[])))) in
parse (Z.sub i 1) acc
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
let cr_annot :=
match field_annot with
| None => []
| Some f =>
cons
(String.append "@" % string
(String.sub f 1 (Z.sub (String.length f) 1))) []
end in
match String.get str (Z.sub len 2) with
| "A" % char =>
let init :=
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim loc "CDR" % string []
(cons "@%%" % string []))
(cons
(Tezos_micheline.Micheline.Prim loc "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc
"CAR" % string [] cr_annot) (cons code [])))
[]) [])
(cons
(Tezos_micheline.Micheline.Prim loc "SWAP" % string
[] [])
(cons
(Tezos_micheline.Micheline.Prim loc
"PAIR" % string []
(cons (Option.unopt "%" % string field_annot)
(cons "%@" % string []))) []))))) in
ok (Some (parse (Z.sub len 3) init))
| "D" % char =>
let init :=
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim loc "CDR" % string []
cr_annot)
(cons code
(cons
(Tezos_micheline.Micheline.Prim loc "SWAP" % string
[] [])
(cons
(Tezos_micheline.Micheline.Prim loc "CAR" % string
[] (cons "@%%" % string []))
(cons
(Tezos_micheline.Micheline.Prim loc
"PAIR" % string []
(cons "%@" % string
(cons
(Option.unopt "%" % string field_annot) [])))
[])))))) in
ok (Some (parse (Z.sub len 3) init))
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end))
else
ok None
| _ => ok None
end.
(* ❌ The definition of exceptions is not handled. *)
exception
Definition decimal_of_roman (roman : string) : Z :=
let arabic := Stdlib.ref 0 in
let lastval := Stdlib.ref 0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ For loops not handled. *)
for in
Stdlib.op_exclamation arabic.
Definition dip {A : Type}
(loc : A) (op_staroptstar : option Tezos_micheline.Micheline.annot)
: Z ->
(Tezos_micheline.Micheline.node A string) ->
Tezos_micheline.Micheline.node A string :=
let annot :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun depth =>
fun instr =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.ge depth 0) in
if equiv_decb depth 1 then
Tezos_micheline.Micheline.Prim loc "DIP" % string (cons instr []) annot
else
Tezos_micheline.Micheline.Prim loc "DIP" % string
(cons (Tezos_micheline.Micheline.Int loc (Z.of_int depth))
(cons instr [])) annot.
Definition expand_deprecated_dxiiivp {A : Type}
(original : Tezos_micheline.Micheline.node A string)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node A string)) :=
match original with
| Tezos_micheline.Micheline.Prim loc str args annot =>
let len := String.length str in
if
andb (OCaml.Stdlib.gt len 3)
(andb (equiv_decb (String.get str 0) "D" % char)
(equiv_decb (String.get str (Z.sub len 1)) "P" % char)) then
(* ❌ Try-with are not handled *)
try
(let depth := decimal_of_roman (String.sub str 1 (Z.sub len 2)) in
match args with
| cons ((Tezos_micheline.Micheline.Seq _ _) as arg) [] =>
apply ok (Some (dip loc (Some annot) depth arg))
| cons _ [] => error (Tezos_base__TzPervasives.Sequence_expected str)
| [] | cons _ (cons _ _) =>
error
(Tezos_base__TzPervasives.Invalid_arity str (List.length args) 1)
end)
else
ok None
| _ => ok None
end.
(* ❌ The definition of exceptions is not handled. *)
exception
Inductive pair_item : Type :=
| A : pair_item
| I : pair_item
| P : Z -> pair_item -> pair_item -> pair_item.
Definition parse_pair_substr (str : string) (len : Z) (start : Z) : pair_item :=
let fix parse (left : option bool) (i : Z) : Z * pair_item :=
if equiv_decb i (Z.sub len 1) then
Stdlib.raise_notrace Not_a_pair
else
if equiv_decb (String.get str i) "P" % char then
let '(next_i, l) := parse (Some true) (Z.add i 1) in
let '(next_i, r) := parse (Some false) next_i in
(next_i, (P i l r))
else
if
andb (equiv_decb (String.get str i) "A" % char)
(equiv_decb left (Some true)) then
((Z.add i 1), A)
else
if
andb (equiv_decb (String.get str i) "I" % char)
(nequiv_decb left (Some true)) then
((Z.add i 1), I)
else
Stdlib.raise_notrace Not_a_pair in
let '(last, ast) := parse None start in
if nequiv_decb last (Z.sub len 1) then
Stdlib.raise_notrace Not_a_pair
else
ast.
Definition unparse_pair_item (ast : pair_item) : string :=
let fix unparse (ast : pair_item) (acc : list string) : list string :=
match ast with
| P _ l r => unparse r (unparse l (cons "P" % string acc))
| A => cons "A" % string acc
| I => cons "I" % string acc
end in
OCaml.Stdlib.reverse_apply (List.rev (cons "R" % string (unparse ast [])))
(String.concat "" % string).
Definition pappaiir_annots_pos {A : Type} (ast : pair_item) (annot : list A)
: IntMap.t ((list A) * (list A)) :=
let fix find_annots_pos {B : Type}
(p_pos : IntMap.key) (ast : pair_item) (annots : list B) (acc :
IntMap.t ((list B) * (list B)))
: (list B) * (IntMap.t ((list B) * (list B))) :=
match (ast, annots) with
| (_, []) => (annots, acc)
| (P i left right, _) =>
let '(annots, acc) := find_annots_pos i left annots acc in
find_annots_pos i right annots acc
| (A, cons a annots) =>
let pos :=
match IntMap.find_opt p_pos acc with
| None => ((cons a []), [])
| Some (_, cdr) => ((cons a []), cdr)
end in
(annots, (IntMap.add p_pos pos acc))
| (I, cons a annots) =>
let pos :=
match IntMap.find_opt p_pos acc with
| None => ([], (cons a []))
| Some (car, _) => (car, (cons a []))
end in
(annots, (IntMap.add p_pos pos acc))
end in
snd (find_annots_pos 0 ast annot IntMap.empty).
Definition expand_pappaiir {A : Type}
(original : Tezos_micheline.Micheline.node A string)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node A string)) :=
match original with
| Tezos_micheline.Micheline.Prim loc str args annot =>
let len := String.length str in
if
andb (OCaml.Stdlib.gt len 4)
(andb (equiv_decb (String.get str 0) "P" % char)
(andb (equiv_decb (String.get str (Z.sub len 1)) "R" % char)
(check_letters str 1 (Z.sub len 2)
(fun function_parameter =>
match function_parameter with
| "P" % char | "A" % char | "I" % char => true
| _ => false
end)))) then
(* ❌ Try-with are not handled *)
try
(let '(field_annots, annot) := extract_field_annots annot in
let ast := parse_pair_substr str len 0 in
let field_annots_pos := pappaiir_annots_pos ast field_annots in
let fix parse
(p : pair_item) (function_parameter :
Z * (list (Tezos_micheline.Micheline.node A string)))
: Z * (list (Tezos_micheline.Micheline.node A string)) :=
let '(depth, acc) := function_parameter in
match p with
| P i left right =>
let annot :=
match (i, (IntMap.find_opt i field_annots_pos)) with
| (0, None) => annot
| (_, None) => []
| (0, Some ([], cdr_annot)) =>
OCaml.Stdlib.app (cons "%" % string cdr_annot) annot
| (_, Some ([], cdr_annot)) => cons "%" % string cdr_annot
| (0, Some (car_annot, cdr_annot)) =>
OCaml.Stdlib.app car_annot (OCaml.Stdlib.app cdr_annot annot)
| (_, Some (car_annot, cdr_annot)) =>
OCaml.Stdlib.app car_annot cdr_annot
end in
let acc :=
if equiv_decb depth 0 then
cons
(Tezos_micheline.Micheline.Prim loc "PAIR" % string [] annot)
acc
else
cons
(dip loc None depth
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "PAIR" % string []
annot) []))) acc in
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply (depth, acc) (parse left))
(parse right)
| A | I => ((Z.add depth 1), acc)
end in
let '(_, expanded) := parse ast (0, []) in
op_gtgtquestion
match args with
| [] => ok tt
| cons _ _ =>
error
(Tezos_base__TzPervasives.Invalid_arity str (List.length args) 0)
end
(fun function_parameter =>
let 'tt := function_parameter in
ok (Some (Tezos_micheline.Micheline.Seq loc expanded))))
else
ok None
| _ => ok None
end.
Definition expand_unpappaiir {A : Type}
(original : Tezos_micheline.Micheline.node A string)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node A string)) :=
match original with
| Tezos_micheline.Micheline.Prim loc str args annot =>
let len := String.length str in
if
andb (OCaml.Stdlib.ge len 6)
(andb (equiv_decb (String.sub str 0 3) "UNP" % string)
(andb (equiv_decb (String.get str (Z.sub len 1)) "R" % char)
(check_letters str 3 (Z.sub len 2)
(fun function_parameter =>
match function_parameter with
| "P" % char | "A" % char | "I" % char => true
| _ => false
end)))) then
(* ❌ Try-with are not handled *)
try
(let unpair
(car_annot : Tezos_micheline.Micheline.annot) (cdr_annot :
Tezos_micheline.Micheline.annot)
: Tezos_micheline.Micheline.node A string :=
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim loc "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim loc "CAR" % string [] car_annot)
(cons
(dip loc None 1
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "CDR" % string []
cdr_annot) []))) []))) in
let ast := parse_pair_substr str len 2 in
let annots_pos := pappaiir_annots_pos ast annot in
let fix parse
(p : pair_item) (function_parameter :
Z * (list (Tezos_micheline.Micheline.node A string)))
: Z * (list (Tezos_micheline.Micheline.node A string)) :=
let '(depth, acc) := function_parameter in
match p with
| P i left right =>
let '(car_annot, cdr_annot) :=
match IntMap.find_opt i annots_pos with
| None => ([], [])
| Some (car_annot, cdr_annot) => (car_annot, cdr_annot)
end in
let acc :=
if equiv_decb depth 0 then
cons (unpair car_annot cdr_annot) acc
else
cons
(dip loc None depth
(Tezos_micheline.Micheline.Seq loc
(cons (unpair car_annot cdr_annot) []))) acc in
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply (depth, acc) (parse left))
(parse right)
| A | I => ((Z.add depth 1), acc)
end in
let '(_, rev_expanded) := parse ast (0, []) in
let expanded :=
Tezos_micheline.Micheline.Seq loc (List.rev rev_expanded) in
op_gtgtquestion
match args with
| [] => ok tt
| cons _ _ =>
error
(Tezos_base__TzPervasives.Invalid_arity str (List.length args) 0)
end
(fun function_parameter =>
let 'tt := function_parameter in
ok (Some expanded)))
else
ok None
| _ => ok None
end.
(* ❌ The definition of exceptions is not handled. *)
exception
Definition dupn {A : Type}
(loc : A) (nloc : A) (n : Z) (annot : Tezos_micheline.Micheline.annot)
: Tezos_micheline.Micheline.node A string :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.gt n 1) in
if equiv_decb n 2 then
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim nloc "DUP" % string [] annot) []))
[]) [])
(cons (Tezos_micheline.Micheline.Prim loc "SWAP" % string [] []) []))
else
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "DIP" % string
(cons (Tezos_micheline.Micheline.Int loc (Z.of_int (Z.sub n 1)))
(cons
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "DUP" % string [] annot)
[])) [])) [])
(cons
(Tezos_micheline.Micheline.Prim loc "DIG" % string
(cons (Tezos_micheline.Micheline.Int nloc (Z.of_int n)) []) []) [])).
Definition expand_dupn {A : Type}
(original : Tezos_micheline.Micheline.node A string)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node A string)) :=
match original with
|
Tezos_micheline.Micheline.Prim loc "DUP" % string
(cons (Tezos_micheline.Micheline.Int nloc n) []) annot =>
ok (Some (dupn loc nloc (Z.to_int n) annot))
| _ => ok None
end.
Definition expand_deprecated_duuuuup {A : Type}
(original : Tezos_micheline.Micheline.node A string)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node A string)) :=
match original with
| Tezos_micheline.Micheline.Prim loc str args annot =>
let len := String.length str in
if
andb (OCaml.Stdlib.gt len 3)
(andb (equiv_decb (String.get str 0) "D" % char)
(andb (equiv_decb (String.get str (Z.sub len 1)) "P" % char)
(check_letters str 1 (Z.sub len 2) (equiv_decb "U" % char)))) then
op_gtgtquestion
match args with
| [] => ok tt
| cons _ _ =>
error
(Tezos_base__TzPervasives.Invalid_arity str (List.length args) 0)
end
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Try-with are not handled *)
try
(let fix parse (i : Z) : Tezos_micheline.Micheline.node A string :=
if equiv_decb i 1 then
dupn loc loc (Z.sub len 2) annot
else
if equiv_decb (String.get str i) "U" % char then
parse (Z.sub i 1)
else
Stdlib.raise_notrace Not_a_dup in
ok (Some (parse (Z.sub len 2)))))
else
ok None
| _ => ok None
end.
Definition expand_compare {A : Type}
(original : Tezos_micheline.Micheline.node A string)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node A string)) :=
let cmp {B C : Type}
(loc : B) (is : list C) (annot : Tezos_micheline.Micheline.annot)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node B C)) :=
let is :=
match
List.rev_map (fun i => Tezos_micheline.Micheline.Prim loc i [] []) is
with
| cons (Tezos_micheline.Micheline.Prim loc i args _) r =>
List.rev (cons (Tezos_micheline.Micheline.Prim loc i args annot) r)
| is => List.rev is
end in
ok (Some (Tezos_micheline.Micheline.Seq loc is)) in
let ifcmp {B : Type}
(loc : B) (is : list string) (l : Tezos_micheline.Micheline.node B string)
(r : Tezos_micheline.Micheline.node B string) (annot :
Tezos_micheline.Micheline.annot)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node B string)) :=
let is :=
OCaml.Stdlib.app
(List.map (fun i => Tezos_micheline.Micheline.Prim loc i [] []) is)
(cons
(Tezos_micheline.Micheline.Prim loc "IF" % string (cons l (cons r []))
annot) []) in
ok (Some (Tezos_micheline.Micheline.Seq loc is)) in
match original with
| Tezos_micheline.Micheline.Prim loc "CMPEQ" % string [] annot =>
cmp loc (cons "COMPARE" % string (cons "EQ" % string [])) annot
| Tezos_micheline.Micheline.Prim loc "CMPNEQ" % string [] annot =>
cmp loc (cons "COMPARE" % string (cons "NEQ" % string [])) annot
| Tezos_micheline.Micheline.Prim loc "CMPLT" % string [] annot =>
cmp loc (cons "COMPARE" % string (cons "LT" % string [])) annot
| Tezos_micheline.Micheline.Prim loc "CMPGT" % string [] annot =>
cmp loc (cons "COMPARE" % string (cons "GT" % string [])) annot
| Tezos_micheline.Micheline.Prim loc "CMPLE" % string [] annot =>
cmp loc (cons "COMPARE" % string (cons "LE" % string [])) annot
| Tezos_micheline.Micheline.Prim loc "CMPGE" % string [] annot =>
cmp loc (cons "COMPARE" % string (cons "GE" % string [])) annot
|
Tezos_micheline.Micheline.Prim _
(("CMPEQ" % string | "CMPNEQ" % string | "CMPLT" % string |
"CMPGT" % string | "CMPLE" % string | "CMPGE" % string) as str) args []
=> error (Tezos_base__TzPervasives.Invalid_arity str (List.length args) 0)
|
Tezos_micheline.Micheline.Prim loc "IFCMPEQ" % string (cons l (cons r []))
annot =>
ifcmp loc (cons "COMPARE" % string (cons "EQ" % string [])) l r annot
|
Tezos_micheline.Micheline.Prim loc "IFCMPNEQ" % string (cons l (cons r []))
annot =>
ifcmp loc (cons "COMPARE" % string (cons "NEQ" % string [])) l r annot
|
Tezos_micheline.Micheline.Prim loc "IFCMPLT" % string (cons l (cons r []))
annot =>
ifcmp loc (cons "COMPARE" % string (cons "LT" % string [])) l r annot
|
Tezos_micheline.Micheline.Prim loc "IFCMPGT" % string (cons l (cons r []))
annot =>
ifcmp loc (cons "COMPARE" % string (cons "GT" % string [])) l r annot
|
Tezos_micheline.Micheline.Prim loc "IFCMPLE" % string (cons l (cons r []))
annot =>
ifcmp loc (cons "COMPARE" % string (cons "LE" % string [])) l r annot
|
Tezos_micheline.Micheline.Prim loc "IFCMPGE" % string (cons l (cons r []))
annot =>
ifcmp loc (cons "COMPARE" % string (cons "GE" % string [])) l r annot
|
Tezos_micheline.Micheline.Prim loc "IFEQ" % string (cons l (cons r []))
annot => ifcmp loc (cons "EQ" % string []) l r annot
|
Tezos_micheline.Micheline.Prim loc "IFNEQ" % string (cons l (cons r []))
annot => ifcmp loc (cons "NEQ" % string []) l r annot
|
Tezos_micheline.Micheline.Prim loc "IFLT" % string (cons l (cons r []))
annot => ifcmp loc (cons "LT" % string []) l r annot
|
Tezos_micheline.Micheline.Prim loc "IFGT" % string (cons l (cons r []))
annot => ifcmp loc (cons "GT" % string []) l r annot
|
Tezos_micheline.Micheline.Prim loc "IFLE" % string (cons l (cons r []))
annot => ifcmp loc (cons "LE" % string []) l r annot
|
Tezos_micheline.Micheline.Prim loc "IFGE" % string (cons l (cons r []))
annot => ifcmp loc (cons "GE" % string []) l r annot
|
Tezos_micheline.Micheline.Prim _
(("IFCMPEQ" % string | "IFCMPNEQ" % string | "IFCMPLT" % string |
"IFCMPGT" % string | "IFCMPLE" % string | "IFCMPGE" % string |
"IFEQ" % string | "IFNEQ" % string | "IFLT" % string | "IFGT" % string |
"IFLE" % string | "IFGE" % string) as str) args [] =>
error (Tezos_base__TzPervasives.Invalid_arity str (List.length args) 2)
|
Tezos_micheline.Micheline.Prim _
(("IFCMPEQ" % string | "IFCMPNEQ" % string | "IFCMPLT" % string |
"IFCMPGT" % string | "IFCMPLE" % string | "IFCMPGE" % string |
"IFEQ" % string | "IFNEQ" % string | "IFLT" % string | "IFGT" % string |
"IFLE" % string | "IFGE" % string) as str) [] (cons _ _) =>
error (Tezos_base__TzPervasives.Unexpected_macro_annotation str)
| _ => ok None
end.
Definition expand_asserts {A : Type}
(original : Tezos_micheline.Micheline.node A string)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node A string)) :=
let may_rename {B : Type}
(loc : B) (function_parameter : Tezos_micheline.Micheline.annot)
: Tezos_micheline.Micheline.node B string :=
match function_parameter with
| [] => Tezos_micheline.Micheline.Seq loc []
| annot =>
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim loc "RENAME" % string [] annot) [])
end in
let fail_false {B : Type}
(op_staroptstar : option Tezos_micheline.Micheline.annot)
: B -> list (Tezos_micheline.Micheline.node B string) :=
let annot :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun loc =>
cons (may_rename loc annot)
(cons
(Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim loc "FAIL" % string [] []) []))
[]) in
let fail_true {B : Type}
(op_staroptstar : option Tezos_micheline.Micheline.annot)
: B -> list (Tezos_micheline.Micheline.node B string) :=
let annot :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun loc =>
cons
(Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim loc "FAIL" % string [] []) []))
(cons (may_rename loc annot) []) in
match original with
| Tezos_micheline.Micheline.Prim loc "ASSERT" % string [] [] =>
apply ok
(Some
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "IF" % string
(fail_false None loc) []) [])))
| Tezos_micheline.Micheline.Prim loc "ASSERT_NONE" % string [] [] =>
apply ok
(Some
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "IF_NONE" % string
(fail_false None loc) []) [])))
| Tezos_micheline.Micheline.Prim loc "ASSERT_SOME" % string [] annot =>
apply ok
(Some
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "IF_NONE" % string
(fail_true (Some annot) loc) []) [])))
| Tezos_micheline.Micheline.Prim loc "ASSERT_LEFT" % string [] annot =>
apply ok
(Some
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "IF_LEFT" % string
(fail_false (Some annot) loc) []) [])))
| Tezos_micheline.Micheline.Prim loc "ASSERT_RIGHT" % string [] annot =>
apply ok
(Some
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "IF_LEFT" % string
(fail_true (Some annot) loc) []) [])))
|
Tezos_micheline.Micheline.Prim _
(("ASSERT" % string | "ASSERT_NONE" % string | "ASSERT_SOME" % string |
"ASSERT_LEFT" % string | "ASSERT_RIGHT" % string) as str) args [] =>
error (Tezos_base__TzPervasives.Invalid_arity str (List.length args) 0)
|
Tezos_micheline.Micheline.Prim _
(("ASSERT" % string | "ASSERT_NONE" % string) as str) [] (cons _ _) =>
error (Tezos_base__TzPervasives.Unexpected_macro_annotation str)
| Tezos_micheline.Micheline.Prim loc s args annot =>
op_gtgtquestion
match args with
| [] => ok tt
| cons _ _ =>
error (Tezos_base__TzPervasives.Invalid_arity s (List.length args) 0)
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
match annot with
| cons _ _ =>
error (Tezos_base__TzPervasives.Unexpected_macro_annotation s)
| [] => ok tt
end
(fun function_parameter =>
let 'tt := function_parameter in
let remaining := sub s 7 (Z.sub (length s) 7) in
let remaining_prim :=
Tezos_micheline.Micheline.Prim loc remaining [] [] in
match remaining with
|
"EQ" % string | "NEQ" % string | "LT" % string | "LE" % string |
"GE" % string | "GT" % string =>
apply ok
(Some
(Tezos_micheline.Micheline.Seq loc
(cons remaining_prim
(cons
(Tezos_micheline.Micheline.Prim loc "IF" % string
(fail_false None loc) []) []))))
| _ =>
op_gtpipequestion (expand_compare remaining_prim)
(fun function_parameter =>
match function_parameter with
| None => None
| Some seq =>
Some
(Tezos_micheline.Micheline.Seq loc
(cons seq
(cons
(Tezos_micheline.Micheline.Prim loc "IF" % string
(fail_false None loc) []) [])))
end)
end))
| _ => ok None
end.
Definition expand_if_some {A : Type}
(function_parameter : Tezos_micheline.Micheline.node A string)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node A string)) :=
match function_parameter with
|
Tezos_micheline.Micheline.Prim loc "IF_SOME" % string
(cons right (cons left [])) annot =>
apply ok
(Some
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "IF_NONE" % string
(cons left (cons right [])) annot) [])))
| Tezos_micheline.Micheline.Prim _ "IF_SOME" % string args _annot =>
error
(Tezos_base__TzPervasives.Invalid_arity "IF_SOME" % string
(List.length args) 2)
| _ => apply ok None
end.
Definition expand_if_right {A : Type}
(function_parameter : Tezos_micheline.Micheline.node A string)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node A string)) :=
match function_parameter with
|
Tezos_micheline.Micheline.Prim loc "IF_RIGHT" % string
(cons right (cons left [])) annot =>
apply ok
(Some
(Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim loc "IF_LEFT" % string
(cons left (cons right [])) annot) [])))
| Tezos_micheline.Micheline.Prim _ "IF_RIGHT" % string args _annot =>
error
(Tezos_base__TzPervasives.Invalid_arity "IF_RIGHT" % string
(List.length args) 2)
| _ => apply ok None
end.
Definition expand_fail {A : Type}
(function_parameter : Tezos_micheline.Micheline.node A string)
: Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node A string)) :=
match function_parameter with
| Tezos_micheline.Micheline.Prim loc "FAIL" % string [] [] =>
apply ok
(Some
(Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim loc "UNIT" % string [] [])
(cons (Tezos_micheline.Micheline.Prim loc "FAILWITH" % string [] [])
[]))))
| _ => apply ok None
end.
Definition expand {A : Type}
(original : Tezos_micheline.Micheline.node A string)
: Tezos_base__TzPervasives.tzresult (Tezos_micheline.Micheline.node A string) :=
let fix try_expansions
(function_parameter :
list
((Tezos_micheline.Micheline.node A string) ->
Tezos_base__TzPervasives.tzresult
(option (Tezos_micheline.Micheline.node A string))))
: Tezos_base__TzPervasives.tzresult
(Tezos_micheline.Micheline.node A string) :=
match function_parameter with
| [] => apply ok original
| cons expander expanders =>
op_gtgtquestion (expander original)
(fun function_parameter =>
match function_parameter with
| None => try_expansions expanders
| Some rewritten => ok rewritten
end)
end in
try_expansions
(cons expand_caddadr
(cons expand_set_caddadr
(cons expand_map_caddadr
(cons expand_deprecated_dxiiivp
(cons expand_pappaiir
(cons expand_unpappaiir
(cons expand_deprecated_duuuuup
(cons expand_dupn
(cons expand_compare
(cons expand_asserts
(cons expand_if_some
(cons expand_if_right (cons expand_fail []))))))))))))).
Definition expand_rec {A : Type}
(expr : Tezos_micheline.Micheline.node A string)
: (Tezos_micheline.Micheline.node A string) * Tezos_base__TzPervasives.trace :=
let fix error_map {B C D : Type} (function_parameter : (list B) * (list C))
: (D -> B * (list C)) -> (list D) -> (list B) * (list C) :=
let '(expanded, errors) := function_parameter in
fun f =>
fun function_parameter =>
match function_parameter with
| [] => ((List.rev expanded), (List.rev errors))
| cons hd tl =>
let '(new_expanded, new_errors) := f hd in
error_map
((cons new_expanded expanded), (List.rev_append new_errors errors))
f tl
end in
let error_map := error_map ([], []) in
let fix expand_rec (expr : Tezos_micheline.Micheline.node A string)
: (Tezos_micheline.Micheline.node A string) * Tezos_base__TzPervasives.trace :=
match expand expr with
| Stdlib.Ok expanded =>
match expanded with
| Tezos_micheline.Micheline.Seq loc items =>
let '(items, errors) := error_map expand_rec items in
((Tezos_micheline.Micheline.Seq loc items), errors)
| Tezos_micheline.Micheline.Prim loc name args annot =>
let '(args, errors) := error_map expand_rec args in
((Tezos_micheline.Micheline.Prim loc name args annot), errors)
|
(Tezos_micheline.Micheline.Int _ _ |
Tezos_micheline.Micheline.String _ _ |
Tezos_micheline.Micheline.Bytes _ _) as atom => (atom, [])
end
| Stdlib.Error errors => (expr, errors)
end in
expand_rec expr.
Definition unexpand_caddadr {A : Type}
(expanded : Tezos_micheline.Micheline.node A string)
: option (Tezos_micheline.Micheline.node A string) :=
let fix rsteps {B : Type}
(acc : list string) (function_parameter :
list (Tezos_micheline.Micheline.node B string)) : option (list string) :=
match function_parameter with
| [] => Some acc
| cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] []) rest =>
rsteps (cons "A" % string acc) rest
| cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] []) rest =>
rsteps (cons "D" % string acc) rest
| _ => None
end in
match expanded with
|
Tezos_micheline.Micheline.Seq loc
((cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] []) _) as nodes)
|
Tezos_micheline.Micheline.Seq loc
((cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] []) _) as
nodes) =>
match rsteps [] nodes with
| Some steps =>
let name :=
String.concat "" % string
(cons "C" % string (List.rev (cons "R" % string steps))) in
Some (Tezos_micheline.Micheline.Prim loc name [] [])
| None => None
end
| _ => None
end.
Definition unexpand_set_caddadr {A : Type}
(expanded : Tezos_micheline.Micheline.node A string)
: option (Tezos_micheline.Micheline.node A string) :=
let fix steps {B : Type}
(acc : list string) (annots : list string) (function_parameter :
Tezos_micheline.Micheline.node B string)
: option (B * (list string) * (list string)) :=
match function_parameter with
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _) [])))
=> Some (loc, (cons "A" % string acc), annots)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "CAR" % string []
(cons field_annot []))
(cons (Tezos_micheline.Micheline.Prim _ "DROP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _)
[])))))) =>
Some (loc, (cons "A" % string acc), (cons field_annot annots))
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _) [])) =>
Some (loc, (cons "D" % string acc), annots)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "CDR" % string []
(cons field_annot []))
(cons (Tezos_micheline.Micheline.Prim _ "DROP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _) [])))))
=> Some (loc, (cons "D" % string acc), (cons field_annot annots))
|
Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] _)
(cons sub []))) []) [])
(cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "PAIR" % string []
pair_annots) []))))) =>
let '(_, pair_annots) := extract_field_annots pair_annots in
steps (cons "A" % string acc) (List.rev_append pair_annots annots) sub
|
Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] _)
(cons sub []))) []) [])
(cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] _)
(cons
(Tezos_micheline.Micheline.Prim _ "PAIR" % string [] pair_annots)
[])))) =>
let '(_, pair_annots) := extract_field_annots pair_annots in
steps (cons "D" % string acc) (List.rev_append pair_annots annots) sub
| _ => None
end in
match steps [] [] expanded with
| Some (loc, steps, annots) =>
let name :=
String.concat "" % string
(cons "SET_C" % string (List.rev (cons "R" % string steps))) in
Some (Tezos_micheline.Micheline.Prim loc name [] (List.rev annots))
| None => None
end.
Definition unexpand_map_caddadr {A : Type}
(expanded : Tezos_micheline.Micheline.node A string)
: option (Tezos_micheline.Micheline.node A string) :=
let fix steps {B : Type}
(acc : list string) (annots : list string) (function_parameter :
Tezos_micheline.Micheline.node B string)
: option
(B * (list string) * (list string) *
(Tezos_micheline.Micheline.node B string)) :=
match function_parameter with
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "CAR" % string [] [])
(cons code []))) []) [])
(cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _) [])))))
=> Some (loc, (cons "A" % string acc), annots, code)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "CAR" % string []
(cons field_annot [])) (cons code []))) []) [])
(cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _) [])))))
=> Some (loc, (cons "A" % string acc), (cons field_annot annots), code)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] [])
(cons code
(cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _)
[])))))) =>
Some (loc, (cons "D" % string acc), annots, code)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "CDR" % string []
(cons field_annot []))
(cons code
(cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _)
[])))))) =>
Some (loc, (cons "D" % string acc), (cons field_annot annots), code)
|
Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] _)
(cons sub []))) []) [])
(cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "PAIR" % string []
pair_annots) []))))) =>
let '(_, pair_annots) := extract_field_annots pair_annots in
steps (cons "A" % string acc) (List.rev_append pair_annots annots) sub
|
Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] [])
(cons sub []))) []) [])
(cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "PAIR" % string [] pair_annots)
[])))) =>
let '(_, pair_annots) := extract_field_annots pair_annots in
steps (cons "D" % string acc) (List.rev_append pair_annots annots) sub
| _ => None
end in
match steps [] [] expanded with
| Some (loc, steps, annots, code) =>
let name :=
String.concat "" % string
(cons "MAP_C" % string (List.rev (cons "R" % string steps))) in
Some
(Tezos_micheline.Micheline.Prim loc name (cons code []) (List.rev annots))
| None => None
end.
Definition unexpand_deprecated_dxiiivp {A : Type}
(expanded : Tezos_micheline.Micheline.node A string)
: option (Tezos_micheline.Micheline.node A string) :=
match expanded with
|
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons
((Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string (cons _ []) [])
[])) as sub) []) []) []) =>
let fix count {B : Type}
(acc : Z) (function_parameter : Tezos_micheline.Micheline.node B string)
: Z * (Tezos_micheline.Micheline.node B string) :=
match function_parameter with
|
Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string (cons sub []) [])
[]) => count (Z.add acc 1) sub
| sub => (acc, sub)
end in
let '(depth, sub) := count 1 sub in
Some
(Tezos_micheline.Micheline.Prim loc "DIP" % string
(cons (Tezos_micheline.Micheline.Int loc (Z.of_int depth)) (cons sub []))
[])
| _ => None
end.
Definition unexpand_dupn {A : Type}
(expanded : Tezos_micheline.Micheline.node A string)
: option (Tezos_micheline.Micheline.node A string) :=
match expanded with
|
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons (Tezos_micheline.Micheline.Int _ np)
(cons
(Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] annot)
[])) [])) [])
(cons
(Tezos_micheline.Micheline.Prim _ "DIG" % string
(cons (Tezos_micheline.Micheline.Int nloc ng) []) []) [])) =>
Some
(Tezos_micheline.Micheline.Prim loc "DUP" % string
(cons (Tezos_micheline.Micheline.Int nloc ng) []) annot)
| _ => None
end.
Definition unexpand_deprecated_duuuuup {A : Type}
(expanded : Tezos_micheline.Micheline.node A string)
: option (Tezos_micheline.Micheline.node A string) :=
let fix expand {B : Type}
(n : Z) (function_parameter : Tezos_micheline.Micheline.node B string)
: option (Tezos_micheline.Micheline.node B string) :=
match function_parameter with
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim nloc "DUP" % string [] annot) [])
=>
if equiv_decb n 1 then
None
else
Some
(Tezos_micheline.Micheline.Prim loc "DUP" % string
(cons (Tezos_micheline.Micheline.Int nloc (Z.of_int n)) []) annot)
|
Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string (cons expanded' [])
[])
(cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] []) [])) =>
expand (Z.add n 1) expanded'
| _ => None
end in
expand 1 expanded.
Fixpoint normalize_pair_item (op_staroptstar : option bool)
: pair_item -> pair_item :=
let right :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun function_parameter =>
match function_parameter with
| P i a b =>
P i (normalize_pair_item None a) (normalize_pair_item (Some true) b)
| A => I
| A => A
| I => I
end.
Definition unexpand_pappaiir {A : Type}
(expanded : Tezos_micheline.Micheline.node A string)
: option (Tezos_micheline.Micheline.node A string) :=
match expanded with
|
Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] []) []) =>
Some expanded
| Tezos_micheline.Micheline.Seq loc ((cons _ _) as nodes) =>
let fix exec {B : Type}
(stack : list pair_item) (nodes :
list (Tezos_micheline.Micheline.node B string)) : list pair_item :=
match (nodes, stack) with
| ([], _) => stack
|
(cons
(Tezos_micheline.Micheline.Prim ploc "DIP" % string
(cons (Tezos_micheline.Micheline.Int loc n)
(cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) rest,
cons a rstack) =>
exec
(cons a
(exec rstack
(cons
(Tezos_micheline.Micheline.Prim ploc "DIP" % string
(cons (Tezos_micheline.Micheline.Int loc (Z.pred n))
(cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) [])))
rest
|
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons (Tezos_micheline.Micheline.Int _ n)
(cons (Tezos_micheline.Micheline.Seq _ sub) [])) []) rest,
cons a rstack) => exec (cons a (exec rstack sub)) rest
|
(cons
(Tezos_micheline.Micheline.Prim ploc "DIP" % string
(cons (Tezos_micheline.Micheline.Int loc n)
(cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) rest, [])
=>
exec
(cons A
(exec []
(cons
(Tezos_micheline.Micheline.Prim ploc "DIP" % string
(cons (Tezos_micheline.Micheline.Int loc (Z.pred n))
(cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) [])))
rest
|
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons (Tezos_micheline.Micheline.Int _ n)
(cons (Tezos_micheline.Micheline.Seq _ sub) [])) []) rest, []) =>
exec (cons A (exec [] sub)) rest
|
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons (Tezos_micheline.Micheline.Seq _ sub) []) []) rest,
cons a rstack) => exec (cons a (exec rstack sub)) rest
|
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons (Tezos_micheline.Micheline.Seq _ sub) []) []) rest, []) =>
exec (cons A (exec [] sub)) rest
|
(cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] []) rest,
cons a (cons b rstack)) => exec (cons (P 0 a b) rstack) rest
|
(cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] []) rest,
cons a []) => exec (cons (P 0 a I) []) rest
| (cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] []) rest, [])
=> exec (cons (P 0 A I) []) rest
| _ => Stdlib.raise_notrace Not_a_pair
end in
match exec [] nodes with
| [] => None
| cons res _ =>
let res := normalize_pair_item None res in
let name := unparse_pair_item res in
Some (Tezos_micheline.Micheline.Prim loc name [] [])
end
| _ => None
end.
Definition unexpand_unpappaiir {A : Type}
(expanded : Tezos_micheline.Micheline.node A string)
: option (Tezos_micheline.Micheline.node A string) :=
match expanded with
| Tezos_micheline.Micheline.Seq loc ((cons _ _) as nodes) =>
let fix exec {B : Type}
(stack : list pair_item) (nodes :
list (Tezos_micheline.Micheline.node B string)) : list pair_item :=
match (nodes, stack) with
| ([], _) => stack
|
(cons
(Tezos_micheline.Micheline.Prim ploc "DIP" % string
(cons (Tezos_micheline.Micheline.Int loc n)
(cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) rest,
cons a rstack) =>
exec
(cons a
(exec rstack
(cons
(Tezos_micheline.Micheline.Prim ploc "DIP" % string
(cons (Tezos_micheline.Micheline.Int loc (Z.pred n))
(cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) [])))
rest
|
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons (Tezos_micheline.Micheline.Int _ n)
(cons (Tezos_micheline.Micheline.Seq _ sub) [])) []) rest,
cons a rstack) => exec (cons a (exec rstack sub)) rest
|
(cons
(Tezos_micheline.Micheline.Prim ploc "DIP" % string
(cons (Tezos_micheline.Micheline.Int loc n)
(cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) rest, [])
=>
exec
(cons A
(exec []
(cons
(Tezos_micheline.Micheline.Prim ploc "DIP" % string
(cons (Tezos_micheline.Micheline.Int loc (Z.pred n))
(cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) [])))
rest
|
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons (Tezos_micheline.Micheline.Int _ n)
(cons (Tezos_micheline.Micheline.Seq _ sub) [])) []) rest, []) =>
exec (cons A (exec [] sub)) rest
|
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons (Tezos_micheline.Micheline.Seq _ sub) []) []) rest,
cons a rstack) => exec (cons a (exec rstack sub)) rest
|
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons (Tezos_micheline.Micheline.Seq _ sub) []) []) rest, []) =>
exec (cons A (exec [] sub)) rest
|
(cons
(Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "CDR" % string [] [])
[])) []) []) [])))) rest, cons a (cons b rstack)) =>
exec (cons (P 0 a b) rstack) rest
|
(cons
(Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "CDR" % string [] [])
[])) []) []) [])))) rest, cons a []) =>
exec (cons (P 0 a I) []) rest
|
(cons
(Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "CDR" % string [] [])
[])) []) []) [])))) rest, []) =>
exec (cons (P 0 A I) []) rest
| _ => Stdlib.raise_notrace Not_a_pair
end in
match exec [] (List.rev nodes) with
| [] => None
| cons res _ =>
let res := normalize_pair_item None res in
let name := String.append "UN" % string (unparse_pair_item res) in
Some (Tezos_micheline.Micheline.Prim loc name [] [])
end
| _ => None
end.
Definition unexpand_compare {A : Type}
(expanded : Tezos_micheline.Micheline.node A string)
: option (Tezos_micheline.Micheline.node A string) :=
match expanded with
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "EQ" % string [] annot) [])) =>
Some (Tezos_micheline.Micheline.Prim loc "CMPEQ" % string [] annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "NEQ" % string [] annot) [])) =>
Some (Tezos_micheline.Micheline.Prim loc "CMPNEQ" % string [] annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "LT" % string [] annot) [])) =>
Some (Tezos_micheline.Micheline.Prim loc "CMPLT" % string [] annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "GT" % string [] annot) [])) =>
Some (Tezos_micheline.Micheline.Prim loc "CMPGT" % string [] annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "LE" % string [] annot) [])) =>
Some (Tezos_micheline.Micheline.Prim loc "CMPLE" % string [] annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "GE" % string [] annot) [])) =>
Some (Tezos_micheline.Micheline.Prim loc "CMPGE" % string [] annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "EQ" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) [])))
=> Some (Tezos_micheline.Micheline.Prim loc "IFCMPEQ" % string args annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "NEQ" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) [])))
=> Some (Tezos_micheline.Micheline.Prim loc "IFCMPNEQ" % string args annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "LT" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) [])))
=> Some (Tezos_micheline.Micheline.Prim loc "IFCMPLT" % string args annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "GT" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) [])))
=> Some (Tezos_micheline.Micheline.Prim loc "IFCMPGT" % string args annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "LE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) [])))
=> Some (Tezos_micheline.Micheline.Prim loc "IFCMPLE" % string args annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "GE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) [])))
=> Some (Tezos_micheline.Micheline.Prim loc "IFCMPGE" % string args annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "EQ" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) []))
=> Some (Tezos_micheline.Micheline.Prim loc "IFEQ" % string args annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "NEQ" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) []))
=> Some (Tezos_micheline.Micheline.Prim loc "IFNEQ" % string args annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "LT" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) []))
=> Some (Tezos_micheline.Micheline.Prim loc "IFLT" % string args annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "GT" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) []))
=> Some (Tezos_micheline.Micheline.Prim loc "IFGT" % string args annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "LE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) []))
=> Some (Tezos_micheline.Micheline.Prim loc "IFLE" % string args annot)
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "GE" % string [] _)
(cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) []))
=> Some (Tezos_micheline.Micheline.Prim loc "IFGE" % string args annot)
| _ => None
end.
Definition unexpand_asserts {A : Type}
(expanded : Tezos_micheline.Micheline.node A string)
: option (Tezos_micheline.Micheline.node A string) :=
match expanded with
|
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim _ "IF" % string
(cons (Tezos_micheline.Micheline.Seq _ [])
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
[]) []))) [])) [])) []) []) =>
Some (Tezos_micheline.Micheline.Prim loc "ASSERT" % string [] [])
|
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] [])
(cons (Tezos_micheline.Micheline.Prim _ comparison [] []) [])))
(cons
(Tezos_micheline.Micheline.Prim _ "IF" % string
(cons (Tezos_micheline.Micheline.Seq _ [])
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "FAILWITH" % string
[] []) []))) [])) [])) []) [])) =>
Some
(Tezos_micheline.Micheline.Prim loc
(String.append "ASSERT_CMP" % string comparison) [] [])
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ comparison [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "IF" % string
(cons (Tezos_micheline.Micheline.Seq _ [])
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "FAILWITH" % string
[] []) []))) [])) [])) []) [])) =>
Some
(Tezos_micheline.Micheline.Prim loc
(String.append "ASSERT_" % string comparison) [] [])
|
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim _ "IF_NONE" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "RENAME" % string [] annot) []))
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
[]) []))) [])) [])) []) []) =>
Some (Tezos_micheline.Micheline.Prim loc "ASSERT_NONE" % string [] annot)
|
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim _ "IF_NONE" % string
(cons (Tezos_micheline.Micheline.Seq _ [])
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
[]) []))) [])) [])) []) []) =>
Some (Tezos_micheline.Micheline.Prim loc "ASSERT_NONE" % string [] [])
|
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim _ "IF_NONE" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
[]) []))) []))
(cons (Tezos_micheline.Micheline.Seq _ []) [])) []) []) =>
Some (Tezos_micheline.Micheline.Prim loc "ASSERT_SOME" % string [] [])
|
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim _ "IF_NONE" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
[]) []))) []))
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "RENAME" % string [] annot)
[])) [])) []) []) =>
Some (Tezos_micheline.Micheline.Prim loc "ASSERT_SOME" % string [] annot)
|
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim _ "IF_LEFT" % string
(cons (Tezos_micheline.Micheline.Seq _ [])
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
[]) []))) [])) [])) []) []) =>
Some (Tezos_micheline.Micheline.Prim loc "ASSERT_LEFT" % string [] [])
|
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim _ "IF_LEFT" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "RENAME" % string [] annot) []))
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
[]) []))) [])) [])) []) []) =>
Some (Tezos_micheline.Micheline.Prim loc "ASSERT_LEFT" % string [] annot)
|
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim _ "IF_LEFT" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
[]) []))) []))
(cons (Tezos_micheline.Micheline.Seq _ []) [])) []) []) =>
Some (Tezos_micheline.Micheline.Prim loc "ASSERT_RIGHT" % string [] [])
|
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim _ "IF_LEFT" % string
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Seq _
(cons (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
[]) []))) []))
(cons
(Tezos_micheline.Micheline.Seq _
(cons
(Tezos_micheline.Micheline.Prim _ "RENAME" % string [] annot)
[])) [])) []) []) =>
Some (Tezos_micheline.Micheline.Prim loc "ASSERT_RIGHT" % string [] annot)
| _ => None
end.
Definition unexpand_if_some {A : Type}
(function_parameter : Tezos_micheline.Micheline.node A string)
: option (Tezos_micheline.Micheline.node A string) :=
match function_parameter with
|
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim _ "IF_NONE" % string
(cons left (cons right [])) annot) []) =>
Some
(Tezos_micheline.Micheline.Prim loc "IF_SOME" % string
(cons right (cons left [])) annot)
| _ => None
end.
Definition unexpand_if_right {A : Type}
(function_parameter : Tezos_micheline.Micheline.node A string)
: option (Tezos_micheline.Micheline.node A string) :=
match function_parameter with
|
Tezos_micheline.Micheline.Seq loc
(cons
(Tezos_micheline.Micheline.Prim _ "IF_LEFT" % string
(cons left (cons right [])) annot) []) =>
Some
(Tezos_micheline.Micheline.Prim loc "IF_RIGHT" % string
(cons right (cons left [])) annot)
| _ => None
end.
Definition unexpand_fail {A : Type}
(function_parameter : Tezos_micheline.Micheline.node A string)
: option (Tezos_micheline.Micheline.node A string) :=
match function_parameter with
|
Tezos_micheline.Micheline.Seq loc
(cons (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
(cons (Tezos_micheline.Micheline.Prim _ "FAILWITH" % string [] []) []))
=> Some (Tezos_micheline.Micheline.Prim loc "FAIL" % string [] [])
| _ => None
end.
Definition unexpand {A : Type}
(original : Tezos_micheline.Micheline.node A string)
: Tezos_micheline.Micheline.node A string :=
let try_unexpansions
(unexpanders :
list
((Tezos_micheline.Micheline.node A string) ->
option (Tezos_micheline.Micheline.node A string)))
: Tezos_micheline.Micheline.node A string :=
match
List.fold_left
(fun acc =>
fun f =>
match acc with
| None => f original
| Some rewritten => Some rewritten
end) None unexpanders with
| None => original
| Some rewritten => rewritten
end in
try_unexpansions
(cons unexpand_asserts
(cons unexpand_caddadr
(cons unexpand_set_caddadr
(cons unexpand_map_caddadr
(cons unexpand_deprecated_dxiiivp
(cons unexpand_pappaiir
(cons unexpand_unpappaiir
(cons unexpand_deprecated_duuuuup
(cons unexpand_dupn
(cons unexpand_compare
(cons unexpand_if_some
(cons unexpand_if_right (cons unexpand_fail []))))))))))))).
Fixpoint unexpand_rec {A : Type}
(expr : Tezos_micheline.Micheline.node A string)
: Tezos_micheline.Micheline.node A string :=
unexpand_rec_but_root (unexpand expr)
with unexpand_rec_but_root {A : Type}
(function_parameter : Tezos_micheline.Micheline.node A string)
: Tezos_micheline.Micheline.node A string :=
match function_parameter with
| Tezos_micheline.Micheline.Seq loc items =>
Tezos_micheline.Micheline.Seq loc (List.map unexpand_rec items)
| Tezos_micheline.Micheline.Prim loc name args annot =>
Tezos_micheline.Micheline.Prim loc name
(List.map unexpand_rec_but_root args) annot
|
(Tezos_micheline.Micheline.Int _ _ | Tezos_micheline.Micheline.String _ _ |
Tezos_micheline.Micheline.Bytes _ _) as atom => atom
end.
src/proto_alpha/lib_client/michelson_v1_parser.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Tezos_micheline
open Micheline_parser
open Micheline
type parsed = {
source : string;
unexpanded : string canonical;
expanded : Michelson_v1_primitives.prim canonical;
expansion_table : (int * (Micheline_parser.location * int list)) list;
unexpansion_table : (int * int) list;
}
(* Unexpanded toplevel expression should be a sequence *)
let expand_all source ast errors =
let (unexpanded, loc_table) = extract_locations ast in
let (expanded, expansion_errors) =
Michelson_v1_macros.expand_rec (root unexpanded)
in
let (expanded, unexpansion_table) = extract_locations expanded in
let expansion_table =
let sorted =
List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table
in
let grouped =
let rec group = function
| (acc, []) ->
acc
| ([], (u, e) :: r) ->
group ([(e, [u])], r)
| (((pe, us) :: racc as acc), (u, e) :: r) ->
if e = pe then group ((e, u :: us) :: racc, r)
else group ((e, [u]) :: acc, r)
in
group ([], sorted)
in
List.map2
(fun (l, ploc) (l', elocs) ->
assert (l = l') ;
(l, (ploc, elocs)))
(List.sort compare loc_table)
(List.sort compare grouped)
in
match
Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded)
with
| Ok expanded ->
( {source; unexpanded; expanded; expansion_table; unexpansion_table},
errors @ expansion_errors )
| Error errs ->
( {
source;
unexpanded;
expanded = Micheline.strip_locations (Seq ((), []));
expansion_table;
unexpansion_table;
},
errors @ expansion_errors @ errs )
let parse_toplevel ?check source =
let (tokens, lexing_errors) = Micheline_parser.tokenize source in
let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in
let ast =
let start = min_point asts and stop = max_point asts in
Seq ({start; stop}, asts)
in
expand_all source ast (lexing_errors @ parsing_errors)
let parse_expression ?check source =
let (tokens, lexing_errors) = Micheline_parser.tokenize source in
let (ast, parsing_errors) =
Micheline_parser.parse_expression ?check tokens
in
expand_all source ast (lexing_errors @ parsing_errors)
let expand_all ~source ~original = expand_all source original []
src/proto_alpha/lib_client/michelson_v1_parser.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Tezos_micheline.
Import Micheline_parser.
Import Micheline.
Record parsed := {
source : string;
unexpanded : Tezos_micheline.Micheline.canonical string;
expanded :
Tezos_micheline.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim;
expansion_table :
list (Z * (Tezos_micheline.Micheline_parser.location * (list Z)));
unexpansion_table : list (Z * Z) }.
Definition expand_all
(source : string)
(ast :
Tezos_micheline.Micheline.node Tezos_micheline.Micheline_parser.location
string) (errors : list Tezos_base__TzPervasives.error)
: parsed * (list Tezos_base__TzPervasives.error) :=
let '(unexpanded, loc_table) := extract_locations ast in
let '(expanded, expansion_errors) :=
Michelson_v1_macros.expand_rec (root unexpanded) in
let '(expanded, unexpansion_table) := extract_locations expanded in
let expansion_table :=
let sorted :=
List.sort
(fun function_parameter =>
let '(_, a) := function_parameter in
fun function_parameter =>
let '(_, b) := function_parameter in
OCaml.Stdlib.compare a b) unexpansion_table in
let grouped :=
let fix group {A B : Type}
(function_parameter : (list (A * (list B))) * (list (B * A)))
: list (A * (list B)) :=
match function_parameter with
| (acc, []) => acc
| ([], cons (u, e) r) => group ((cons (e, (cons u [])) []), r)
| ((cons (pe, us) racc) as acc, cons (u, e) r) =>
if equiv_decb e pe then
group ((cons (e, (cons u us)) racc), r)
else
group ((cons (e, (cons u [])) acc), r)
end in
group ([], sorted) in
List.map2
(fun function_parameter =>
let '(l, ploc) := function_parameter in
fun function_parameter =>
let '(l', elocs) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (equiv_decb l l') in
(l, (ploc, elocs))) (List.sort OCaml.Stdlib.compare loc_table)
(List.sort OCaml.Stdlib.compare grouped) in
match
Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded)
with
| Stdlib.Ok expanded =>
({| source := source; unexpanded := unexpanded; expanded := expanded;
expansion_table := expansion_table; unexpansion_table := unexpansion_table
|}, (OCaml.Stdlib.app errors expansion_errors))
| Stdlib.Error errs =>
({| source := source; unexpanded := unexpanded;
expanded :=
Micheline.strip_locations (Tezos_micheline.Micheline.Seq tt []);
expansion_table := expansion_table; unexpansion_table := unexpansion_table
|}, (OCaml.Stdlib.app errors (OCaml.Stdlib.app expansion_errors errs)))
end.
Definition parse_toplevel (check : option bool) (source : string)
: parsed * (list Tezos_base__TzPervasives.error) :=
let '(tokens, lexing_errors) := Micheline_parser.tokenize source in
let '(asts, parsing_errors) := Micheline_parser.parse_toplevel check tokens in
let ast :=
let start : Tezos_micheline.Micheline_parser.point :=
min_point asts
with stop : Tezos_micheline.Micheline_parser.point :=
max_point asts in
Tezos_micheline.Micheline.Seq {| start := start; stop := stop |} asts in
expand_all source ast (OCaml.Stdlib.app lexing_errors parsing_errors).
Definition parse_expression (check : option bool) (source : string)
: parsed * (list Tezos_base__TzPervasives.error) :=
let '(tokens, lexing_errors) := Micheline_parser.tokenize source in
let '(ast, parsing_errors) := Micheline_parser.parse_expression check tokens
in
expand_all source ast (OCaml.Stdlib.app lexing_errors parsing_errors).
Definition expand_all
(source : string)
(original :
Tezos_micheline.Micheline.node Tezos_micheline.Micheline_parser.location
string) : parsed * (list Tezos_base__TzPervasives.error) :=
expand_all source original [].
src/proto_alpha/lib_client/michelson_v1_printer.ml 23 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Tezos_micheline
open Micheline
open Micheline_printer
let anon = {comment = None}
let print_expr ppf expr =
expr |> Michelson_v1_primitives.strings_of_prims
|> Micheline.inject_locations (fun _ -> anon)
|> print_expr ppf
let print_expr_unwrapped ppf expr =
expr |> Michelson_v1_primitives.strings_of_prims
|> Micheline.inject_locations (fun _ -> anon)
|> print_expr_unwrapped ppf
let print_var_annots ppf = List.iter (Format.fprintf ppf "%s ")
let print_annot_expr_unwrapped ppf (expr, annot) =
Format.fprintf ppf "%a%a" print_var_annots annot print_expr_unwrapped expr
let print_stack ppf = function
| [] ->
Format.fprintf ppf "[]"
| more ->
Format.fprintf
ppf
"@[<hov 0>[ %a ]@]"
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf "@ : ")
print_annot_expr_unwrapped)
more
let print_execution_trace ppf trace =
Format.pp_print_list
(fun ppf (loc, gas, stack) ->
Format.fprintf
ppf
"- @[<v 0>location: %d (remaining gas: %a)@,[ @[<v 0>%a ]@]@]"
loc
Gas.pp
gas
(Format.pp_print_list (fun ppf (e, annot) ->
Format.fprintf
ppf
"@[<v 0>%a \t%s@]"
print_expr
e
(match annot with None -> "" | Some a -> a)))
stack)
ppf
trace
let print_big_map_diff ppf diff =
let pp_map ppf id =
if Compare.Z.(id < Z.zero) then
Format.fprintf ppf "temp(%s)" (Z.to_string (Z.neg id))
else Format.fprintf ppf "map(%s)" (Z.to_string id)
in
Format.fprintf
ppf
"@[<v 0>%a@]"
(Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf ->
function
| Contract.Clear id ->
Format.fprintf ppf "Clear %a" pp_map id
| Contract.Alloc {big_map; key_type; value_type} ->
Format.fprintf
ppf
"New %a of type (big_map %a %a)"
pp_map
big_map
print_expr
key_type
print_expr
value_type
| Contract.Copy (src, dst) ->
Format.fprintf ppf "Copy %a to %a" pp_map src pp_map dst
| Contract.Update {big_map; diff_key; diff_value; _} ->
Format.fprintf
ppf
"%s %a[%a]%a"
(match diff_value with None -> "Unset" | Some _ -> "Set")
pp_map
big_map
print_expr
diff_key
(fun ppf -> function None -> () | Some x ->
Format.fprintf ppf " to %a" print_expr x)
diff_value))
diff
let inject_types type_map parsed =
let rec inject_expr = function
| Seq (loc, items) ->
Seq (inject_loc `before loc, List.map inject_expr items)
| Prim (loc, name, items, annot) ->
Prim (inject_loc `after loc, name, List.map inject_expr items, annot)
| Int (loc, value) ->
Int (inject_loc `after loc, value)
| String (loc, value) ->
String (inject_loc `after loc, value)
| Bytes (loc, value) ->
Bytes (inject_loc `after loc, value)
and inject_loc which loc =
try
let stack =
let locs =
List.assoc loc parsed.Michelson_v1_parser.expansion_table
|> snd |> List.sort compare
in
let (bef, aft) = List.assoc (List.hd locs) type_map in
match which with `before -> bef | `after -> aft
in
{comment = Some (Format.asprintf "%a" print_stack stack)}
with Not_found -> {comment = None}
in
inject_expr (root parsed.unexpanded)
let unparse ?type_map parse expanded =
let source =
match type_map with
| Some type_map ->
let (unexpanded, unexpansion_table) =
expanded |> Michelson_v1_primitives.strings_of_prims |> root
|> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations
in
let rec inject_expr = function
| Seq (loc, items) ->
Seq (inject_loc `before loc, List.map inject_expr items)
| Prim (loc, name, items, annot) ->
Prim
(inject_loc `after loc, name, List.map inject_expr items, annot)
| Int (loc, value) ->
Int (inject_loc `after loc, value)
| String (loc, value) ->
String (inject_loc `after loc, value)
| Bytes (loc, value) ->
Bytes (inject_loc `after loc, value)
and inject_loc which loc =
try
let stack =
let (bef, aft) =
List.assoc (List.assoc loc unexpansion_table) type_map
in
match which with `before -> bef | `after -> aft
in
{comment = Some (Format.asprintf "%a" print_stack stack)}
with Not_found -> {comment = None}
in
unexpanded |> root |> inject_expr
|> Format.asprintf "%a" Micheline_printer.print_expr
| None ->
expanded |> Michelson_v1_primitives.strings_of_prims |> root
|> Michelson_v1_macros.unexpand_rec |> Micheline.strip_locations
|> Micheline_printer.printable (fun n -> n)
|> Format.asprintf "%a" Micheline_printer.print_expr
in
match parse source with
| (res, []) ->
res
| (_, _ :: _) ->
Pervasives.failwith "Michelson_v1_printer.unparse"
let unparse_toplevel ?type_map =
unparse ?type_map Michelson_v1_parser.parse_toplevel
let unparse_expression = unparse Michelson_v1_parser.parse_expression
let unparse_invalid expanded =
let source =
expanded |> root |> Michelson_v1_macros.unexpand_rec
|> Micheline.strip_locations
|> Micheline_printer.printable (fun n -> n)
|> Format.asprintf "%a" Micheline_printer.print_expr_unwrapped
in
fst (Michelson_v1_parser.parse_toplevel source)
src/proto_alpha/lib_client/michelson_v1_printer.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Import Tezos_micheline.
Import Micheline.
Import Micheline_printer.
Definition anon : Tezos_micheline.Micheline_printer.location :=
{| comment := None |}.
Definition print_expr
(ppf : Stdlib.Format.formatter)
(expr :
Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) : unit :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply expr Michelson_v1_primitives.strings_of_prims)
(Micheline.inject_locations
(fun function_parameter =>
let '_ := function_parameter in
anon))) (print_expr ppf).
Definition print_expr_unwrapped
(ppf : Stdlib.Format.formatter)
(expr :
Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) : unit :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply expr Michelson_v1_primitives.strings_of_prims)
(Micheline.inject_locations
(fun function_parameter =>
let '_ := function_parameter in
anon))) (print_expr_unwrapped ppf).
Definition print_var_annots (ppf : Stdlib.Format.formatter)
: (list string) -> unit :=
List.iter
(Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
CamlinternalFormatBasics.End_of_format)) "%s " % string)).
Definition print_annot_expr_unwrapped
(ppf : Stdlib.Format.formatter)
(function_parameter :
(Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
(list string)) : unit :=
let '(expr, annot) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
"%a%a" % string) print_var_annots annot print_expr_unwrapped expr.
Definition print_stack
(ppf : Stdlib.Format.formatter)
(function_parameter :
list
((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
(list string))) : unit :=
match function_parameter with
| [] =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "[]" % string
CamlinternalFormatBasics.End_of_format) "[]" % string)
| more =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<hov 0>" % string
CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
(CamlinternalFormatBasics.String_literal "[ " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " ]" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<hov 0>[ %a ]@]" % string)
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal ": " % string
CamlinternalFormatBasics.End_of_format)) "@ : " % string)))
print_annot_expr_unwrapped) more
end.
Definition print_execution_trace
(ppf : Stdlib.Format.formatter)
(trace :
list
(Z * Tezos_protocol_alpha.Protocol.Alpha_context.Gas.t *
(list
((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
(option string))))) : unit :=
Format.pp_print_list None
(fun ppf =>
fun function_parameter =>
let '(loc, gas, stack) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "- " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal "location: " % string
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" (remaining gas: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"[ " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" ]" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))
"- @[<v 0>location: %d (remaining gas: %a)@,[ @[<v 0>%a ]@]@]" %
string) loc Gas.pp gas
(Format.pp_print_list None
(fun ppf =>
fun function_parameter =>
let '(e, annot) := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<v 0>%a %s@]" % string) print_expr e
match annot with
| None => "" % string
| Some a => a
end)) stack) ppf trace.
Definition print_big_map_diff
(ppf : Stdlib.Format.formatter)
(diff :
list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.big_map_diff_item)
: unit :=
let pp_map
(ppf : Stdlib.Format.formatter) (id : Tezos_base__TzPervasives.Compare.Z.t)
: unit :=
if op_lt id Z.zero then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "temp(" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))) "temp(%s)" % string)
(Z.to_string (Z.neg id))
else
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "map(" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format))) "map(%s)" % string)
(Z.to_string id) in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))) "@[<v 0>%a@]" % string)
(Format.pp_print_list (Some Format.pp_print_space)
(fun ppf =>
fun function_parameter =>
match function_parameter with
| Tezos_protocol_alpha.Protocol.Alpha_context.Contract.Clear id =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Clear " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "Clear %a" % string)
pp_map id
|
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.Alloc {|
big_map := big_map;
key_type := key_type;
value_type := value_type
|} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "New " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" of type (big_map " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))))
"New %a of type (big_map %a %a)" % string) pp_map big_map
print_expr key_type print_expr value_type
| Tezos_protocol_alpha.Protocol.Alpha_context.Contract.Copy src dst =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Copy " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " to " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Copy %a to %a" % string) pp_map src pp_map dst
|
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.Update {|
big_map := big_map;
diff_key := diff_key;
diff_value := diff_value
|} =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "]" % char
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))))))
"%s %a[%a]%a" % string)
match diff_value with
| None => "Unset" % string
| Some _ => "Set" % string
end pp_map big_map print_expr diff_key
(fun ppf =>
fun function_parameter =>
match function_parameter with
| None => tt
| Some x =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal " to " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
" to %a" % string) print_expr x
end) diff_value
end)) diff.
Definition inject_types
(type_map :
list
(Z *
((list
((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
(list string))) *
(list
((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
(list string))))))
(parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
: Tezos_micheline.Micheline.node Tezos_micheline.Micheline_printer.location
string :=
let fix inject_expr {A : Type}
(function_parameter : Tezos_micheline.Micheline.node Z A)
: Tezos_micheline.Micheline.node Tezos_micheline.Micheline_printer.location
A :=
match function_parameter with
| Tezos_micheline.Micheline.Seq loc items =>
Tezos_micheline.Micheline.Seq
(inject_loc
(* ❌ Variants not supported *)
variant loc) (List.map inject_expr items)
| Tezos_micheline.Micheline.Prim loc name items annot =>
Tezos_micheline.Micheline.Prim
(inject_loc
(* ❌ Variants not supported *)
variant loc) name (List.map inject_expr items) annot
| Tezos_micheline.Micheline.Int loc value =>
Tezos_micheline.Micheline.Int
(inject_loc
(* ❌ Variants not supported *)
variant loc) value
| Tezos_micheline.Micheline.String loc value =>
Tezos_micheline.Micheline.String
(inject_loc
(* ❌ Variants not supported *)
variant loc) value
| Tezos_micheline.Micheline.Bytes loc value =>
Tezos_micheline.Micheline.Bytes
(inject_loc
(* ❌ Variants not supported *)
variant loc) value
end
with inject_loc (which : variant) (loc : Z)
: Tezos_micheline.Micheline_printer.location :=
(* ❌ Try-with are not handled *)
try
(let stack :=
let locs :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(List.assoc loc (Michelson_v1_parser.expansion_table parsed)) snd)
(List.sort OCaml.Stdlib.compare) in
let '(bef, aft) := List.assoc (List.hd locs) type_map in
match which with
| before => bef
| after => aft
end in
{|
comment :=
Some
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
print_stack stack) |}) in
inject_expr (root (unexpanded parsed)).
Definition unparse {A B : Type}
(type_map :
option
(list
(Tezos_micheline.Micheline.canonical_location *
((list
((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
(list string))) *
(list
((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
(list string))))))) (parse : string -> A * (list B))
(expanded :
Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) : A :=
let source :=
match type_map with
| Some type_map =>
let '(unexpanded, unexpansion_table) :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply expanded
Michelson_v1_primitives.strings_of_prims) root)
Michelson_v1_macros.unexpand_rec) Micheline.extract_locations in
let fix inject_expr {C : Type}
(function_parameter :
Tezos_micheline.Micheline.node
Tezos_micheline.Micheline.canonical_location C)
: Tezos_micheline.Micheline.node
Tezos_micheline.Micheline_printer.location C :=
match function_parameter with
| Tezos_micheline.Micheline.Seq loc items =>
Tezos_micheline.Micheline.Seq
(inject_loc
(* ❌ Variants not supported *)
variant loc) (List.map inject_expr items)
| Tezos_micheline.Micheline.Prim loc name items annot =>
Tezos_micheline.Micheline.Prim
(inject_loc
(* ❌ Variants not supported *)
variant loc) name (List.map inject_expr items) annot
| Tezos_micheline.Micheline.Int loc value =>
Tezos_micheline.Micheline.Int
(inject_loc
(* ❌ Variants not supported *)
variant loc) value
| Tezos_micheline.Micheline.String loc value =>
Tezos_micheline.Micheline.String
(inject_loc
(* ❌ Variants not supported *)
variant loc) value
| Tezos_micheline.Micheline.Bytes loc value =>
Tezos_micheline.Micheline.Bytes
(inject_loc
(* ❌ Variants not supported *)
variant loc) value
end
with inject_loc
(which : variant) (loc : Tezos_micheline.Micheline.canonical_location)
: Tezos_micheline.Micheline_printer.location :=
(* ❌ Try-with are not handled *)
try
(let stack :=
let '(bef, aft) :=
List.assoc (List.assoc loc unexpansion_table) type_map in
match which with
| before => bef
| after => aft
end in
{|
comment :=
Some
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
print_stack stack) |}) in
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply unexpanded root)
inject_expr)
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Micheline_printer.print_expr)
| None =>
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply expanded
Michelson_v1_primitives.strings_of_prims) root)
Michelson_v1_macros.unexpand_rec) Micheline.strip_locations)
(Micheline_printer.printable None (fun n => n)))
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Micheline_printer.print_expr)
end in
match parse source with
| (res, []) => res
| (_, cons _ _) => Pervasives.failwith "Michelson_v1_printer.unparse" % string
end.
Definition unparse_toplevel
(type_map :
option
(list
(Tezos_micheline.Micheline.canonical_location *
((list
((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
(list string))) *
(list
((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
(list string)))))))
: (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) ->
Tezos_client_alpha.Michelson_v1_parser.parsed :=
unparse type_map
(let arg := Michelson_v1_parser.parse_toplevel in
fun eta => arg None eta).
Definition unparse_expression
: (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) ->
Tezos_client_alpha.Michelson_v1_parser.parsed :=
unparse None
(let arg := Michelson_v1_parser.parse_expression in
fun eta => arg None eta).
Definition unparse_invalid
(expanded : Tezos_micheline.Micheline.canonical string)
: Tezos_client_alpha.Michelson_v1_parser.parsed :=
let source :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply expanded root)
Michelson_v1_macros.unexpand_rec) Micheline.strip_locations)
(Micheline_printer.printable None (fun n => n)))
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) Micheline_printer.print_expr_unwrapped) in
fst (Michelson_v1_parser.parse_toplevel None source).
src/proto_alpha/lib_client/operation_result.ml 87 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Apply_results
let pp_manager_operation_content (type kind) source internal pp_result ppf
((operation, result) : kind manager_operation * _) =
Format.fprintf ppf "@[<v 0>" ;
( match operation with
| Transaction {destination; amount; parameters; entrypoint} ->
Format.fprintf
ppf
"@[<v 2>%s:@,Amount: %s%a@,From: %a@,To: %a"
(if internal then "Internal transaction" else "Transaction")
Client_proto_args.tez_sym
Tez.pp
amount
Contract.pp
source
Contract.pp
destination ;
( match entrypoint with
| "default" ->
()
| _ ->
Format.fprintf ppf "@,Entrypoint: %s" entrypoint ) ;
( if not (Script_repr.is_unit_parameter parameters) then
let expr =
Option.unopt_exn
(Failure "ill-serialized argument")
(Data_encoding.force_decode parameters)
in
Format.fprintf
ppf
"@,Parameter: @[<v 0>%a@]"
Michelson_v1_printer.print_expr
expr ) ;
pp_result ppf result ; Format.fprintf ppf "@]"
| Origination {delegate; credit; script = {code; storage}; preorigination = _}
->
Format.fprintf
ppf
"@[<v 2>%s:@,From: %a@,Credit: %s%a"
(if internal then "Internal origination" else "Origination")
Contract.pp
source
Client_proto_args.tez_sym
Tez.pp
credit ;
let code =
Option.unopt_exn
(Failure "ill-serialized code")
(Data_encoding.force_decode code)
and storage =
Option.unopt_exn
(Failure "ill-serialized storage")
(Data_encoding.force_decode storage)
in
let {Michelson_v1_parser.source; _} =
Michelson_v1_printer.unparse_toplevel code
in
Format.fprintf
ppf
"@,@[<hv 2>Script:@ @[<h>%a@]@,@[<hv 2>Initial storage:@ %a@]"
Format.pp_print_text
source
Michelson_v1_printer.print_expr
storage ;
( match delegate with
| None ->
Format.fprintf ppf "@,No delegate for this contract"
| Some delegate ->
Format.fprintf
ppf
"@,Delegate: %a"
Signature.Public_key_hash.pp
delegate ) ;
pp_result ppf result ; Format.fprintf ppf "@]"
| Reveal key ->
Format.fprintf
ppf
"@[<v 2>%s of manager public key:@,Contract: %a@,Key: %a%a@]"
(if internal then "Internal revelation" else "Revelation")
Contract.pp
source
Signature.Public_key.pp
key
pp_result
result
| Delegation None ->
Format.fprintf
ppf
"@[<v 2>%s:@,Contract: %a@,To: nobody%a@]"
(if internal then "Internal Delegation" else "Delegation")
Contract.pp
source
pp_result
result
| Delegation (Some delegate) ->
Format.fprintf
ppf
"@[<v 2>%s:@,Contract: %a@,To: %a%a@]"
(if internal then "Internal Delegation" else "Delegation")
Contract.pp
source
Signature.Public_key_hash.pp
delegate
pp_result
result ) ;
Format.fprintf ppf "@]"
let pp_balance_updates ppf = function
| [] ->
()
| balance_updates ->
let open Delegate in
let balance_updates =
List.map
(fun (balance, update) ->
let balance =
match balance with
| Contract c ->
Format.asprintf "%a" Contract.pp c
| Rewards (pkh, l) ->
Format.asprintf
"rewards(%a,%a)"
Signature.Public_key_hash.pp
pkh
Cycle.pp
l
| Fees (pkh, l) ->
Format.asprintf
"fees(%a,%a)"
Signature.Public_key_hash.pp
pkh
Cycle.pp
l
| Deposits (pkh, l) ->
Format.asprintf
"deposits(%a,%a)"
Signature.Public_key_hash.pp
pkh
Cycle.pp
l
in
(balance, update))
balance_updates
in
let column_size =
List.fold_left
(fun acc (balance, _) -> Compare.Int.max acc (String.length balance))
0
balance_updates
in
let pp_update ppf = function
| Credited amount ->
Format.fprintf ppf "+%s%a" Client_proto_args.tez_sym Tez.pp amount
| Debited amount ->
Format.fprintf ppf "-%s%a" Client_proto_args.tez_sym Tez.pp amount
in
let pp_one ppf (balance, update) =
let to_fill = column_size + 3 - String.length balance in
let filler = String.make to_fill '.' in
Format.fprintf ppf "%s %s %a" balance filler pp_update update
in
Format.fprintf
ppf
"@[<v 0>%a@]"
(Format.pp_print_list pp_one)
balance_updates
let pp_manager_operation_contents_and_result ppf
( Manager_operation
{source; fee; operation; counter; gas_limit; storage_limit},
Manager_operation_result
{balance_updates; operation_result; internal_operation_results} ) =
let pp_transaction_result
(Transaction_result
{ balance_updates;
consumed_gas;
storage;
originated_contracts;
storage_size;
paid_storage_size_diff;
big_map_diff;
allocated_destination_contract = _ }) =
( match originated_contracts with
| [] ->
()
| contracts ->
Format.fprintf
ppf
"@,@[<v 2>Originated contracts:@,%a@]"
(Format.pp_print_list Contract.pp)
contracts ) ;
( match storage with
| None ->
()
| Some expr ->
Format.fprintf
ppf
"@,@[<hv 2>Updated storage:@ %a@]"
Michelson_v1_printer.print_expr
expr ) ;
( match big_map_diff with
| None | Some [] ->
()
| Some diff ->
Format.fprintf
ppf
"@,@[<v 2>Updated big_maps:@ %a@]"
Michelson_v1_printer.print_big_map_diff
diff ) ;
if storage_size <> Z.zero then
Format.fprintf ppf "@,Storage size: %s bytes" (Z.to_string storage_size) ;
if paid_storage_size_diff <> Z.zero then
Format.fprintf
ppf
"@,Paid storage size diff: %s bytes"
(Z.to_string paid_storage_size_diff) ;
Format.fprintf ppf "@,Consumed gas: %s" (Z.to_string consumed_gas) ;
match balance_updates with
| [] ->
()
| balance_updates ->
Format.fprintf
ppf
"@,Balance updates:@, %a"
pp_balance_updates
balance_updates
in
let pp_origination_result
(Origination_result
{ big_map_diff;
balance_updates;
consumed_gas;
originated_contracts;
storage_size;
paid_storage_size_diff }) =
( match originated_contracts with
| [] ->
()
| contracts ->
Format.fprintf
ppf
"@,@[<v 2>Originated contracts:@,%a@]"
(Format.pp_print_list Contract.pp)
contracts ) ;
if storage_size <> Z.zero then
Format.fprintf ppf "@,Storage size: %s bytes" (Z.to_string storage_size) ;
( match big_map_diff with
| None | Some [] ->
()
| Some diff ->
Format.fprintf
ppf
"@,@[<v 2>Updated big_maps:@ %a@]"
Michelson_v1_printer.print_big_map_diff
diff ) ;
if paid_storage_size_diff <> Z.zero then
Format.fprintf
ppf
"@,Paid storage size diff: %s bytes"
(Z.to_string paid_storage_size_diff) ;
Format.fprintf ppf "@,Consumed gas: %s" (Z.to_string consumed_gas) ;
match balance_updates with
| [] ->
()
| balance_updates ->
Format.fprintf
ppf
"@,Balance updates:@, %a"
pp_balance_updates
balance_updates
in
let pp_result (type kind) ppf (result : kind manager_operation_result) =
Format.fprintf ppf "@," ;
match result with
| Skipped _ ->
Format.fprintf ppf "This operation was skipped"
| Failed (_, _errs) ->
Format.fprintf ppf "This operation FAILED."
| Applied (Reveal_result {consumed_gas}) ->
Format.fprintf ppf "This revelation was successfully applied" ;
Format.fprintf ppf "@,Consumed gas: %s" (Z.to_string consumed_gas)
| Backtracked (Reveal_result _, _) ->
Format.fprintf
ppf
"@[<v 0>This revelation was BACKTRACKED, its expected effects were \
NOT applied.@]"
| Applied (Delegation_result {consumed_gas}) ->
Format.fprintf ppf "This delegation was successfully applied" ;
Format.fprintf ppf "@,Consumed gas: %s" (Z.to_string consumed_gas)
| Backtracked (Delegation_result _, _) ->
Format.fprintf
ppf
"@[<v 0>This delegation was BACKTRACKED, its expected effects were \
NOT applied.@]"
| Applied (Transaction_result _ as tx) ->
Format.fprintf ppf "This transaction was successfully applied" ;
pp_transaction_result tx
| Backtracked ((Transaction_result _ as tx), _errs) ->
Format.fprintf
ppf
"@[<v 0>This transaction was BACKTRACKED, its expected effects (as \
follow) were NOT applied.@]" ;
pp_transaction_result tx
| Applied (Origination_result _ as op) ->
Format.fprintf ppf "This origination was successfully applied" ;
pp_origination_result op
| Backtracked ((Origination_result _ as op), _errs) ->
Format.fprintf
ppf
"@[<v 0>This origination was BACKTRACKED, its expected effects (as \
follow) were NOT applied.@]" ;
pp_origination_result op
in
Format.fprintf
ppf
"@[<v 0>@[<v 2>Manager signed operations:@,\
From: %a@,\
Fee to the baker: %s%a@,\
Expected counter: %s@,\
Gas limit: %s@,\
Storage limit: %s bytes"
Signature.Public_key_hash.pp
source
Client_proto_args.tez_sym
Tez.pp
fee
(Z.to_string counter)
(Z.to_string gas_limit)
(Z.to_string storage_limit) ;
( match balance_updates with
| [] ->
()
| balance_updates ->
Format.fprintf
ppf
"@,Balance updates:@, %a"
pp_balance_updates
balance_updates ) ;
Format.fprintf
ppf
"@,%a"
(pp_manager_operation_content
(Contract.implicit_contract source)
false
pp_result)
(operation, operation_result) ;
( match internal_operation_results with
| [] ->
()
| _ :: _ ->
Format.fprintf
ppf
"@,@[<v 2>Internal operations:@ %a@]"
(Format.pp_print_list (fun ppf (Internal_operation_result (op, res)) ->
pp_manager_operation_content
op.source
false
pp_result
ppf
(op.operation, res)))
internal_operation_results ) ;
Format.fprintf ppf "@]"
let rec pp_contents_and_result_list :
type kind. Format.formatter -> kind contents_and_result_list -> unit =
fun ppf -> function
| Single_and_result
(Seed_nonce_revelation {level; nonce}, Seed_nonce_revelation_result bus)
->
Format.fprintf
ppf
"@[<v 2>Seed nonce revelation:@,\
Level: %a@,\
Nonce (hash): %a@,\
Balance updates:@,\
\ %a@]"
Raw_level.pp
level
Nonce_hash.pp
(Nonce.hash nonce)
pp_balance_updates
bus
| Single_and_result
(Double_baking_evidence {bh1; bh2}, Double_baking_evidence_result bus) ->
Format.fprintf
ppf
"@[<v 2>Double baking evidence:@,\
Exhibit A: %a@,\
Exhibit B: %a@,\
Balance updates:@,\
\ %a@]"
Block_hash.pp
(Block_header.hash bh1)
Block_hash.pp
(Block_header.hash bh2)
pp_balance_updates
bus
| Single_and_result
( Double_endorsement_evidence {op1; op2},
Double_endorsement_evidence_result bus ) ->
Format.fprintf
ppf
"@[<v 2>Double endorsement evidence:@,\
Exhibit A: %a@,\
Exhibit B: %a@,\
Balance updates:@,\
\ %a@]"
Operation_hash.pp
(Operation.hash op1)
Operation_hash.pp
(Operation.hash op2)
pp_balance_updates
bus
| Single_and_result (Activate_account {id; _}, Activate_account_result bus)
->
Format.fprintf
ppf
"@[<v 2>Genesis account activation:@,\
Account: %a@,\
Balance updates:@,\
\ %a@]"
Ed25519.Public_key_hash.pp
id
pp_balance_updates
bus
| Single_and_result
( Endorsement {level},
Endorsement_result {balance_updates; delegate; slots} ) ->
Format.fprintf
ppf
"@[<v 2>Endorsement:@,\
Level: %a@,\
Balance updates:%a@,\
Delegate: %a@,\
Slots: %a@]"
Raw_level.pp
level
pp_balance_updates
balance_updates
Signature.Public_key_hash.pp
delegate
(Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_int)
slots
| Single_and_result (Proposals {source; period; proposals}, Proposals_result)
->
Format.fprintf
ppf
"@[<v 2>Proposals:@,From: %a@,Period: %a@,Protocols:@, @[<v 0>%a@]@]"
Signature.Public_key_hash.pp
source
Voting_period.pp
period
(Format.pp_print_list Protocol_hash.pp)
proposals
| Single_and_result (Ballot {source; period; proposal; ballot}, Ballot_result)
->
Format.fprintf
ppf
"@[<v 2>Ballot:@,From: %a@,Period: %a@,Protocol: %a@,Vote: %a@]"
Signature.Public_key_hash.pp
source
Voting_period.pp
period
Protocol_hash.pp
proposal
Data_encoding.Json.pp
(Data_encoding.Json.construct Vote.ballot_encoding ballot)
| Single_and_result
((Manager_operation _ as op), (Manager_operation_result _ as res)) ->
Format.fprintf ppf "%a" pp_manager_operation_contents_and_result (op, res)
| Cons_and_result
((Manager_operation _ as op), (Manager_operation_result _ as res), rest)
->
Format.fprintf
ppf
"%a@\n%a"
pp_manager_operation_contents_and_result
(op, res)
pp_contents_and_result_list
rest
let pp_operation_result ppf
((op, res) : 'kind contents_list * 'kind contents_result_list) =
Format.fprintf ppf "@[<v 0>" ;
let contents_and_result_list = Apply_results.pack_contents_list op res in
pp_contents_and_result_list ppf contents_and_result_list ;
Format.fprintf ppf "@]@."
let pp_internal_operation ppf
(Internal_operation {source; operation; nonce = _}) =
pp_manager_operation_content
source
true
(fun _ppf () -> ())
ppf
(operation, ())
src/proto_alpha/lib_client/operation_result.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Import Apply_results.
Definition pp_manager_operation_content {A B : Type}
(source : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
(internal : bool) (pp_result : Stdlib.Format.formatter -> A -> unit)
(ppf : Stdlib.Format.formatter)
(function_parameter :
(Tezos_protocol_alpha.Protocol.Alpha_context.manager_operation B) * A)
: unit :=
let '(operation, result) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match operation with
|
Tezos_protocol_alpha.Protocol.Alpha_context.Transaction {|
amount := amount;
parameters := parameters;
entrypoint := entrypoint;
destination := destination
|} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Amount: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"From: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string
0 0)
(CamlinternalFormatBasics.String_literal
"To: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))))))))))))
"@[<v 2>%s:@,Amount: %s%a@,From: %a@,To: %a" % string)
(if internal then
"Internal transaction" % string
else
"Transaction" % string) Client_proto_args.tez_sym Tez.pp amount
Contract.pp source Contract.pp destination in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match entrypoint with
| "default" % string => tt
| _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Entrypoint: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"@,Entrypoint: %s" % string) entrypoint
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if negb (Script_repr.is_unit_parameter parameters) then
let expr :=
Option.unopt_exn (OCaml.Failure "ill-serialized argument" % string)
(Data_encoding.force_decode parameters) in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Parameter: " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@,Parameter: @[<v 0>%a@]" % string)
Michelson_v1_printer.print_expr expr
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_result ppf result in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format) "@]" % string)
|
Tezos_protocol_alpha.Protocol.Alpha_context.Origination {|
delegate := delegate;
script := {| code := code; storage := storage |};
credit := credit;
preorigination := _
|} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "From: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Credit: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))))))))
"@[<v 2>%s:@,From: %a@,Credit: %s%a" % string)
(if internal then
"Internal origination" % string
else
"Origination" % string) Contract.pp source Client_proto_args.tez_sym
Tez.pp credit in
let code : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr :=
Option.unopt_exn (OCaml.Failure "ill-serialized code" % string)
(Data_encoding.force_decode code)
with storage : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr :=
Option.unopt_exn (OCaml.Failure "ill-serialized storage" % string)
(Data_encoding.force_decode storage) in
let '{| Michelson_v1_parser.source := source |} :=
Michelson_v1_printer.unparse_toplevel None code in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<hv 2>" % string
CamlinternalFormatBasics.End_of_format) "<hv 2>" % string))
(CamlinternalFormatBasics.String_literal "Script:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<h>" % string
CamlinternalFormatBasics.End_of_format)
"<h>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hv 2>" % string
CamlinternalFormatBasics.End_of_format)
"<hv 2>" % string))
(CamlinternalFormatBasics.String_literal
"Initial storage:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string
1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))
"@,@[<hv 2>Script:@ @[<h>%a@]@,@[<hv 2>Initial storage:@ %a@]" %
string) Format.pp_print_text source
Michelson_v1_printer.print_expr storage in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match delegate with
| None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"No delegate for this contract" % string
CamlinternalFormatBasics.End_of_format))
"@,No delegate for this contract" % string)
| Some delegate =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Delegate: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))
"@,Delegate: %a" % string) Signature.Public_key_hash.pp delegate
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_result ppf result in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format) "@]" % string)
| Tezos_protocol_alpha.Protocol.Alpha_context.Reveal key =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" of manager public key:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Contract: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Key: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))
"@[<v 2>%s of manager public key:@,Contract: %a@,Key: %a%a@]" % string)
(if internal then
"Internal revelation" % string
else
"Revelation" % string) Contract.pp source Signature.Public_key.pp key
pp_result result
| Tezos_protocol_alpha.Protocol.Alpha_context.Delegation None =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Contract: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"To: nobody" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))
"@[<v 2>%s:@,Contract: %a@,To: nobody%a@]" % string)
(if internal then
"Internal Delegation" % string
else
"Delegation" % string) Contract.pp source pp_result result
| Tezos_protocol_alpha.Protocol.Alpha_context.Delegation (Some delegate) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ":" % char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Contract: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "To: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))
"@[<v 2>%s:@,Contract: %a@,To: %a%a@]" % string)
(if internal then
"Internal Delegation" % string
else
"Delegation" % string) Contract.pp source Signature.Public_key_hash.pp
delegate pp_result result
end in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format) "@]" % string).
Definition pp_balance_updates
(ppf : Stdlib.Format.formatter)
(function_parameter :
list
(Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.balance *
Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.balance_update))
: unit :=
match function_parameter with
| [] => tt
| balance_updates =>
let balance_updates :=
List.map
(fun function_parameter =>
let '(balance, update) := function_parameter in
let balance :=
match balance with
| Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.Contract c =>
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Contract.pp c
| Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.Rewards pkh l
=>
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "rewards(" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "," % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"rewards(%a,%a)" % string) Signature.Public_key_hash.pp pkh
Cycle.pp l
| Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.Fees pkh l =>
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "fees(" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "," % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"fees(%a,%a)" % string) Signature.Public_key_hash.pp pkh
Cycle.pp l
|
Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.Deposits pkh
l =>
Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "deposits(" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "," % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))))
"deposits(%a,%a)" % string) Signature.Public_key_hash.pp pkh
Cycle.pp l
end in
(balance, update)) balance_updates in
let column_size :=
List.fold_left
(fun acc =>
fun function_parameter =>
let '(balance, _) := function_parameter in
Compare.Int.max acc (String.length balance)) 0 balance_updates in
let pp_update
(ppf : Stdlib.Format.formatter) (function_parameter :
Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.balance_update)
: unit :=
match function_parameter with
| Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.Credited amount =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "+" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))) "+%s%a" % string)
Client_proto_args.tez_sym Tez.pp amount
| Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.Debited amount =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "-" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))) "-%s%a" % string)
Client_proto_args.tez_sym Tez.pp amount
end in
let pp_one
(ppf : Stdlib.Format.formatter) (function_parameter :
string *
Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.balance_update)
: unit :=
let '(balance, update) := function_parameter in
let to_fill := Z.sub (Z.add column_size 3) (String.length balance) in
let filler := String.make to_fill "." % char in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))))
"%s %s %a" % string) balance filler pp_update update in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))) "@[<v 0>%a@]" % string)
(Format.pp_print_list None pp_one) balance_updates
end.
Definition pp_manager_operation_contents_and_result {A B : Type}
(ppf : Stdlib.Format.formatter)
(function_parameter :
(Tezos_protocol_alpha.Protocol.Alpha_context.contents
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager A)) *
(Tezos_protocol_alpha.Protocol.Apply_results.contents_result
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager B))) : unit :=
let
'(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation {|
source := source;
fee := fee;
counter := counter;
operation := operation;
gas_limit := gas_limit;
storage_limit := storage_limit
|},
Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result {|
balance_updates := balance_updates;
operation_result := operation_result;
internal_operation_results := internal_operation_results
|}) := function_parameter in
let pp_transaction_result
(function_parameter :
Tezos_protocol_alpha.Protocol.Apply_results.successful_manager_operation_result
Tezos_raw_protocol_alpha.Alpha_context.Kind.transaction) : unit :=
let
'Tezos_protocol_alpha.Protocol.Apply_results.Transaction_result {|
storage := storage;
big_map_diff := big_map_diff;
balance_updates := balance_updates;
originated_contracts := originated_contracts;
consumed_gas := consumed_gas;
storage_size := storage_size;
paid_storage_size_diff := paid_storage_size_diff;
allocated_destination_contract := _
|} := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match originated_contracts with
| [] => tt
| contracts =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Originated contracts:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@,@[<v 2>Originated contracts:@,%a@]" % string)
(Format.pp_print_list None Contract.pp) contracts
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match storage with
| None => tt
| Some expr =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<hv 2>" % string
CamlinternalFormatBasics.End_of_format) "<hv 2>" % string))
(CamlinternalFormatBasics.String_literal
"Updated storage:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@,@[<hv 2>Updated storage:@ %a@]" % string)
Michelson_v1_printer.print_expr expr
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match big_map_diff with
| None | Some [] => tt
| Some diff =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Updated big_maps:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@,@[<v 2>Updated big_maps:@ %a@]" % string)
Michelson_v1_printer.print_big_map_diff diff
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb storage_size Z.zero then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Storage size: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " bytes" % string
CamlinternalFormatBasics.End_of_format))))
"@,Storage size: %s bytes" % string) (Z.to_string storage_size)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb paid_storage_size_diff Z.zero then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Paid storage size diff: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " bytes" % string
CamlinternalFormatBasics.End_of_format))))
"@,Paid storage size diff: %s bytes" % string)
(Z.to_string paid_storage_size_diff)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Consumed gas: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"@,Consumed gas: %s" % string) (Z.to_string consumed_gas) in
match balance_updates with
| [] => tt
| balance_updates =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Balance updates:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal " " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))))
"@,Balance updates:@, %a" % string) pp_balance_updates
balance_updates
end in
let pp_origination_result
(function_parameter :
Tezos_protocol_alpha.Protocol.Apply_results.successful_manager_operation_result
Tezos_raw_protocol_alpha.Alpha_context.Kind.origination) : unit :=
let
'Tezos_protocol_alpha.Protocol.Apply_results.Origination_result {|
big_map_diff := big_map_diff;
balance_updates := balance_updates;
originated_contracts := originated_contracts;
consumed_gas := consumed_gas;
storage_size := storage_size;
paid_storage_size_diff := paid_storage_size_diff
|} := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match originated_contracts with
| [] => tt
| contracts =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Originated contracts:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@,@[<v 2>Originated contracts:@,%a@]" % string)
(Format.pp_print_list None Contract.pp) contracts
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb storage_size Z.zero then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Storage size: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " bytes" % string
CamlinternalFormatBasics.End_of_format))))
"@,Storage size: %s bytes" % string) (Z.to_string storage_size)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match big_map_diff with
| None | Some [] => tt
| Some diff =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Updated big_maps:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@,@[<v 2>Updated big_maps:@ %a@]" % string)
Michelson_v1_printer.print_big_map_diff diff
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if nequiv_decb paid_storage_size_diff Z.zero then
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Paid storage size diff: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal " bytes" % string
CamlinternalFormatBasics.End_of_format))))
"@,Paid storage size diff: %s bytes" % string)
(Z.to_string paid_storage_size_diff)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Consumed gas: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"@,Consumed gas: %s" % string) (Z.to_string consumed_gas) in
match balance_updates with
| [] => tt
| balance_updates =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Balance updates:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal " " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))))
"@,Balance updates:@, %a" % string) pp_balance_updates
balance_updates
end in
let pp_result {C : Type}
(ppf : Stdlib.Format.formatter) (result :
Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result C)
: unit :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
CamlinternalFormatBasics.End_of_format) "@," % string) in
match result with
| Tezos_protocol_alpha.Protocol.Apply_results.Skipped _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This operation was skipped" % string
CamlinternalFormatBasics.End_of_format)
"This operation was skipped" % string)
| Tezos_protocol_alpha.Protocol.Apply_results.Failed _ _errs =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This operation FAILED." % string
CamlinternalFormatBasics.End_of_format)
"This operation FAILED." % string)
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Reveal_result {|
consumed_gas := consumed_gas |}) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This revelation was successfully applied" % string
CamlinternalFormatBasics.End_of_format)
"This revelation was successfully applied" % string) in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Consumed gas: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"@,Consumed gas: %s" % string) (Z.to_string consumed_gas)
|
Tezos_protocol_alpha.Protocol.Apply_results.Backtracked
(Tezos_protocol_alpha.Protocol.Apply_results.Reveal_result _) _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"This revelation was BACKTRACKED, its expected effects were NOT applied."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))
"@[<v 0>This revelation was BACKTRACKED, its expected effects were NOT applied.@]"
% string)
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Delegation_result {|
consumed_gas := consumed_gas |}) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This delegation was successfully applied" % string
CamlinternalFormatBasics.End_of_format)
"This delegation was successfully applied" % string) in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Consumed gas: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"@,Consumed gas: %s" % string) (Z.to_string consumed_gas)
|
Tezos_protocol_alpha.Protocol.Apply_results.Backtracked
(Tezos_protocol_alpha.Protocol.Apply_results.Delegation_result _) _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"This delegation was BACKTRACKED, its expected effects were NOT applied."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))
"@[<v 0>This delegation was BACKTRACKED, its expected effects were NOT applied.@]"
% string)
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
((Tezos_protocol_alpha.Protocol.Apply_results.Transaction_result _) as
tx) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This transaction was successfully applied" % string
CamlinternalFormatBasics.End_of_format)
"This transaction was successfully applied" % string) in
pp_transaction_result tx
|
Tezos_protocol_alpha.Protocol.Apply_results.Backtracked
((Tezos_protocol_alpha.Protocol.Apply_results.Transaction_result _) as
tx) _errs =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"This transaction was BACKTRACKED, its expected effects (as follow) were NOT applied."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))
"@[<v 0>This transaction was BACKTRACKED, its expected effects (as follow) were NOT applied.@]"
% string) in
pp_transaction_result tx
|
Tezos_protocol_alpha.Protocol.Apply_results.Applied
((Tezos_protocol_alpha.Protocol.Apply_results.Origination_result _) as
op) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This origination was successfully applied" % string
CamlinternalFormatBasics.End_of_format)
"This origination was successfully applied" % string) in
pp_origination_result op
|
Tezos_protocol_alpha.Protocol.Apply_results.Backtracked
((Tezos_protocol_alpha.Protocol.Apply_results.Origination_result _) as
op) _errs =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"This origination was BACKTRACKED, its expected effects (as follow) were NOT applied."
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))
"@[<v 0>This origination was BACKTRACKED, its expected effects (as follow) were NOT applied.@]"
% string) in
pp_origination_result op
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Manager signed operations:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "From: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Fee to the baker: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Expected counter: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Gas limit: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Storage limit: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" bytes" % string
CamlinternalFormatBasics.End_of_format))))))))))))))))))))
"@[<v 0>@[<v 2>Manager signed operations:@,From: %a@,Fee to the baker: %s%a@,Expected counter: %s@,Gas limit: %s@,Storage limit: %s bytes"
% string) Signature.Public_key_hash.pp source
Client_proto_args.tez_sym Tez.pp fee (Z.to_string counter)
(Z.to_string gas_limit) (Z.to_string storage_limit) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match balance_updates with
| [] => tt
| balance_updates =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Balance updates:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal " " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))))
"@,Balance updates:@, %a" % string) pp_balance_updates
balance_updates
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
"@,%a" % string)
(pp_manager_operation_content (Contract.implicit_contract source) false
pp_result) (operation, operation_result) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match internal_operation_results with
| [] => tt
| cons _ _ =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Internal operations:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@,@[<v 2>Internal operations:@ %a@]" % string)
(Format.pp_print_list None
(fun ppf =>
fun function_parameter =>
let
'Tezos_protocol_alpha.Protocol.Apply_results.Internal_operation_result
op res := function_parameter in
pp_manager_operation_content (source op) false pp_result ppf
((operation op), res))) internal_operation_results
end in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format) "@]" % string).
Fixpoint pp_contents_and_result_list {kind : Type}
(ppf : Stdlib.Format.formatter)
(function_parameter :
Tezos_protocol_alpha.Protocol.Apply_results.contents_and_result_list kind)
: unit :=
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Seed_nonce_revelation {|
level := level; nonce := nonce |})
(Tezos_protocol_alpha.Protocol.Apply_results.Seed_nonce_revelation_result
bus) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Seed nonce revelation:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Level: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Nonce (hash): " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Balance updates:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))
"@[<v 2>Seed nonce revelation:@,Level: %a@,Nonce (hash): %a@,Balance updates:@, %a@]"
% string) Raw_level.pp level Nonce_hash.pp (Nonce.hash nonce)
pp_balance_updates bus
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Double_baking_evidence {|
bh1 := bh1; bh2 := bh2 |})
(Tezos_protocol_alpha.Protocol.Apply_results.Double_baking_evidence_result
bus) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Double baking evidence:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Exhibit A: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Exhibit B: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Balance updates:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))
"@[<v 2>Double baking evidence:@,Exhibit A: %a@,Exhibit B: %a@,Balance updates:@, %a@]"
% string) Block_hash.pp (Block_header.hash bh1) Block_hash.pp
(Block_header.hash bh2) pp_balance_updates bus
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Double_endorsement_evidence
{| op1 := op1; op2 := op2 |})
(Tezos_protocol_alpha.Protocol.Apply_results.Double_endorsement_evidence_result
bus) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Double endorsement evidence:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Exhibit A: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Exhibit B: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Balance updates:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))
"@[<v 2>Double endorsement evidence:@,Exhibit A: %a@,Exhibit B: %a@,Balance updates:@, %a@]"
% string) Operation_hash.pp (Operation.hash op1) Operation_hash.pp
(Operation.hash op2) pp_balance_updates bus
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Activate_account {|
id := id |})
(Tezos_protocol_alpha.Protocol.Apply_results.Activate_account_result bus)
=>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Genesis account activation:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Account: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Balance updates:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal " " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))
"@[<v 2>Genesis account activation:@,Account: %a@,Balance updates:@, %a@]"
% string) Ed25519.Public_key_hash.pp id pp_balance_updates bus
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Endorsement {|
level := level |})
(Tezos_protocol_alpha.Protocol.Apply_results.Endorsement_result {|
balance_updates := balance_updates;
delegate := delegate;
slots := slots
|}) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Endorsement:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Level: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Balance updates:" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Delegate: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0
0)
(CamlinternalFormatBasics.String_literal
"Slots: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))))
"@[<v 2>Endorsement:@,Level: %a@,Balance updates:%a@,Delegate: %a@,Slots: %a@]"
% string) Raw_level.pp level pp_balance_updates balance_updates
Signature.Public_key_hash.pp delegate
(Format.pp_print_list (Some Format.pp_print_space) Format.pp_print_int)
slots
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Proposals {|
source := source; period := period; proposals := proposals |})
Tezos_protocol_alpha.Protocol.Apply_results.Proposals_result =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Proposals:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "From: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Period: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Protocols:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
" " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))))))))
"@[<v 2>Proposals:@,From: %a@,Period: %a@,Protocols:@, @[<v 0>%a@]@]" %
string) Signature.Public_key_hash.pp source Voting_period.pp period
(Format.pp_print_list None Protocol_hash.pp) proposals
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Ballot {|
source := source;
period := period;
proposal := proposal;
ballot := ballot
|}) Tezos_protocol_alpha.Protocol.Apply_results.Ballot_result =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 2>" % string
CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
(CamlinternalFormatBasics.String_literal "Ballot:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "From: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal "Period: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Protocol: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@," % string 0
0)
(CamlinternalFormatBasics.String_literal
"Vote: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))))
"@[<v 2>Ballot:@,From: %a@,Period: %a@,Protocol: %a@,Vote: %a@]" %
string) Signature.Public_key_hash.pp source Voting_period.pp period
Protocol_hash.pp proposal Data_encoding.Json.pp
(Data_encoding.Json.construct Vote.ballot_encoding ballot)
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation _) as op)
((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result _)
as res) =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) pp_manager_operation_contents_and_result (op, res)
|
Tezos_protocol_alpha.Protocol.Apply_results.Cons_and_result
((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation _) as op)
((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result _)
as res) rest =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))) "%a@
%a" % string)
pp_manager_operation_contents_and_result (op, res)
pp_contents_and_result_list rest
end.
Definition pp_operation_result {kind : Type}
(ppf : Stdlib.Format.formatter)
(function_parameter :
(Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind) *
(Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind))
: unit :=
let '(op, res) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v 0>" % string
CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string) in
let contents_and_result_list := Apply_results.pack_contents_list op res in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_contents_and_result_list ppf contents_and_result_list in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)) "@]@." % string).
Definition pp_internal_operation
(ppf : Stdlib.Format.formatter)
(function_parameter :
Tezos_protocol_alpha.Protocol.Alpha_context.packed_internal_operation)
: unit :=
let
'Tezos_protocol_alpha.Protocol.Alpha_context.Internal_operation {|
source := source; operation := operation; nonce := _ |} :=
function_parameter in
pp_manager_operation_content source true
(fun _ppf =>
fun function_parameter =>
let 'tt := function_parameter in
tt) ppf (operation, tt).
src/proto_alpha/lib_client/protocol_client_context.ml 6 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Alpha_block_services = Block_services.Make (Protocol) (Protocol)
(** Client RPC context *)
class type rpc_context =
object
inherit RPC_context.json
inherit
[Shell_services.chain * Shell_services.block] Protocol.Environment
.RPC_context
.simple
end
class wrap_rpc_context (t : RPC_context.json) : rpc_context =
object
method base : Uri.t = t#base
method generic_json_call = t#generic_json_call
method call_service
: 'm 'p 'q 'i 'o.
(([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t -> 'p ->
'q -> 'i -> 'o tzresult Lwt.t =
t#call_service
method call_streamed_service
: 'm 'p 'q 'i 'o.
(([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t ->
on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q -> 'i ->
(unit -> unit) tzresult Lwt.t =
t#call_streamed_service
inherit
[Shell_services.chain, Shell_services.block] Protocol.Environment
.proto_rpc_context
(t :> RPC_context.t)
Shell_services.Blocks.path
end
class type full =
object
inherit Client_context.full
inherit
[Shell_services.chain * Shell_services.block] Protocol.Environment
.RPC_context
.simple
inherit
[Shell_services.chain, Shell_services.block] Protocol.Environment
.proto_rpc_context
end
class wrap_full (t : Client_context.full) : full =
object
inherit Client_context.proxy_context t
inherit
[Shell_services.chain, Shell_services.block] Protocol.Environment
.proto_rpc_context
(t :> RPC_context.t)
Shell_services.Blocks.path
end
let register_error_kind category ~id ~title ~description ?pp encoding
from_error to_error =
let id = "client." ^ Protocol.name ^ "." ^ id in
register_error_kind
category
~id
~title
~description
?pp
encoding
from_error
to_error
let () =
let open Tezos_data_encoding.Data_encoding.Registration in
let open Tezos_data_encoding.Data_encoding in
let stamp_proto id ids = String.concat "." (Protocol.name :: id :: ids) in
register
@@ def (stamp_proto "parameters" []) Protocol.Parameters_repr.encoding ;
register ~pp:Protocol.Alpha_context.Tez.pp
@@ def (stamp_proto "tez" []) Protocol.Alpha_context.Tez.encoding ;
register @@ def (stamp_proto "roll" []) Protocol.Alpha_context.Roll.encoding ;
register ~pp:Protocol.Alpha_context.Fitness.pp
@@ def (stamp_proto "fitness" []) Protocol.Alpha_context.Fitness.encoding ;
register ~pp:Protocol.Alpha_context.Timestamp.pp
@@ def (stamp_proto "timestamp" []) Protocol.Alpha_context.Timestamp.encoding ;
register ~pp:Protocol.Alpha_context.Raw_level.pp
@@ def (stamp_proto "raw_level" []) Protocol.Alpha_context.Raw_level.encoding ;
register
@@ def
(stamp_proto "vote" ["ballot"])
Protocol.Alpha_context.Vote.ballot_encoding ;
register
@@ def
(stamp_proto "vote" ["ballots"])
Protocol.Alpha_context.Vote.ballots_encoding ;
register
@@ def
(stamp_proto "vote" ["listings"])
Protocol.Alpha_context.Vote.listings_encoding ;
register
@@ def (stamp_proto "seed" []) Protocol.Alpha_context.Seed.seed_encoding ;
register ~pp:Protocol.Alpha_context.Gas.pp
@@ def (stamp_proto "gas" []) Protocol.Alpha_context.Gas.encoding ;
register ~pp:Protocol.Alpha_context.Gas.pp_cost
@@ def (stamp_proto "gas" ["cost"]) Protocol.Alpha_context.Gas.cost_encoding ;
register
@@ def (stamp_proto "script" []) Protocol.Alpha_context.Script.encoding ;
register
@@ def
(stamp_proto "script" ["expr"])
Protocol.Alpha_context.Script.expr_encoding ;
register
@@ def
(stamp_proto "script" ["prim"])
Protocol.Alpha_context.Script.prim_encoding ;
register
@@ def
(stamp_proto "script" ["lazy_expr"])
Protocol.Alpha_context.Script.lazy_expr_encoding ;
register
@@ def
(stamp_proto "script" ["loc"])
Protocol.Alpha_context.Script.location_encoding ;
register ~pp:Protocol.Alpha_context.Contract.pp
@@ def (stamp_proto "contract" []) Protocol.Alpha_context.Contract.encoding ;
register
@@ def
(stamp_proto "contract" ["big_map_diff"])
Protocol.Alpha_context.Contract.big_map_diff_encoding ;
register
@@ def
(stamp_proto "delegate" ["frozen_balance"])
Protocol.Alpha_context.Delegate.frozen_balance_encoding ;
register
@@ def
(stamp_proto "delegate" ["balance_updates"])
Protocol.Alpha_context.Delegate.balance_updates_encoding ;
register
@@ def
(stamp_proto "delegate" ["frozen_balance_by_cycles"])
Protocol.Alpha_context.Delegate.frozen_balance_by_cycle_encoding ;
register ~pp:Protocol.Alpha_context.Level.pp_full
@@ def (stamp_proto "level" []) Protocol.Alpha_context.Level.encoding ;
register
@@ def (stamp_proto "operation" []) Protocol.Alpha_context.Operation.encoding ;
register
@@ def
(stamp_proto "operation" ["contents"])
Protocol.Alpha_context.Operation.contents_encoding ;
register
@@ def
(stamp_proto "operation" ["contents_list"])
Protocol.Alpha_context.Operation.contents_list_encoding ;
register
@@ def
(stamp_proto "operation" ["protocol_data"])
Protocol.Alpha_context.Operation.protocol_data_encoding ;
register
@@ def
(stamp_proto "operation" ["raw"])
Protocol.Alpha_context.Operation.raw_encoding ;
register
@@ def
(stamp_proto "operation" ["internal"])
Protocol.Alpha_context.Operation.internal_operation_encoding ;
register
@@ def
(stamp_proto "operation" ["unsigned"])
Protocol.Alpha_context.Operation.unsigned_encoding ;
register ~pp:Protocol.Alpha_context.Period.pp
@@ def (stamp_proto "period" []) Protocol.Alpha_context.Period.encoding ;
register ~pp:Protocol.Alpha_context.Cycle.pp
@@ def (stamp_proto "cycle" []) Protocol.Alpha_context.Cycle.encoding ;
register
@@ def (stamp_proto "constants" []) Protocol.Alpha_context.Constants.encoding ;
register
@@ def
(stamp_proto "constants" ["fixed"])
Protocol.Alpha_context.Constants.fixed_encoding ;
register
@@ def
(stamp_proto "constants" ["parametric"])
Protocol.Alpha_context.Constants.parametric_encoding ;
register
@@ def (stamp_proto "nonce" []) Protocol.Alpha_context.Nonce.encoding ;
register
@@ def
(stamp_proto "block_header" [])
Protocol.Alpha_context.Block_header.encoding ;
register
@@ def
(stamp_proto "block_header" ["unsigned"])
Protocol.Alpha_context.Block_header.unsigned_encoding ;
register
@@ def
(stamp_proto "block_header" ["raw"])
Protocol.Alpha_context.Block_header.raw_encoding ;
register
@@ def
(stamp_proto "block_header" ["contents"])
Protocol.Alpha_context.Block_header.contents_encoding ;
register
@@ def
(stamp_proto "block_header" ["shell_header"])
Protocol.Alpha_context.Block_header.shell_header_encoding ;
register
@@ def
(stamp_proto "block_header" ["protocol_data"])
Protocol.Alpha_context.Block_header.protocol_data_encoding ;
register ~pp:Protocol.Alpha_context.Voting_period.pp
@@ def
(stamp_proto "voting_period" [])
Protocol.Alpha_context.Voting_period.encoding ;
register
@@ def
(stamp_proto "voting_period" ["kind"])
Protocol.Alpha_context.Voting_period.kind_encoding ;
register
@@ Data_encoding.def
(stamp_proto "errors" [])
~description:
"The full list of RPC errors would be too long to include.It is\n\
available through the RPC `/errors` (GET)."
error_encoding
src/proto_alpha/lib_client/protocol_client_context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class` not handled. *)
class
(* ❌ Structure item `class_type` not handled. *)
class_type
(* ❌ Structure item `class` not handled. *)
class
Definition register_error_kind {A : Type}
(category : Tezos_error_monad.Sig.error_category) (id : string)
(title : string) (description : string)
(pp : option (Stdlib.Format.formatter -> A -> unit))
(encoding : Tezos_data_encoding.Data_encoding.t A)
(from_error : Tezos_base__TzPervasives.error -> option A)
(to_error : A -> Tezos_base__TzPervasives.error) : unit :=
let id :=
String.append "client." % string
(String.append Protocol.name (String.append "." % string id)) in
register_error_kind category id title description pp encoding from_error
to_error.
src/proto_alpha/lib_client/test/assert.ml success
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let fail expected given msg =
Format.kasprintf
Pervasives.failwith
"@[%s@ expected: %s@ got: %s@]"
msg
expected
given
let default_printer _ = ""
let equal ?(eq = ( = )) ?(print = default_printer) ?(msg = "") x y =
if not (eq x y) then fail (print x) (print y) msg
src/proto_alpha/lib_client/test/assert.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition fail {A : Type} (expected : string) (given : string) (msg : string)
: A :=
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "expected: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string 1 0)
(CamlinternalFormatBasics.String_literal "got: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))
"@[%s@ expected: %s@ got: %s@]" % string) msg expected given.
Definition default_printer {A : Type} (function_parameter : A) : string :=
let '_ := function_parameter in
"" % string.
Definition equal {A : Type} (op_staroptstar : option (A -> A -> bool))
: (option (A -> string)) -> (option string) -> A -> A -> unit :=
let eq :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => equiv_decb
end in
fun op_staroptstar =>
let print :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_printer
end in
fun op_staroptstar =>
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
fun y =>
if negb (eq x y) then
fail (print x) (print y) msg
else
tt.
src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml 210 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
let print expr : string =
expr
|> Micheline_printer.printable (fun s -> s)
|> Format.asprintf "%a" Micheline_printer.print_expr
(* expands : expression with macros fully expanded *)
let assert_expands
(original : (Micheline_parser.location, string) Micheline.node)
(expanded : (Micheline_parser.location, string) Micheline.node) =
let ({Michelson_v1_parser.expanded = expansion; _}, errors) =
let source = print (Micheline.strip_locations original) in
Michelson_v1_parser.expand_all ~source ~original
in
match errors with
| [] ->
Assert.equal
~print
(Michelson_v1_primitives.strings_of_prims expansion)
(Micheline.strip_locations expanded) ;
ok ()
| errors ->
Error errors
(****************************************************************************)
open Micheline
let zero_loc = Micheline_parser.location_zero
let left_branch = Seq (zero_loc, [Prim (zero_loc, "SWAP", [], [])])
let right_branch = Seq (zero_loc, [])
(***************************************************************************)
(* Test expands *)
(***************************************************************************)
let assert_compare_macro prim_name compare_name =
assert_expands
(Prim (zero_loc, prim_name, [], []))
(Seq
( zero_loc,
[ Prim (zero_loc, "COMPARE", [], []);
Prim (zero_loc, compare_name, [], []) ] ))
let test_compare_marco_expansion () =
assert_compare_macro "CMPEQ" "EQ"
>>? fun () ->
assert_compare_macro "CMPNEQ" "NEQ"
>>? fun () ->
assert_compare_macro "CMPLT" "LT"
>>? fun () ->
assert_compare_macro "CMPGT" "GT"
>>? fun () ->
assert_compare_macro "CMPLE" "LE"
>>? fun () -> assert_compare_macro "CMPGE" "GE"
let assert_if_macro prim_name compare_name =
assert_expands
(Prim (zero_loc, prim_name, [left_branch; right_branch], []))
(Seq
( zero_loc,
[ Prim (zero_loc, compare_name, [], []);
Prim (zero_loc, "IF", [left_branch; right_branch], []) ] ))
let test_if_compare_macros_expansion () =
assert_if_macro "IFEQ" "EQ"
>>? fun () ->
assert_if_macro "IFNEQ" "NEQ"
>>? fun () ->
assert_if_macro "IFLT" "LT"
>>? fun () ->
assert_if_macro "IFGT" "GT"
>>? fun () ->
assert_if_macro "IFLE" "LE" >>? fun () -> assert_if_macro "IFGE" "GE"
let assert_if_cmp_macros prim_name compare_name =
assert_expands
(Prim (zero_loc, prim_name, [left_branch; right_branch], []))
(Seq
( zero_loc,
[ Prim (zero_loc, "COMPARE", [], []);
Prim (zero_loc, compare_name, [], []);
Prim (zero_loc, "IF", [left_branch; right_branch], []) ] ))
let test_if_cmp_macros_expansion () =
assert_if_cmp_macros "IFCMPEQ" "EQ"
>>? fun () ->
assert_if_cmp_macros "IFCMPNEQ" "NEQ"
>>? fun () ->
assert_if_cmp_macros "IFCMPLT" "LT"
>>? fun () ->
assert_if_cmp_macros "IFCMPGT" "GT"
>>? fun () ->
assert_if_cmp_macros "IFCMPLE" "LE"
>>? fun () -> assert_if_cmp_macros "IFCMPGE" "GE"
(****************************************************************************)
(* Fail *)
let test_fail_expansion () =
assert_expands
(Prim (zero_loc, "FAIL", [], []))
(Seq
( zero_loc,
[Prim (zero_loc, "UNIT", [], []); Prim (zero_loc, "FAILWITH", [], [])]
))
(**********************************************************************)
(* assertion *)
let seq_unit_failwith =
Seq
( zero_loc,
[Prim (zero_loc, "UNIT", [], []); Prim (zero_loc, "FAILWITH", [], [])] )
(* {} {FAIL} *)
let fail_false = [Seq (zero_loc, []); Seq (zero_loc, [seq_unit_failwith])]
(* {FAIL} {} *)
let fail_true = [Seq (zero_loc, [seq_unit_failwith]); Seq (zero_loc, [])]
let test_assert_expansion () =
assert_expands
(Prim (zero_loc, "ASSERT", [], []))
(Seq (zero_loc, [Prim (zero_loc, "IF", fail_false, [])]))
let assert_assert_if_compare prim_name compare_name =
assert_expands
(Prim (zero_loc, prim_name, [], []))
(Seq
( zero_loc,
[ Prim (zero_loc, compare_name, [], []);
Prim (zero_loc, "IF", fail_false, []) ] ))
let test_assert_if () =
assert_assert_if_compare "ASSERT_EQ" "EQ"
>>? fun () ->
assert_assert_if_compare "ASSERT_NEQ" "NEQ"
>>? fun () ->
assert_assert_if_compare "ASSERT_LT" "LT"
>>? fun () ->
assert_assert_if_compare "ASSERT_LE" "LE"
>>? fun () ->
assert_assert_if_compare "ASSERT_GT" "GT"
>>? fun () -> assert_assert_if_compare "ASSERT_GE" "GE"
let assert_cmp_if prim_name compare_name =
assert_expands
(Prim (zero_loc, prim_name, [], []))
(Seq
( zero_loc,
[ Seq
( zero_loc,
[ Prim (zero_loc, "COMPARE", [], []);
Prim (zero_loc, compare_name, [], []) ] );
Prim (zero_loc, "IF", fail_false, []) ] ))
let test_assert_cmp_if () =
assert_cmp_if "ASSERT_CMPEQ" "EQ"
>>? fun () ->
assert_cmp_if "ASSERT_CMPNEQ" "NEQ"
>>? fun () ->
assert_cmp_if "ASSERT_CMPLT" "LT"
>>? fun () ->
assert_cmp_if "ASSERT_CMPLE" "LE"
>>? fun () ->
assert_cmp_if "ASSERT_CMPGT" "GT"
>>? fun () -> assert_cmp_if "ASSERT_CMPGE" "GE"
(* The work of merge request !628
> ASSERT_LEFT @x => IF_LEFT {RENAME @x} {FAIL}
> ASSERT_RIGHT @x => IF_LEFT {FAIL} {RENAME @x}
> ASSERT_SOME @x => IF_NONE {FAIL} {RENAME @x}
*)
let may_rename annot = Seq (zero_loc, [Prim (zero_loc, "RENAME", [], annot)])
let fail_false_may_rename =
[ may_rename ["@annot"];
Seq
( zero_loc,
[ Seq
( zero_loc,
[ Prim (zero_loc, "UNIT", [], []);
Prim (zero_loc, "FAILWITH", [], []) ] ) ] ) ]
let fail_true_may_rename =
[ Seq
( zero_loc,
[ Seq
( zero_loc,
[ Prim (zero_loc, "UNIT", [], []);
Prim (zero_loc, "FAILWITH", [], []) ] ) ] );
may_rename ["@annot"] ]
let test_assert_some_annot () =
assert_expands
(Prim (zero_loc, "ASSERT_SOME", [], ["@annot"]))
(Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true_may_rename, [])]))
let test_assert_left_annot () =
assert_expands
(Prim (zero_loc, "ASSERT_LEFT", [], ["@annot"]))
(Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false_may_rename, [])]))
let test_assert_right_annot () =
assert_expands
(Prim (zero_loc, "ASSERT_RIGHT", [], ["@annot"]))
(Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true_may_rename, [])]))
let test_assert_none () =
assert_expands
(Prim (zero_loc, "ASSERT_NONE", [], []))
(Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_false, [])]))
let test_assert_some () =
assert_expands
(Prim (zero_loc, "ASSERT_SOME", [], []))
(Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true, [])]))
let test_assert_left () =
assert_expands
(Prim (zero_loc, "ASSERT_LEFT", [], []))
(Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false, [])]))
let test_assert_right () =
assert_expands
(Prim (zero_loc, "ASSERT_RIGHT", [], []))
(Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true, [])]))
(***********************************************************************)
(*Syntactic Conveniences*)
(* diip *)
let test_diip () =
let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
assert_expands
(Prim (zero_loc, "DIP", [code], []))
(Prim (zero_loc, "DIP", [code], []))
>>? fun () ->
assert_expands
(Prim (zero_loc, "DIIIIIIIIP", [code], []))
(Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 8); code], []))
>>? fun () ->
assert_expands
(Prim (zero_loc, "DIIP", [code], []))
(Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], []))
(* pair *)
let test_pair () =
assert_expands
(Prim (zero_loc, "PAIR", [], []))
(Prim (zero_loc, "PAIR", [], []))
let test_pappaiir () =
let pair = Prim (zero_loc, "PAIR", [], []) in
assert_expands
(Prim (zero_loc, "PAPPAIIR", [], []))
(Seq
( zero_loc,
[ Prim (zero_loc, "DIP", [Seq (zero_loc, [pair])], []);
Prim (zero_loc, "DIP", [Seq (zero_loc, [pair])], []);
pair ] ))
(* unpair *)
let test_unpair () =
assert_expands
(Prim (zero_loc, "UNPAIR", [], []))
(Seq
( zero_loc,
[ Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim (zero_loc, "CAR", [], []);
Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "CDR", [], [])])],
[] ) ] ) ] ))
(* duup *)
let test_duup () =
let dup = Prim (zero_loc, "DUP", [], []) in
assert_expands
(Prim (zero_loc, "DUUP", [], []))
(Seq
( zero_loc,
[ Prim (zero_loc, "DIP", [Seq (zero_loc, [dup])], []);
Prim (zero_loc, "SWAP", [], []) ] ))
(* car/cdr *)
let test_caddadr_expansion () =
let car = Prim (zero_loc, "CAR", [], []) in
assert_expands (Prim (zero_loc, "CAR", [], [])) car
>>? fun () ->
let cdr = Prim (zero_loc, "CDR", [], []) in
assert_expands (Prim (zero_loc, "CDR", [], [])) cdr
>>? fun () ->
assert_expands (Prim (zero_loc, "CADR", [], [])) (Seq (zero_loc, [car; cdr]))
>>? fun () ->
assert_expands (Prim (zero_loc, "CDAR", [], [])) (Seq (zero_loc, [cdr; car]))
(* if_some *)
let test_if_some () =
assert_expands
(Prim (zero_loc, "IF_SOME", [right_branch; left_branch], []))
(Seq
(zero_loc, [Prim (zero_loc, "IF_NONE", [left_branch; right_branch], [])]))
(*set_caddadr*)
let test_set_car_expansion () =
assert_expands
(Prim (zero_loc, "SET_CAR", [], []))
(Seq
( zero_loc,
[ Prim (zero_loc, "CDR", [], ["@%%"]);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] ))
let test_set_cdr_expansion () =
assert_expands
(Prim (zero_loc, "SET_CDR", [], []))
(Seq
( zero_loc,
[ Prim (zero_loc, "CAR", [], ["@%%"]);
Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ))
let test_set_cadr_expansion () =
let set_car =
Seq
( zero_loc,
[ Prim (zero_loc, "CAR", [], ["@%%"]);
Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] )
in
assert_expands
(Prim (zero_loc, "SET_CADR", [], []))
(Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); set_car])],
[] );
Prim (zero_loc, "CDR", [], ["@%%"]);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))
let test_set_cdar_expansion () =
let set_cdr =
Seq
( zero_loc,
[ Prim (zero_loc, "CDR", [], ["@%%"]);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] )
in
assert_expands
(Prim (zero_loc, "SET_CDAR", [], []))
(Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); set_cdr])],
[] );
Prim (zero_loc, "CAR", [], ["@%%"]);
Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))
(* TO BE CHANGE IN THE DOCUMENTATION: @MR!791
FROM:
> MAP_CAR code => DUP ; CDR ; DIP { CAR ; code } ; SWAP ; PAIR
TO:
> MAP_CAR code => DUP ; CDR ; DIP { CAR ; {code} } ; SWAP ; PAIR
*)
let test_map_car () =
(* code is a sequence *)
let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
assert_expands
(Prim (zero_loc, "MAP_CAR", [code], []))
(Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim (zero_loc, "CDR", [], ["@%%"]);
Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "CAR", [], []); code])],
[] );
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] ))
let test_map_cdr () =
let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
assert_expands
(Prim (zero_loc, "MAP_CDR", [code], []))
(Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim (zero_loc, "CDR", [], []);
code;
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "CAR", [], ["@%%"]);
Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ))
let test_map_caadr () =
let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
let map_cdr =
Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim (zero_loc, "CDR", [], []);
code;
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "CAR", [], ["@%%"]);
Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] )
in
let map_cadr =
Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cdr])],
[] );
Prim (zero_loc, "CDR", [], ["@%%"]);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] )
in
assert_expands
(Prim (zero_loc, "MAP_CAADR", [code], []))
(Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cadr])],
[] );
Prim (zero_loc, "CDR", [], ["@%%"]);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))
let test_map_cdadr () =
let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
let map_cdr =
Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim (zero_loc, "CDR", [], []);
code;
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "CAR", [], ["@%%"]);
Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] )
in
let map_cadr =
Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cdr])],
[] );
Prim (zero_loc, "CDR", [], ["@%%"]);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] )
in
assert_expands
(Prim (zero_loc, "MAP_CDADR", [code], []))
(Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); map_cadr])],
[] );
Prim (zero_loc, "CAR", [], ["@%%"]);
Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))
(****************************************************************************)
(* Unexpand tests *)
(****************************************************************************)
(* unpexpanded : original expression with macros *)
let assert_unexpansion original ex =
let ({Michelson_v1_parser.expanded; _}, errors) =
let source = print (Micheline.strip_locations original) in
Michelson_v1_parser.expand_all ~source ~original
in
let unparse = Michelson_v1_printer.unparse_expression expanded in
match errors with
| [] ->
Assert.equal
~print
unparse.Michelson_v1_parser.unexpanded
(Micheline.strip_locations ex) ;
ok ()
| _ :: _ ->
Error errors
let assert_unexpansion_consistent original =
let ({Michelson_v1_parser.expanded; _}, errors) =
let source = print (Micheline.strip_locations original) in
Michelson_v1_parser.expand_all ~source ~original
in
match errors with
| _ :: _ ->
Error errors
| [] ->
let {Michelson_v1_parser.unexpanded; _} =
Michelson_v1_printer.unparse_expression expanded
in
Assert.equal ~print unexpanded (Micheline.strip_locations original) ;
ok ()
let test_unexpand_fail () =
assert_unexpansion
(Seq
( zero_loc,
[Prim (zero_loc, "UNIT", [], []); Prim (zero_loc, "FAILWITH", [], [])]
))
(Prim (zero_loc, "FAIL", [], []))
let test_unexpand_if_right () =
assert_unexpansion
(Seq
(zero_loc, [Prim (zero_loc, "IF_LEFT", [left_branch; right_branch], [])]))
(Prim (zero_loc, "IF_RIGHT", [right_branch; left_branch], []))
let test_unexpand_if_some () =
assert_unexpansion
(Seq
(zero_loc, [Prim (zero_loc, "IF_NONE", [left_branch; right_branch], [])]))
(Prim (zero_loc, "IF_SOME", [right_branch; left_branch], []))
let test_unexpand_assert () =
assert_unexpansion
(Seq (zero_loc, [Prim (zero_loc, "IF", fail_false, [])]))
(Prim (zero_loc, "ASSERT", [], []))
let assert_unexpansion_assert_if_compare compare_name prim_name =
assert_unexpansion
(Seq
( zero_loc,
[ Prim (zero_loc, compare_name, [], []);
Prim (zero_loc, "IF", fail_false, []) ] ))
(Prim (zero_loc, prim_name, [], []))
let test_unexpand_assert_if () =
assert_unexpansion_assert_if_compare "EQ" "ASSERT_EQ"
>>? fun () ->
assert_unexpansion_assert_if_compare "NEQ" "ASSERT_NEQ"
>>? fun () ->
assert_unexpansion_assert_if_compare "LT" "ASSERT_LT"
>>? fun () ->
assert_unexpansion_assert_if_compare "LE" "ASSERT_LE"
>>? fun () ->
assert_unexpansion_assert_if_compare "GT" "ASSERT_GT"
>>? fun () -> assert_unexpansion_assert_if_compare "GE" "ASSERT_GE"
let assert_unexpansion_assert_cmp_if_compare compare_name prim_name =
assert_unexpansion
(Seq
( zero_loc,
[ Seq
( zero_loc,
[ Prim (zero_loc, "COMPARE", [], []);
Prim (zero_loc, compare_name, [], []) ] );
Prim (zero_loc, "IF", fail_false, []) ] ))
(Prim (zero_loc, prim_name, [], []))
let test_unexpansion_assert_cmp_if () =
assert_unexpansion_assert_cmp_if_compare "EQ" "ASSERT_CMPEQ"
>>? fun () ->
assert_unexpansion_assert_cmp_if_compare "NEQ" "ASSERT_CMPNEQ"
>>? fun () ->
assert_unexpansion_assert_cmp_if_compare "LT" "ASSERT_CMPLT"
>>? fun () ->
assert_unexpansion_assert_cmp_if_compare "LE" "ASSERT_CMPLE"
>>? fun () ->
assert_unexpansion_assert_cmp_if_compare "GT" "ASSERT_CMPGT"
>>? fun () -> assert_unexpansion_assert_cmp_if_compare "GE" "ASSERT_CMPGE"
let test_unexpand_assert_some_annot () =
assert_unexpansion
(Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true_may_rename, [])]))
(Prim (zero_loc, "ASSERT_SOME", [], ["@annot"]))
let test_unexpand_assert_left_annot () =
assert_unexpansion
(Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false_may_rename, [])]))
(Prim (zero_loc, "ASSERT_LEFT", [], ["@annot"]))
let test_unexpand_assert_right_annot () =
assert_unexpansion
(Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true_may_rename, [])]))
(Prim (zero_loc, "ASSERT_RIGHT", [], ["@annot"]))
let test_unexpand_assert_none () =
assert_unexpansion
(Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_false, [])]))
(Prim (zero_loc, "ASSERT_NONE", [], []))
let test_unexpand_assert_some () =
assert_unexpansion
(Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true, [])]))
(Prim (zero_loc, "ASSERT_SOME", [], []))
let test_unexpand_assert_left () =
assert_unexpansion
(Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false, [])]))
(Prim (zero_loc, "ASSERT_LEFT", [], []))
let test_unexpand_assert_right () =
assert_unexpansion
(Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true, [])]))
(Prim (zero_loc, "ASSERT_RIGHT", [], []))
let test_unexpand_unpair () =
assert_unexpansion
(Seq
( zero_loc,
[ Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim (zero_loc, "CAR", [], []);
Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "CDR", [], [])])],
[] ) ] ) ] ))
(Prim (zero_loc, "UNPAIR", [], []))
let test_unexpand_pair () =
assert_unexpansion
(Prim (zero_loc, "PAIR", [], []))
(Prim (zero_loc, "PAIR", [], []))
let test_unexpand_pappaiir () =
assert_unexpansion
(Seq
( zero_loc,
[ Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "PAIR", [], [])])],
[] );
Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "PAIR", [], [])])],
[] );
Prim (zero_loc, "PAIR", [], []) ] ))
(Prim (zero_loc, "PAPPAIIR", [], []))
let test_unexpand_duup () =
assert_unexpansion
(Seq
( zero_loc,
[ Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "DUP", [], [])])],
[] );
Prim (zero_loc, "SWAP", [], []) ] ))
(Prim (zero_loc, "DUP", [Int (zero_loc, Z.of_int 2)], []))
let test_unexpand_caddadr () =
let car = Prim (zero_loc, "CAR", [], []) in
let cdr = Prim (zero_loc, "CDR", [], []) in
assert_unexpansion (Seq (zero_loc, [car])) car
>>? fun () ->
assert_unexpansion (Seq (zero_loc, [cdr])) cdr
>>? fun () ->
assert_unexpansion
(Seq (zero_loc, [car; cdr]))
(Prim (zero_loc, "CADR", [], []))
>>? fun () ->
assert_unexpansion
(Seq (zero_loc, [cdr; car]))
(Prim (zero_loc, "CDAR", [], []))
let test_unexpand_set_car () =
assert_unexpansion
(Seq
( zero_loc,
[ Prim (zero_loc, "CDR", [], ["@%%"]);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] ))
(Prim (zero_loc, "SET_CAR", [], []))
let test_unexpand_set_cdr () =
assert_unexpansion
(Seq
( zero_loc,
[ Prim (zero_loc, "CAR", [], ["@%%"]);
Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ))
(Prim (zero_loc, "SET_CDR", [], []))
let test_unexpand_set_car_annot () =
assert_unexpansion
(Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim (zero_loc, "CAR", [], ["%@"]);
Prim (zero_loc, "DROP", [], []);
Prim (zero_loc, "CDR", [], []);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], []) ] ))
(Prim (zero_loc, "SET_CAR", [], ["%@"]))
let test_unexpand_set_cdr_annot () =
assert_unexpansion
(Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim (zero_loc, "CDR", [], ["%@"]);
Prim (zero_loc, "DROP", [], []);
Prim (zero_loc, "CAR", [], []);
Prim (zero_loc, "PAIR", [], []) ] ))
(Prim (zero_loc, "SET_CDR", [], ["%@"]))
let test_unexpand_set_cadr () =
let set_car =
Seq
( zero_loc,
[ Prim (zero_loc, "CAR", [], ["@%%"]);
Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] )
in
assert_unexpansion
(Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); set_car])],
[] );
Prim (zero_loc, "CDR", [], ["@%%"]);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))
(Prim (zero_loc, "SET_CADR", [], []))
let test_unexpand_set_cdar () =
let set_cdr =
Seq
( zero_loc,
[ Prim (zero_loc, "CDR", [], ["@%%"]);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] )
in
assert_unexpansion
(Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); set_cdr])],
[] );
Prim (zero_loc, "CAR", [], ["@%%"]);
Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))
(Prim (zero_loc, "SET_CDAR", [], []))
(* FIXME: Seq()(Prim): does not parse, raise an error unparse *)
let test_unexpand_map_car () =
let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
assert_unexpansion
(Prim (zero_loc, "MAP_CAR", [code], []))
(Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim (zero_loc, "CDR", [], ["@%%"]);
Prim
( zero_loc,
"DIP",
[ Seq
( zero_loc,
[ Prim (zero_loc, "CAR", [], []);
Prim (zero_loc, "CAR", [], []) ] ) ],
[] );
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] ))
(***********************************************************************)
(*BUG: DIIP and the test with MAP_CDR: or any map with "D" inside fail *)
let test_unexpand_diip () =
let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
assert_unexpansion
(Prim (zero_loc, "DIIP", [code], []))
(Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], []))
let test_unexpand_map_cdr () =
let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
assert_unexpansion
(Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim (zero_loc, "CDR", [], []);
code;
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "CAR", [], []);
Prim (zero_loc, "PAIR", [], []) ] ))
(Prim (zero_loc, "MAP_CDR", [code], []))
let test_unexpand_map_caadr () =
let code = [Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])])] in
let map_cdr =
Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim
( zero_loc,
"DIP",
[ Seq
( zero_loc,
[ Prim (zero_loc, "CAR", [], ["@%%"]);
Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim (zero_loc, "CDR", [], []);
Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "CAR", [], ["@%%"]);
Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ) ] ) ],
[] );
Prim (zero_loc, "CDR", [], ["@%%"]);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] )
in
assert_unexpansion
(Prim (zero_loc, "MAP_CAAR", code, []))
(Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cdr])],
[] );
Prim (zero_loc, "CDR", [], ["@%%"]);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))
let test_unexpand_map_cdadr () =
let code = [Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])])] in
let map_cdr =
Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim
( zero_loc,
"DIP",
[ Seq
( zero_loc,
[ Prim (zero_loc, "CAR", [], ["@%%"]);
Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim (zero_loc, "CDR", [], []);
Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "CAR", [], ["@%%"]);
Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ) ] ) ],
[] );
Prim (zero_loc, "CDR", [], ["@%%"]);
Prim (zero_loc, "SWAP", [], []);
Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] )
in
assert_unexpansion
(Seq
( zero_loc,
[ Prim (zero_loc, "DUP", [], []);
Prim
( zero_loc,
"DIP",
[Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); map_cdr])],
[] );
Prim (zero_loc, "CAR", [], ["@%%"]);
Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))
(Prim (zero_loc, "MAP_CDADR", code, []))
let test_unexpand_diip_duup1 () =
let single code = Seq (zero_loc, [code]) in
let cst str = Prim (zero_loc, str, [], []) in
let app str code = Prim (zero_loc, str, [code], []) in
let dip = app "DIP" in
let diip code =
Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], [])
in
let dup = cst "DUP" in
let swap = cst "SWAP" in
let dip_dup_swap = Seq (zero_loc, [dip (single dup); swap]) in
assert_unexpansion
(* { DIP { DIP { DIP { DUP }; SWAP }}} *)
(single (dip (single (dip dip_dup_swap))))
(* DIIP { DIP { DUP }; SWAP } *)
(diip dip_dup_swap)
let test_unexpand_diip_duup2 () =
let single code = Seq (zero_loc, [code]) in
let cst str = Prim (zero_loc, str, [], []) in
let app str code = Prim (zero_loc, str, [code], []) in
let dip = app "DIP" in
let diip code =
Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], [])
in
let dup = cst "DUP" in
let duup = Prim (zero_loc, "DUP", [Int (zero_loc, Z.of_int 2)], []) in
let swap = cst "SWAP" in
let dip_dup_swap = Seq (zero_loc, [dip (single dup); swap]) in
assert_unexpansion
(* { DIP { DIP {{ DIP { DUP }; SWAP }}}} *)
(single (dip (single (dip (single dip_dup_swap)))))
(* DIIP { DUUP } *)
(diip (single duup))
(*****************************************************************************)
(* Test *)
(*****************************************************************************)
let tests =
[ (*compare*)
("compare expansion", fun _ -> Lwt.return (test_compare_marco_expansion ()));
( "if compare expansion",
fun _ -> Lwt.return (test_if_compare_macros_expansion ()) );
( "if compare expansion: IFCMP",
fun _ -> Lwt.return (test_if_cmp_macros_expansion ()) );
(*fail*)
("fail expansion", fun _ -> Lwt.return (test_fail_expansion ()));
(*assertion*)
("assert expansion", fun _ -> Lwt.return (test_assert_expansion ()));
("assert if expansion", fun _ -> Lwt.return (test_assert_if ()));
("assert cmpif expansion", fun _ -> Lwt.return (test_assert_cmp_if ()));
("assert none expansion", fun _ -> Lwt.return (test_assert_none ()));
("assert some expansion", fun _ -> Lwt.return (test_assert_some ()));
("assert left expansion", fun _ -> Lwt.return (test_assert_left ()));
("assert right expansion", fun _ -> Lwt.return (test_assert_right ()));
( "assert some annot expansion",
fun _ -> Lwt.return (test_assert_some_annot ()) );
( "assert left annot expansion",
fun _ -> Lwt.return (test_assert_left_annot ()) );
( "assert right annot expansion",
fun _ -> Lwt.return (test_assert_right_annot ()) );
(*syntactic conveniences*)
("diip expansion", fun _ -> Lwt.return (test_diip ()));
("duup expansion", fun _ -> Lwt.return (test_duup ()));
("pair expansion", fun _ -> Lwt.return (test_pair ()));
("pappaiir expansion", fun _ -> Lwt.return (test_pappaiir ()));
("unpair expansion", fun _ -> Lwt.return (test_unpair ()));
("caddadr expansion", fun _ -> Lwt.return (test_caddadr_expansion ()));
("if_some expansion", fun _ -> Lwt.return (test_if_some ()));
("set_car expansion", fun _ -> Lwt.return (test_set_car_expansion ()));
("set_cdr expansion", fun _ -> Lwt.return (test_set_cdr_expansion ()));
("set_cadr expansion", fun _ -> Lwt.return (test_set_cadr_expansion ()));
("set_cdar expansion", fun _ -> Lwt.return (test_set_cdar_expansion ()));
("map_car expansion", fun _ -> Lwt.return (test_map_car ()));
("map_cdr expansion", fun _ -> Lwt.return (test_map_cdr ()));
("map_caadr expansion", fun _ -> Lwt.return (test_map_caadr ()));
("map_cdadr expansion", fun _ -> Lwt.return (test_map_cdadr ()));
(*Unexpand*)
("fail unexpansion", fun _ -> Lwt.return (test_unexpand_fail ()));
("if_right unexpansion", fun _ -> Lwt.return (test_unexpand_if_right ()));
("if_some unexpansion", fun _ -> Lwt.return (test_unexpand_if_some ()));
("assert unexpansion", fun _ -> Lwt.return (test_unexpand_assert ()));
("assert_if unexpansion", fun _ -> Lwt.return (test_unexpand_assert_if ()));
( "assert_cmp_if unexpansion",
fun _ -> Lwt.return (test_unexpansion_assert_cmp_if ()) );
( "assert_none unexpansion",
fun _ -> Lwt.return (test_unexpand_assert_none ()) );
( "assert_some unexpansion",
fun _ -> Lwt.return (test_unexpand_assert_some ()) );
( "assert_left unexpansion",
fun _ -> Lwt.return (test_unexpand_assert_left ()) );
( "assert_right unexpansion",
fun _ -> Lwt.return (test_unexpand_assert_right ()) );
( "assert_some annot unexpansion",
fun _ -> Lwt.return (test_unexpand_assert_some_annot ()) );
( "assert_left annot unexpansion",
fun _ -> Lwt.return (test_unexpand_assert_left_annot ()) );
( "assert_right annot unexpansion",
fun _ -> Lwt.return (test_unexpand_assert_right_annot ()) );
("unpair unexpansion", fun _ -> Lwt.return (test_unexpand_unpair ()));
("pair unexpansion", fun _ -> Lwt.return (test_unexpand_pair ()));
("pappaiir unexpansion", fun _ -> Lwt.return (test_unexpand_pappaiir ()));
("duup unexpansion", fun _ -> Lwt.return (test_unexpand_duup ()));
("caddadr unexpansion", fun _ -> Lwt.return (test_unexpand_caddadr ()));
("set_car unexpansion", fun _ -> Lwt.return (test_unexpand_set_car ()));
("set_cdr unexpansion", fun _ -> Lwt.return (test_unexpand_set_cdr ()));
("set_cadr unexpansion", fun _ -> Lwt.return (test_unexpand_set_cadr ()));
( "set_car annot unexpansion",
fun _ -> Lwt.return (test_unexpand_set_car_annot ()) );
( "set_cdr annot unexpansion",
fun _ -> Lwt.return (test_unexpand_set_cdr_annot ()) );
("map_car unexpansion", fun _ -> Lwt.return (test_unexpand_map_car ()));
( "diip_duup1 unexpansion",
fun _ -> Lwt.return (test_unexpand_diip_duup1 ()) );
( "diip_duup2 unexpansion",
fun _ -> Lwt.return (test_unexpand_diip_duup2 ()) )
(***********************************************************************)
(*BUG
the function in Michelson_v1_macros.unexpand_map_caddadr
failed to test the case with the character "D".
It returns an empty {} for the expand *)
(*"diip unexpansion", (fun _ -> Lwt.return (test_unexpand_diip ())) ;*)
(*"map_cdr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdr ())) ;*)
(*"map_caadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_caadr ())) ;*)
(*"map_cdadr unexpansion", (fun _ -> Lwt.return (test_unexpand_map_cdadr ())) ;*)
]
let wrap (n, f) =
Alcotest_lwt.test_case n `Quick (fun _ () ->
f ()
>>= function
| Ok () ->
Lwt.return_unit
| Error error ->
Format.kasprintf Pervasives.failwith "%a" pp_print_error error)
let () =
Alcotest.run
~argv:[|""|]
"tezos-lib-client"
[("micheline v1 macros", List.map wrap tests)]
src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Definition print {A : Type} (expr : A) : string :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply expr (op_startypeminuserrorstar (fun s => s)))
(Format.asprintf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
"%a" % string) op_startypeminuserrorstar).
Definition assert_expands {A B : Type} (function_parameter : A)
: B -> Tezos_base__TzPervasives.tzresult unit :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
let '({| Michelson_v1_parser.expanded := expansion |}, errors) :=
let source := print (op_startypeminuserrorstar op_startypeminuserrorstar)
in
Michelson_v1_parser.expand_all source op_startypeminuserrorstar in
match errors with
| [] =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar print
(Michelson_v1_primitives.strings_of_prims expansion)
(op_startypeminuserrorstar op_startypeminuserrorstar) in
ok tt
| errors => Stdlib.Error errors
end.
Definition zero_loc {A : Type} : A := op_startypeminuserrorstar.
Definition left_branch {A : Type} : A := op_startypeminuserrorstar.
Definition right_branch {A : Type} : A := op_startypeminuserrorstar.
Definition assert_compare_macro {A B : Type} (prim_name : A) (compare_name : B)
: Tezos_base__TzPervasives.tzresult unit :=
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_compare_marco_expansion (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
op_gtgtquestion (assert_compare_macro "CMPEQ" % string "EQ" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (assert_compare_macro "CMPNEQ" % string "NEQ" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (assert_compare_macro "CMPLT" % string "LT" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_compare_macro "CMPGT" % string "GT" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_compare_macro "CMPLE" % string "LE" % string)
(fun function_parameter =>
let 'tt := function_parameter in
assert_compare_macro "CMPGE" % string "GE" % string))))).
Definition assert_if_macro {A B : Type} (prim_name : A) (compare_name : B)
: Tezos_base__TzPervasives.tzresult unit :=
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_if_compare_macros_expansion (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
op_gtgtquestion (assert_if_macro "IFEQ" % string "EQ" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (assert_if_macro "IFNEQ" % string "NEQ" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (assert_if_macro "IFLT" % string "LT" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (assert_if_macro "IFGT" % string "GT" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_if_macro "IFLE" % string "LE" % string)
(fun function_parameter =>
let 'tt := function_parameter in
assert_if_macro "IFGE" % string "GE" % string))))).
Definition assert_if_cmp_macros {A B : Type} (prim_name : A) (compare_name : B)
: Tezos_base__TzPervasives.tzresult unit :=
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_if_cmp_macros_expansion (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
op_gtgtquestion (assert_if_cmp_macros "IFCMPEQ" % string "EQ" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (assert_if_cmp_macros "IFCMPNEQ" % string "NEQ" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_if_cmp_macros "IFCMPLT" % string "LT" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_if_cmp_macros "IFCMPGT" % string "GT" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_if_cmp_macros "IFCMPLE" % string "LE" % string)
(fun function_parameter =>
let 'tt := function_parameter in
assert_if_cmp_macros "IFCMPGE" % string "GE" % string))))).
Definition test_fail_expansion (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition seq_unit_failwith {A : Type} : A := op_startypeminuserrorstar.
Definition fail_false {A : Type} : list A :=
cons op_startypeminuserrorstar (cons op_startypeminuserrorstar []).
Definition fail_true {A : Type} : list A :=
cons op_startypeminuserrorstar (cons op_startypeminuserrorstar []).
Definition test_assert_expansion (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition assert_assert_if_compare {A B : Type}
(prim_name : A) (compare_name : B) : Tezos_base__TzPervasives.tzresult unit :=
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_assert_if (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
op_gtgtquestion (assert_assert_if_compare "ASSERT_EQ" % string "EQ" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_assert_if_compare "ASSERT_NEQ" % string "NEQ" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_assert_if_compare "ASSERT_LT" % string "LT" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_assert_if_compare "ASSERT_LE" % string "LE" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_assert_if_compare "ASSERT_GT" % string "GT" % string)
(fun function_parameter =>
let 'tt := function_parameter in
assert_assert_if_compare "ASSERT_GE" % string
"GE" % string))))).
Definition assert_cmp_if {A B : Type} (prim_name : A) (compare_name : B)
: Tezos_base__TzPervasives.tzresult unit :=
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_assert_cmp_if (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
op_gtgtquestion (assert_cmp_if "ASSERT_CMPEQ" % string "EQ" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (assert_cmp_if "ASSERT_CMPNEQ" % string "NEQ" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (assert_cmp_if "ASSERT_CMPLT" % string "LT" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_cmp_if "ASSERT_CMPLE" % string "LE" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_cmp_if "ASSERT_CMPGT" % string "GT" % string)
(fun function_parameter =>
let 'tt := function_parameter in
assert_cmp_if "ASSERT_CMPGE" % string "GE" % string))))).
Definition may_rename {A B : Type} (annot : A) : B := op_startypeminuserrorstar.
Definition fail_false_may_rename {A : Type} : list A :=
cons (may_rename (cons "@annot" % string []))
(cons op_startypeminuserrorstar []).
Definition fail_true_may_rename {A : Type} : list A :=
cons op_startypeminuserrorstar
(cons (may_rename (cons "@annot" % string [])) []).
Definition test_assert_some_annot (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_assert_left_annot (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_assert_right_annot (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_assert_none (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_assert_some (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_assert_left (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_assert_right (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_diip (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let code := op_startypeminuserrorstar in
op_gtgtquestion
(assert_expands op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_expands op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar)).
Definition test_pair (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_pappaiir (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let pair := op_startypeminuserrorstar in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_unpair (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_duup (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let dup := op_startypeminuserrorstar in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_caddadr_expansion (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let car := op_startypeminuserrorstar in
op_gtgtquestion (assert_expands op_startypeminuserrorstar car)
(fun function_parameter =>
let 'tt := function_parameter in
let cdr := op_startypeminuserrorstar in
op_gtgtquestion (assert_expands op_startypeminuserrorstar cdr)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_expands op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar))).
Definition test_if_some (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_set_car_expansion (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_set_cdr_expansion (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_set_cadr_expansion (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let set_car := op_startypeminuserrorstar in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_set_cdar_expansion (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let set_cdr := op_startypeminuserrorstar in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_map_car (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let code := op_startypeminuserrorstar in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_map_cdr (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let code := op_startypeminuserrorstar in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_map_caadr (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let code := op_startypeminuserrorstar in
let map_cdr := op_startypeminuserrorstar in
let map_cadr := op_startypeminuserrorstar in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition test_map_cdadr (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let code := op_startypeminuserrorstar in
let map_cdr := op_startypeminuserrorstar in
let map_cadr := op_startypeminuserrorstar in
assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.
Definition assert_unexpansion {A : Type}
(original : Tezos_micheline.Micheline_parser.node) (ex : A)
: Tezos_base__TzPervasives.tzresult unit :=
let '({| Michelson_v1_parser.expanded := expanded |}, errors) :=
let source := print (op_startypeminuserrorstar original) in
Michelson_v1_parser.expand_all source original in
let unparse := Michelson_v1_printer.unparse_expression expanded in
match errors with
| [] =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar print (Michelson_v1_parser.unexpanded unparse)
(op_startypeminuserrorstar ex) in
ok tt
| cons _ _ => Stdlib.Error errors
end.
Definition assert_unexpansion_consistent
(original : Tezos_micheline.Micheline_parser.node)
: sum unit Tezos_base__TzPervasives.trace :=
let '({| Michelson_v1_parser.expanded := expanded |}, errors) :=
let source := print (op_startypeminuserrorstar original) in
Michelson_v1_parser.expand_all source original in
match errors with
| cons _ _ => Stdlib.Error errors
| [] =>
let '{| Michelson_v1_parser.unexpanded := unexpanded |} :=
Michelson_v1_printer.unparse_expression expanded in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar print unexpanded
(op_startypeminuserrorstar original) in
ok tt
end.
Definition test_unexpand_fail (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons (Tezos_micheline.Micheline.Prim zero_loc "UNIT" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "FAILWITH" % string [] []) [])))
op_startypeminuserrorstar.
Definition test_unexpand_if_right (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "IF_LEFT" % string
(cons left_branch (cons right_branch [])) []) []))
op_startypeminuserrorstar.
Definition test_unexpand_if_some (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "IF_NONE" % string
(cons left_branch (cons right_branch [])) []) []))
op_startypeminuserrorstar.
Definition test_unexpand_assert (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "IF" % string fail_false []) []))
op_startypeminuserrorstar.
Definition assert_unexpansion_assert_if_compare {A : Type}
(compare_name : string) (prim_name : A)
: Tezos_base__TzPervasives.tzresult unit :=
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons (Tezos_micheline.Micheline.Prim zero_loc compare_name [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "IF" % string fail_false [])
[]))) op_startypeminuserrorstar.
Definition test_unexpand_assert_if (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
op_gtgtquestion
(assert_unexpansion_assert_if_compare "EQ" % string "ASSERT_EQ" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_unexpansion_assert_if_compare "NEQ" % string
"ASSERT_NEQ" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_unexpansion_assert_if_compare "LT" % string
"ASSERT_LT" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_unexpansion_assert_if_compare "LE" % string
"ASSERT_LE" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_unexpansion_assert_if_compare "GT" % string
"ASSERT_GT" % string)
(fun function_parameter =>
let 'tt := function_parameter in
assert_unexpansion_assert_if_compare "GE" % string
"ASSERT_GE" % string))))).
Definition assert_unexpansion_assert_cmp_if_compare {A : Type}
(compare_name : string) (prim_name : A)
: Tezos_base__TzPervasives.tzresult unit :=
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "COMPARE" % string [] [])
(cons (Tezos_micheline.Micheline.Prim zero_loc compare_name [] [])
[])))
(cons
(Tezos_micheline.Micheline.Prim zero_loc "IF" % string fail_false [])
[]))) op_startypeminuserrorstar.
Definition test_unexpansion_assert_cmp_if (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
op_gtgtquestion
(assert_unexpansion_assert_cmp_if_compare "EQ" % string
"ASSERT_CMPEQ" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_unexpansion_assert_cmp_if_compare "NEQ" % string
"ASSERT_CMPNEQ" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_unexpansion_assert_cmp_if_compare "LT" % string
"ASSERT_CMPLT" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_unexpansion_assert_cmp_if_compare "LE" % string
"ASSERT_CMPLE" % string)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_unexpansion_assert_cmp_if_compare "GT" % string
"ASSERT_CMPGT" % string)
(fun function_parameter =>
let 'tt := function_parameter in
assert_unexpansion_assert_cmp_if_compare "GE" % string
"ASSERT_CMPGE" % string))))).
Definition test_unexpand_assert_some_annot (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "IF_NONE" % string
fail_true_may_rename []) [])) op_startypeminuserrorstar.
Definition test_unexpand_assert_left_annot (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "IF_LEFT" % string
fail_false_may_rename []) [])) op_startypeminuserrorstar.
Definition test_unexpand_assert_right_annot (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "IF_LEFT" % string
fail_true_may_rename []) [])) op_startypeminuserrorstar.
Definition test_unexpand_assert_none (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "IF_NONE" % string fail_false
[]) [])) op_startypeminuserrorstar.
Definition test_unexpand_assert_some (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "IF_NONE" % string fail_true [])
[])) op_startypeminuserrorstar.
Definition test_unexpand_assert_left (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "IF_LEFT" % string fail_false
[]) [])) op_startypeminuserrorstar.
Definition test_unexpand_assert_right (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "IF_LEFT" % string fail_true [])
[])) op_startypeminuserrorstar.
Definition test_unexpand_unpair (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Seq zero_loc
(cons (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim zero_loc "CAR" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "CDR" % string
[] []) [])) []) []) [])))) []))
op_startypeminuserrorstar.
Definition test_unexpand_pair (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string [] [])
op_startypeminuserrorstar.
Definition test_unexpand_pappaiir (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string [] [])
[])) []) [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string [] [])
[])) []) [])
(cons (Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string [] [])
[])))) op_startypeminuserrorstar.
Definition test_unexpand_duup (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
[])) []) [])
(cons (Tezos_micheline.Micheline.Prim zero_loc "SWAP" % string [] []) [])))
op_startypeminuserrorstar.
Definition test_unexpand_caddadr (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let car := op_startypeminuserrorstar in
let cdr := op_startypeminuserrorstar in
op_gtgtquestion
(assert_unexpansion (Tezos_micheline.Micheline.Seq zero_loc (cons car []))
car)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc (cons cdr [])) cdr)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc (cons car (cons cdr [])))
op_startypeminuserrorstar)
(fun function_parameter =>
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc (cons cdr (cons car [])))
op_startypeminuserrorstar))).
Definition test_unexpand_set_car (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "CDR" % string []
(cons "@%%" % string []))
(cons (Tezos_micheline.Micheline.Prim zero_loc "SWAP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string []
(cons "%" % string (cons "%@" % string []))) []))))
op_startypeminuserrorstar.
Definition test_unexpand_set_cdr (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "CAR" % string []
(cons "@%%" % string []))
(cons
(Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string []
(cons "%@" % string (cons "%" % string []))) [])))
op_startypeminuserrorstar.
Definition test_unexpand_set_car_annot (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "CAR" % string []
(cons "%@" % string []))
(cons (Tezos_micheline.Micheline.Prim zero_loc "DROP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim zero_loc "CDR" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "SWAP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string [] [])
[]))))))) op_startypeminuserrorstar.
Definition test_unexpand_set_cdr_annot (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "CDR" % string []
(cons "%@" % string []))
(cons (Tezos_micheline.Micheline.Prim zero_loc "DROP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim zero_loc "CAR" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string [] [])
[])))))) op_startypeminuserrorstar.
Definition test_unexpand_set_cadr (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let set_car := op_startypeminuserrorstar in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "CAR" % string []
(cons "@%%" % string [])) (cons set_car []))) []) [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "CDR" % string []
(cons "@%%" % string []))
(cons
(Tezos_micheline.Micheline.Prim zero_loc "SWAP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string []
(cons "%@" % string (cons "%@" % string []))) []))))))
op_startypeminuserrorstar.
Definition test_unexpand_set_cdar (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let set_cdr := op_startypeminuserrorstar in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "CDR" % string []
(cons "@%%" % string [])) (cons set_cdr []))) []) [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "CAR" % string []
(cons "@%%" % string []))
(cons
(Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string []
(cons "%@" % string (cons "%@" % string []))) [])))))
op_startypeminuserrorstar.
Definition test_unexpand_map_car (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let code := op_startypeminuserrorstar in
assert_unexpansion
(Tezos_micheline.Micheline.Prim zero_loc "MAP_CAR" % string (cons code [])
[]) op_startypeminuserrorstar.
Definition test_unexpand_diip (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let code := op_startypeminuserrorstar in
assert_unexpansion
(Tezos_micheline.Micheline.Prim zero_loc "DIIP" % string (cons code []) [])
op_startypeminuserrorstar.
Definition test_unexpand_map_cdr (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let code := op_startypeminuserrorstar in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
(cons (Tezos_micheline.Micheline.Prim zero_loc "CDR" % string [] [])
(cons code
(cons
(Tezos_micheline.Micheline.Prim zero_loc "SWAP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "CAR" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string [] [])
[]))))))) op_startypeminuserrorstar.
Definition test_unexpand_map_caadr (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let code := cons op_startypeminuserrorstar [] in
let map_cdr := op_startypeminuserrorstar in
assert_unexpansion
(Tezos_micheline.Micheline.Prim zero_loc "MAP_CAAR" % string code [])
op_startypeminuserrorstar.
Definition test_unexpand_map_cdadr (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let code := cons op_startypeminuserrorstar [] in
let map_cdr := op_startypeminuserrorstar in
assert_unexpansion
(Tezos_micheline.Micheline.Seq zero_loc
(cons (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "DIP" % string
(cons
(Tezos_micheline.Micheline.Seq zero_loc
(cons
(Tezos_micheline.Micheline.Prim zero_loc "CDR" % string []
(cons "@%%" % string [])) (cons map_cdr []))) []) [])
(cons
(Tezos_micheline.Micheline.Prim zero_loc "CAR" % string []
(cons "@%%" % string []))
(cons
(Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string []
(cons "%@" % string (cons "%@" % string []))) [])))))
op_startypeminuserrorstar.
Definition test_unexpand_diip_duup1 (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let single {A B : Type} (code : A) : B :=
op_startypeminuserrorstar in
let cst {A B : Type} (str : A) : B :=
op_startypeminuserrorstar in
let app {A B C : Type} (str : A) (code : B) : C :=
op_startypeminuserrorstar in
let dip := app "DIP" % string in
let diip {A B : Type} (code : A) : B :=
op_startypeminuserrorstar in
let dup := cst "DUP" % string in
let swap := cst "SWAP" % string in
let dip_dup_swap := op_startypeminuserrorstar in
assert_unexpansion (single (dip (single (dip dip_dup_swap))))
(diip dip_dup_swap).
Definition test_unexpand_diip_duup2 (function_parameter : unit)
: Tezos_base__TzPervasives.tzresult unit :=
let 'tt := function_parameter in
let single {A B : Type} (code : A) : B :=
op_startypeminuserrorstar in
let cst {A B : Type} (str : A) : B :=
op_startypeminuserrorstar in
let app {A B C : Type} (str : A) (code : B) : C :=
op_startypeminuserrorstar in
let dip := app "DIP" % string in
let diip {A B : Type} (code : A) : B :=
op_startypeminuserrorstar in
let dup := cst "DUP" % string in
let duup := op_startypeminuserrorstar in
let swap := cst "SWAP" % string in
let dip_dup_swap := op_startypeminuserrorstar in
assert_unexpansion (single (dip (single (dip (single dip_dup_swap)))))
(diip (single duup)).
Definition tests {A : Type}
: list (string * (A -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
cons
("compare expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_compare_marco_expansion tt)))
(cons
("if compare expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_if_compare_macros_expansion tt)))
(cons
("if compare expansion: IFCMP" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_if_cmp_macros_expansion tt)))
(cons
("fail expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_fail_expansion tt)))
(cons
("assert expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_assert_expansion tt)))
(cons
("assert if expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_assert_if tt)))
(cons
("assert cmpif expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_assert_cmp_if tt)))
(cons
("assert none expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_assert_none tt)))
(cons
("assert some expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_assert_some tt)))
(cons
("assert left expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_assert_left tt)))
(cons
("assert right expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_assert_right tt)))
(cons
("assert some annot expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_assert_some_annot tt)))
(cons
("assert left annot expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_assert_left_annot tt)))
(cons
("assert right annot expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_assert_right_annot tt)))
(cons
("diip expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_diip tt)))
(cons
("duup expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_duup tt)))
(cons
("pair expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_pair tt)))
(cons
("pappaiir expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_pappaiir tt)))
(cons
("unpair expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_unpair tt)))
(cons
("caddadr expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return
(test_caddadr_expansion tt)))
(cons
("if_some expansion" % string,
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return (test_if_some tt)))
(cons
("set_car expansion" % string,
(fun function_parameter =>
let '_ := function_parameter
in
Lwt._return
(test_set_car_expansion tt)))
(cons
("set_cdr expansion" % string,
(fun function_parameter =>
let '_ := function_parameter
in
Lwt._return
(test_set_cdr_expansion tt)))
(cons
("set_cadr expansion" % string,
(fun function_parameter =>
let '_ :=
function_parameter in
Lwt._return
(test_set_cadr_expansion
tt)))
(cons
("set_cdar expansion" %
string,
(fun function_parameter =>
let '_ :=
function_parameter in
Lwt._return
(test_set_cdar_expansion
tt)))
(cons
("map_car expansion" %
string,
(fun function_parameter
=>
let '_ :=
function_parameter
in
Lwt._return
(test_map_car tt)))
(cons
("map_cdr expansion" %
string,
(fun
function_parameter
=>
let '_ :=
function_parameter
in
Lwt._return
(test_map_cdr tt)))
(cons
("map_caadr expansion"
% string,
(fun
function_parameter
=>
let '_ :=
function_parameter
in
Lwt._return
(test_map_caadr
tt)))
(cons
("map_cdadr expansion"
% string,
(fun
function_parameter
=>
let '_ :=
function_parameter
in
Lwt._return
(test_map_cdadr
tt)))
(cons
("fail unexpansion"
% string,
(fun
function_parameter
=>
let '_ :=
function_parameter
in
Lwt._return
(test_unexpand_fail
tt)))
(cons
("if_right unexpansion"
% string,
(fun
function_parameter
=>
let '_ :=
function_parameter
in
Lwt._return
(test_unexpand_if_right
tt)))
(cons
("if_some unexpansion"
% string,
(fun
function_parameter
=>
let '_ :=
function_parameter
in
Lwt._return
(test_unexpand_if_some
tt)))
(cons
("assert unexpansion"
% string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_assert
tt)))
(cons
("assert_if unexpansion"
% string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_assert_if
tt)))
(cons
("assert_cmp_if unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpansion_assert_cmp_if
tt)))
(cons
("assert_none unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_assert_none
tt)))
(cons
("assert_some unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_assert_some
tt)))
(cons
("assert_left unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_assert_left
tt)))
(cons
("assert_right unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_assert_right
tt)))
(cons
("assert_some annot unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_assert_some_annot
tt)))
(cons
("assert_left annot unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_assert_left_annot
tt)))
(cons
("assert_right annot unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_assert_right_annot
tt)))
(cons
("unpair unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_unpair
tt)))
(cons
("pair unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_pair
tt)))
(cons
("pappaiir unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_pappaiir
tt)))
(cons
("duup unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_duup
tt)))
(cons
("caddadr unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_caddadr
tt)))
(cons
("set_car unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_set_car
tt)))
(cons
("set_cdr unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_set_cdr
tt)))
(cons
("set_cadr unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_set_cadr
tt)))
(cons
("set_car annot unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_set_car_annot
tt)))
(cons
("set_cdr annot unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_set_cdr_annot
tt)))
(cons
("map_car unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_map_car
tt)))
(cons
("diip_duup1 unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_diip_duup1
tt)))
(cons
("diip_duup2 unexpansion"
%
string,
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
Lwt._return
(test_unexpand_diip_duup2
tt)))
[])))))))))))))))))))))))))))))))))))))))))))))))))))))).
Definition wrap {A B : Type}
(function_parameter :
A * (unit -> Lwt.t (sum unit Tezos_base__TzPervasives.trace))) : B :=
let '(n, f) := function_parameter in
op_startypeminuserrorstar n
(* ❌ Variants not supported *)
variant
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (f tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error error =>
Format.kasprintf Pervasives.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
pp_print_error error
end)).
src/proto_alpha/lib_client_commands/alpha_commands_registration.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) let () = Client_commands.register Protocol.hash @@ fun network -> List.map (Clic.map_command (new Protocol_client_context.wrap_full)) @@ Client_proto_programs_commands.commands () @ Client_proto_contracts_commands.commands () @ Client_proto_context_commands.commands network () @ Client_proto_multisig_commands.commands ()
src/proto_alpha/lib_client_commands/alpha_commands_registration.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations.
src/proto_alpha/lib_client_commands/client_proto_context_commands.ml 217 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Tezos_micheline
open Client_proto_context
open Client_proto_contracts
open Client_proto_programs
open Client_keys
open Client_proto_args
let encrypted_switch =
Clic.switch ~long:"encrypted" ~doc:"encrypt the key on-disk" ()
let dry_run_switch =
Clic.switch
~long:"dry-run"
~short:'D'
~doc:"don't inject the operation, just display it"
()
let verbose_signing_switch =
Clic.switch
~long:"verbose-signing"
~doc:"display extra information before signing the operation"
()
let report_michelson_errors ?(no_print_source = false) ~msg
(cctxt : #Client_context.printer) = function
| Error errs ->
cctxt#warning
"%a"
(Michelson_v1_error_reporter.report_errors
~details:(not no_print_source)
~show_source:(not no_print_source)
?parsed:None)
errs
>>= fun () -> cctxt#error "%s" msg >>= fun () -> Lwt.return_none
| Ok data ->
Lwt.return_some data
let json_file_or_text_parameter =
Clic.parameter (fun _ p ->
match String.split ~limit:1 ':' p with
| ["text"; text] ->
return (Ezjsonm.from_string text)
| ["file"; path] ->
Lwt_utils_unix.Json.read_file path
| _ -> (
if Sys.file_exists p then Lwt_utils_unix.Json.read_file p
else
try return (Ezjsonm.from_string p)
with Ezjsonm.Parse_error _ ->
failwith "Neither an existing file nor valid JSON: '%s'" p ))
let data_parameter =
Clic.parameter (fun _ data ->
Lwt.return
( Micheline_parser.no_parsing_error
@@ Michelson_v1_parser.parse_expression data ))
let non_negative_param =
Clic.parameter (fun _ s ->
match int_of_string_opt s with
| Some i when i >= 0 ->
return i
| _ ->
failwith "Parameter should be a non-negative integer literal")
let block_hash_param =
Clic.parameter (fun _ s ->
try return (Block_hash.of_b58check_exn s)
with _ -> failwith "Parameter '%s' is an invalid block hash" s)
let group =
{
Clic.name = "context";
title = "Block contextual commands (see option -block)";
}
let alphanet = {Clic.name = "alphanet"; title = "Alphanet only commands"}
let binary_description =
{Clic.name = "description"; title = "Binary Description"}
let commands version () =
let open Clic in
[ command
~group
~desc:"Access the timestamp of the block."
(args1
(switch ~doc:"output time in seconds" ~short:'s' ~long:"seconds" ()))
(fixed ["get"; "timestamp"])
(fun seconds (cctxt : Protocol_client_context.full) ->
Shell_services.Blocks.Header.shell_header
cctxt
~chain:cctxt#chain
~block:cctxt#block
()
>>=? fun {timestamp = v; _} ->
( if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v)
else cctxt#message "%s" (Time.Protocol.to_notation v) )
>>= fun () -> return_unit);
command
~group
~desc:"Lists all non empty contracts of the block."
no_options
(fixed ["list"; "contracts"])
(fun () (cctxt : Protocol_client_context.full) ->
list_contract_labels cctxt ~chain:cctxt#chain ~block:cctxt#block
>>=? fun contracts ->
Lwt_list.iter_s
(fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias)
contracts
>>= fun () -> return_unit);
command
~group
~desc:"Get the balance of a contract."
no_options
( prefixes ["get"; "balance"; "for"]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop )
(fun () (_, contract) (cctxt : Protocol_client_context.full) ->
get_balance cctxt ~chain:cctxt#chain ~block:cctxt#block contract
>>=? fun amount ->
cctxt#answer "%a %s" Tez.pp amount Client_proto_args.tez_sym
>>= fun () -> return_unit);
command
~group
~desc:"Get the storage of a contract."
no_options
( prefixes ["get"; "contract"; "storage"; "for"]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop )
(fun () (_, contract) (cctxt : Protocol_client_context.full) ->
get_storage cctxt ~chain:cctxt#chain ~block:cctxt#block contract
>>=? function
| None ->
cctxt#error "This is not a smart contract."
| Some storage ->
cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped storage
>>= fun () -> return_unit);
command
~group
~desc:
"Get the value associated to a key in the big map storage of a \
contract (deprecated)."
no_options
( prefixes ["get"; "big"; "map"; "value"; "for"]
@@ Clic.param ~name:"key" ~desc:"the key to look for" data_parameter
@@ prefixes ["of"; "type"]
@@ Clic.param ~name:"type" ~desc:"type of the key" data_parameter
@@ prefix "in"
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop )
(fun () key key_type (_, contract) (cctxt : Protocol_client_context.full) ->
get_contract_big_map_value
cctxt
~chain:cctxt#chain
~block:cctxt#block
contract
(key.expanded, key_type.expanded)
>>=? function
| None ->
cctxt#error "No value associated to this key."
| Some value ->
cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped value
>>= fun () -> return_unit);
command
~group
~desc:"Get a value in a big map."
no_options
( prefixes ["get"; "element"]
@@ Clic.param
~name:"key"
~desc:"the key to look for"
(Clic.parameter (fun _ s ->
return (Script_expr_hash.of_b58check_exn s)))
@@ prefixes ["of"; "big"; "map"]
@@ Clic.param
~name:"big_map"
~desc:"identifier of the big_map"
int_parameter
@@ stop )
(fun () key id (cctxt : Protocol_client_context.full) ->
get_big_map_value
cctxt
~chain:cctxt#chain
~block:cctxt#block
(Z.of_int id)
key
>>=? fun value ->
cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped value
>>= fun () -> return_unit);
command
~group
~desc:"Get the code of a contract."
no_options
( prefixes ["get"; "contract"; "code"; "for"]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop )
(fun () (_, contract) (cctxt : Protocol_client_context.full) ->
get_script cctxt ~chain:cctxt#chain ~block:cctxt#block contract
>>=? function
| None ->
cctxt#error "This is not a smart contract."
| Some {code; storage = _} -> (
match Script_repr.force_decode code with
| Error errs ->
cctxt#error
"%a"
(Format.pp_print_list
~pp_sep:Format.pp_print_newline
Environment.Error_monad.pp)
errs
| Ok (code, _) ->
let {Michelson_v1_parser.source; _} =
Michelson_v1_printer.unparse_toplevel code
in
cctxt#answer "%a" Format.pp_print_text source >>= return ));
command
~group
~desc:"Get the type of an entrypoint of a contract."
no_options
( prefixes ["get"; "contract"; "entrypoint"; "type"; "of"]
@@ Clic.string ~name:"entrypoint" ~desc:"the entrypoint to describe"
@@ prefixes ["for"]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop )
(fun () entrypoint (_, contract) (cctxt : Protocol_client_context.full) ->
Michelson_v1_entrypoints.contract_entrypoint_type
cctxt
~chain:cctxt#chain
~block:cctxt#block
~contract
~entrypoint
>>= Michelson_v1_entrypoints.print_entrypoint_type
cctxt
~emacs:false
~contract
~entrypoint);
command
~group
~desc:"Get the entrypoint list of a contract."
no_options
( prefixes ["get"; "contract"; "entrypoints"; "for"]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop )
(fun () (_, contract) (cctxt : Protocol_client_context.full) ->
Michelson_v1_entrypoints.list_contract_entrypoints
cctxt
~chain:cctxt#chain
~block:cctxt#block
~contract
>>= Michelson_v1_entrypoints.print_entrypoints_list
cctxt
~emacs:false
~contract);
command
~group
~desc:"Get the list of unreachable pathsin a contract's parameter type."
no_options
( prefixes ["get"; "contract"; "unreachable"; "paths"; "for"]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop )
(fun () (_, contract) (cctxt : Protocol_client_context.full) ->
Michelson_v1_entrypoints.list_contract_unreachables
cctxt
~chain:cctxt#chain
~block:cctxt#block
~contract
>>= Michelson_v1_entrypoints.print_unreachables
cctxt
~emacs:false
~contract);
command
~group
~desc:"Get the delegate of a contract."
no_options
( prefixes ["get"; "delegate"; "for"]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop )
(fun () (_, contract) (cctxt : Protocol_client_context.full) ->
Client_proto_contracts.get_delegate
cctxt
~chain:cctxt#chain
~block:cctxt#block
contract
>>=? function
| None ->
cctxt#message "none" >>= fun () -> return_unit
| Some delegate ->
Public_key_hash.rev_find cctxt delegate
>>=? fun mn ->
Public_key_hash.to_source delegate
>>=? fun m ->
cctxt#message
"%s (%s)"
m
(match mn with None -> "unknown" | Some n -> "known as " ^ n)
>>= fun () -> return_unit);
command
~group
~desc:"Set the delegate of a contract."
(args9
fee_arg
dry_run_switch
verbose_signing_switch
minimal_fees_arg
minimal_nanotez_per_byte_arg
minimal_nanotez_per_gas_unit_arg
force_low_fee_arg
fee_cap_arg
burn_cap_arg)
( prefixes ["set"; "delegate"; "for"]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ prefix "to"
@@ Public_key_hash.alias_param
~name:"mgr"
~desc:"new delegate of the contract"
@@ stop )
(fun ( fee,
dry_run,
verbose_signing,
minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee,
fee_cap,
burn_cap )
(_, contract)
(_, delegate)
(cctxt : Protocol_client_context.full) ->
let fee_parameter =
{
Injection.minimal_fees;
minimal_nanotez_per_byte;
minimal_nanotez_per_gas_unit;
force_low_fee;
fee_cap;
burn_cap;
}
in
match Contract.is_implicit contract with
| None ->
Managed_contract.get_contract_manager cctxt contract
>>=? fun source ->
Client_keys.get_key cctxt source
>>=? fun (_, src_pk, src_sk) ->
Managed_contract.set_delegate
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
~verbose_signing
~fee_parameter
?fee
~source
~src_pk
~src_sk
contract
(Some delegate)
>>= fun errors ->
report_michelson_errors
~no_print_source:true
~msg:"Setting delegate through entrypoints failed."
cctxt
errors
>>= fun _ -> return_unit
| Some mgr ->
Client_keys.get_key cctxt mgr
>>=? fun (_, src_pk, manager_sk) ->
set_delegate
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
~verbose_signing
~fee_parameter
?fee
mgr
(Some delegate)
~src_pk
~manager_sk
>>=? fun _ -> return_unit);
command
~group
~desc:"Withdraw the delegate from a contract."
(args9
fee_arg
dry_run_switch
verbose_signing_switch
minimal_fees_arg
minimal_nanotez_per_byte_arg
minimal_nanotez_per_gas_unit_arg
force_low_fee_arg
fee_cap_arg
burn_cap_arg)
( prefixes ["withdraw"; "delegate"; "from"]
@@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
@@ stop )
(fun ( fee,
dry_run,
verbose_signing,
minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee,
fee_cap,
burn_cap )
(_, contract)
(cctxt : Protocol_client_context.full) ->
let fee_parameter =
{
Injection.minimal_fees;
minimal_nanotez_per_byte;
minimal_nanotez_per_gas_unit;
force_low_fee;
fee_cap;
burn_cap;
}
in
match Contract.is_implicit contract with
| None ->
Managed_contract.get_contract_manager cctxt contract
>>=? fun source ->
Client_keys.get_key cctxt source
>>=? fun (_, src_pk, src_sk) ->
Managed_contract.set_delegate
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
~verbose_signing
~fee_parameter
?fee
~source
~src_pk
~src_sk
contract
None
>>= fun errors ->
report_michelson_errors
~no_print_source:true
~msg:"Withdrawing delegate through entrypoints failed."
cctxt
errors
>>= fun _ -> return_unit
| Some mgr ->
Client_keys.get_key cctxt mgr
>>=? fun (_, src_pk, manager_sk) ->
set_delegate
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
~verbose_signing
~fee_parameter
mgr
None
?fee
~src_pk
~manager_sk
>>= fun _ -> return_unit);
command
~group
~desc:"Launch a smart contract on the blockchain."
(args15
fee_arg
dry_run_switch
verbose_signing_switch
gas_limit_arg
storage_limit_arg
delegate_arg
(Client_keys.force_switch ())
init_arg
no_print_source_flag
minimal_fees_arg
minimal_nanotez_per_byte_arg
minimal_nanotez_per_gas_unit_arg
force_low_fee_arg
fee_cap_arg
burn_cap_arg)
( prefixes ["originate"; "contract"]
@@ RawContractAlias.fresh_alias_param
~name:"new"
~desc:"name of the new contract"
@@ prefix "transferring"
@@ tez_param ~name:"qty" ~desc:"amount taken from source"
@@ prefix "from"
@@ ContractAlias.destination_param
~name:"src"
~desc:"name of the source contract"
@@ prefix "running"
@@ Program.source_param
~name:"prg"
~desc:
"script of the account\n\
Combine with -init if the storage type is not unit."
@@ stop )
(fun ( fee,
dry_run,
verbose_signing,
gas_limit,
storage_limit,
delegate,
force,
initial_storage,
no_print_source,
minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee,
fee_cap,
burn_cap )
alias_name
balance
(_, source)
program
(cctxt : Protocol_client_context.full) ->
RawContractAlias.of_fresh cctxt force alias_name
>>=? fun alias_name ->
Lwt.return (Micheline_parser.no_parsing_error program)
>>=? fun {expanded = code; _} ->
match Contract.is_implicit source with
| None ->
failwith
"only implicit accounts can be the source of an origination"
| Some source -> (
Client_keys.get_key cctxt source
>>=? fun (_, src_pk, src_sk) ->
let fee_parameter =
{
Injection.minimal_fees;
minimal_nanotez_per_byte;
minimal_nanotez_per_gas_unit;
force_low_fee;
fee_cap;
burn_cap;
}
in
originate_contract
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
~verbose_signing
?fee
?gas_limit
?storage_limit
~delegate
~initial_storage
~balance
~source
~src_pk
~src_sk
~code
~fee_parameter
()
>>= fun errors ->
report_michelson_errors
~no_print_source
~msg:"origination simulation failed"
cctxt
errors
>>= function
| None ->
return_unit
| Some (_res, contract) ->
if dry_run then return_unit
else
save_contract ~force cctxt alias_name contract
>>=? fun () -> return_unit ));
command
~group
~desc:"Transfer tokens / call a smart contract."
(args15
fee_arg
dry_run_switch
verbose_signing_switch
gas_limit_arg
storage_limit_arg
counter_arg
arg_arg
no_print_source_flag
minimal_fees_arg
minimal_nanotez_per_byte_arg
minimal_nanotez_per_gas_unit_arg
force_low_fee_arg
fee_cap_arg
burn_cap_arg
entrypoint_arg)
( prefixes ["transfer"]
@@ tez_param ~name:"qty" ~desc:"amount taken from source"
@@ prefix "from"
@@ ContractAlias.destination_param
~name:"src"
~desc:"name of the source contract"
@@ prefix "to"
@@ ContractAlias.destination_param
~name:"dst"
~desc:"name/literal of the destination contract"
@@ stop )
(fun ( fee,
dry_run,
verbose_signing,
gas_limit,
storage_limit,
counter,
arg,
no_print_source,
minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee,
fee_cap,
burn_cap,
entrypoint )
amount
(_, source)
(_, destination)
cctxt ->
let fee_parameter =
{
Injection.minimal_fees;
minimal_nanotez_per_byte;
minimal_nanotez_per_gas_unit;
force_low_fee;
fee_cap;
burn_cap;
}
in
( match Contract.is_implicit source with
| None ->
let contract = source in
Managed_contract.get_contract_manager cctxt source
>>=? fun source ->
Client_keys.get_key cctxt source
>>=? fun (_, src_pk, src_sk) ->
Managed_contract.transfer
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
~verbose_signing
~fee_parameter
?fee
~contract
~source
~src_pk
~src_sk
~destination
?entrypoint
?arg
~amount
?gas_limit
?storage_limit
?counter
()
| Some source ->
Client_keys.get_key cctxt source
>>=? fun (_, src_pk, src_sk) ->
transfer
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
~verbose_signing
~fee_parameter
~source
?fee
~src_pk
~src_sk
~destination
?entrypoint
?arg
~amount
?gas_limit
?storage_limit
?counter
() )
>>= report_michelson_errors
~no_print_source
~msg:"transfer simulation failed"
cctxt
>>= function
| None -> return_unit | Some (_res, _contracts) -> return_unit);
command
~group
~desc:"Call a smart contract (same as 'transfer 0')."
(args15
fee_arg
dry_run_switch
verbose_signing_switch
gas_limit_arg
storage_limit_arg
counter_arg
arg_arg
no_print_source_flag
minimal_fees_arg
minimal_nanotez_per_byte_arg
minimal_nanotez_per_gas_unit_arg
force_low_fee_arg
fee_cap_arg
burn_cap_arg
entrypoint_arg)
( prefixes ["call"]
@@ prefix "from"
@@ ContractAlias.destination_param
~name:"src"
~desc:"name of the source contract"
@@ prefix "to"
@@ ContractAlias.destination_param
~name:"dst"
~desc:"name/literal of the destination contract"
@@ stop )
(fun ( fee,
dry_run,
verbose_signing,
gas_limit,
storage_limit,
counter,
arg,
no_print_source,
minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee,
fee_cap,
burn_cap,
entrypoint )
(_, source)
(_, destination)
cctxt ->
let fee_parameter =
{
Injection.minimal_fees;
minimal_nanotez_per_byte;
minimal_nanotez_per_gas_unit;
force_low_fee;
fee_cap;
burn_cap;
}
in
let amount = Tez.zero in
( match Contract.is_implicit source with
| None ->
let contract = source in
Managed_contract.get_contract_manager cctxt source
>>=? fun source ->
Client_keys.get_key cctxt source
>>=? fun (_, src_pk, src_sk) ->
Managed_contract.transfer
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
~verbose_signing
~fee_parameter
?fee
~contract
~source
~src_pk
~src_sk
~destination
?entrypoint
?arg
~amount
?gas_limit
?storage_limit
?counter
()
| Some source ->
Client_keys.get_key cctxt source
>>=? fun (_, src_pk, src_sk) ->
transfer
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
~verbose_signing
~fee_parameter
~source
?fee
~src_pk
~src_sk
~destination
?entrypoint
?arg
~amount
?gas_limit
?storage_limit
?counter
() )
>>= report_michelson_errors
~no_print_source
~msg:"transfer simulation failed"
cctxt
>>= function
| None -> return_unit | Some (_res, _contracts) -> return_unit);
command
~group
~desc:"Reveal the public key of the contract manager."
(args9
fee_arg
dry_run_switch
verbose_signing_switch
minimal_fees_arg
minimal_nanotez_per_byte_arg
minimal_nanotez_per_gas_unit_arg
force_low_fee_arg
fee_cap_arg
burn_cap_arg)
( prefixes ["reveal"; "key"; "for"]
@@ ContractAlias.alias_param
~name:"src"
~desc:"name of the source contract"
@@ stop )
(fun ( fee,
dry_run,
verbose_signing,
minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee,
fee_cap,
burn_cap )
(_, source)
cctxt ->
match Contract.is_implicit source with
| None ->
failwith "only implicit accounts can be revealed"
| Some source ->
Client_keys.get_key cctxt source
>>=? fun (_, src_pk, src_sk) ->
let fee_parameter =
{
Injection.minimal_fees;
minimal_nanotez_per_byte;
minimal_nanotez_per_gas_unit;
force_low_fee;
fee_cap;
burn_cap;
}
in
reveal
cctxt
~dry_run
~verbose_signing
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~source
?fee
~src_pk
~src_sk
~fee_parameter
()
>>=? fun _res -> return_unit);
command
~group
~desc:"Register the public key hash as a delegate."
(args9
fee_arg
dry_run_switch
verbose_signing_switch
minimal_fees_arg
minimal_nanotez_per_byte_arg
minimal_nanotez_per_gas_unit_arg
force_low_fee_arg
fee_cap_arg
burn_cap_arg)
( prefixes ["register"; "key"]
@@ Public_key_hash.source_param ~name:"mgr" ~desc:"the delegate key"
@@ prefixes ["as"; "delegate"]
@@ stop )
(fun ( fee,
dry_run,
verbose_signing,
minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee,
fee_cap,
burn_cap )
src_pkh
cctxt ->
Client_keys.get_key cctxt src_pkh
>>=? fun (_, src_pk, src_sk) ->
let fee_parameter =
{
Injection.minimal_fees;
minimal_nanotez_per_byte;
minimal_nanotez_per_gas_unit;
force_low_fee;
fee_cap;
burn_cap;
}
in
register_as_delegate
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
~fee_parameter
~verbose_signing
?fee
~manager_sk:src_sk
src_pk
>>= function
| Ok _ ->
return_unit
| Error [Environment.Ecoproto_error Delegate_storage.Active_delegate]
->
cctxt#message "Delegate already activated."
>>= fun () -> return_unit
| Error el ->
Lwt.return_error el) ]
@ ( if version = Some `Mainnet then []
else
[ command
~group
~desc:"Register and activate an Alphanet/Zeronet faucet account."
(args2 (Secret_key.force_switch ()) encrypted_switch)
( prefixes ["activate"; "account"]
@@ Secret_key.fresh_alias_param
@@ prefixes ["with"]
@@ param
~name:"activation_key"
~desc:
"Activate an Alphanet/Zeronet faucet account from the JSON \
(file or directly inlined)."
json_file_or_text_parameter
@@ stop )
(fun (force, encrypted) name activation_json cctxt ->
Secret_key.of_fresh cctxt force name
>>=? fun name ->
match
Data_encoding.Json.destruct
Client_proto_context.activation_key_encoding
activation_json
with
| exception (Data_encoding.Json.Cannot_destruct _ as exn) ->
Format.kasprintf
(fun s -> failwith "%s" s)
"Invalid activation file: %a %a"
(fun ppf -> Data_encoding.Json.print_error ppf)
exn
Data_encoding.Json.pp
activation_json
| key ->
activate_account
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~encrypted
~force
key
name
>>=? fun _res -> return_unit) ] )
@ ( if version <> Some `Mainnet then []
else
[ command
~group
~desc:"Activate a fundraiser account."
(args1 dry_run_switch)
( prefixes ["activate"; "fundraiser"; "account"]
@@ Public_key_hash.alias_param
@@ prefixes ["with"]
@@ param
~name:"code"
(Clic.parameter (fun _ctx code ->
protect (fun () ->
return
(Blinded_public_key_hash.activation_code_of_hex code))))
~desc:"Activation code obtained from the Tezos foundation."
@@ stop )
(fun dry_run (name, _pkh) code cctxt ->
activate_existing_account
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
name
code
>>=? fun _res -> return_unit) ] )
@ [ command
~desc:"Wait until an operation is included in a block"
(args3
(default_arg
~long:"confirmations"
~placeholder:"num_blocks"
~doc:
"wait until 'N' additional blocks after the operation appears \
in the considered chain"
~default:"0"
non_negative_param)
(default_arg
~long:"check-previous"
~placeholder:"num_blocks"
~doc:"number of previous blocks to check"
~default:"10"
non_negative_param)
(arg
~long:"branch"
~placeholder:"block_hash"
~doc:
"hash of the oldest block where we should look for the \
operation"
block_hash_param))
( prefixes ["wait"; "for"]
@@ param
~name:"operation"
~desc:"Operation to be included"
(parameter (fun _ x ->
match Operation_hash.of_b58check_opt x with
| None ->
Error_monad.failwith "Invalid operation hash: '%s'" x
| Some hash ->
return hash))
@@ prefixes ["to"; "be"; "included"]
@@ stop )
(fun (confirmations, predecessors, branch)
operation_hash
(ctxt : Protocol_client_context.full) ->
Client_confirmations.wait_for_operation_inclusion
ctxt
~chain:ctxt#chain
~confirmations
~predecessors
?branch
operation_hash
>>=? fun _ -> return_unit);
command
~desc:"Get receipt for past operation"
(args1
(default_arg
~long:"check-previous"
~placeholder:"num_blocks"
~doc:"number of previous blocks to check"
~default:"10"
non_negative_param))
( prefixes ["get"; "receipt"; "for"]
@@ param
~name:"operation"
~desc:"Operation to be looked up"
(parameter (fun _ x ->
match Operation_hash.of_b58check_opt x with
| None ->
Error_monad.failwith "Invalid operation hash: '%s'" x
| Some hash ->
return hash))
@@ stop )
(fun predecessors operation_hash (ctxt : Protocol_client_context.full) ->
display_receipt_for_operation
ctxt
~chain:ctxt#chain
~predecessors
operation_hash
>>=? fun _ -> return_unit);
command
~group:binary_description
~desc:"Describe unsigned block header"
no_options
(fixed ["describe"; "unsigned"; "block"; "header"])
(fun () (cctxt : Protocol_client_context.full) ->
cctxt#message
"%a"
Data_encoding.Binary_schema.pp
(Data_encoding.Binary.describe
Alpha_context.Block_header.unsigned_encoding)
>>= fun () -> return_unit);
command
~group:binary_description
~desc:"Describe unsigned block header"
no_options
(fixed ["describe"; "unsigned"; "operation"])
(fun () (cctxt : Protocol_client_context.full) ->
cctxt#message
"%a"
Data_encoding.Binary_schema.pp
(Data_encoding.Binary.describe
Alpha_context.Operation.unsigned_encoding)
>>= fun () -> return_unit);
command
~group
~desc:"Submit protocol proposals"
(args3
dry_run_switch
verbose_signing_switch
(switch
~doc:
"Do not fail when the checks that try to prevent the user \
from shooting themselves in the foot do."
~long:"force"
()))
( prefixes ["submit"; "proposals"; "for"]
@@ Client_keys.Secret_key.alias_param
~name:"delegate"
~desc:"the delegate who makes the proposal"
@@ seq_of_param
(param
~name:"proposal"
~desc:"the protocol hash proposal to be submitted"
(parameter (fun _ x ->
match Protocol_hash.of_b58check_opt x with
| None ->
Error_monad.failwith "Invalid proposal hash: '%s'" x
| Some hash ->
return hash))) )
(fun (dry_run, verbose_signing, force)
(src_name, src_sk)
proposals
(cctxt : Protocol_client_context.full) ->
Client_keys.neuterize src_sk
>>=? fun src_pk ->
Client_keys.public_key_hash src_pk
>>=? fun (src_pkh, _) ->
get_period_info ~chain:cctxt#chain ~block:cctxt#block cctxt
>>=? fun info ->
( match info.current_period_kind with
| Proposal ->
return_unit
| _ ->
cctxt#error "Not in a proposal period" )
>>=? fun () ->
Shell_services.Protocol.list cctxt
>>=? fun known_protos ->
get_proposals ~chain:cctxt#chain ~block:cctxt#block cctxt
>>=? fun known_proposals ->
Alpha_services.Voting.listings cctxt (cctxt#chain, cctxt#block)
>>=? fun listings ->
(* for a proposal to be valid it must either a protocol that was already
proposed by somebody else or a protocol known by the node, because
the user is the first proposer and just injected it with
tezos-admin-client *)
let check_proposals proposals : bool tzresult Lwt.t =
let n = List.length proposals in
let errors = ref [] in
let error ppf =
Format.kasprintf (fun s -> errors := s :: !errors) ppf
in
if n = 0 then error "Empty proposal list." ;
if n > Constants.fixed.max_proposals_per_delegate then
error
"Too many proposals: %d > %d."
n
Constants.fixed.max_proposals_per_delegate ;
( match
Base.List.find_all_dups
~compare:Protocol_hash.compare
proposals
with
| [] ->
()
| dups ->
error
"There %s: %a."
( if List.length dups = 1 then "is a duplicate proposal"
else "are duplicate proposals" )
Format.(
pp_print_list
~pp_sep:(fun ppf () -> pp_print_string ppf ", ")
Protocol_hash.pp)
dups ) ;
List.iter
(fun (p : Protocol_hash.t) ->
if
List.mem p known_protos
|| Environment.Protocol_hash.Map.mem p known_proposals
then ()
else
error
"Protocol %a is not a known proposal."
Protocol_hash.pp
p)
proposals ;
if
not
(List.exists
(fun (pkh, _) ->
Signature.Public_key_hash.equal pkh src_pkh)
listings)
then
error
"Public-key-hash `%a` from account `%s` does not appear to \
have voting rights."
Signature.Public_key_hash.pp
src_pkh
src_name ;
if !errors <> [] then
cctxt#message
"There %s with the submission:%t"
( if List.length !errors = 1 then "is an issue"
else "are issues" )
Format.(
fun ppf ->
pp_print_cut ppf () ;
pp_open_vbox ppf 0 ;
List.iter
(fun msg ->
pp_open_hovbox ppf 2 ;
pp_print_string ppf "* " ;
pp_print_text ppf msg ;
pp_close_box ppf () ;
pp_print_cut ppf ())
!errors ;
pp_close_box ppf ())
>>= fun () -> return_false
else return_true
in
check_proposals proposals
>>=? fun all_valid ->
( if all_valid then cctxt#message "All proposals are valid."
else if force then
cctxt#message
"Some proposals are not valid, but `--force` was used."
else cctxt#error "Submission failed because of invalid proposals." )
>>= fun () ->
submit_proposals
~dry_run
~verbose_signing
cctxt
~chain:cctxt#chain
~block:cctxt#block
~src_sk
src_pkh
proposals
>>= function
| Ok _res ->
return_unit
| Error errs ->
( match errs with
| [ Unregistred_error
(`O [("kind", `String "generic"); ("error", `String msg)])
] ->
cctxt#message
"Error:@[<hov>@.%a@]"
Format.pp_print_text
( String.split_on_char ' ' msg
|> List.filter (function "" | "\n" -> false | _ -> true)
|> String.concat " "
|> String.map (function '\n' | '\t' -> ' ' | c -> c) )
| el ->
cctxt#message "Error:@ %a" pp_print_error el )
>>= fun () -> failwith "Failed to submit proposals");
command
~group
~desc:"Submit a ballot"
(args2 verbose_signing_switch dry_run_switch)
( prefixes ["submit"; "ballot"; "for"]
@@ Client_keys.Secret_key.alias_param
~name:"delegate"
~desc:"the delegate who votes"
@@ param
~name:"proposal"
~desc:"the protocol hash proposal to vote for"
(parameter (fun _ x ->
match Protocol_hash.of_b58check_opt x with
| None ->
failwith "Invalid proposal hash: '%s'" x
| Some hash ->
return hash))
@@ param
~name:"ballot"
~desc:"the ballot value (yea/yay, nay, or pass)"
(parameter
~autocomplete:(fun _ -> return ["yea"; "nay"; "pass"])
(fun _ s ->
(* We should have [Vote.of_string]. *)
match String.lowercase_ascii s with
| "yay" | "yea" ->
return Vote.Yay
| "nay" ->
return Vote.Nay
| "pass" ->
return Vote.Pass
| s ->
failwith "Invalid ballot: '%s'" s))
@@ stop )
(fun (verbose_signing, dry_run)
(_, src_sk)
proposal
ballot
(cctxt : Protocol_client_context.full) ->
Client_keys.neuterize src_sk
>>=? fun src_pk ->
Client_keys.public_key_hash src_pk
>>=? fun (src_pkh, _) ->
get_period_info ~chain:cctxt#chain ~block:cctxt#block cctxt
>>=? fun info ->
( match info.current_period_kind with
| Testing_vote | Promotion_vote ->
return_unit
| _ ->
cctxt#error "Not in a Testing_vote or Promotion_vote period" )
>>=? fun () ->
submit_ballot
cctxt
~chain:cctxt#chain
~block:cctxt#block
~src_sk
src_pkh
~verbose_signing
~dry_run
proposal
ballot
>>=? fun _res -> return_unit);
command
~group
~desc:"Summarize the current voting period"
no_options
(fixed ["show"; "voting"; "period"])
(fun () (cctxt : Protocol_client_context.full) ->
get_period_info ~chain:cctxt#chain ~block:cctxt#block cctxt
>>=? fun info ->
cctxt#message
"Current period: %a\nBlocks remaining until end of period: %ld"
Data_encoding.Json.pp
(Data_encoding.Json.construct
Alpha_context.Voting_period.kind_encoding
info.current_period_kind)
info.remaining
>>= fun () ->
Shell_services.Protocol.list cctxt
>>=? fun known_protos ->
get_proposals ~chain:cctxt#chain ~block:cctxt#block cctxt
>>=? fun props ->
let ranks =
Environment.Protocol_hash.Map.bindings props
|> List.sort (fun (_, v1) (_, v2) -> Int32.(compare v2 v1))
in
let print_proposal = function
| None ->
assert false (* not called during proposal phase *)
| Some proposal ->
cctxt#message "Current proposal: %a" Protocol_hash.pp proposal
in
match info.current_period_kind with
| Proposal ->
cctxt#answer
"Current proposals:%t"
Format.(
fun ppf ->
pp_print_cut ppf () ;
pp_open_vbox ppf 0 ;
List.iter
(fun (p, w) ->
fprintf
ppf
"* %a %ld (%sknown by the node)@."
Protocol_hash.pp
p
w
(if List.mem p known_protos then "" else "not "))
ranks ;
pp_close_box ppf ())
>>= fun () -> return_unit
| Testing_vote | Promotion_vote ->
print_proposal info.current_proposal
>>= fun () ->
get_ballots_info ~chain:cctxt#chain ~block:cctxt#block cctxt
>>=? fun ballots_info ->
cctxt#answer
"Ballots: %a@,\
Current participation %.2f%%, necessary quorum %.2f%%@,\
Current in favor %ld, needed supermajority %ld"
Data_encoding.Json.pp
(Data_encoding.Json.construct
Vote.ballots_encoding
ballots_info.ballots)
(Int32.to_float ballots_info.participation /. 100.)
(Int32.to_float ballots_info.current_quorum /. 100.)
ballots_info.ballots.yay
ballots_info.supermajority
>>= fun () -> return_unit
| Testing ->
print_proposal info.current_proposal >>= fun () -> return_unit)
]
src/proto_alpha/lib_client_commands/client_proto_context_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Import Tezos_micheline.
Import Client_proto_context.
Import Client_proto_contracts.
Import Client_proto_programs.
Import Client_keys.
Import Client_proto_args.
Definition encrypted_switch
: Tezos_base__TzPervasives.Clic.arg bool
Tezos_client_alpha.Protocol_client_context.full :=
Clic.switch "encrypt the key on-disk" % string None "encrypted" % string tt.
Definition dry_run_switch
: Tezos_base__TzPervasives.Clic.arg bool
Tezos_client_alpha.Protocol_client_context.full :=
Clic.switch "don't inject the operation, just display it" % string
(Some "D" % char) "dry-run" % string tt.
Definition verbose_signing_switch
: Tezos_base__TzPervasives.Clic.arg bool
Tezos_client_alpha.Protocol_client_context.full :=
Clic.switch "display extra information before signing the operation" % string
None "verbose-signing" % string tt.
Definition report_michelson_errors {C D a b : Type}
(op_staroptstar : option bool)
: string ->
(((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C) ->
(sum D (list Tezos_base__TzPervasives.Error_monad.error)) ->
Lwt.t (option D) :=
let no_print_source :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun msg =>
fun cctxt =>
fun function_parameter =>
match function_parameter with
| Stdlib.Error errs =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
(Michelson_v1_error_reporter.report_errors (negb no_print_source)
(negb no_print_source) None) errs)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string) msg)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_none))
| Stdlib.Ok data => Lwt.return_some data
end.
Definition json_file_or_text_parameter
: Tezos_base__TzPervasives.Clic.parameter
Tezos_data_encoding.Data_encoding.json
Tezos_client_alpha.Protocol_client_context.full :=
Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun p =>
match String.split ":" % char None (Some 1) p with
| cons "text" % string (cons text []) =>
_return (Ezjsonm.from_string text)
| cons "file" % string (cons path []) =>
Lwt_utils_unix.Json.read_file path
| _ =>
if Sys.file_exists p then
Lwt_utils_unix.Json.read_file p
else
(* ❌ Try-with are not handled *)
try (_return (Ezjsonm.from_string p))
end).
Definition data_parameter
: Tezos_base__TzPervasives.Clic.parameter
Tezos_client_alpha.Michelson_v1_parser.parsed
Tezos_client_alpha.Protocol_client_context.full :=
Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun data =>
Lwt._return
(apply Micheline_parser.no_parsing_error
(Michelson_v1_parser.parse_expression None data))).
Definition non_negative_param
: Tezos_base__TzPervasives.Clic.parameter Z
Tezos_client_alpha.Protocol_client_context.full :=
Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
match Stdlib.int_of_string_opt s with
| Some i => _return i
| _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Parameter should be a non-negative integer literal" % string
CamlinternalFormatBasics.End_of_format)
"Parameter should be a non-negative integer literal" % string)
end).
Definition block_hash_param
: Tezos_base__TzPervasives.Clic.parameter
Tezos_base__TzPervasives.Block_hash.t
Tezos_client_alpha.Protocol_client_context.full :=
Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
(* ❌ Try-with are not handled *)
try (_return (Block_hash.of_b58check_exn s))).
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "context" % string;
Clic.title := "Block contextual commands (see option -block)" % string |}.
Definition alphanet : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "alphanet" % string;
Clic.title := "Alphanet only commands" % string |}.
Definition binary_description : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "description" % string;
Clic.title := "Binary Description" % string |}.
Definition commands (version : option variant) (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_alpha.Protocol_client_context.full) :=
let 'tt := function_parameter in
OCaml.Stdlib.app
(cons
(command (Some group) "Access the timestamp of the block." % string
(args1
(switch "output time in seconds" % string (Some "s" % char)
"seconds" % string tt))
(fixed (cons "get" % string (cons "timestamp" % string [])))
(fun seconds =>
fun cctxt =>
op_gtgteqquestion
(Shell_services.Blocks.Header.shell_header cctxt
(Some
(* ❌ Sending method message is not handled *)
send)
(Some
(* ❌ Sending method message is not handled *)
send) tt)
(fun function_parameter =>
let '{| timestamp := v |} := function_parameter in
op_gtgteq
(if seconds then
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int64
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format) "%Ld" % string)
(Time.Protocol.to_seconds v)
else
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
(Time.Protocol.to_notation v))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Lists all non empty contracts of the block." % string no_options
(fixed (cons "list" % string (cons "contracts" % string [])))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion
(list_contract_labels cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send)
(fun contracts =>
op_gtgteq
(Lwt_list.iter_s
(fun function_parameter =>
let '(alias, hash, kind) := function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"%s%s%s" % string) hash kind alias) contracts)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group) "Get the balance of a contract." % string
no_options
(apply
(prefixes
(cons "get" % string
(cons "balance" % string (cons "for" % string []))))
(apply
(ContractAlias.destination_param (Some "src" % string)
(Some "source contract" % string)) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(_, contract) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(get_balance cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send contract)
(fun amount =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal " " % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))
"%a %s" % string) Tez.pp amount
Client_proto_args.tez_sym)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group) "Get the storage of a contract." % string
no_options
(apply
(prefixes
(cons "get" % string
(cons "contract" % string
(cons "storage" % string (cons "for" % string [])))))
(apply
(ContractAlias.destination_param (Some "src" % string)
(Some "source contract" % string)) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(_, contract) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(get_storage cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send contract)
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This is not a smart contract." % string
CamlinternalFormatBasics.End_of_format)
"This is not a smart contract." % string)
| Some storage =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string)
Michelson_v1_printer.print_expr_unwrapped storage)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end)))
(cons
(command (Some group)
"Get the value associated to a key in the big map storage of a contract (deprecated)."
% string no_options
(apply
(prefixes
(cons "get" % string
(cons "big" % string
(cons "map" % string
(cons "value" % string (cons "for" % string []))))))
(apply
(Clic.param "key" % string "the key to look for" % string
data_parameter)
(apply
(prefixes (cons "of" % string (cons "type" % string [])))
(apply
(Clic.param "type" % string "type of the key" % string
data_parameter)
(apply (prefix "in" % string)
(apply
(ContractAlias.destination_param
(Some "src" % string)
(Some "source contract" % string)) stop))))))
(fun function_parameter =>
let 'tt := function_parameter in
fun key =>
fun key_type =>
fun function_parameter =>
let '(_, contract) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(get_contract_big_map_value cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send contract
((expanded key), (expanded key_type)))
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No value associated to this key." %
string
CamlinternalFormatBasics.End_of_format)
"No value associated to this key." % string)
| Some value =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string)
Michelson_v1_printer.print_expr_unwrapped
value)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end)))
(cons
(command (Some group) "Get a value in a big map." % string
no_options
(apply
(prefixes (cons "get" % string (cons "element" % string [])))
(apply
(Clic.param "key" % string "the key to look for" % string
(Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
_return (Script_expr_hash.of_b58check_exn s))))
(apply
(prefixes
(cons "of" % string
(cons "big" % string (cons "map" % string []))))
(apply
(Clic.param "big_map" % string
"identifier of the big_map" % string int_parameter)
stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun key =>
fun id =>
fun cctxt =>
op_gtgteqquestion
(get_big_map_value cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Z.of_int id) key)
(fun value =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string)
Michelson_v1_printer.print_expr_unwrapped
value)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group) "Get the code of a contract." % string
no_options
(apply
(prefixes
(cons "get" % string
(cons "contract" % string
(cons "code" % string (cons "for" % string [])))))
(apply
(ContractAlias.destination_param (Some "src" % string)
(Some "source contract" % string)) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(_, contract) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(get_script cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send contract)
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"This is not a smart contract." % string
CamlinternalFormatBasics.End_of_format)
"This is not a smart contract." % string)
| Some {| code := code; storage := _ |} =>
match Script_repr.force_decode code with
| Stdlib.Error errs =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string)
(Format.pp_print_list
(Some Format.pp_print_newline)
Environment.Error_monad.pp) errs
| Stdlib.Ok (code, _) =>
let '{|
Michelson_v1_parser.source := source |} :=
Michelson_v1_printer.unparse_toplevel None
code in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Format.pp_print_text
source) _return
end
end)))
(cons
(command (Some group)
"Get the type of an entrypoint of a contract." % string
no_options
(apply
(prefixes
(cons "get" % string
(cons "contract" % string
(cons "entrypoint" % string
(cons "type" % string (cons "of" % string []))))))
(apply
(Clic.string "entrypoint" % string
"the entrypoint to describe" % string)
(apply (prefixes (cons "for" % string []))
(apply
(ContractAlias.destination_param
(Some "src" % string)
(Some "source contract" % string)) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun entrypoint =>
fun function_parameter =>
let '(_, contract) := function_parameter in
fun cctxt =>
op_gtgteq
(Michelson_v1_entrypoints.contract_entrypoint_type
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send contract entrypoint)
(let arg :=
Michelson_v1_entrypoints.print_entrypoint_type
cctxt
(* ❌ expected an argument *)
expected_argument false (Some contract)
(* ❌ expected an argument *)
expected_argument entrypoint in
fun eta => arg None None eta)))
(cons
(command (Some group)
"Get the entrypoint list of a contract." % string
no_options
(apply
(prefixes
(cons "get" % string
(cons "contract" % string
(cons "entrypoints" % string
(cons "for" % string [])))))
(apply
(ContractAlias.destination_param
(Some "src" % string)
(Some "source contract" % string)) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(_, contract) := function_parameter in
fun cctxt =>
op_gtgteq
(Michelson_v1_entrypoints.list_contract_entrypoints
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send contract)
(let arg :=
Michelson_v1_entrypoints.print_entrypoints_list
cctxt
(* ❌ expected an argument *)
expected_argument false (Some contract) in
fun eta => arg None None eta)))
(cons
(command (Some group)
"Get the list of unreachable pathsin a contract's parameter type."
% string no_options
(apply
(prefixes
(cons "get" % string
(cons "contract" % string
(cons "unreachable" % string
(cons "paths" % string
(cons "for" % string []))))))
(apply
(ContractAlias.destination_param
(Some "src" % string)
(Some "source contract" % string)) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(_, contract) := function_parameter in
fun cctxt =>
op_gtgteq
(Michelson_v1_entrypoints.list_contract_unreachables
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send contract)
(let arg :=
Michelson_v1_entrypoints.print_unreachables
cctxt
(* ❌ expected an argument *)
expected_argument false (Some contract) in
fun eta => arg None None eta)))
(cons
(command (Some group)
"Get the delegate of a contract." % string
no_options
(apply
(prefixes
(cons "get" % string
(cons "delegate" % string
(cons "for" % string []))))
(apply
(ContractAlias.destination_param
(Some "src" % string)
(Some "source contract" % string)) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(_, contract) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(Client_proto_contracts.get_delegate cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send contract)
(fun function_parameter =>
match function_parameter with
| None =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"none" % string
CamlinternalFormatBasics.End_of_format)
"none" % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Some delegate =>
op_gtgteqquestion
(Public_key_hash.rev_find cctxt
delegate)
(fun mn =>
op_gtgteqquestion
(Public_key_hash.to_source
delegate)
(fun m =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format))))
"%s (%s)" % string) m
match mn with
| None => "unknown" % string
| Some n =>
String.append
"known as " % string n
end)
(fun function_parameter =>
let 'tt :=
function_parameter in
return_unit)))
end)))
(cons
(command (Some group)
"Set the delegate of a contract." % string
(args9 fee_arg dry_run_switch
verbose_signing_switch minimal_fees_arg
minimal_nanotez_per_byte_arg
minimal_nanotez_per_gas_unit_arg
force_low_fee_arg fee_cap_arg burn_cap_arg)
(apply
(prefixes
(cons "set" % string
(cons "delegate" % string
(cons "for" % string []))))
(apply
(ContractAlias.destination_param
(Some "src" % string)
(Some "source contract" % string))
(apply (prefix "to" % string)
(apply
(Public_key_hash.alias_param
(Some "mgr" % string)
(Some
"new delegate of the contract" %
string)) stop))))
(fun function_parameter =>
let
'(fee, dry_run, verbose_signing, minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit, force_low_fee,
fee_cap, burn_cap) := function_parameter in
fun function_parameter =>
let '(_, contract) := function_parameter in
fun function_parameter =>
let '(_, delegate) := function_parameter in
fun cctxt =>
let fee_parameter :=
{|
Injection.minimal_fees := minimal_fees;
Injection.minimal_nanotez_per_byte :=
minimal_nanotez_per_byte;
Injection.minimal_nanotez_per_gas_unit :=
minimal_nanotez_per_gas_unit;
Injection.force_low_fee :=
force_low_fee;
Injection.fee_cap := fee_cap;
Injection.burn_cap := burn_cap |} in
match Contract.is_implicit contract with
| None =>
op_gtgteqquestion
(Managed_contract.get_contract_manager
cctxt contract)
(fun source =>
op_gtgteqquestion
(Client_keys.get_key cctxt source)
(fun function_parameter =>
let '(_, src_pk, src_sk) :=
function_parameter in
op_gtgteq
(Managed_contract.set_delegate
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some dry_run)
(Some verbose_signing) None
fee_parameter fee source
src_pk src_sk contract
(Some delegate))
(fun errors =>
op_gtgteq
(report_michelson_errors
(Some true)
"Setting delegate through entrypoints failed."
% string cctxt errors)
(fun function_parameter =>
let '_ :=
function_parameter in
return_unit))))
| Some mgr =>
op_gtgteqquestion
(Client_keys.get_key cctxt mgr)
(fun function_parameter =>
let '(_, src_pk, manager_sk) :=
function_parameter in
op_gtgteqquestion
(set_delegate cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some dry_run)
(Some verbose_signing) fee mgr
src_pk manager_sk fee_parameter
(Some delegate))
(fun function_parameter =>
let '_ := function_parameter in
return_unit))
end))
(cons
(command (Some group)
"Withdraw the delegate from a contract." %
string
(args9 fee_arg dry_run_switch
verbose_signing_switch minimal_fees_arg
minimal_nanotez_per_byte_arg
minimal_nanotez_per_gas_unit_arg
force_low_fee_arg fee_cap_arg burn_cap_arg)
(apply
(prefixes
(cons "withdraw" % string
(cons "delegate" % string
(cons "from" % string []))))
(apply
(ContractAlias.destination_param
(Some "src" % string)
(Some "source contract" % string)) stop))
(fun function_parameter =>
let
'(fee, dry_run, verbose_signing,
minimal_fees, minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee, fee_cap, burn_cap) :=
function_parameter in
fun function_parameter =>
let '(_, contract) := function_parameter in
fun cctxt =>
let fee_parameter :=
{|
Injection.minimal_fees := minimal_fees;
Injection.minimal_nanotez_per_byte :=
minimal_nanotez_per_byte;
Injection.minimal_nanotez_per_gas_unit :=
minimal_nanotez_per_gas_unit;
Injection.force_low_fee :=
force_low_fee;
Injection.fee_cap := fee_cap;
Injection.burn_cap := burn_cap |} in
match Contract.is_implicit contract with
| None =>
op_gtgteqquestion
(Managed_contract.get_contract_manager
cctxt contract)
(fun source =>
op_gtgteqquestion
(Client_keys.get_key cctxt source)
(fun function_parameter =>
let '(_, src_pk, src_sk) :=
function_parameter in
op_gtgteq
(Managed_contract.set_delegate
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some dry_run)
(Some verbose_signing) None
fee_parameter fee source
src_pk src_sk contract None)
(fun errors =>
op_gtgteq
(report_michelson_errors
(Some true)
"Withdrawing delegate through entrypoints failed."
% string cctxt errors)
(fun function_parameter =>
let '_ :=
function_parameter in
return_unit))))
| Some mgr =>
op_gtgteqquestion
(Client_keys.get_key cctxt mgr)
(fun function_parameter =>
let '(_, src_pk, manager_sk) :=
function_parameter in
op_gtgteq
(set_delegate cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some dry_run)
(Some verbose_signing) fee mgr
src_pk manager_sk fee_parameter
None)
(fun function_parameter =>
let '_ := function_parameter in
return_unit))
end))
(cons
(command (Some group)
"Launch a smart contract on the blockchain." %
string
(args15 fee_arg dry_run_switch
verbose_signing_switch gas_limit_arg
storage_limit_arg delegate_arg
(Client_keys.force_switch tt) init_arg
no_print_source_flag minimal_fees_arg
minimal_nanotez_per_byte_arg
minimal_nanotez_per_gas_unit_arg
force_low_fee_arg fee_cap_arg burn_cap_arg)
(apply
(prefixes
(cons "originate" % string
(cons "contract" % string [])))
(apply
(RawContractAlias.fresh_alias_param
(Some "new" % string)
(Some
"name of the new contract" % string))
(apply (prefix "transferring" % string)
(apply
(tez_param "qty" % string
"amount taken from source" % string)
(apply (prefix "from" % string)
(apply
(ContractAlias.destination_param
(Some "src" % string)
(Some
"name of the source contract"
% string))
(apply (prefix "running" % string)
(apply
(Program.source_param
(Some "prg" % string)
(Some
"script of the account
Combine with -init if the storage type is not unit."
% string)) stop))))))))
(fun function_parameter =>
let
'(fee, dry_run, verbose_signing,
gas_limit, storage_limit, delegate,
force, initial_storage, no_print_source,
minimal_fees, minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee, fee_cap, burn_cap) :=
function_parameter in
fun alias_name =>
fun balance =>
fun function_parameter =>
let '(_, source) := function_parameter
in
fun program =>
fun cctxt =>
op_gtgteqquestion
(RawContractAlias.of_fresh cctxt
force alias_name)
(fun alias_name =>
op_gtgteqquestion
(Lwt._return
(Micheline_parser.no_parsing_error
program))
(fun function_parameter =>
let '{|
expanded := code |} :=
function_parameter in
match
Contract.is_implicit
source with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"only implicit accounts can be the source of an origination"
% string
CamlinternalFormatBasics.End_of_format)
"only implicit accounts can be the source of an origination"
% string)
| Some source =>
op_gtgteqquestion
(Client_keys.get_key
cctxt source)
(fun
function_parameter
=>
let
'(_, src_pk,
src_sk) :=
function_parameter
in
let fee_parameter :=
{|
Injection.minimal_fees :=
minimal_fees;
Injection.minimal_nanotez_per_byte :=
minimal_nanotez_per_byte;
Injection.minimal_nanotez_per_gas_unit :=
minimal_nanotez_per_gas_unit;
Injection.force_low_fee :=
force_low_fee;
Injection.fee_cap :=
fee_cap;
Injection.burn_cap :=
burn_cap |} in
op_gtgteq
(originate_contract
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(Some dry_run)
(Some
verbose_signing)
None fee
gas_limit
storage_limit
delegate
initial_storage
balance source
src_pk src_sk
code
fee_parameter tt)
(fun errors =>
op_gtgteq
(report_michelson_errors
(Some
no_print_source)
"origination simulation failed"
% string
cctxt errors)
(fun
function_parameter
=>
match
function_parameter
with
| None =>
return_unit
|
Some
(_res,
contract)
=>
if dry_run
then
return_unit
else
op_gtgteqquestion
(save_contract
force
cctxt
alias_name
contract)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
return_unit)
end)))
end))))
(cons
(command (Some group)
"Transfer tokens / call a smart contract." %
string
(args15 fee_arg dry_run_switch
verbose_signing_switch gas_limit_arg
storage_limit_arg counter_arg arg_arg
no_print_source_flag minimal_fees_arg
minimal_nanotez_per_byte_arg
minimal_nanotez_per_gas_unit_arg
force_low_fee_arg fee_cap_arg burn_cap_arg
entrypoint_arg)
(apply
(prefixes (cons "transfer" % string []))
(apply
(tez_param "qty" % string
"amount taken from source" % string)
(apply (prefix "from" % string)
(apply
(ContractAlias.destination_param
(Some "src" % string)
(Some
"name of the source contract" %
string))
(apply (prefix "to" % string)
(apply
(ContractAlias.destination_param
(Some "dst" % string)
(Some
"name/literal of the destination contract"
% string)) stop))))))
(fun function_parameter =>
let
'(fee, dry_run, verbose_signing,
gas_limit, storage_limit, counter,
arg, no_print_source, minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee, fee_cap, burn_cap,
entrypoint) := function_parameter in
fun amount =>
fun function_parameter =>
let '(_, source) := function_parameter
in
fun function_parameter =>
let '(_, destination) :=
function_parameter in
fun cctxt =>
let fee_parameter :=
{|
Injection.minimal_fees :=
minimal_fees;
Injection.minimal_nanotez_per_byte :=
minimal_nanotez_per_byte;
Injection.minimal_nanotez_per_gas_unit :=
minimal_nanotez_per_gas_unit;
Injection.force_low_fee :=
force_low_fee;
Injection.fee_cap := fee_cap;
Injection.burn_cap := burn_cap
|} in
op_gtgteq
(op_gtgteq
match
Contract.is_implicit source
with
| None =>
let contract := source in
op_gtgteqquestion
(Managed_contract.get_contract_manager
cctxt source)
(fun source =>
op_gtgteqquestion
(Client_keys.get_key
cctxt source)
(fun
function_parameter
=>
let
'(_, src_pk,
src_sk) :=
function_parameter
in
Managed_contract.transfer
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(Some dry_run)
(Some
verbose_signing)
None source src_pk
src_sk contract
destination
entrypoint arg
amount fee
gas_limit
storage_limit
counter
fee_parameter tt))
| Some source =>
op_gtgteqquestion
(Client_keys.get_key cctxt
source)
(fun function_parameter =>
let
'(_, src_pk, src_sk) :=
function_parameter in
transfer cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some dry_run)
(Some verbose_signing)
None source src_pk
src_sk destination
entrypoint arg amount
fee gas_limit
storage_limit counter
fee_parameter tt)
end
(report_michelson_errors
(Some no_print_source)
"transfer simulation failed"
% string cctxt))
(fun function_parameter =>
match function_parameter with
| None => return_unit
| Some (_res, _contracts) =>
return_unit
end)))
(cons
(command (Some group)
"Call a smart contract (same as 'transfer 0')."
% string
(args15 fee_arg dry_run_switch
verbose_signing_switch gas_limit_arg
storage_limit_arg counter_arg arg_arg
no_print_source_flag minimal_fees_arg
minimal_nanotez_per_byte_arg
minimal_nanotez_per_gas_unit_arg
force_low_fee_arg fee_cap_arg
burn_cap_arg entrypoint_arg)
(apply
(prefixes (cons "call" % string []))
(apply (prefix "from" % string)
(apply
(ContractAlias.destination_param
(Some "src" % string)
(Some
"name of the source contract" %
string))
(apply (prefix "to" % string)
(apply
(ContractAlias.destination_param
(Some "dst" % string)
(Some
"name/literal of the destination contract"
% string)) stop)))))
(fun function_parameter =>
let
'(fee, dry_run, verbose_signing,
gas_limit, storage_limit, counter,
arg, no_print_source, minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee, fee_cap, burn_cap,
entrypoint) := function_parameter in
fun function_parameter =>
let '(_, source) := function_parameter
in
fun function_parameter =>
let '(_, destination) :=
function_parameter in
fun cctxt =>
let fee_parameter :=
{|
Injection.minimal_fees :=
minimal_fees;
Injection.minimal_nanotez_per_byte :=
minimal_nanotez_per_byte;
Injection.minimal_nanotez_per_gas_unit :=
minimal_nanotez_per_gas_unit;
Injection.force_low_fee :=
force_low_fee;
Injection.fee_cap := fee_cap;
Injection.burn_cap := burn_cap
|} in
let amount := Tez.zero in
op_gtgteq
(op_gtgteq
match
Contract.is_implicit source
with
| None =>
let contract := source in
op_gtgteqquestion
(Managed_contract.get_contract_manager
cctxt source)
(fun source =>
op_gtgteqquestion
(Client_keys.get_key
cctxt source)
(fun
function_parameter
=>
let
'(_, src_pk,
src_sk) :=
function_parameter
in
Managed_contract.transfer
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(Some dry_run)
(Some
verbose_signing)
None source src_pk
src_sk contract
destination
entrypoint arg
amount fee
gas_limit
storage_limit
counter
fee_parameter tt))
| Some source =>
op_gtgteqquestion
(Client_keys.get_key cctxt
source)
(fun function_parameter =>
let
'(_, src_pk, src_sk) :=
function_parameter in
transfer cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some dry_run)
(Some verbose_signing)
None source src_pk
src_sk destination
entrypoint arg amount
fee gas_limit
storage_limit counter
fee_parameter tt)
end
(report_michelson_errors
(Some no_print_source)
"transfer simulation failed"
% string cctxt))
(fun function_parameter =>
match function_parameter with
| None => return_unit
| Some (_res, _contracts) =>
return_unit
end)))
(cons
(command (Some group)
"Reveal the public key of the contract manager."
% string
(args9 fee_arg dry_run_switch
verbose_signing_switch
minimal_fees_arg
minimal_nanotez_per_byte_arg
minimal_nanotez_per_gas_unit_arg
force_low_fee_arg fee_cap_arg
burn_cap_arg)
(apply
(prefixes
(cons "reveal" % string
(cons "key" % string
(cons "for" % string []))))
(apply
(ContractAlias.alias_param
(Some "src" % string)
(Some
"name of the source contract" %
string)) stop))
(fun function_parameter =>
let
'(fee, dry_run, verbose_signing,
minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee, fee_cap, burn_cap) :=
function_parameter in
fun function_parameter =>
let '(_, source) :=
function_parameter in
fun cctxt =>
match Contract.is_implicit source
with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"only implicit accounts can be revealed"
% string
CamlinternalFormatBasics.End_of_format)
"only implicit accounts can be revealed"
% string)
| Some source =>
op_gtgteqquestion
(Client_keys.get_key cctxt
source)
(fun function_parameter =>
let '(_, src_pk, src_sk) :=
function_parameter in
let fee_parameter :=
{|
Injection.minimal_fees :=
minimal_fees;
Injection.minimal_nanotez_per_byte :=
minimal_nanotez_per_byte;
Injection.minimal_nanotez_per_gas_unit :=
minimal_nanotez_per_gas_unit;
Injection.force_low_fee :=
force_low_fee;
Injection.fee_cap :=
fee_cap;
Injection.burn_cap :=
burn_cap |} in
op_gtgteqquestion
(reveal cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some dry_run)
(Some verbose_signing)
None source src_pk
src_sk fee fee_parameter
tt)
(fun _res => return_unit))
end))
(cons
(command (Some group)
"Register the public key hash as a delegate."
% string
(args9 fee_arg dry_run_switch
verbose_signing_switch
minimal_fees_arg
minimal_nanotez_per_byte_arg
minimal_nanotez_per_gas_unit_arg
force_low_fee_arg fee_cap_arg
burn_cap_arg)
(apply
(prefixes
(cons "register" % string
(cons "key" % string [])))
(apply
(Public_key_hash.source_param
(Some "mgr" % string)
(Some
"the delegate key" % string))
(apply
(prefixes
(cons "as" % string
(cons "delegate" % string [])))
stop)))
(fun function_parameter =>
let
'(fee, dry_run, verbose_signing,
minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee, fee_cap, burn_cap) :=
function_parameter in
fun src_pkh =>
fun cctxt =>
op_gtgteqquestion
(Client_keys.get_key cctxt
src_pkh)
(fun function_parameter =>
let '(_, src_pk, src_sk) :=
function_parameter in
let fee_parameter :=
{|
Injection.minimal_fees :=
minimal_fees;
Injection.minimal_nanotez_per_byte :=
minimal_nanotez_per_byte;
Injection.minimal_nanotez_per_gas_unit :=
minimal_nanotez_per_gas_unit;
Injection.force_low_fee :=
force_low_fee;
Injection.fee_cap :=
fee_cap;
Injection.burn_cap :=
burn_cap |} in
op_gtgteq
(register_as_delegate
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some dry_run)
(Some verbose_signing)
fee src_sk fee_parameter
src_pk)
(fun function_parameter =>
match function_parameter
with
| Stdlib.Ok _ =>
return_unit
|
Stdlib.Error
(cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
Tezos_protocol_environment_alpha__Environment.Error_monad.Active_delegate)
[]) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Delegate already activated."
% string
CamlinternalFormatBasics.End_of_format)
"Delegate already activated."
% string))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
return_unit)
| Stdlib.Error el =>
Lwt.return_error el
end)))) []))))))))))))))))))
(OCaml.Stdlib.app
(if
equiv_decb version
(Some
(* ❌ Variants not supported *)
variant) then
[]
else
cons
(command (Some group)
"Register and activate an Alphanet/Zeronet faucet account." % string
(args2 (Secret_key.force_switch tt) encrypted_switch)
(apply
(prefixes (cons "activate" % string (cons "account" % string [])))
(apply
(let arg := Secret_key.fresh_alias_param in
fun eta => arg None None eta)
(apply (prefixes (cons "with" % string []))
(apply
(param "activation_key" % string
"Activate an Alphanet/Zeronet faucet account from the JSON (file or directly inlined)."
% string json_file_or_text_parameter) stop))))
(fun function_parameter =>
let '(force, encrypted) := function_parameter in
fun name =>
fun activation_json =>
fun cctxt =>
op_gtgteqquestion (Secret_key.of_fresh cctxt force name)
(fun name =>
let 'key :=
Data_encoding.Json.destruct
Client_proto_context.activation_key_encoding
activation_json in
op_gtgteqquestion
(activate_account cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send None (Some encrypted) (Some force) key name)
(fun _res => return_unit)))) [])
(OCaml.Stdlib.app
(if
nequiv_decb version
(Some
(* ❌ Variants not supported *)
variant) then
[]
else
cons
(command (Some group) "Activate a fundraiser account." % string
(args1 dry_run_switch)
(apply
(prefixes
(cons "activate" % string
(cons "fundraiser" % string (cons "account" % string []))))
(apply
(let arg := Public_key_hash.alias_param in
fun eta => arg None None eta)
(apply (prefixes (cons "with" % string []))
(apply
(param "code" % string
"Activation code obtained from the Tezos foundation." %
string
(Clic.parameter None
(fun _ctx =>
fun code =>
protect None None
(fun function_parameter =>
let 'tt := function_parameter in
_return
(Blinded_public_key_hash.activation_code_of_hex
code))))) stop))))
(fun dry_run =>
fun function_parameter =>
let '(name, _pkh) := function_parameter in
fun code =>
fun cctxt =>
op_gtgteqquestion
(activate_existing_account cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some dry_run) name code)
(fun _res => return_unit))) [])
(cons
(command None
"Wait until an operation is included in a block" % string
(args3
(default_arg
"wait until 'N' additional blocks after the operation appears in the considered chain"
% string None "confirmations" % string "num_blocks" % string
"0" % string non_negative_param)
(default_arg "number of previous blocks to check" % string None
"check-previous" % string "num_blocks" % string "10" % string
non_negative_param)
(arg
"hash of the oldest block where we should look for the operation"
% string None "branch" % string "block_hash" % string
block_hash_param))
(apply (prefixes (cons "wait" % string (cons "for" % string [])))
(apply
(param "operation" % string "Operation to be included" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x =>
match Operation_hash.of_b58check_opt x with
| None =>
Error_monad.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid operation hash: '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))
"Invalid operation hash: '%s'" % string) x
| Some hash => _return hash
end)))
(apply
(prefixes
(cons "to" % string
(cons "be" % string (cons "included" % string [])))) stop)))
(fun function_parameter =>
let '(confirmations, predecessors, branch) := function_parameter
in
fun operation_hash =>
fun ctxt =>
op_gtgteqquestion
(Client_confirmations.wait_for_operation_inclusion ctxt
(* ❌ Sending method message is not handled *)
send (Some predecessors) (Some confirmations) branch
operation_hash)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)))
(cons
(command None "Get receipt for past operation" % string
(args1
(default_arg "number of previous blocks to check" % string None
"check-previous" % string "num_blocks" % string "10" % string
non_negative_param))
(apply
(prefixes
(cons "get" % string
(cons "receipt" % string (cons "for" % string []))))
(apply
(param "operation" % string
"Operation to be looked up" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x =>
match Operation_hash.of_b58check_opt x with
| None =>
Error_monad.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid operation hash: '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))
"Invalid operation hash: '%s'" % string) x
| Some hash => _return hash
end))) stop))
(fun predecessors =>
fun operation_hash =>
fun ctxt =>
op_gtgteqquestion
(display_receipt_for_operation ctxt
(* ❌ Sending method message is not handled *)
send (Some predecessors) operation_hash)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)))
(cons
(command (Some binary_description)
"Describe unsigned block header" % string no_options
(fixed
(cons "describe" % string
(cons "unsigned" % string
(cons "block" % string (cons "header" % string [])))))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Data_encoding.Binary_schema.pp
(Data_encoding.Binary.describe
Alpha_context.Block_header.unsigned_encoding))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(cons
(command (Some binary_description)
"Describe unsigned block header" % string no_options
(fixed
(cons "describe" % string
(cons "unsigned" % string (cons "operation" % string []))))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string) Data_encoding.Binary_schema.pp
(Data_encoding.Binary.describe
Alpha_context.Operation.unsigned_encoding))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))
(cons
(command (Some group) "Submit protocol proposals" % string
(args3 dry_run_switch verbose_signing_switch
(switch
"Do not fail when the checks that try to prevent the user from shooting themselves in the foot do."
% string None "force" % string tt))
(apply
(prefixes
(cons "submit" % string
(cons "proposals" % string (cons "for" % string []))))
(apply
(Client_keys.Secret_key.alias_param
(Some "delegate" % string)
(Some "the delegate who makes the proposal" % string))
(seq_of_param
(param "proposal" % string
"the protocol hash proposal to be submitted" %
string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x =>
match Protocol_hash.of_b58check_opt x with
| None =>
Error_monad.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid proposal hash: '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))
"Invalid proposal hash: '%s'" % string)
x
| Some hash => _return hash
end))))))
(fun function_parameter =>
let '(dry_run, verbose_signing, force) :=
function_parameter in
fun function_parameter =>
let '(src_name, src_sk) := function_parameter in
fun proposals =>
fun cctxt =>
op_gtgteqquestion (Client_keys.neuterize src_sk)
(fun src_pk =>
op_gtgteqquestion
(Client_keys.public_key_hash src_pk)
(fun function_parameter =>
let '(src_pkh, _) := function_parameter in
op_gtgteqquestion
(get_period_info cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send)
(fun info =>
op_gtgteqquestion
match current_period_kind info with
|
Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.Proposal
=> return_unit
| _ =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Not in a proposal period" %
string
CamlinternalFormatBasics.End_of_format)
"Not in a proposal period" %
string)
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Shell_services.Protocol.list
cctxt)
(fun known_protos =>
op_gtgteqquestion
(get_proposals cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send)
(fun known_proposals =>
op_gtgteqquestion
(Alpha_services.Voting.listings
cctxt
((* ❌ Sending method message is not handled *)
send,
(* ❌ Sending method message is not handled *)
send))
(fun listings =>
let check_proposals
(proposals :
Base.List.t
Tezos_base__TzPervasives.Protocol_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
bool) :=
let n :=
List.length
proposals in
let errors :=
Stdlib.ref [] in
let error {A : Type}
(ppf :
Stdlib.format4 A
Stdlib.Format.formatter
unit unit) : A :=
Format.kasprintf
(fun s =>
Stdlib.op_coloneq
errors
(cons s
(Stdlib.op_exclamation
errors)))
ppf in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if equiv_decb n 0
then
error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Empty proposal list."
% string
CamlinternalFormatBasics.End_of_format)
"Empty proposal list."
% string)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
OCaml.Stdlib.gt n
(max_proposals_per_delegate
Constants.fixed)
then
error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Too many proposals: "
% string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" > " %
string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
"."
%
char
CamlinternalFormatBasics.End_of_format)))))
"Too many proposals: %d > %d."
% string) n
(max_proposals_per_delegate
Constants.fixed)
else
tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match
Base.List.find_all_dups
Protocol_hash.compare
proposals with
| [] => tt
| dups =>
error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"There " %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"."
%
char
CamlinternalFormatBasics.End_of_format)))))
"There %s: %a."
% string)
(if
equiv_decb
(List.length
dups) 1
then
"is a duplicate proposal"
% string
else
"are duplicate proposals"
% string)
(pp_print_list
(Some
(fun ppf =>
fun
function_parameter
=>
let
'tt :=
function_parameter
in
pp_print_string
ppf
", " %
string))
Protocol_hash.pp)
dups
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun p =>
if
orb
(List.mem p
known_protos)
(Environment.Protocol_hash.Map.mem
p
known_proposals)
then
tt
else
error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Protocol "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is not a known proposal."
%
string
CamlinternalFormatBasics.End_of_format)))
"Protocol %a is not a known proposal."
% string)
Protocol_hash.pp
p) proposals
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
negb
(List._exists
(fun
function_parameter
=>
let
'(pkh, _) :=
function_parameter
in
Signature.Public_key_hash.equal
pkh
src_pkh)
listings) then
error
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Public-key-hash `"
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"` from account `"
%
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"` does not appear to have voting rights."
%
string
CamlinternalFormatBasics.End_of_format)))))
"Public-key-hash `%a` from account `%s` does not appear to have voting rights."
% string)
Signature.Public_key_hash.pp
src_pkh src_name
else
tt in
if
nequiv_decb
(Stdlib.op_exclamation
errors) [] then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"There " %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" with the submission:"
%
string
(CamlinternalFormatBasics.Theta
CamlinternalFormatBasics.End_of_format))))
"There %s with the submission:%t"
% string)
(if
equiv_decb
(List.length
(Stdlib.op_exclamation
errors))
1 then
"is an issue"
% string
else
"are issues" %
string)
(fun ppf =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
pp_print_cut
ppf tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
pp_open_vbox
ppf 0 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun msg
=>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
pp_open_hovbox
ppf
2 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
pp_print_string
ppf
"* "
%
string
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
pp_print_text
ppf
msg
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
pp_close_box
ppf
tt
in
pp_print_cut
ppf tt)
(Stdlib.op_exclamation
errors)
in
pp_close_box
ppf tt))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
return_false)
else
return_true in
op_gtgteqquestion
(check_proposals
proposals)
(fun all_valid =>
op_gtgteq
(if all_valid then
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"All proposals are valid."
% string
CamlinternalFormatBasics.End_of_format)
"All proposals are valid."
% string)
else
if force then
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Some proposals are not valid, but `--force` was used."
%
string
CamlinternalFormatBasics.End_of_format)
"Some proposals are not valid, but `--force` was used."
% string)
else
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Submission failed because of invalid proposals."
%
string
CamlinternalFormatBasics.End_of_format)
"Submission failed because of invalid proposals."
% string))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(submit_proposals
(Some
dry_run)
(Some
verbose_signing)
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send None
src_sk
src_pkh
proposals)
(fun
function_parameter
=>
match
function_parameter
with
|
Stdlib.Ok
_res =>
return_unit
|
Stdlib.Error
errs =>
op_gtgteq
match
errs
with
|
cons
(Tezos_base__TzPervasives.Unregistred_error
(O
(cons
("kind"
%
string,
String
"generic"
%
string)
(cons
("error"
%
string,
String
msg)
[]))))
[]
=>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error:"
%
string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<hov>"
%
string
CamlinternalFormatBasics.End_of_format)
"<hov>"
%
string))
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"Error:@[<hov>@.%a@]"
%
string)
Format.pp_print_text
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(String.split_on_char
" "
%
char
msg)
(List.filter
(fun
function_parameter
=>
match
function_parameter
with
|
""
%
string
|
"
"
%
string
=>
false
|
_
=>
true
end)))
(String.concat
" "
%
string))
(String.map
(fun
function_parameter
=>
match
function_parameter
with
|
"010"
%
char
|
"009"
%
char
=>
" "
%
char
|
c
=>
c
end)))
| el =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error:"
%
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ "
%
string
1
0)
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))
"Error:@ %a"
%
string)
pp_print_error
el
end
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to submit proposals"
%
string
CamlinternalFormatBasics.End_of_format)
"Failed to submit proposals"
%
string))
end))))))))))))
(cons
(command (Some group) "Submit a ballot" % string
(args2 verbose_signing_switch dry_run_switch)
(apply
(prefixes
(cons "submit" % string
(cons "ballot" % string (cons "for" % string []))))
(apply
(Client_keys.Secret_key.alias_param
(Some "delegate" % string)
(Some "the delegate who votes" % string))
(apply
(param "proposal" % string
"the protocol hash proposal to vote for" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun x =>
match Protocol_hash.of_b58check_opt x with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid proposal hash: '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))
"Invalid proposal hash: '%s'" % string)
x
| Some hash => _return hash
end)))
(apply
(param "ballot" % string
"the ballot value (yea/yay, nay, or pass)" %
string
(parameter
(Some
(fun function_parameter =>
let '_ := function_parameter in
_return
(cons "yea" % string
(cons "nay" % string
(cons "pass" % string [])))))
(fun function_parameter =>
let '_ := function_parameter in
fun s =>
match String.lowercase_ascii s with
| "yay" % string | "yea" % string =>
_return
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay
| "nay" % string =>
_return
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Nay
| "pass" % string =>
_return
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Pass
| s =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid ballot: '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))
"Invalid ballot: '%s'" % string) s
end))) stop))))
(fun function_parameter =>
let '(verbose_signing, dry_run) := function_parameter in
fun function_parameter =>
let '(_, src_sk) := function_parameter in
fun proposal =>
fun ballot =>
fun cctxt =>
op_gtgteqquestion (Client_keys.neuterize src_sk)
(fun src_pk =>
op_gtgteqquestion
(Client_keys.public_key_hash src_pk)
(fun function_parameter =>
let '(src_pkh, _) := function_parameter
in
op_gtgteqquestion
(get_period_info cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send)
(fun info =>
op_gtgteqquestion
match current_period_kind info
with
|
Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.Testing_vote
|
Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.Promotion_vote
=> return_unit
| _ =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Not in a Testing_vote or Promotion_vote period"
% string
CamlinternalFormatBasics.End_of_format)
"Not in a Testing_vote or Promotion_vote period"
% string)
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(submit_ballot (Some dry_run)
(Some verbose_signing) cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send None src_sk src_pkh
proposal ballot)
(fun _res => return_unit)))))))
(cons
(command (Some group)
"Summarize the current voting period" % string
no_options
(fixed
(cons "show" % string
(cons "voting" % string (cons "period" % string []))))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion
(get_period_info cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send)
(fun info =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Current period: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"
Blocks remaining until end of period: "
% string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))))
"Current period: %a
Blocks remaining until end of period: %ld"
% string) Data_encoding.Json.pp
(Data_encoding.Json.construct
Alpha_context.Voting_period.kind_encoding
(current_period_kind info))
(remaining info))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Shell_services.Protocol.list cctxt)
(fun known_protos =>
op_gtgteqquestion
(get_proposals cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send)
(fun props =>
let ranks :=
OCaml.Stdlib.reverse_apply
(Environment.Protocol_hash.Map.bindings
props)
(List.sort
(fun function_parameter =>
let '(_, v1) :=
function_parameter in
fun function_parameter =>
let '(_, v2) :=
function_parameter in
compare v2 v1)) in
let print_proposal
(function_parameter :
option
Tezos_base__TzPervasives.Protocol_hash.t)
: Lwt.t unit :=
match function_parameter with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some proposal =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Current proposal: " %
string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Current proposal: %a" %
string) Protocol_hash.pp
proposal
end in
match current_period_kind info with
|
Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.Proposal
=>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Current proposals:" %
string
(CamlinternalFormatBasics.Theta
CamlinternalFormatBasics.End_of_format))
"Current proposals:%t" %
string)
(fun ppf =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_print_cut ppf tt
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := pp_open_vbox ppf 0
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun function_parameter
=>
let '(p, w) :=
function_parameter
in
fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"* " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
" " % char
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" (" %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"known by the node)"
%
string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))
"* %a %ld (%sknown by the node)@."
% string)
Protocol_hash.pp p w
(if
List.mem p
known_protos
then
"" % string
else
"not " % string))
ranks in
pp_close_box ppf tt))
(fun function_parameter =>
let 'tt := function_parameter
in
return_unit)
|
Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.Testing_vote
|
Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.Promotion_vote
=>
op_gtgteq
(print_proposal
(current_proposal info))
(fun function_parameter =>
let 'tt := function_parameter
in
op_gtgteqquestion
(get_ballots_info cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send)
(fun ballots_info =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Ballots: " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," %
string 0 0)
(CamlinternalFormatBasics.String_literal
"Current participation "
% string
(CamlinternalFormatBasics.Float
CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision
2)
(CamlinternalFormatBasics.Char_literal
"%" %
char
(CamlinternalFormatBasics.String_literal
", necessary quorum "
%
string
(CamlinternalFormatBasics.Float
CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision
2)
(CamlinternalFormatBasics.Char_literal
"%"
%
char
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@,"
%
string
0
0)
(CamlinternalFormatBasics.String_literal
"Current in favor "
%
string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
", needed supermajority "
%
string
(CamlinternalFormatBasics.Int32
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format))))))))))))))
"Ballots: %a@,Current participation %.2f%%, necessary quorum %.2f%%@,Current in favor %ld, needed supermajority %ld"
% string)
Data_encoding.Json.pp
(Data_encoding.Json.construct
Vote.ballots_encoding
(ballots
ballots_info))
(Stdlib.op_divpoint
(Int32.to_float
(participation
ballots_info))
(* ❌ Float constant 100. is approximated by the integer 100 *)
100)
(Stdlib.op_divpoint
(Int32.to_float
(current_quorum
ballots_info))
(* ❌ Float constant 100. is approximated by the integer 100 *)
100)
(yay
(ballots
ballots_info))
(supermajority
ballots_info))
(fun function_parameter
=>
let 'tt :=
function_parameter
in
return_unit)))
|
Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.Testing
=>
op_gtgteq
(print_proposal
(current_proposal info))
(fun function_parameter =>
let 'tt := function_parameter
in
return_unit)
end)))))) []))))))))).
src/proto_alpha/lib_client_commands/client_proto_contracts_commands.ml 14 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Client_proto_contracts
let group =
{
Clic.name = "contracts";
title = "Commands for managing the record of known contracts";
}
let commands () =
let open Clic in
[ command
~group
~desc:"Add a contract to the wallet."
(args1 (RawContractAlias.force_switch ()))
( prefixes ["remember"; "contract"]
@@ RawContractAlias.fresh_alias_param @@ RawContractAlias.source_param
@@ stop )
(fun force name hash cctxt ->
RawContractAlias.of_fresh cctxt force name
>>=? fun name -> RawContractAlias.add ~force cctxt name hash);
command
~group
~desc:"Remove a contract from the wallet."
no_options
(prefixes ["forget"; "contract"] @@ RawContractAlias.alias_param @@ stop)
(fun () (name, _) cctxt -> RawContractAlias.del cctxt name);
command
~group
~desc:"Lists all known contracts in the wallet."
no_options
(fixed ["list"; "known"; "contracts"])
(fun () (cctxt : Protocol_client_context.full) ->
list_contracts cctxt
>>=? fun contracts ->
iter_s
(fun (prefix, alias, contract) ->
cctxt#message
"%s%s: %s"
prefix
alias
(Contract.to_b58check contract)
>>= return)
contracts);
command
~group
~desc:"Forget the entire wallet of known contracts."
(args1 (RawContractAlias.force_switch ()))
(fixed ["forget"; "all"; "contracts"])
(fun force cctxt ->
fail_unless force (failure "this can only used with option -force")
>>=? fun () -> RawContractAlias.set cctxt []);
command
~group
~desc:"Display a contract from the wallet."
no_options
( prefixes ["show"; "known"; "contract"]
@@ RawContractAlias.alias_param @@ stop )
(fun () (_, contract) (cctxt : Protocol_client_context.full) ->
cctxt#message "%a\n%!" Contract.pp contract >>= fun () -> return_unit)
]
src/proto_alpha/lib_client_commands/client_proto_contracts_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Import Client_proto_contracts.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "contracts" % string;
Clic.title := "Commands for managing the record of known contracts" % string
|}.
Definition commands (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_alpha.Protocol_client_context.full) :=
let 'tt := function_parameter in
cons
(command (Some group) "Add a contract to the wallet." % string
(args1 (RawContractAlias.force_switch tt))
(apply (prefixes (cons "remember" % string (cons "contract" % string [])))
(apply
(let arg := RawContractAlias.fresh_alias_param in
fun eta => arg None None eta)
(apply
(let arg := RawContractAlias.source_param in
fun eta => arg None None eta) stop)))
(fun force =>
fun name =>
fun hash =>
fun cctxt =>
op_gtgteqquestion (RawContractAlias.of_fresh cctxt force name)
(fun name => RawContractAlias.add force cctxt name hash)))
(cons
(command (Some group) "Remove a contract from the wallet." % string
no_options
(apply (prefixes (cons "forget" % string (cons "contract" % string [])))
(apply
(let arg := RawContractAlias.alias_param in
fun eta => arg None None eta) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(name, _) := function_parameter in
fun cctxt => RawContractAlias.del cctxt name))
(cons
(command (Some group)
"Lists all known contracts in the wallet." % string no_options
(fixed
(cons "list" % string
(cons "known" % string (cons "contracts" % string []))))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion (list_contracts cctxt)
(fun contracts =>
iter_s
(fun function_parameter =>
let '(prefix, alias, contract) := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
": " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"%s%s: %s" % string) prefix alias
(Contract.to_b58check contract)) _return) contracts)))
(cons
(command (Some group)
"Forget the entire wallet of known contracts." % string
(args1 (RawContractAlias.force_switch tt))
(fixed
(cons "forget" % string
(cons "all" % string (cons "contracts" % string []))))
(fun force =>
fun cctxt =>
op_gtgteqquestion
(fail_unless force
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"this can only used with option -force" % string
CamlinternalFormatBasics.End_of_format)
"this can only used with option -force" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
RawContractAlias.set cctxt [])))
(cons
(command (Some group) "Display a contract from the wallet." % string
no_options
(apply
(prefixes
(cons "show" % string
(cons "known" % string (cons "contract" % string []))))
(apply
(let arg := RawContractAlias.alias_param in
fun eta => arg None None eta) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(_, contract) := function_parameter in
fun cctxt =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "010" % char
(CamlinternalFormatBasics.Flush
CamlinternalFormatBasics.End_of_format)))
"%a
%!" % string) Contract.pp contract)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))) [])))).
src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml 185 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
let group =
{
Clic.name = "multisig";
title = "Commands for managing a multisig smart contract";
}
let threshold_param () =
Clic.param
~name:"threshold"
~desc:"Number of required signatures"
Client_proto_args.int_parameter
let public_key_param () =
Client_keys.Public_key.source_param
~name:"key"
~desc:"Each signer of the multisig contract"
let secret_key_param () =
Client_keys.Secret_key.source_param
~name:"key"
~desc:
"Secret key corresponding to one of the public keys stored on the \
multisig contract"
let signature_param () =
Clic.param
~name:"signature"
~desc:"Each signer of the multisig contract"
Client_proto_args.signature_parameter
let bytes_only_switch =
Clic.switch
~long:"bytes-only"
~doc:"return only the byte sequence to be signed"
()
let bytes_param ~name ~desc =
Clic.param ~name ~desc Client_proto_args.bytes_parameter
let transfer_options =
Clic.args12
Client_proto_args.fee_arg
Client_proto_context_commands.dry_run_switch
Client_proto_args.gas_limit_arg
Client_proto_args.storage_limit_arg
Client_proto_args.counter_arg
Client_proto_args.no_print_source_flag
Client_proto_args.minimal_fees_arg
Client_proto_args.minimal_nanotez_per_byte_arg
Client_proto_args.minimal_nanotez_per_gas_unit_arg
Client_proto_args.force_low_fee_arg
Client_proto_args.fee_cap_arg
Client_proto_args.burn_cap_arg
let commands () : #Protocol_client_context.full Clic.command list =
Clic.
[ command
~group
~desc:"Originate a new multisig contract."
(args13
Client_proto_args.fee_arg
Client_proto_context_commands.dry_run_switch
Client_proto_args.gas_limit_arg
Client_proto_args.storage_limit_arg
Client_proto_args.delegate_arg
(Client_keys.force_switch ())
Client_proto_args.no_print_source_flag
Client_proto_args.minimal_fees_arg
Client_proto_args.minimal_nanotez_per_byte_arg
Client_proto_args.minimal_nanotez_per_gas_unit_arg
Client_proto_args.force_low_fee_arg
Client_proto_args.fee_cap_arg
Client_proto_args.burn_cap_arg)
( prefixes ["deploy"; "multisig"]
@@ Client_proto_contracts.RawContractAlias.fresh_alias_param
~name:"new_multisig"
~desc:"name of the new multisig contract"
@@ prefix "transferring"
@@ Client_proto_args.tez_param
~name:"qty"
~desc:"amount taken from source"
@@ prefix "from"
@@ Client_proto_contracts.ContractAlias.destination_param
~name:"src"
~desc:"name of the source contract"
@@ prefixes ["with"; "threshold"]
@@ threshold_param ()
@@ prefixes ["on"; "public"; "keys"]
@@ seq_of_param (public_key_param ()) )
(fun ( fee,
dry_run,
gas_limit,
storage_limit,
delegate,
force,
no_print_source,
minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee,
fee_cap,
burn_cap )
alias_name
balance
(_, source)
threshold
keys
(cctxt : #Protocol_client_context.full) ->
Client_proto_contracts.RawContractAlias.of_fresh
cctxt
force
alias_name
>>=? fun alias_name ->
match Contract.is_implicit source with
| None ->
failwith
"only implicit accounts can be the source of an origination"
| Some source -> (
Client_keys.get_key cctxt source
>>=? fun (_, src_pk, src_sk) ->
let fee_parameter =
{
Injection.minimal_fees;
minimal_nanotez_per_byte;
minimal_nanotez_per_gas_unit;
force_low_fee;
fee_cap;
burn_cap;
}
in
map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) keys
>>=? fun keys ->
Client_proto_multisig.originate_multisig
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
?fee
?gas_limit
?storage_limit
~delegate
~threshold:(Z.of_int threshold)
~keys
~balance
~source
~src_pk
~src_sk
~fee_parameter
()
>>= fun errors ->
Client_proto_context_commands.report_michelson_errors
~no_print_source
~msg:"multisig origination simulation failed"
cctxt
errors
>>= function
| None ->
return_unit
| Some (_res, contract) ->
if dry_run then return_unit
else
Client_proto_context.save_contract
~force
cctxt
alias_name
contract
>>=? fun () -> return_unit ));
command
~group
~desc:
"Display the threshold, public keys, and byte sequence to sign for \
a multisigned transfer."
(args1 bytes_only_switch)
( prefixes ["prepare"; "multisig"; "transaction"; "on"]
@@ Client_proto_contracts.RawContractAlias.alias_param
~name:"multisig"
~desc:"name of the originated multisig contract"
@@ prefix "transferring"
@@ Client_proto_args.tez_param
~name:"qty"
~desc:"amount taken from source"
@@ prefix "to"
@@ Client_proto_contracts.ContractAlias.destination_param
~name:"dst"
~desc:"name/literal of the destination contract"
@@ stop )
(fun bytes_only
(_, multisig_contract)
amount
(_, destination)
(cctxt : #Protocol_client_context.full) ->
Client_proto_multisig.prepare_multisig_transaction
cctxt
~chain:cctxt#chain
~block:cctxt#block
~multisig_contract
~action:(Client_proto_multisig.Transfer (amount, destination))
()
>>=? fun prepared_command ->
return
@@
if bytes_only then
Format.printf
"0x%a@."
Hex.pp
(Hex.of_bytes prepared_command.Client_proto_multisig.bytes)
else
Format.printf
"%a@.%a@.%a@."
(fun ppf x ->
Format.fprintf
ppf
"Bytes to sign: '0x%a'"
Hex.pp
(Hex.of_bytes x))
prepared_command.Client_proto_multisig.bytes
(fun ppf z ->
Format.fprintf
ppf
"Threshold (number of signatures required): %s"
(Z.to_string z))
prepared_command.Client_proto_multisig.threshold
(fun ppf ->
Format.fprintf
ppf
"@[<2>Public keys of the signers:@ %a@]"
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ")
Signature.Public_key.pp))
prepared_command.Client_proto_multisig.keys);
command
~group
~desc:
"Display the threshold, public keys, and byte sequence to sign for \
a multisigned delegate change."
(args1 bytes_only_switch)
( prefixes ["prepare"; "multisig"; "transaction"; "on"]
@@ Client_proto_contracts.RawContractAlias.alias_param
~name:"multisig"
~desc:"name of the originated multisig contract"
@@ prefixes ["setting"; "delegate"; "to"]
@@ Client_keys.Public_key_hash.source_param
~name:"dlgt"
~desc:"new delegate of the new multisig contract"
@@ stop )
(fun bytes_only
(_, multisig_contract)
new_delegate
(cctxt : #Protocol_client_context.full) ->
Client_proto_multisig.prepare_multisig_transaction
cctxt
~chain:cctxt#chain
~block:cctxt#block
~multisig_contract
~action:(Client_proto_multisig.Change_delegate (Some new_delegate))
()
>>=? fun prepared_command ->
return
@@
if bytes_only then
Format.printf
"0x%a@."
Hex.pp
(Hex.of_bytes prepared_command.Client_proto_multisig.bytes)
else
Format.printf
"%a@.%a@.%a@."
(fun ppf x ->
Format.fprintf
ppf
"Bytes to sign: '0x%a'"
Hex.pp
(Hex.of_bytes x))
prepared_command.Client_proto_multisig.bytes
(fun ppf z ->
Format.fprintf
ppf
"Threshold (number of signatures required): %s"
(Z.to_string z))
prepared_command.Client_proto_multisig.threshold
(fun ppf ->
Format.fprintf
ppf
"@[<2>Public keys of the signers:@ %a@]"
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ")
Signature.Public_key.pp))
prepared_command.Client_proto_multisig.keys);
command
~group
~desc:
"Display the threshold, public keys, and byte sequence to sign for \
a multisigned delegate withdraw."
(args1 bytes_only_switch)
( prefixes ["prepare"; "multisig"; "transaction"; "on"]
@@ Client_proto_contracts.RawContractAlias.alias_param
~name:"multisig"
~desc:"name of the originated multisig contract"
@@ prefixes ["withdrawing"; "delegate"]
@@ stop )
(fun bytes_only
(_, multisig_contract)
(cctxt : #Protocol_client_context.full) ->
Client_proto_multisig.prepare_multisig_transaction
cctxt
~chain:cctxt#chain
~block:cctxt#block
~multisig_contract
~action:(Client_proto_multisig.Change_delegate None)
()
>>=? fun prepared_command ->
return
@@
if bytes_only then
Format.printf
"0x%a@."
Hex.pp
(Hex.of_bytes prepared_command.Client_proto_multisig.bytes)
else
Format.printf
"%a@.%a@.%a@."
(fun ppf x ->
Format.fprintf
ppf
"Bytes to sign: '0x%a'"
Hex.pp
(Hex.of_bytes x))
prepared_command.Client_proto_multisig.bytes
(fun ppf z ->
Format.fprintf
ppf
"Threshold (number of signatures required): %s"
(Z.to_string z))
prepared_command.Client_proto_multisig.threshold
(fun ppf ->
Format.fprintf
ppf
"@[<2>Public keys of the signers:@ %a@]"
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ")
Signature.Public_key.pp))
prepared_command.Client_proto_multisig.keys);
command
~group
~desc:
"Display the threshold, public keys, and byte sequence to sign for \
a multisigned change of keys and threshold."
(args1 bytes_only_switch)
( prefixes ["prepare"; "multisig"; "transaction"; "on"]
@@ Client_proto_contracts.RawContractAlias.alias_param
~name:"multisig"
~desc:"name of the originated multisig contract"
@@ prefixes ["setting"; "threshold"; "to"]
@@ threshold_param ()
@@ prefixes ["and"; "public"; "keys"; "to"]
@@ seq_of_param (public_key_param ()) )
(fun bytes_only
(_, multisig_contract)
new_threshold
new_keys
(cctxt : #Protocol_client_context.full) ->
map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) new_keys
>>=? fun keys ->
Client_proto_multisig.prepare_multisig_transaction
cctxt
~chain:cctxt#chain
~block:cctxt#block
~multisig_contract
~action:
(Client_proto_multisig.Change_keys (Z.of_int new_threshold, keys))
()
>>=? fun prepared_command ->
return
@@
if bytes_only then
Format.printf
"0x%a@."
Hex.pp
(Hex.of_bytes prepared_command.Client_proto_multisig.bytes)
else
Format.printf
"%a@.%a@.%a@."
(fun ppf x ->
Format.fprintf
ppf
"Bytes to sign: '0x%a'"
Hex.pp
(Hex.of_bytes x))
prepared_command.Client_proto_multisig.bytes
(fun ppf z ->
Format.fprintf
ppf
"Threshold (number of signatures required): %s"
(Z.to_string z))
prepared_command.Client_proto_multisig.threshold
(fun ppf ->
Format.fprintf
ppf
"@[<2>Public keys of the signers:@ %a@]"
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ")
Signature.Public_key.pp))
prepared_command.Client_proto_multisig.keys);
command
~group
~desc:"Sign a transaction for a multisig contract."
no_options
( prefixes ["sign"; "multisig"; "transaction"; "on"]
@@ Client_proto_contracts.RawContractAlias.alias_param
~name:"multisig"
~desc:"name of the originated multisig contract"
@@ prefix "transferring"
@@ Client_proto_args.tez_param
~name:"qty"
~desc:"amount taken from source"
@@ prefix "to"
@@ Client_proto_contracts.ContractAlias.destination_param
~name:"dst"
~desc:"name/literal of the destination contract"
@@ prefixes ["using"; "secret"; "key"]
@@ secret_key_param () @@ stop )
(fun ()
(_, multisig_contract)
amount
(_, destination)
sk
(cctxt : #Protocol_client_context.full) ->
Client_proto_multisig.prepare_multisig_transaction
cctxt
~chain:cctxt#chain
~block:cctxt#block
~multisig_contract
~action:(Client_proto_multisig.Transfer (amount, destination))
()
>>=? fun prepared_command ->
Client_keys.sign cctxt sk prepared_command.bytes
>>=? fun signature ->
return @@ Format.printf "%a@." Signature.pp signature);
command
~group
~desc:"Sign a delegate change for a multisig contract."
no_options
( prefixes ["sign"; "multisig"; "transaction"; "on"]
@@ Client_proto_contracts.RawContractAlias.alias_param
~name:"multisig"
~desc:"name of the originated multisig contract"
@@ prefixes ["setting"; "delegate"; "to"]
@@ Client_keys.Public_key_hash.source_param
~name:"dlgt"
~desc:"new delegate of the new multisig contract"
@@ prefixes ["using"; "secret"; "key"]
@@ secret_key_param () @@ stop )
(fun ()
(_, multisig_contract)
delegate
sk
(cctxt : #Protocol_client_context.full) ->
Client_proto_multisig.prepare_multisig_transaction
cctxt
~chain:cctxt#chain
~block:cctxt#block
~multisig_contract
~action:(Client_proto_multisig.Change_delegate (Some delegate))
()
>>=? fun prepared_command ->
Client_keys.sign cctxt sk prepared_command.bytes
>>=? fun signature ->
return @@ Format.printf "%a@." Signature.pp signature);
command
~group
~desc:"Sign a delegate withdraw for a multisig contract."
no_options
( prefixes ["sign"; "multisig"; "transaction"; "on"]
@@ Client_proto_contracts.RawContractAlias.alias_param
~name:"multisig"
~desc:"name of the originated multisig contract"
@@ prefixes ["withdrawing"; "delegate"]
@@ prefixes ["using"; "secret"; "key"]
@@ secret_key_param () @@ stop )
(fun ()
(_, multisig_contract)
sk
(cctxt : #Protocol_client_context.full) ->
Client_proto_multisig.prepare_multisig_transaction
cctxt
~chain:cctxt#chain
~block:cctxt#block
~multisig_contract
~action:(Client_proto_multisig.Change_delegate None)
()
>>=? fun prepared_command ->
Client_keys.sign cctxt sk prepared_command.bytes
>>=? fun signature ->
return @@ Format.printf "%a@." Signature.pp signature);
command
~group
~desc:
"Sign a change of public keys and threshold for a multisig contract."
no_options
( prefixes ["sign"; "multisig"; "transaction"; "on"]
@@ Client_proto_contracts.RawContractAlias.alias_param
~name:"multisig"
~desc:"name of the originated multisig contract"
@@ prefixes ["using"; "secret"; "key"]
@@ secret_key_param ()
@@ prefixes ["setting"; "threshold"; "to"]
@@ threshold_param ()
@@ prefixes ["and"; "public"; "keys"; "to"]
@@ seq_of_param (public_key_param ()) )
(fun ()
(_, multisig_contract)
sk
new_threshold
new_keys
(cctxt : #Protocol_client_context.full) ->
map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) new_keys
>>=? fun keys ->
Client_proto_multisig.prepare_multisig_transaction
cctxt
~chain:cctxt#chain
~block:cctxt#block
~multisig_contract
~action:
(Client_proto_multisig.Change_keys (Z.of_int new_threshold, keys))
()
>>=? fun prepared_command ->
Client_keys.sign cctxt sk prepared_command.bytes
>>=? fun signature ->
return @@ Format.printf "%a@." Signature.pp signature);
command
~group
~desc:"Transfer tokens using a multisig contract."
transfer_options
( prefixes ["from"; "multisig"; "contract"]
@@ Client_proto_contracts.ContractAlias.destination_param
~name:"multisig"
~desc:"name/literal of the multisig contract"
@@ prefix "transfer"
@@ Client_proto_args.tez_param
~name:"qty"
~desc:"amount taken from the multisig contract"
@@ prefix "to"
@@ Client_proto_contracts.ContractAlias.destination_param
~name:"dst"
~desc:"name/literal of the destination contract"
@@ prefixes ["on"; "behalf"; "of"]
@@ Client_proto_contracts.ContractAlias.destination_param
~name:"src"
~desc:"source calling the multisig contract"
@@ prefixes ["with"; "signatures"]
@@ seq_of_param (signature_param ()) )
(fun ( fee,
dry_run,
gas_limit,
storage_limit,
counter,
no_print_source,
minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee,
fee_cap,
burn_cap )
(_, multisig_contract)
amount
(_, destination)
(_, source)
signatures
(cctxt : #Protocol_client_context.full) ->
match Contract.is_implicit source with
| None ->
failwith
"only implicit accounts can be the source of a contract call"
| Some source -> (
Client_keys.get_key cctxt source
>>=? fun (_, src_pk, src_sk) ->
let fee_parameter =
{
Injection.minimal_fees;
minimal_nanotez_per_byte;
minimal_nanotez_per_gas_unit;
force_low_fee;
fee_cap;
burn_cap;
}
in
Client_proto_multisig.call_multisig
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
~fee_parameter
~source
?fee
~src_pk
~src_sk
~multisig_contract
~action:(Client_proto_multisig.Transfer (amount, destination))
~signatures
~amount:Tez.zero
?gas_limit
?storage_limit
?counter
()
>>= Client_proto_context_commands.report_michelson_errors
~no_print_source
~msg:"transfer simulation failed"
cctxt
>>= function
| None -> return_unit | Some (_res, _contracts) -> return_unit ));
command
~group
~desc:"Change the delegate of a multisig contract."
transfer_options
( prefixes ["set"; "delegate"; "of"; "multisig"; "contract"]
@@ Client_proto_contracts.RawContractAlias.alias_param
~name:"multisig"
~desc:"name of the originated multisig contract"
@@ prefix "to"
@@ Client_keys.Public_key_hash.source_param
~name:"dlgt"
~desc:"new delegate of the new multisig contract"
@@ prefixes ["on"; "behalf"; "of"]
@@ Client_proto_contracts.ContractAlias.destination_param
~name:"src"
~desc:"source calling the multisig contract"
@@ prefixes ["with"; "signatures"]
@@ seq_of_param (signature_param ()) )
(fun ( fee,
dry_run,
gas_limit,
storage_limit,
counter,
no_print_source,
minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee,
fee_cap,
burn_cap )
(_, multisig_contract)
delegate
(_, source)
signatures
(cctxt : #Protocol_client_context.full) ->
match Contract.is_implicit source with
| None ->
failwith
"only implicit accounts can be the source of a contract call"
| Some source -> (
Client_keys.get_key cctxt source
>>=? fun (_, src_pk, src_sk) ->
let fee_parameter =
{
Injection.minimal_fees;
minimal_nanotez_per_byte;
minimal_nanotez_per_gas_unit;
force_low_fee;
fee_cap;
burn_cap;
}
in
Client_proto_multisig.call_multisig
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
~fee_parameter
~source
?fee
~src_pk
~src_sk
~multisig_contract
~action:(Client_proto_multisig.Change_delegate (Some delegate))
~signatures
~amount:Tez.zero
?gas_limit
?storage_limit
?counter
()
>>= Client_proto_context_commands.report_michelson_errors
~no_print_source
~msg:"transfer simulation failed"
cctxt
>>= function
| None -> return_unit | Some (_res, _contracts) -> return_unit ));
command
~group
~desc:"Withdrow the delegate of a multisig contract."
transfer_options
( prefixes ["withdraw"; "delegate"; "of"; "multisig"; "contract"]
@@ Client_proto_contracts.RawContractAlias.alias_param
~name:"multisig"
~desc:"name of the originated multisig contract"
@@ prefixes ["on"; "behalf"; "of"]
@@ Client_proto_contracts.ContractAlias.destination_param
~name:"src"
~desc:"source calling the multisig contract"
@@ prefixes ["with"; "signatures"]
@@ seq_of_param (signature_param ()) )
(fun ( fee,
dry_run,
gas_limit,
storage_limit,
counter,
no_print_source,
minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee,
fee_cap,
burn_cap )
(_, multisig_contract)
(_, source)
signatures
(cctxt : #Protocol_client_context.full) ->
match Contract.is_implicit source with
| None ->
failwith
"only implicit accounts can be the source of a contract call"
| Some source -> (
Client_keys.get_key cctxt source
>>=? fun (_, src_pk, src_sk) ->
let fee_parameter =
{
Injection.minimal_fees;
minimal_nanotez_per_byte;
minimal_nanotez_per_gas_unit;
force_low_fee;
fee_cap;
burn_cap;
}
in
Client_proto_multisig.call_multisig
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
~fee_parameter
~source
?fee
~src_pk
~src_sk
~multisig_contract
~action:(Client_proto_multisig.Change_delegate None)
~signatures
~amount:Tez.zero
?gas_limit
?storage_limit
?counter
()
>>= Client_proto_context_commands.report_michelson_errors
~no_print_source
~msg:"transfer simulation failed"
cctxt
>>= function
| None -> return_unit | Some (_res, _contracts) -> return_unit ));
(* Unfortunately, Clic does not support non terminal lists of
parameters so we cannot pass both a list of public keys and a
list of signatures on the command line. This would permit a
command for running the Change_keys action.
However, we can run any action by deserialising the sequence of
bytes built using the "prepare multisig transaction" commands *)
command
~group
~desc:
"Run a transaction described by a sequence of bytes on a multisig \
contract."
transfer_options
( prefixes ["run"; "transaction"]
@@ bytes_param
~name:"bytes"
~desc:
"the sequence of bytes to deserialize as a multisig action, \
can be obtained by one of the \"prepare multisig \
transaction\" commands"
@@ prefixes ["on"; "multisig"; "contract"]
@@ Client_proto_contracts.RawContractAlias.alias_param
~name:"multisig"
~desc:"name of the originated multisig contract"
@@ prefixes ["on"; "behalf"; "of"]
@@ Client_proto_contracts.ContractAlias.destination_param
~name:"src"
~desc:"source calling the multisig contract"
@@ prefixes ["with"; "signatures"]
@@ seq_of_param (signature_param ()) )
(fun ( fee,
dry_run,
gas_limit,
storage_limit,
counter,
no_print_source,
minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit,
force_low_fee,
fee_cap,
burn_cap )
bytes
(_, multisig_contract)
(_, source)
signatures
(cctxt : #Protocol_client_context.full) ->
match Contract.is_implicit source with
| None ->
failwith
"only implicit accounts can be the source of a contract call"
| Some source -> (
Client_keys.get_key cctxt source
>>=? fun (_, src_pk, src_sk) ->
let fee_parameter =
{
Injection.minimal_fees;
minimal_nanotez_per_byte;
minimal_nanotez_per_gas_unit;
force_low_fee;
fee_cap;
burn_cap;
}
in
Client_proto_multisig.call_multisig_on_bytes
cctxt
~chain:cctxt#chain
~block:cctxt#block
?confirmations:cctxt#confirmations
~dry_run
~fee_parameter
~source
?fee
~src_pk
~src_sk
~multisig_contract
~bytes
~signatures
~amount:Tez.zero
?gas_limit
?storage_limit
?counter
()
>>= Client_proto_context_commands.report_michelson_errors
~no_print_source
~msg:"transfer simulation failed"
cctxt
>>= function
| None -> return_unit | Some (_res, _contracts) -> return_unit ));
command
~group
~desc:"Show the hashes of the supported multisig contracts."
no_options
(fixed ["show"; "supported"; "multisig"; "hashes"])
(fun () _cctxt ->
Lwt.return Client_proto_multisig.known_multisig_hashes
>>=? fun l ->
Format.printf "Hashes of supported multisig contracts:@." ;
List.iter
(fun h ->
Format.printf
" 0x%a@."
Hex.pp
(Script_expr_hash.to_bytes h |> Hex.of_bytes))
l ;
return_unit) ]
src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "multisig" % string;
Clic.title := "Commands for managing a multisig smart contract" % string |}.
Definition threshold_param {A : Type} (function_parameter : unit)
: (Tezos_base__TzPervasives.Clic.params A
Tezos_client_alpha.Protocol_client_context.full) ->
Tezos_base__TzPervasives.Clic.params (Z -> A)
Tezos_client_alpha.Protocol_client_context.full :=
let 'tt := function_parameter in
Clic.param "threshold" % string "Number of required signatures" % string
Client_proto_args.int_parameter.
Definition public_key_param {A C a : Type} (function_parameter : unit)
: (Tezos_base__TzPervasives.Clic.params A
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
* C)) ->
Tezos_base__TzPervasives.Clic.params
(Tezos_client_base.Client_keys.Public_key.t -> A)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
* C) :=
let 'tt := function_parameter in
Client_keys.Public_key.source_param (Some "key" % string)
(Some "Each signer of the multisig contract" % string).
Definition secret_key_param {A C a : Type} (function_parameter : unit)
: (Tezos_base__TzPervasives.Clic.params A
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
* C)) ->
Tezos_base__TzPervasives.Clic.params
(Tezos_client_base.Client_keys.Secret_key.t -> A)
(((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
* C) :=
let 'tt := function_parameter in
Client_keys.Secret_key.source_param (Some "key" % string)
(Some
"Secret key corresponding to one of the public keys stored on the multisig contract"
% string).
Definition signature_param {A : Type} (function_parameter : unit)
: (Tezos_base__TzPervasives.Clic.params A
Tezos_client_alpha.Protocol_client_context.full) ->
Tezos_base__TzPervasives.Clic.params
(Tezos_base__TzPervasives.Signature.t -> A)
Tezos_client_alpha.Protocol_client_context.full :=
let 'tt := function_parameter in
Clic.param "signature" % string
"Each signer of the multisig contract" % string
Client_proto_args.signature_parameter.
Definition bytes_only_switch
: Tezos_base__TzPervasives.Clic.arg bool
Tezos_client_alpha.Protocol_client_context.full :=
Clic.switch "return only the byte sequence to be signed" % string None
"bytes-only" % string tt.
Definition bytes_param {A : Type} (name : string) (desc : string)
: (Tezos_base__TzPervasives.Clic.params A
Tezos_client_alpha.Protocol_client_context.full) ->
Tezos_base__TzPervasives.Clic.params (Stdlib.Bytes.t -> A)
Tezos_client_alpha.Protocol_client_context.full :=
Clic.param name desc Client_proto_args.bytes_parameter.
Definition transfer_options
: Tezos_base__TzPervasives.Clic.options
((option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) * bool *
(option Z.t) * (option Z.t) * (option Z.t) * bool *
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez * Z.t * Z.t * bool *
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t *
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
Tezos_client_alpha.Protocol_client_context.full :=
Clic.args12 Client_proto_args.fee_arg
Client_proto_context_commands.dry_run_switch Client_proto_args.gas_limit_arg
Client_proto_args.storage_limit_arg Client_proto_args.counter_arg
Client_proto_args.no_print_source_flag Client_proto_args.minimal_fees_arg
Client_proto_args.minimal_nanotez_per_byte_arg
Client_proto_args.minimal_nanotez_per_gas_unit_arg
Client_proto_args.force_low_fee_arg Client_proto_args.fee_cap_arg
Client_proto_args.burn_cap_arg.
Definition commands {D F H J L M a b c i o p q : Type}
(function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json)
->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) *
nil)))))))))))))))))))))))))
* nil)) :=
let 'tt := function_parameter in
cons
(command (Some group) "Originate a new multisig contract." % string
(args13 Client_proto_args.fee_arg
Client_proto_context_commands.dry_run_switch
Client_proto_args.gas_limit_arg Client_proto_args.storage_limit_arg
Client_proto_args.delegate_arg (Client_keys.force_switch tt)
Client_proto_args.no_print_source_flag
Client_proto_args.minimal_fees_arg
Client_proto_args.minimal_nanotez_per_byte_arg
Client_proto_args.minimal_nanotez_per_gas_unit_arg
Client_proto_args.force_low_fee_arg Client_proto_args.fee_cap_arg
Client_proto_args.burn_cap_arg)
(apply (prefixes (cons "deploy" % string (cons "multisig" % string [])))
(apply
(Client_proto_contracts.RawContractAlias.fresh_alias_param
(Some "new_multisig" % string)
(Some "name of the new multisig contract" % string))
(apply (prefix "transferring" % string)
(apply
(Client_proto_args.tez_param "qty" % string
"amount taken from source" % string)
(apply (prefix "from" % string)
(apply
(Client_proto_contracts.ContractAlias.destination_param
(Some "src" % string)
(Some "name of the source contract" % string))
(apply
(prefixes
(cons "with" % string (cons "threshold" % string [])))
(apply (threshold_param tt)
(apply
(prefixes
(cons "on" % string
(cons "public" % string (cons "keys" % string []))))
(seq_of_param (public_key_param tt)))))))))))
(fun function_parameter =>
let
'(fee, dry_run, gas_limit, storage_limit, delegate, force,
no_print_source, minimal_fees, minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit, force_low_fee, fee_cap, burn_cap) :=
function_parameter in
fun alias_name =>
fun balance =>
fun function_parameter =>
let '(_, source) := function_parameter in
fun threshold =>
fun keys =>
fun cctxt =>
op_gtgteqquestion
(Client_proto_contracts.RawContractAlias.of_fresh cctxt
force alias_name)
(fun alias_name =>
match Contract.is_implicit source with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"only implicit accounts can be the source of an origination"
% string
CamlinternalFormatBasics.End_of_format)
"only implicit accounts can be the source of an origination"
% string)
| Some source =>
op_gtgteqquestion (Client_keys.get_key cctxt source)
(fun function_parameter =>
let '(_, src_pk, src_sk) := function_parameter in
let fee_parameter :=
{| Injection.minimal_fees := minimal_fees;
Injection.minimal_nanotez_per_byte :=
minimal_nanotez_per_byte;
Injection.minimal_nanotez_per_gas_unit :=
minimal_nanotez_per_gas_unit;
Injection.force_low_fee := force_low_fee;
Injection.fee_cap := fee_cap;
Injection.burn_cap := burn_cap |} in
op_gtgteqquestion
(map_s
(fun function_parameter =>
let '(pk_uri, _) := function_parameter in
Client_keys.public_key pk_uri) keys)
(fun keys =>
op_gtgteq
(Client_proto_multisig.originate_multisig
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some dry_run) None fee gas_limit
storage_limit delegate
(Z.of_int threshold) keys balance source
src_pk src_sk fee_parameter tt)
(fun errors =>
op_gtgteq
(Client_proto_context_commands.report_michelson_errors
(Some no_print_source)
"multisig origination simulation failed"
% string cctxt errors)
(fun function_parameter =>
match function_parameter with
| None => return_unit
| Some (_res, contract) =>
if dry_run then
return_unit
else
op_gtgteqquestion
(Client_proto_context.save_contract
force cctxt alias_name
contract)
(fun function_parameter =>
let 'tt := function_parameter
in
return_unit)
end))))
end)))
(cons
(command (Some group)
"Display the threshold, public keys, and byte sequence to sign for a multisigned transfer."
% string (args1 bytes_only_switch)
(apply
(prefixes
(cons "prepare" % string
(cons "multisig" % string
(cons "transaction" % string (cons "on" % string [])))))
(apply
(Client_proto_contracts.RawContractAlias.alias_param
(Some "multisig" % string)
(Some "name of the originated multisig contract" % string))
(apply (prefix "transferring" % string)
(apply
(Client_proto_args.tez_param "qty" % string
"amount taken from source" % string)
(apply (prefix "to" % string)
(apply
(Client_proto_contracts.ContractAlias.destination_param
(Some "dst" % string)
(Some "name/literal of the destination contract" % string))
stop))))))
(fun bytes_only =>
fun function_parameter =>
let '(_, multisig_contract) := function_parameter in
fun amount =>
fun function_parameter =>
let '(_, destination) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(Client_proto_multisig.prepare_multisig_transaction cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send multisig_contract
(Tezos_client_alpha.Client_proto_multisig.Transfer amount
destination) tt)
(fun prepared_command =>
apply _return
(if bytes_only then
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"0x" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))
"0x%a@." % string) Hex.pp
(Hex.of_bytes None
(Client_proto_multisig.bytes prepared_command))
else
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"%a@.%a@.%a@." % string)
(fun ppf =>
fun x =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Bytes to sign: '0x" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))
"Bytes to sign: '0x%a'" % string) Hex.pp
(Hex.of_bytes None x))
(Client_proto_multisig.bytes prepared_command)
(fun ppf =>
fun z =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Threshold (number of signatures required): "
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Threshold (number of signatures required): %s"
% string) (Z.to_string z))
(Client_proto_multisig.threshold prepared_command)
(fun ppf =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<2>" % string
CamlinternalFormatBasics.End_of_format)
"<2>" % string))
(CamlinternalFormatBasics.String_literal
"Public keys of the signers:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<2>Public keys of the signers:@ %a@]" %
string)
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
CamlinternalFormatBasics.End_of_format)
"@ " % string)))
Signature.Public_key.pp))
(Client_proto_multisig.keys prepared_command)))))
(cons
(command (Some group)
"Display the threshold, public keys, and byte sequence to sign for a multisigned delegate change."
% string (args1 bytes_only_switch)
(apply
(prefixes
(cons "prepare" % string
(cons "multisig" % string
(cons "transaction" % string (cons "on" % string [])))))
(apply
(Client_proto_contracts.RawContractAlias.alias_param
(Some "multisig" % string)
(Some "name of the originated multisig contract" % string))
(apply
(prefixes
(cons "setting" % string
(cons "delegate" % string (cons "to" % string []))))
(apply
(Client_keys.Public_key_hash.source_param
(Some "dlgt" % string)
(Some "new delegate of the new multisig contract" % string))
stop))))
(fun bytes_only =>
fun function_parameter =>
let '(_, multisig_contract) := function_parameter in
fun new_delegate =>
fun cctxt =>
op_gtgteqquestion
(Client_proto_multisig.prepare_multisig_transaction cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send multisig_contract
(Tezos_client_alpha.Client_proto_multisig.Change_delegate
(Some new_delegate)) tt)
(fun prepared_command =>
apply _return
(if bytes_only then
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"0x" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))
"0x%a@." % string) Hex.pp
(Hex.of_bytes None
(Client_proto_multisig.bytes prepared_command))
else
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"%a@.%a@.%a@." % string)
(fun ppf =>
fun x =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Bytes to sign: '0x" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))
"Bytes to sign: '0x%a'" % string) Hex.pp
(Hex.of_bytes None x))
(Client_proto_multisig.bytes prepared_command)
(fun ppf =>
fun z =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Threshold (number of signatures required): "
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Threshold (number of signatures required): %s"
% string) (Z.to_string z))
(Client_proto_multisig.threshold prepared_command)
(fun ppf =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<2>" % string
CamlinternalFormatBasics.End_of_format)
"<2>" % string))
(CamlinternalFormatBasics.String_literal
"Public keys of the signers:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<2>Public keys of the signers:@ %a@]" %
string)
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
CamlinternalFormatBasics.End_of_format)
"@ " % string)))
Signature.Public_key.pp))
(Client_proto_multisig.keys prepared_command)))))
(cons
(command (Some group)
"Display the threshold, public keys, and byte sequence to sign for a multisigned delegate withdraw."
% string (args1 bytes_only_switch)
(apply
(prefixes
(cons "prepare" % string
(cons "multisig" % string
(cons "transaction" % string (cons "on" % string [])))))
(apply
(Client_proto_contracts.RawContractAlias.alias_param
(Some "multisig" % string)
(Some "name of the originated multisig contract" % string))
(apply
(prefixes
(cons "withdrawing" % string (cons "delegate" % string [])))
stop)))
(fun bytes_only =>
fun function_parameter =>
let '(_, multisig_contract) := function_parameter in
fun cctxt =>
op_gtgteqquestion
(Client_proto_multisig.prepare_multisig_transaction cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send multisig_contract
(Tezos_client_alpha.Client_proto_multisig.Change_delegate
None) tt)
(fun prepared_command =>
apply _return
(if bytes_only then
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"0x" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))
"0x%a@." % string) Hex.pp
(Hex.of_bytes None
(Client_proto_multisig.bytes prepared_command))
else
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"%a@.%a@.%a@." % string)
(fun ppf =>
fun x =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Bytes to sign: '0x" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))
"Bytes to sign: '0x%a'" % string) Hex.pp
(Hex.of_bytes None x))
(Client_proto_multisig.bytes prepared_command)
(fun ppf =>
fun z =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Threshold (number of signatures required): "
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Threshold (number of signatures required): %s"
% string) (Z.to_string z))
(Client_proto_multisig.threshold prepared_command)
(fun ppf =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<2>" % string
CamlinternalFormatBasics.End_of_format)
"<2>" % string))
(CamlinternalFormatBasics.String_literal
"Public keys of the signers:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<2>Public keys of the signers:@ %a@]" %
string)
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
CamlinternalFormatBasics.End_of_format)
"@ " % string)))
Signature.Public_key.pp))
(Client_proto_multisig.keys prepared_command)))))
(cons
(command (Some group)
"Display the threshold, public keys, and byte sequence to sign for a multisigned change of keys and threshold."
% string (args1 bytes_only_switch)
(apply
(prefixes
(cons "prepare" % string
(cons "multisig" % string
(cons "transaction" % string (cons "on" % string [])))))
(apply
(Client_proto_contracts.RawContractAlias.alias_param
(Some "multisig" % string)
(Some "name of the originated multisig contract" % string))
(apply
(prefixes
(cons "setting" % string
(cons "threshold" % string (cons "to" % string []))))
(apply (threshold_param tt)
(apply
(prefixes
(cons "and" % string
(cons "public" % string
(cons "keys" % string (cons "to" % string [])))))
(seq_of_param (public_key_param tt)))))))
(fun bytes_only =>
fun function_parameter =>
let '(_, multisig_contract) := function_parameter in
fun new_threshold =>
fun new_keys =>
fun cctxt =>
op_gtgteqquestion
(map_s
(fun function_parameter =>
let '(pk_uri, _) := function_parameter in
Client_keys.public_key pk_uri) new_keys)
(fun keys =>
op_gtgteqquestion
(Client_proto_multisig.prepare_multisig_transaction
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send multisig_contract
(Tezos_client_alpha.Client_proto_multisig.Change_keys
(Z.of_int new_threshold) keys) tt)
(fun prepared_command =>
apply _return
(if bytes_only then
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"0x" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))
"0x%a@." % string) Hex.pp
(Hex.of_bytes None
(Client_proto_multisig.bytes
prepared_command))
else
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))
"%a@.%a@.%a@." % string)
(fun ppf =>
fun x =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Bytes to sign: '0x" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))
"Bytes to sign: '0x%a'" % string)
Hex.pp (Hex.of_bytes None x))
(Client_proto_multisig.bytes
prepared_command)
(fun ppf =>
fun z =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Threshold (number of signatures required): "
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Threshold (number of signatures required): %s"
% string) (Z.to_string z))
(Client_proto_multisig.threshold
prepared_command)
(fun ppf =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<2>" % string
CamlinternalFormatBasics.End_of_format)
"<2>" % string))
(CamlinternalFormatBasics.String_literal
"Public keys of the signers:" %
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"@[<2>Public keys of the signers:@ %a@]"
% string)
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter
in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
CamlinternalFormatBasics.End_of_format)
"@ " % string)))
Signature.Public_key.pp))
(Client_proto_multisig.keys
prepared_command))))))
(cons
(command (Some group)
"Sign a transaction for a multisig contract." % string
no_options
(apply
(prefixes
(cons "sign" % string
(cons "multisig" % string
(cons "transaction" % string (cons "on" % string [])))))
(apply
(Client_proto_contracts.RawContractAlias.alias_param
(Some "multisig" % string)
(Some "name of the originated multisig contract" % string))
(apply (prefix "transferring" % string)
(apply
(Client_proto_args.tez_param "qty" % string
"amount taken from source" % string)
(apply (prefix "to" % string)
(apply
(Client_proto_contracts.ContractAlias.destination_param
(Some "dst" % string)
(Some
"name/literal of the destination contract" %
string))
(apply
(prefixes
(cons "using" % string
(cons "secret" % string
(cons "key" % string []))))
(apply (secret_key_param tt) stop))))))))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(_, multisig_contract) := function_parameter in
fun amount =>
fun function_parameter =>
let '(_, destination) := function_parameter in
fun sk =>
fun cctxt =>
op_gtgteqquestion
(Client_proto_multisig.prepare_multisig_transaction
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send multisig_contract
(Tezos_client_alpha.Client_proto_multisig.Transfer
amount destination) tt)
(fun prepared_command =>
op_gtgteqquestion
(Client_keys.sign cctxt None sk
(bytes prepared_command))
(fun signature =>
apply _return
(Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))
"%a@." % string) Signature.pp
signature)))))
(cons
(command (Some group)
"Sign a delegate change for a multisig contract." % string
no_options
(apply
(prefixes
(cons "sign" % string
(cons "multisig" % string
(cons "transaction" % string (cons "on" % string [])))))
(apply
(Client_proto_contracts.RawContractAlias.alias_param
(Some "multisig" % string)
(Some
"name of the originated multisig contract" % string))
(apply
(prefixes
(cons "setting" % string
(cons "delegate" % string (cons "to" % string []))))
(apply
(Client_keys.Public_key_hash.source_param
(Some "dlgt" % string)
(Some
"new delegate of the new multisig contract" %
string))
(apply
(prefixes
(cons "using" % string
(cons "secret" % string (cons "key" % string []))))
(apply (secret_key_param tt) stop))))))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(_, multisig_contract) := function_parameter in
fun delegate =>
fun sk =>
fun cctxt =>
op_gtgteqquestion
(Client_proto_multisig.prepare_multisig_transaction
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send multisig_contract
(Tezos_client_alpha.Client_proto_multisig.Change_delegate
(Some delegate)) tt)
(fun prepared_command =>
op_gtgteqquestion
(Client_keys.sign cctxt None sk
(bytes prepared_command))
(fun signature =>
apply _return
(Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))
"%a@." % string) Signature.pp
signature)))))
(cons
(command (Some group)
"Sign a delegate withdraw for a multisig contract." % string
no_options
(apply
(prefixes
(cons "sign" % string
(cons "multisig" % string
(cons "transaction" % string (cons "on" % string [])))))
(apply
(Client_proto_contracts.RawContractAlias.alias_param
(Some "multisig" % string)
(Some
"name of the originated multisig contract" % string))
(apply
(prefixes
(cons "withdrawing" % string
(cons "delegate" % string [])))
(apply
(prefixes
(cons "using" % string
(cons "secret" % string (cons "key" % string []))))
(apply (secret_key_param tt) stop)))))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(_, multisig_contract) := function_parameter in
fun sk =>
fun cctxt =>
op_gtgteqquestion
(Client_proto_multisig.prepare_multisig_transaction
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send multisig_contract
(Tezos_client_alpha.Client_proto_multisig.Change_delegate
None) tt)
(fun prepared_command =>
op_gtgteqquestion
(Client_keys.sign cctxt None sk
(bytes prepared_command))
(fun signature =>
apply _return
(Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))
"%a@." % string) Signature.pp
signature)))))
(cons
(command (Some group)
"Sign a change of public keys and threshold for a multisig contract."
% string no_options
(apply
(prefixes
(cons "sign" % string
(cons "multisig" % string
(cons "transaction" % string
(cons "on" % string [])))))
(apply
(Client_proto_contracts.RawContractAlias.alias_param
(Some "multisig" % string)
(Some
"name of the originated multisig contract" %
string))
(apply
(prefixes
(cons "using" % string
(cons "secret" % string (cons "key" % string []))))
(apply (secret_key_param tt)
(apply
(prefixes
(cons "setting" % string
(cons "threshold" % string
(cons "to" % string []))))
(apply (threshold_param tt)
(apply
(prefixes
(cons "and" % string
(cons "public" % string
(cons "keys" % string
(cons "to" % string [])))))
(seq_of_param (public_key_param tt)))))))))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(_, multisig_contract) := function_parameter in
fun sk =>
fun new_threshold =>
fun new_keys =>
fun cctxt =>
op_gtgteqquestion
(map_s
(fun function_parameter =>
let '(pk_uri, _) := function_parameter
in
Client_keys.public_key pk_uri) new_keys)
(fun keys =>
op_gtgteqquestion
(Client_proto_multisig.prepare_multisig_transaction
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send multisig_contract
(Tezos_client_alpha.Client_proto_multisig.Change_keys
(Z.of_int new_threshold) keys) tt)
(fun prepared_command =>
op_gtgteqquestion
(Client_keys.sign cctxt None sk
(bytes prepared_command))
(fun signature =>
apply _return
(Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))
"%a@." % string)
Signature.pp signature))))))
(cons
(command (Some group)
"Transfer tokens using a multisig contract." % string
transfer_options
(apply
(prefixes
(cons "from" % string
(cons "multisig" % string
(cons "contract" % string []))))
(apply
(Client_proto_contracts.ContractAlias.destination_param
(Some "multisig" % string)
(Some
"name/literal of the multisig contract" % string))
(apply (prefix "transfer" % string)
(apply
(Client_proto_args.tez_param "qty" % string
"amount taken from the multisig contract" %
string)
(apply (prefix "to" % string)
(apply
(Client_proto_contracts.ContractAlias.destination_param
(Some "dst" % string)
(Some
"name/literal of the destination contract"
% string))
(apply
(prefixes
(cons "on" % string
(cons "behalf" % string
(cons "of" % string []))))
(apply
(Client_proto_contracts.ContractAlias.destination_param
(Some "src" % string)
(Some
"source calling the multisig contract"
% string))
(apply
(prefixes
(cons "with" % string
(cons "signatures" % string [])))
(seq_of_param (signature_param tt)))))))))))
(fun function_parameter =>
let
'(fee, dry_run, gas_limit, storage_limit, counter,
no_print_source, minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit, force_low_fee,
fee_cap, burn_cap) := function_parameter in
fun function_parameter =>
let '(_, multisig_contract) := function_parameter in
fun amount =>
fun function_parameter =>
let '(_, destination) := function_parameter in
fun function_parameter =>
let '(_, source) := function_parameter in
fun signatures =>
fun cctxt =>
match Contract.is_implicit source with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"only implicit accounts can be the source of a contract call"
% string
CamlinternalFormatBasics.End_of_format)
"only implicit accounts can be the source of a contract call"
% string)
| Some source =>
op_gtgteqquestion
(Client_keys.get_key cctxt source)
(fun function_parameter =>
let '(_, src_pk, src_sk) :=
function_parameter in
let fee_parameter :=
{|
Injection.minimal_fees :=
minimal_fees;
Injection.minimal_nanotez_per_byte :=
minimal_nanotez_per_byte;
Injection.minimal_nanotez_per_gas_unit :=
minimal_nanotez_per_gas_unit;
Injection.force_low_fee :=
force_low_fee;
Injection.fee_cap := fee_cap;
Injection.burn_cap := burn_cap
|} in
op_gtgteq
(op_gtgteq
(Client_proto_multisig.call_multisig
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some dry_run) None
source src_pk src_sk
multisig_contract
(Tezos_client_alpha.Client_proto_multisig.Transfer
amount destination)
signatures Tez.zero fee
gas_limit storage_limit
counter fee_parameter tt)
(Client_proto_context_commands.report_michelson_errors
(Some no_print_source)
"transfer simulation failed" %
string cctxt))
(fun function_parameter =>
match function_parameter with
| None => return_unit
| Some (_res, _contracts) =>
return_unit
end))
end))
(cons
(command (Some group)
"Change the delegate of a multisig contract." % string
transfer_options
(apply
(prefixes
(cons "set" % string
(cons "delegate" % string
(cons "of" % string
(cons "multisig" % string
(cons "contract" % string []))))))
(apply
(Client_proto_contracts.RawContractAlias.alias_param
(Some "multisig" % string)
(Some
"name of the originated multisig contract" %
string))
(apply (prefix "to" % string)
(apply
(Client_keys.Public_key_hash.source_param
(Some "dlgt" % string)
(Some
"new delegate of the new multisig contract"
% string))
(apply
(prefixes
(cons "on" % string
(cons "behalf" % string
(cons "of" % string []))))
(apply
(Client_proto_contracts.ContractAlias.destination_param
(Some "src" % string)
(Some
"source calling the multisig contract"
% string))
(apply
(prefixes
(cons "with" % string
(cons "signatures" % string [])))
(seq_of_param (signature_param tt)))))))))
(fun function_parameter =>
let
'(fee, dry_run, gas_limit, storage_limit, counter,
no_print_source, minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit, force_low_fee,
fee_cap, burn_cap) := function_parameter in
fun function_parameter =>
let '(_, multisig_contract) := function_parameter
in
fun delegate =>
fun function_parameter =>
let '(_, source) := function_parameter in
fun signatures =>
fun cctxt =>
match Contract.is_implicit source with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"only implicit accounts can be the source of a contract call"
% string
CamlinternalFormatBasics.End_of_format)
"only implicit accounts can be the source of a contract call"
% string)
| Some source =>
op_gtgteqquestion
(Client_keys.get_key cctxt source)
(fun function_parameter =>
let '(_, src_pk, src_sk) :=
function_parameter in
let fee_parameter :=
{|
Injection.minimal_fees :=
minimal_fees;
Injection.minimal_nanotez_per_byte :=
minimal_nanotez_per_byte;
Injection.minimal_nanotez_per_gas_unit :=
minimal_nanotez_per_gas_unit;
Injection.force_low_fee :=
force_low_fee;
Injection.fee_cap := fee_cap;
Injection.burn_cap := burn_cap
|} in
op_gtgteq
(op_gtgteq
(Client_proto_multisig.call_multisig
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some dry_run) None
source src_pk src_sk
multisig_contract
(Tezos_client_alpha.Client_proto_multisig.Change_delegate
(Some delegate)) signatures
Tez.zero fee gas_limit
storage_limit counter
fee_parameter tt)
(Client_proto_context_commands.report_michelson_errors
(Some no_print_source)
"transfer simulation failed" %
string cctxt))
(fun function_parameter =>
match function_parameter with
| None => return_unit
| Some (_res, _contracts) =>
return_unit
end))
end))
(cons
(command (Some group)
"Withdrow the delegate of a multisig contract." %
string transfer_options
(apply
(prefixes
(cons "withdraw" % string
(cons "delegate" % string
(cons "of" % string
(cons "multisig" % string
(cons "contract" % string []))))))
(apply
(Client_proto_contracts.RawContractAlias.alias_param
(Some "multisig" % string)
(Some
"name of the originated multisig contract" %
string))
(apply
(prefixes
(cons "on" % string
(cons "behalf" % string
(cons "of" % string []))))
(apply
(Client_proto_contracts.ContractAlias.destination_param
(Some "src" % string)
(Some
"source calling the multisig contract" %
string))
(apply
(prefixes
(cons "with" % string
(cons "signatures" % string [])))
(seq_of_param (signature_param tt)))))))
(fun function_parameter =>
let
'(fee, dry_run, gas_limit, storage_limit,
counter, no_print_source, minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit, force_low_fee,
fee_cap, burn_cap) := function_parameter in
fun function_parameter =>
let '(_, multisig_contract) :=
function_parameter in
fun function_parameter =>
let '(_, source) := function_parameter in
fun signatures =>
fun cctxt =>
match Contract.is_implicit source with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"only implicit accounts can be the source of a contract call"
% string
CamlinternalFormatBasics.End_of_format)
"only implicit accounts can be the source of a contract call"
% string)
| Some source =>
op_gtgteqquestion
(Client_keys.get_key cctxt source)
(fun function_parameter =>
let '(_, src_pk, src_sk) :=
function_parameter in
let fee_parameter :=
{|
Injection.minimal_fees :=
minimal_fees;
Injection.minimal_nanotez_per_byte :=
minimal_nanotez_per_byte;
Injection.minimal_nanotez_per_gas_unit :=
minimal_nanotez_per_gas_unit;
Injection.force_low_fee :=
force_low_fee;
Injection.fee_cap := fee_cap;
Injection.burn_cap := burn_cap
|} in
op_gtgteq
(op_gtgteq
(Client_proto_multisig.call_multisig
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some dry_run) None
source src_pk src_sk
multisig_contract
(Tezos_client_alpha.Client_proto_multisig.Change_delegate
None) signatures Tez.zero
fee gas_limit storage_limit
counter fee_parameter tt)
(Client_proto_context_commands.report_michelson_errors
(Some no_print_source)
"transfer simulation failed" %
string cctxt))
(fun function_parameter =>
match function_parameter with
| None => return_unit
| Some (_res, _contracts) =>
return_unit
end))
end))
(cons
(command (Some group)
"Run a transaction described by a sequence of bytes on a multisig contract."
% string transfer_options
(apply
(prefixes
(cons "run" % string
(cons "transaction" % string [])))
(apply
(bytes_param "bytes" % string
"the sequence of bytes to deserialize as a multisig action, can be obtained by one of the ""prepare multisig transaction"" commands"
% string)
(apply
(prefixes
(cons "on" % string
(cons "multisig" % string
(cons "contract" % string []))))
(apply
(Client_proto_contracts.RawContractAlias.alias_param
(Some "multisig" % string)
(Some
"name of the originated multisig contract"
% string))
(apply
(prefixes
(cons "on" % string
(cons "behalf" % string
(cons "of" % string []))))
(apply
(Client_proto_contracts.ContractAlias.destination_param
(Some "src" % string)
(Some
"source calling the multisig contract"
% string))
(apply
(prefixes
(cons "with" % string
(cons "signatures" % string [])))
(seq_of_param (signature_param tt)))))))))
(fun function_parameter =>
let
'(fee, dry_run, gas_limit, storage_limit,
counter, no_print_source, minimal_fees,
minimal_nanotez_per_byte,
minimal_nanotez_per_gas_unit, force_low_fee,
fee_cap, burn_cap) := function_parameter in
fun bytes =>
fun function_parameter =>
let '(_, multisig_contract) :=
function_parameter in
fun function_parameter =>
let '(_, source) := function_parameter in
fun signatures =>
fun cctxt =>
match Contract.is_implicit source with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"only implicit accounts can be the source of a contract call"
% string
CamlinternalFormatBasics.End_of_format)
"only implicit accounts can be the source of a contract call"
% string)
| Some source =>
op_gtgteqquestion
(Client_keys.get_key cctxt source)
(fun function_parameter =>
let '(_, src_pk, src_sk) :=
function_parameter in
let fee_parameter :=
{|
Injection.minimal_fees :=
minimal_fees;
Injection.minimal_nanotez_per_byte :=
minimal_nanotez_per_byte;
Injection.minimal_nanotez_per_gas_unit :=
minimal_nanotez_per_gas_unit;
Injection.force_low_fee :=
force_low_fee;
Injection.fee_cap := fee_cap;
Injection.burn_cap :=
burn_cap |} in
op_gtgteq
(op_gtgteq
(Client_proto_multisig.call_multisig_on_bytes
cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some dry_run) None
source src_pk src_sk
multisig_contract string
signatures Tez.zero fee
gas_limit storage_limit
counter fee_parameter tt)
(Client_proto_context_commands.report_michelson_errors
(Some no_print_source)
"transfer simulation failed"
% string cctxt))
(fun function_parameter =>
match function_parameter
with
| None => return_unit
| Some (_res, _contracts) =>
return_unit
end))
end))
(cons
(command (Some group)
"Show the hashes of the supported multisig contracts."
% string no_options
(fixed
(cons "show" % string
(cons "supported" % string
(cons "multisig" % string
(cons "hashes" % string [])))))
(fun function_parameter =>
let 'tt := function_parameter in
fun _cctxt =>
op_gtgteqquestion
(Lwt._return
Client_proto_multisig.known_multisig_hashes)
(fun l =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Hashes of supported multisig contracts:"
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))
"Hashes of supported multisig contracts:@."
% string) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun h =>
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
" 0x" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))
" 0x%a@." % string) Hex.pp
(OCaml.Stdlib.reverse_apply
(Script_expr_hash.to_bytes h)
(let arg := Hex.of_bytes in
fun eta => arg None eta))) l
in
return_unit))) []))))))))))))).
src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml 93 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
let group =
{
Clic.name = "scripts";
title = "Commands for managing the library of known scripts";
}
open Tezos_micheline
open Client_proto_programs
open Client_proto_args
open Client_proto_contracts
let commands () =
let open Clic in
let show_types_switch =
switch
~long:"details"
~short:'v'
~doc:"show the types of each instruction"
()
in
let emacs_mode_switch =
switch
~long:"emacs"
?short:None
~doc:"output in `michelson-mode.el` compatible format"
()
in
let trace_stack_switch =
switch ~long:"trace-stack" ~doc:"show the stack after each step" ()
in
let amount_arg =
Client_proto_args.tez_arg
~parameter:"amount"
~doc:"amount of the transfer in \xEA\x9C\xA9"
~default:"0.05"
in
let source_arg =
ContractAlias.destination_arg
~name:"source"
~doc:"name of the source (i.e. SENDER) contract for the transaction"
()
in
let payer_arg =
ContractAlias.destination_arg
~name:"payer"
~doc:"name of the payer (i.e. SOURCE) contract for the transaction"
()
in
let custom_gas_flag =
arg
~long:"gas"
~short:'G'
~doc:"Initial quantity of gas for typechecking and execution"
~placeholder:"gas"
(parameter (fun _ctx str ->
try
let v = Z.of_string str in
assert (Compare.Z.(v >= Z.zero)) ;
return v
with _ -> failwith "invalid gas limit (must be a positive number)"))
in
let resolve_max_gas cctxt block = function
| None ->
Alpha_services.Constants.all cctxt (cctxt#chain, block)
>>=? fun {parametric = {hard_gas_limit_per_operation; _}; _} ->
return hard_gas_limit_per_operation
| Some gas ->
return gas
in
let data_parameter =
Clic.parameter (fun _ data ->
Lwt.return
( Micheline_parser.no_parsing_error
@@ Michelson_v1_parser.parse_expression data ))
in
let bytes_parameter ~name ~desc =
Clic.param ~name ~desc Client_proto_args.bytes_parameter
in
let signature_parameter =
Clic.parameter (fun _cctxt s ->
match Signature.of_b58check_opt s with
| Some s ->
return s
| None ->
failwith "Not given a valid signature")
in
[ command
~group
~desc:"Lists all scripts in the library."
no_options
(fixed ["list"; "known"; "scripts"])
(fun () (cctxt : Protocol_client_context.full) ->
Program.load cctxt
>>=? fun list ->
Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list
>>= fun () -> return_unit);
command
~group
~desc:"Add a script to the library."
(args1 (Program.force_switch ()))
( prefixes ["remember"; "script"]
@@ Program.fresh_alias_param @@ Program.source_param @@ stop )
(fun force name hash cctxt ->
Program.of_fresh cctxt force name
>>=? fun name -> Program.add ~force cctxt name hash);
command
~group
~desc:"Remove a script from the library."
no_options
(prefixes ["forget"; "script"] @@ Program.alias_param @@ stop)
(fun () (name, _) cctxt -> Program.del cctxt name);
command
~group
~desc:"Display a script from the library."
no_options
(prefixes ["show"; "known"; "script"] @@ Program.alias_param @@ stop)
(fun () (_, program) (cctxt : Protocol_client_context.full) ->
Program.to_source program
>>=? fun source ->
cctxt#message "%s\n" source >>= fun () -> return_unit);
command
~group
~desc:"Ask the node to run a script."
(args7
trace_stack_switch
amount_arg
source_arg
payer_arg
no_print_source_flag
custom_gas_flag
entrypoint_arg)
( prefixes ["run"; "script"]
@@ Program.source_param
@@ prefixes ["on"; "storage"]
@@ Clic.param ~name:"storage" ~desc:"the storage data" data_parameter
@@ prefixes ["and"; "input"]
@@ Clic.param ~name:"input" ~desc:"the input data" data_parameter
@@ stop )
(fun (trace_exec, amount, source, payer, no_print_source, gas, entrypoint)
program
storage
input
cctxt ->
let source = Option.map ~f:snd source in
let payer = Option.map ~f:snd payer in
Lwt.return @@ Micheline_parser.no_parsing_error program
>>=? fun program ->
let show_source = not no_print_source in
if trace_exec then
trace
cctxt
~chain:cctxt#chain
~block:cctxt#block
~amount
~program
~storage
~input
?source
?payer
?gas
?entrypoint
()
>>= fun res ->
print_trace_result cctxt ~show_source ~parsed:program res
else
run
cctxt
~chain:cctxt#chain
~block:cctxt#block
~amount
~program
~storage
~input
?source
?payer
?gas
?entrypoint
()
>>= fun res ->
print_run_result cctxt ~show_source ~parsed:program res);
command
~group
~desc:"Ask the node to typecheck a script."
(args4
show_types_switch
emacs_mode_switch
no_print_source_flag
custom_gas_flag)
(prefixes ["typecheck"; "script"] @@ Program.source_param @@ stop)
(fun (show_types, emacs_mode, no_print_source, original_gas)
program
cctxt ->
match program with
| (program, []) ->
resolve_max_gas cctxt cctxt#block original_gas
>>=? fun original_gas ->
typecheck_program
cctxt
~chain:cctxt#chain
~block:cctxt#block
~gas:original_gas
program
>>= fun res ->
print_typecheck_result
~emacs:emacs_mode
~show_types
~print_source_on_error:(not no_print_source)
program
res
cctxt
| res_with_errors when emacs_mode ->
cctxt#message
"(@[<v 0>(types . ())@ (errors . %a)@])"
Michelson_v1_emacs.report_errors
res_with_errors
>>= fun () -> return_unit
| (parsed, errors) ->
cctxt#message
"%a"
(fun ppf () ->
Michelson_v1_error_reporter.report_errors
~details:(not no_print_source)
~parsed
~show_source:(not no_print_source)
ppf
errors)
()
>>= fun () -> cctxt#error "syntax error in program");
command
~group
~desc:"Ask the node to typecheck a data expression."
(args2 no_print_source_flag custom_gas_flag)
( prefixes ["typecheck"; "data"]
@@ Clic.param ~name:"data" ~desc:"the data to typecheck" data_parameter
@@ prefixes ["against"; "type"]
@@ Clic.param ~name:"type" ~desc:"the expected type" data_parameter
@@ stop )
(fun (no_print_source, custom_gas) data ty cctxt ->
resolve_max_gas cctxt cctxt#block custom_gas
>>=? fun original_gas ->
Client_proto_programs.typecheck_data
cctxt
~chain:cctxt#chain
~block:cctxt#block
~gas:original_gas
~data
~ty
()
>>= function
| Ok gas ->
cctxt#message
"@[<v 0>Well typed@,Gas remaining: %a@]"
Alpha_context.Gas.pp
gas
>>= fun () -> return_unit
| Error errs ->
cctxt#warning
"%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source:(not no_print_source)
?parsed:None)
errs
>>= fun () -> cctxt#error "ill-typed data");
command
~group
~desc:
"Ask the node to pack a data expression.\n\
The returned hash is the same as what Michelson instruction `PACK` \
would have produced.\n\
Also displays the result of hashing this packed data with `BLAKE2B`, \
`SHA256` or `SHA512` instruction."
(args1 custom_gas_flag)
( prefixes ["hash"; "data"]
@@ Clic.param ~name:"data" ~desc:"the data to hash" data_parameter
@@ prefixes ["of"; "type"]
@@ Clic.param ~name:"type" ~desc:"type of the data" data_parameter
@@ stop )
(fun custom_gas data typ cctxt ->
resolve_max_gas cctxt cctxt#block custom_gas
>>=? fun original_gas ->
Alpha_services.Helpers.Scripts.pack_data
cctxt
(cctxt#chain, cctxt#block)
(data.expanded, typ.expanded, Some original_gas)
>>= function
| Ok (bytes, remaining_gas) ->
let hash = Script_expr_hash.hash_bytes [bytes] in
cctxt#message
"Raw packed data: 0x%a@,\
Script-expression-ID-Hash: %a@,\
Raw Script-expression-ID-Hash: 0x%a@,\
Ledger Blake2b hash: %s@,\
Raw Sha256 hash: 0x%a@,\
Raw Sha512 hash: 0x%a@,\
Gas remaining: %a"
Hex.pp
(Hex.of_bytes bytes)
Script_expr_hash.pp
hash
Hex.pp
(Hex.of_bytes (Script_expr_hash.to_bytes hash))
(Base58.raw_encode Blake2B.(hash_bytes [bytes] |> to_string))
Hex.pp
(Hex.of_bytes (Environment.Raw_hashes.sha256 bytes))
Hex.pp
(Hex.of_bytes (Environment.Raw_hashes.sha512 bytes))
Alpha_context.Gas.pp
remaining_gas
>>= fun () -> return_unit
| Error errs ->
cctxt#warning
"%a"
(Michelson_v1_error_reporter.report_errors
~details:false
~show_source:false
?parsed:None)
errs
>>= fun () -> cctxt#error "ill-formed data");
command
~group
~desc:
"Parse a byte sequence (in hexadecimal notation) as a data \
expression, as per Michelson instruction `UNPACK`."
Clic.no_options
( prefixes ["unpack"; "michelson"; "data"]
@@ bytes_parameter ~name:"bytes" ~desc:"the packed data to parse"
@@ stop )
(fun () bytes cctxt ->
( if Bytes.get bytes 0 != '\005' then
failwith
"Not a piece of packed Michelson data (must start with `0x05`)"
else return_unit )
>>=? fun () ->
(* Remove first byte *)
let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in
match
Data_encoding.Binary.of_bytes
Alpha_context.Script.expr_encoding
bytes
with
| None ->
failwith "Could not decode bytes"
| Some expr ->
cctxt#message "%a" Michelson_v1_printer.print_expr_unwrapped expr
>>= fun () -> return_unit);
command
~group
~desc:
"Sign a raw sequence of bytes and display it using the format \
expected by Michelson instruction `CHECK_SIGNATURE`."
no_options
( prefixes ["sign"; "bytes"]
@@ bytes_parameter ~name:"data" ~desc:"the raw data to sign"
@@ prefixes ["for"]
@@ Client_keys.Secret_key.source_param @@ stop )
(fun () bytes sk cctxt ->
Client_keys.sign cctxt sk bytes
>>=? fun signature ->
cctxt#message "Signature: %a" Signature.pp signature
>>= fun () -> return_unit);
command
~group
~desc:
"Check the signature of a byte sequence as per Michelson instruction \
`CHECK_SIGNATURE`."
(args1 (switch ~doc:"Use only exit codes" ~short:'q' ~long:"quiet" ()))
( prefixes ["check"; "that"]
@@ bytes_parameter ~name:"bytes" ~desc:"the signed data"
@@ prefixes ["was"; "signed"; "by"]
@@ Client_keys.Public_key.alias_param ~name:"key"
@@ prefixes ["to"; "produce"]
@@ Clic.param
~name:"signature"
~desc:"the signature to check"
signature_parameter
@@ stop )
(fun quiet
bytes
(_, (key_locator, _))
signature
(cctxt : #Protocol_client_context.full) ->
Client_keys.check key_locator signature bytes
>>=? function
| false ->
cctxt#error "invalid signature"
| true ->
if quiet then return_unit
else
cctxt#message "Signature check successfull."
>>= fun () -> return_unit);
command
~group
~desc:"Ask the type of an entrypoint of a script."
(args2 emacs_mode_switch no_print_source_flag)
( prefixes ["get"; "script"; "entrypoint"; "type"; "of"]
@@ Clic.string ~name:"entrypoint" ~desc:"the entrypoint to describe"
@@ prefixes ["for"]
@@ Program.source_param @@ stop )
(fun (emacs_mode, no_print_source) entrypoint program cctxt ->
match program with
| (program, []) ->
entrypoint_type
cctxt
~chain:cctxt#chain
~block:cctxt#block
program
~entrypoint
>>= fun entrypoint_type ->
print_entrypoint_type
~emacs:emacs_mode
~show_source:(not no_print_source)
~parsed:program
~entrypoint
cctxt
entrypoint_type
| res_with_errors when emacs_mode ->
cctxt#message
"(@[<v 0>(entrypoint . ())@ (errors . %a)@])"
Michelson_v1_emacs.report_errors
res_with_errors
>>= fun () -> return_unit
| (parsed, errors) ->
cctxt#message
"%a"
(fun ppf () ->
Michelson_v1_error_reporter.report_errors
~details:(not no_print_source)
~parsed
~show_source:(not no_print_source)
ppf
errors)
()
>>= fun () -> cctxt#error "syntax error in program");
command
~group
~desc:"Ask the node to list the entrypoints of a script."
(args2 emacs_mode_switch no_print_source_flag)
( prefixes ["get"; "script"; "entrypoints"; "for"]
@@ Program.source_param @@ stop )
(fun (emacs_mode, no_print_source) program cctxt ->
match program with
| (program, []) ->
list_entrypoints
cctxt
~chain:cctxt#chain
~block:cctxt#block
program
>>= fun entrypoints ->
print_entrypoints_list
~emacs:emacs_mode
~show_source:(not no_print_source)
~parsed:program
cctxt
entrypoints
| res_with_errors when emacs_mode ->
cctxt#message
"(@[<v 0>(entrypoints . ())@ (errors . %a)@])"
Michelson_v1_emacs.report_errors
res_with_errors
>>= fun () -> return_unit
| (parsed, errors) ->
cctxt#message
"%a"
(fun ppf () ->
Michelson_v1_error_reporter.report_errors
~details:(not no_print_source)
~parsed
~show_source:(not no_print_source)
ppf
errors)
()
>>= fun () -> cctxt#error "syntax error in program");
command
~group
~desc:
"Ask the node to list the unreachable pathsin a script's parameter \
type."
(args2 emacs_mode_switch no_print_source_flag)
( prefixes ["get"; "script"; "unreachable"; "paths"; "for"]
@@ Program.source_param @@ stop )
(fun (emacs_mode, no_print_source) program cctxt ->
match program with
| (program, []) ->
list_unreachables
cctxt
~chain:cctxt#chain
~block:cctxt#block
program
>>= fun entrypoints ->
print_unreachables
~emacs:emacs_mode
~show_source:(not no_print_source)
~parsed:program
cctxt
entrypoints
| res_with_errors when emacs_mode ->
cctxt#message
"(@[<v 0>(entrypoints . ())@ (errors . %a)@])"
Michelson_v1_emacs.report_errors
res_with_errors
>>= fun () -> return_unit
| (parsed, errors) ->
cctxt#message
"%a"
(fun ppf () ->
Michelson_v1_error_reporter.report_errors
~details:(not no_print_source)
~parsed
~show_source:(not no_print_source)
ppf
errors)
()
>>= fun () -> cctxt#error "syntax error in program") ]
src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "scripts" % string;
Clic.title := "Commands for managing the library of known scripts" % string
|}.
Import Tezos_micheline.
Import Client_proto_programs.
Import Client_proto_args.
Import Client_proto_contracts.
Definition commands (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_alpha.Protocol_client_context.full) :=
let 'tt := function_parameter in
let show_types_switch :=
switch "show the types of each instruction" % string (Some "v" % char)
"details" % string tt in
let emacs_mode_switch :=
switch "output in `michelson-mode.el` compatible format" % string None
"emacs" % string tt in
let trace_stack_switch :=
switch "show the stack after each step" % string None "trace-stack" % string
tt in
let amount_arg :=
Client_proto_args.tez_arg "0.05" % string "amount" % string
"amount of the transfer in ꜩ" % string in
let source_arg :=
ContractAlias.destination_arg (Some "source" % string)
(Some
"name of the source (i.e. SENDER) contract for the transaction" % string)
tt in
let payer_arg :=
ContractAlias.destination_arg (Some "payer" % string)
(Some
"name of the payer (i.e. SOURCE) contract for the transaction" % string)
tt in
let custom_gas_flag :=
arg "Initial quantity of gas for typechecking and execution" % string
(Some "G" % char) "gas" % string "gas" % string
(parameter None
(fun _ctx =>
fun str =>
(* ❌ Try-with are not handled *)
try
(let v := Z.of_string str in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (op_gteq v Z.zero) in
_return v))) in
let resolve_max_gas {D E F H J L M a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(D * E) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(D * E) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(D * E) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(D * E) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (L * a * b * c * q * i * o)) * (D * M))))) *
(D * M) * (D * E)) (block : E) (function_parameter :
option Tezos_protocol_environment_alpha__Environment.Z.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_environment_alpha__Environment.Z.t) :=
match function_parameter with
| None =>
op_gtgteqquestion
(Alpha_services.Constants.all cctxt
((* ❌ Sending method message is not handled *)
send, block))
(fun function_parameter =>
let '{|
parametric := {|
hard_gas_limit_per_operation := hard_gas_limit_per_operation
|}
|} := function_parameter in
_return hard_gas_limit_per_operation)
| Some gas => _return gas
end in
let data_parameter :=
Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun data =>
Lwt._return
(apply Micheline_parser.no_parsing_error
(Michelson_v1_parser.parse_expression None data))) in
let bytes_parameter {A : Type} (name : string) (desc : string)
: (Tezos_base__TzPervasives.Clic.params A
Tezos_client_alpha.Protocol_client_context.full) ->
Tezos_base__TzPervasives.Clic.params (Stdlib.Bytes.t -> A)
Tezos_client_alpha.Protocol_client_context.full :=
Clic.param name desc Client_proto_args.bytes_parameter in
let signature_parameter :=
Clic.parameter None
(fun _cctxt =>
fun s =>
match Signature.of_b58check_opt s with
| Some s => _return s
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Not given a valid signature" % string
CamlinternalFormatBasics.End_of_format)
"Not given a valid signature" % string)
end) in
cons
(command (Some group) "Lists all scripts in the library." % string
no_options
(fixed
(cons "list" % string
(cons "known" % string (cons "scripts" % string []))))
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
op_gtgteqquestion (Program.load cctxt)
(fun list =>
op_gtgteq
(Lwt_list.iter_s
(fun function_parameter =>
let '(n, _) := function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format) "%s" % string)
n) list)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group) "Add a script to the library." % string
(args1 (Program.force_switch tt))
(apply (prefixes (cons "remember" % string (cons "script" % string [])))
(apply
(let arg := Program.fresh_alias_param in
fun eta => arg None None eta)
(apply
(let arg := Program.source_param in
fun eta => arg None None eta) stop)))
(fun force =>
fun name =>
fun hash =>
fun cctxt =>
op_gtgteqquestion (Program.of_fresh cctxt force name)
(fun name => Program.add force cctxt name hash)))
(cons
(command (Some group) "Remove a script from the library." % string
no_options
(apply (prefixes (cons "forget" % string (cons "script" % string [])))
(apply
(let arg := Program.alias_param in
fun eta => arg None None eta) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(name, _) := function_parameter in
fun cctxt => Program.del cctxt name))
(cons
(command (Some group) "Display a script from the library." % string
no_options
(apply
(prefixes
(cons "show" % string
(cons "known" % string (cons "script" % string []))))
(apply
(let arg := Program.alias_param in
fun eta => arg None None eta) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(_, program) := function_parameter in
fun cctxt =>
op_gtgteqquestion (Program.to_source program)
(fun source =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"010" % char
CamlinternalFormatBasics.End_of_format))
"%s
" % string) source)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group) "Ask the node to run a script." % string
(args7 trace_stack_switch amount_arg source_arg payer_arg
no_print_source_flag custom_gas_flag entrypoint_arg)
(apply
(prefixes (cons "run" % string (cons "script" % string [])))
(apply
(let arg := Program.source_param in
fun eta => arg None None eta)
(apply
(prefixes (cons "on" % string (cons "storage" % string [])))
(apply
(Clic.param "storage" % string "the storage data" % string
data_parameter)
(apply
(prefixes
(cons "and" % string (cons "input" % string [])))
(apply
(Clic.param "input" % string "the input data" % string
data_parameter) stop))))))
(fun function_parameter =>
let
'(trace_exec, amount, source, payer, no_print_source, gas,
entrypoint) := function_parameter in
fun program =>
fun storage =>
fun input =>
fun cctxt =>
let source := Option.map snd source in
let payer := Option.map snd payer in
op_gtgteqquestion
(apply Lwt._return
(Micheline_parser.no_parsing_error program))
(fun program =>
let show_source := negb no_print_source in
if trace_exec then
op_gtgteq
(trace cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some amount) program storage input
source payer gas entrypoint tt)
(fun res =>
print_trace_result cctxt show_source program
res)
else
op_gtgteq
(run cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some amount) program storage input
source payer gas entrypoint tt)
(fun res =>
print_run_result cctxt show_source program res))))
(cons
(command (Some group)
"Ask the node to typecheck a script." % string
(args4 show_types_switch emacs_mode_switch no_print_source_flag
custom_gas_flag)
(apply
(prefixes
(cons "typecheck" % string (cons "script" % string [])))
(apply
(let arg := Program.source_param in
fun eta => arg None None eta) stop))
(fun function_parameter =>
let
'(show_types, emacs_mode, no_print_source, original_gas) :=
function_parameter in
fun program =>
fun cctxt =>
match program with
| (program, []) =>
op_gtgteqquestion
(resolve_max_gas cctxt
(* ❌ Sending method message is not handled *)
send original_gas)
(fun original_gas =>
op_gtgteq
(typecheck_program cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some original_gas) program)
(fun res =>
print_typecheck_result emacs_mode show_types
(negb no_print_source) program res cctxt))
| res_with_errors =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "(" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"(types . ())" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"(errors . " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))))))))
"(@[<v 0>(types . ())@ (errors . %a)@])" % string)
Michelson_v1_emacs.report_errors res_with_errors)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| (parsed, errors) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string)
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Michelson_v1_error_reporter.report_errors
(negb no_print_source) (negb no_print_source)
(Some parsed) ppf errors) tt)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"syntax error in program" % string
CamlinternalFormatBasics.End_of_format)
"syntax error in program" % string))
end))
(cons
(command (Some group)
"Ask the node to typecheck a data expression." % string
(args2 no_print_source_flag custom_gas_flag)
(apply
(prefixes
(cons "typecheck" % string (cons "data" % string [])))
(apply
(Clic.param "data" % string
"the data to typecheck" % string data_parameter)
(apply
(prefixes
(cons "against" % string (cons "type" % string [])))
(apply
(Clic.param "type" % string
"the expected type" % string data_parameter) stop))))
(fun function_parameter =>
let '(no_print_source, custom_gas) := function_parameter in
fun data =>
fun ty =>
fun cctxt =>
op_gtgteqquestion
(resolve_max_gas cctxt
(* ❌ Sending method message is not handled *)
send custom_gas)
(fun original_gas =>
op_gtgteq
(Client_proto_programs.typecheck_data cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send (Some original_gas) data ty tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok gas =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"Well typed" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Gas remaining: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@[<v 0>Well typed@,Gas remaining: %a@]"
% string) Alpha_context.Gas.pp gas)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error errs =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string)
(Michelson_v1_error_reporter.report_errors
false (negb no_print_source) None)
errs)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"ill-typed data" % string
CamlinternalFormatBasics.End_of_format)
"ill-typed data" % string))
end))))
(cons
(command (Some group)
"Ask the node to pack a data expression.
The returned hash is the same as what Michelson instruction `PACK` would have produced.
Also displays the result of hashing this packed data with `BLAKE2B`, `SHA256` or `SHA512` instruction."
% string (args1 custom_gas_flag)
(apply
(prefixes (cons "hash" % string (cons "data" % string [])))
(apply
(Clic.param "data" % string "the data to hash" % string
data_parameter)
(apply
(prefixes
(cons "of" % string (cons "type" % string [])))
(apply
(Clic.param "type" % string
"type of the data" % string data_parameter) stop))))
(fun custom_gas =>
fun data =>
fun typ =>
fun cctxt =>
op_gtgteqquestion
(resolve_max_gas cctxt
(* ❌ Sending method message is not handled *)
send custom_gas)
(fun original_gas =>
op_gtgteq
(Alpha_services.Helpers.Scripts.pack_data
cctxt
((* ❌ Sending method message is not handled *)
send,
(* ❌ Sending method message is not handled *)
send)
((expanded data), (expanded typ),
(Some original_gas)))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok (bytes, remaining_gas) =>
let hash :=
Script_expr_hash.hash_bytes None
(cons string []) in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Raw packed data: 0x" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Script-expression-ID-Hash: "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0 0)
(CamlinternalFormatBasics.String_literal
"Raw Script-expression-ID-Hash: 0x"
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," % string 0
0)
(CamlinternalFormatBasics.String_literal
"Ledger Blake2b hash: "
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@," %
string 0
0)
(CamlinternalFormatBasics.String_literal
"Raw Sha256 hash: 0x"
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@,"
%
string
0 0)
(CamlinternalFormatBasics.String_literal
"Raw Sha512 hash: 0x"
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@,"
%
string
0
0)
(CamlinternalFormatBasics.String_literal
"Gas remaining: "
%
string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))))))))))))))))))
"Raw packed data: 0x%a@,Script-expression-ID-Hash: %a@,Raw Script-expression-ID-Hash: 0x%a@,Ledger Blake2b hash: %s@,Raw Sha256 hash: 0x%a@,Raw Sha512 hash: 0x%a@,Gas remaining: %a"
% string) Hex.pp
(Hex.of_bytes None string)
Script_expr_hash.pp hash Hex.pp
(Hex.of_bytes None
(Script_expr_hash.to_bytes hash))
(Base58.raw_encode None
(OCaml.Stdlib.reverse_apply
(hash_bytes None (cons string []))
to_string)) Hex.pp
(Hex.of_bytes None
(Environment.Raw_hashes.sha256
string)) Hex.pp
(Hex.of_bytes None
(Environment.Raw_hashes.sha512
string)) Alpha_context.Gas.pp
remaining_gas)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Error errs =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string)
(Michelson_v1_error_reporter.report_errors
false false None) errs)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"ill-formed data" % string
CamlinternalFormatBasics.End_of_format)
"ill-formed data" % string))
end))))
(cons
(command (Some group)
"Parse a byte sequence (in hexadecimal notation) as a data expression, as per Michelson instruction `UNPACK`."
% string Clic.no_options
(apply
(prefixes
(cons "unpack" % string
(cons "michelson" % string (cons "data" % string []))))
(apply
(bytes_parameter "bytes" % string
"the packed data to parse" % string) stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun bytes =>
fun cctxt =>
op_gtgteqquestion
(if
Stdlib.op_exclamationeq
(Stdlib.Bytes.get string 0) "005" % char then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Not a piece of packed Michelson data (must start with `0x05`)"
% string
CamlinternalFormatBasics.End_of_format)
"Not a piece of packed Michelson data (must start with `0x05`)"
% string)
else
return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
let bytes :=
String.sub string 1
(Z.sub (String.length string) 1) in
match
Data_encoding.Binary.of_bytes
Alpha_context.Script.expr_encoding string
with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Could not decode bytes" % string
CamlinternalFormatBasics.End_of_format)
"Could not decode bytes" % string)
| Some expr =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string)
Michelson_v1_printer.print_expr_unwrapped
expr)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end)))
(cons
(command (Some group)
"Sign a raw sequence of bytes and display it using the format expected by Michelson instruction `CHECK_SIGNATURE`."
% string no_options
(apply
(prefixes
(cons "sign" % string (cons "bytes" % string [])))
(apply
(bytes_parameter "data" % string
"the raw data to sign" % string)
(apply (prefixes (cons "for" % string []))
(apply
(let arg := Client_keys.Secret_key.source_param
in
fun eta => arg None None eta) stop))))
(fun function_parameter =>
let 'tt := function_parameter in
fun bytes =>
fun sk =>
fun cctxt =>
op_gtgteqquestion
(Client_keys.sign cctxt None sk string)
(fun signature =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Signature: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Signature: %a" % string) Signature.pp
signature)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))
(cons
(command (Some group)
"Check the signature of a byte sequence as per Michelson instruction `CHECK_SIGNATURE`."
% string
(args1
(switch "Use only exit codes" % string
(Some "q" % char) "quiet" % string tt))
(apply
(prefixes
(cons "check" % string (cons "that" % string [])))
(apply
(bytes_parameter "bytes" % string
"the signed data" % string)
(apply
(prefixes
(cons "was" % string
(cons "signed" % string
(cons "by" % string []))))
(apply
(let arg :=
Client_keys.Public_key.alias_param
(Some "key" % string) in
fun eta => arg None eta)
(apply
(prefixes
(cons "to" % string
(cons "produce" % string [])))
(apply
(Clic.param "signature" % string
"the signature to check" % string
signature_parameter) stop))))))
(fun quiet =>
fun bytes =>
fun function_parameter =>
let '(_, (key_locator, _)) := function_parameter
in
fun signature =>
fun cctxt =>
op_gtgteqquestion
(Client_keys.check None key_locator
signature string)
(fun function_parameter =>
match function_parameter with
| false =>
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"invalid signature" % string
CamlinternalFormatBasics.End_of_format)
"invalid signature" % string)
| true =>
if quiet then
return_unit
else
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Signature check successfull."
% string
CamlinternalFormatBasics.End_of_format)
"Signature check successfull."
% string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end)))
(cons
(command (Some group)
"Ask the type of an entrypoint of a script." %
string
(args2 emacs_mode_switch no_print_source_flag)
(apply
(prefixes
(cons "get" % string
(cons "script" % string
(cons "entrypoint" % string
(cons "type" % string
(cons "of" % string []))))))
(apply
(Clic.string "entrypoint" % string
"the entrypoint to describe" % string)
(apply (prefixes (cons "for" % string []))
(apply
(let arg := Program.source_param in
fun eta => arg None None eta) stop))))
(fun function_parameter =>
let '(emacs_mode, no_print_source) :=
function_parameter in
fun entrypoint =>
fun program =>
fun cctxt =>
match program with
| (program, []) =>
op_gtgteq
(entrypoint_type cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send program entrypoint)
(fun entrypoint_type =>
print_entrypoint_type cctxt emacs_mode
None (negb no_print_source) program
entrypoint entrypoint_type)
| res_with_errors =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal
"(" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"(entrypoint . ())" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"(errors . " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))))))))
"(@[<v 0>(entrypoint . ())@ (errors . %a)@])"
% string)
Michelson_v1_emacs.report_errors
res_with_errors)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| (parsed, errors) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string)
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Michelson_v1_error_reporter.report_errors
(negb no_print_source)
(negb no_print_source)
(Some parsed) ppf errors) tt)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"syntax error in program" %
string
CamlinternalFormatBasics.End_of_format)
"syntax error in program" % string))
end))
(cons
(command (Some group)
"Ask the node to list the entrypoints of a script."
% string
(args2 emacs_mode_switch no_print_source_flag)
(apply
(prefixes
(cons "get" % string
(cons "script" % string
(cons "entrypoints" % string
(cons "for" % string [])))))
(apply
(let arg := Program.source_param in
fun eta => arg None None eta) stop))
(fun function_parameter =>
let '(emacs_mode, no_print_source) :=
function_parameter in
fun program =>
fun cctxt =>
match program with
| (program, []) =>
op_gtgteq
(list_entrypoints cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send program)
(fun entrypoints =>
print_entrypoints_list cctxt
emacs_mode None
(negb no_print_source) program
entrypoints)
| res_with_errors =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal
"(" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"(entrypoints . ())" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"(errors . " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))))))))
"(@[<v 0>(entrypoints . ())@ (errors . %a)@])"
% string)
Michelson_v1_emacs.report_errors
res_with_errors)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| (parsed, errors) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string)
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Michelson_v1_error_reporter.report_errors
(negb no_print_source)
(negb no_print_source)
(Some parsed) ppf errors) tt)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"syntax error in program" %
string
CamlinternalFormatBasics.End_of_format)
"syntax error in program" % string))
end))
(cons
(command (Some group)
"Ask the node to list the unreachable pathsin a script's parameter type."
% string
(args2 emacs_mode_switch no_print_source_flag)
(apply
(prefixes
(cons "get" % string
(cons "script" % string
(cons "unreachable" % string
(cons "paths" % string
(cons "for" % string []))))))
(apply
(let arg := Program.source_param in
fun eta => arg None None eta) stop))
(fun function_parameter =>
let '(emacs_mode, no_print_source) :=
function_parameter in
fun program =>
fun cctxt =>
match program with
| (program, []) =>
op_gtgteq
(list_unreachables cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send program)
(fun entrypoints =>
print_unreachables cctxt emacs_mode
None (negb no_print_source)
program entrypoints)
| res_with_errors =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal
"(" % char
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 0>" % string
CamlinternalFormatBasics.End_of_format)
"<v 0>" % string))
(CamlinternalFormatBasics.String_literal
"(entrypoints . ())" %
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.String_literal
"(errors . " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))))))))
"(@[<v 0>(entrypoints . ())@ (errors . %a)@])"
% string)
Michelson_v1_emacs.report_errors
res_with_errors)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| (parsed, errors) =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)
"%a" % string)
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Michelson_v1_error_reporter.report_errors
(negb no_print_source)
(negb no_print_source)
(Some parsed) ppf errors) tt)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"syntax error in program" %
string
CamlinternalFormatBasics.End_of_format)
"syntax error in program" %
string))
end)) []))))))))))))).
src/proto_alpha/lib_delegate/client_baking_blocks.ml 90 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
type block_info = {
hash : Block_hash.t;
chain_id : Chain_id.t;
predecessor : Block_hash.t;
fitness : Bytes.t list;
timestamp : Time.Protocol.t;
protocol : Protocol_hash.t;
next_protocol : Protocol_hash.t;
proto_level : int;
level : Raw_level.t;
context : Context_hash.t;
}
let raw_info cctxt ?(chain = `Main) hash shell_header =
let block = `Hash (hash, 0) in
Shell_services.Chain.chain_id cctxt ~chain ()
>>=? fun chain_id ->
Shell_services.Blocks.protocols cctxt ~chain ~block ()
>>=? fun {current_protocol = protocol; next_protocol} ->
let { Tezos_base.Block_header.predecessor;
fitness;
timestamp;
level;
context;
proto_level;
_ } =
shell_header
in
match Raw_level.of_int32 level with
| Ok level ->
return
{
hash;
chain_id;
predecessor;
fitness;
timestamp;
protocol;
next_protocol;
proto_level;
level;
context;
}
| Error _ ->
failwith "Cannot convert level into int32"
let info cctxt ?(chain = `Main) block =
Shell_services.Blocks.hash cctxt ~chain ~block ()
>>=? fun hash ->
Shell_services.Blocks.Header.shell_header cctxt ~chain ~block ()
>>=? fun shell_header -> raw_info cctxt ~chain hash shell_header
module Block_seen_event = struct
type t = {
hash : Block_hash.t;
header : Tezos_base.Block_header.t;
occurrence : [`Valid_blocks of Chain_id.t | `Heads];
}
let make hash header occurrence () = {hash; header; occurrence}
module Definition = struct
let name = "block-seen-" ^ Protocol.name
type nonrec t = t
let encoding =
let open Data_encoding in
let v0_encoding =
conv
(function {hash; header; occurrence} -> (hash, occurrence, header))
(fun (b, o, h) -> make b h o ())
(obj3
(req "hash" Block_hash.encoding)
(* Occurrence has to come before header, because:
(Invalid_argument
"Cannot merge two objects when the left element is of
variable length and the right one of dynamic
length. You should use the reverse order, or wrap the
second one with Data_encoding.dynamic_size.") *)
(req
"occurrence"
(union
[ case
~title:"heads"
(Tag 0)
(obj1 (req "occurrence-kind" (constant "heads")))
(function `Heads -> Some () | _ -> None)
(fun () -> `Heads);
case
~title:"valid-blocks"
(Tag 1)
(obj2
(req "occurrence-kind" (constant "valid-blocks"))
(req "chain-id" Chain_id.encoding))
(function
| `Valid_blocks ch -> Some ((), ch) | _ -> None)
(fun ((), ch) -> `Valid_blocks ch) ]))
(req "header" Tezos_base.Block_header.encoding))
in
With_version.(encoding ~name (first_version v0_encoding))
let pp ppf {hash; _} =
Format.fprintf ppf "Saw block %a" Block_hash.pp_short hash
let doc = "Block observed while monitoring a blockchain."
include Internal_event.Event_defaults
end
module Event = Internal_event.Make (Definition)
end
let monitor_valid_blocks cctxt ?chains ?protocols ~next_protocols () =
Monitor_services.valid_blocks cctxt ?chains ?protocols ?next_protocols ()
>>=? fun (block_stream, _stop) ->
return
(Lwt_stream.map_s
(fun ((chain, block), header) ->
Block_seen_event.(
Event.emit (make block header (`Valid_blocks chain)))
>>=? fun () ->
raw_info
cctxt
~chain:(`Hash chain)
block
header.Tezos_base.Block_header.shell)
block_stream)
let monitor_heads cctxt ~next_protocols chain =
Monitor_services.heads cctxt ?next_protocols chain
>>=? fun (block_stream, _stop) ->
return
(Lwt_stream.map_s
(fun (block, ({Tezos_base.Block_header.shell; _} as header)) ->
Block_seen_event.(Event.emit (make block header `Heads))
>>=? fun () -> raw_info cctxt ~chain block shell)
block_stream)
let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () =
Shell_services.Blocks.hash cctxt ~chain ~block ()
>>=? fun hash ->
Shell_services.Blocks.Header.shell_header cctxt ~chain ~block ()
>>=? fun {level; _} ->
Alpha_services.Helpers.levels_in_current_cycle cctxt ~offset (chain, block)
>>= function
| Error (RPC_context.Not_found _ :: _) ->
return_nil
| Error _ as err ->
Lwt.return err
| Ok (first, last) ->
let length = Int32.to_int (Int32.sub level (Raw_level.to_int32 first)) in
Shell_services.Blocks.list cctxt ~chain ~heads:[hash] ~length ()
>>=? fun blocks ->
let blocks =
List.remove
(length - Int32.to_int (Raw_level.diff last first))
(List.hd blocks)
in
if Int32.equal level (Raw_level.to_int32 last) then
return (hash :: blocks)
else return blocks
src/proto_alpha/lib_delegate/client_baking_blocks.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Record block_info := {
hash : Tezos_base__TzPervasives.Block_hash.t;
chain_id : Tezos_base__TzPervasives.Chain_id.t;
predecessor : Tezos_base__TzPervasives.Block_hash.t;
fitness : list Stdlib.Bytes.t;
timestamp : Tezos_base__TzPervasives.Time.Protocol.t;
protocol : Tezos_base__TzPervasives.Protocol_hash.t;
next_protocol : Tezos_base__TzPervasives.Protocol_hash.t;
proto_level : Z;
level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t;
context : Tezos_base__TzPervasives.Context_hash.t }.
Definition raw_info {E F i o p q : Type}
(cctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(op_staroptstar : option Tezos_shell_services.Shell_services.Chain.chain)
: Tezos_base__TzPervasives.Block_hash.t ->
Tezos_base.Block_header.shell_header ->
Lwt.t (Tezos_base__TzPervasives.tzresult block_info) :=
let chain :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun hash =>
fun shell_header =>
let block :=
(* ❌ Variants not supported *)
variant in
op_gtgteqquestion (Shell_services.Chain.chain_id cctxt (Some chain) tt)
(fun chain_id =>
op_gtgteqquestion
(Shell_services.Blocks.protocols cctxt (Some chain) (Some block) tt)
(fun function_parameter =>
let '{|
current_protocol := protocol;
next_protocol := next_protocol
|} := function_parameter in
let '{|
Tezos_base.Block_header.level := level;
Tezos_base.Block_header.proto_level := proto_level;
Tezos_base.Block_header.predecessor := predecessor;
Tezos_base.Block_header.timestamp := timestamp;
Tezos_base.Block_header.fitness := fitness;
Tezos_base.Block_header.context := context
|} := shell_header in
match Raw_level.of_int32 level with
| Stdlib.Ok level =>
_return
{| hash := hash; chain_id := chain_id;
predecessor := predecessor; fitness := fitness;
timestamp := timestamp; protocol := protocol;
next_protocol := next_protocol; proto_level := proto_level;
level := level; context := context |}
| Stdlib.Error _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot convert level into int32" % string
CamlinternalFormatBasics.End_of_format)
"Cannot convert level into int32" % string)
end)).
Definition info {E F i o p q : Type}
(cctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(op_staroptstar : option Tezos_shell_services__Block_services.chain)
: Tezos_shell_services__Block_services.block ->
Lwt.t (Tezos_base__TzPervasives.tzresult block_info) :=
let chain :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun block =>
op_gtgteqquestion
(Shell_services.Blocks.hash cctxt (Some chain) (Some block) tt)
(fun hash =>
op_gtgteqquestion
(Shell_services.Blocks.Header.shell_header cctxt (Some chain)
(Some block) tt)
(fun shell_header => raw_info cctxt (Some chain) hash shell_header)).
Module Block_seen_event.
Record t := {
hash : Tezos_base__TzPervasives.Block_hash.t;
header : Tezos_base.Block_header.t;
occurrence : variant }.
Definition make
(hash : Tezos_base__TzPervasives.Block_hash.t)
(header : Tezos_base.Block_header.t) (occurrence : variant)
(function_parameter : unit) : t :=
let 'tt := function_parameter in
{| hash := hash; header := header; occurrence := occurrence |}.
Module Definition.
Definition name : string :=
String.append "block-seen-" % string Protocol.name.
Definition t := t.
Definition encoding : Tezos_data_encoding__Data_encoding.encoding t :=
let v0_encoding :=
conv
(fun function_parameter =>
let '{|
hash := hash; header := header; occurrence := occurrence |} :=
function_parameter in
(hash, occurrence, header))
(fun function_parameter =>
let '(b, o, h) := function_parameter in
make b h o tt) None
(obj3 (req None None "hash" % string Block_hash.encoding)
(req None None "occurrence" % string
(union None
(cons
(case "heads" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 0)
(obj1
(req None None "occurrence-kind" % string
(constant "heads" % string)))
(fun function_parameter =>
match function_parameter with
| Heads => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Variants not supported *)
variant))
(cons
(case "valid-blocks" % string None
(Tezos_base__TzPervasives.Data_encoding.Tag 1)
(obj2
(req None None "occurrence-kind" % string
(constant "valid-blocks" % string))
(req None None "chain-id" % string Chain_id.encoding))
(fun function_parameter =>
match function_parameter with
| Valid_blocks ch => Some (tt, ch)
| _ => None
end)
(fun function_parameter =>
let '(tt, ch) := function_parameter in
(* ❌ Variants not supported *)
variant)) []))))
(req None None "header" % string Tezos_base.Block_header.encoding))
in
encoding name (first_version v0_encoding).
Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
: unit :=
let '{| hash := hash |} := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "Saw block " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)) "Saw block %a" % string)
Block_hash.pp_short hash.
Definition doc : string :=
"Block observed while monitoring a blockchain." % string.
(* ❌ Structure item `include` not handled. *)
include
End Definition.
(* ❌ Applications of functors are not handled. *)
functor_application
End Block_seen_event.
Definition monitor_valid_blocks {E F G i o p q : Type}
(cctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
* (E * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(F * p * q * i * o)) * G)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(F * p * q * i * o)) * G))
(chains : option (list Tezos_shell_services.Chain_services.chain))
(protocols : option (list Tezos_base__TzPervasives.Protocol_hash.t))
(next_protocols : option (list Tezos_base__TzPervasives.Protocol_hash.t))
(function_parameter : unit)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Lwt_stream.t (Tezos_base__TzPervasives.tzresult block_info))) :=
let 'tt := function_parameter in
op_gtgteqquestion
(Monitor_services.valid_blocks cctxt chains protocols next_protocols tt)
(fun function_parameter =>
let '(block_stream, _stop) := function_parameter in
_return
(Lwt_stream.map_s
(fun function_parameter =>
let '((chain, block), header) := function_parameter in
op_gtgteqquestion
(Event.emit None
(make block header
(* ❌ Variants not supported *)
variant))
(fun function_parameter =>
let 'tt := function_parameter in
raw_info cctxt
(Some
(* ❌ Variants not supported *)
variant) block (Tezos_base.Block_header.shell header)))
block_stream)).
Definition monitor_heads {E F G i o p q : Type}
(cctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
* (E * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(F * p * q * i * o)) * G)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(F * p * q * i * o)) * G))
(next_protocols : option (list Tezos_base__TzPervasives.Protocol_hash.t))
(chain : Tezos_shell_services.Chain_services.chain)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Lwt_stream.t (Tezos_base__TzPervasives.tzresult block_info))) :=
op_gtgteqquestion (Monitor_services.heads cctxt next_protocols chain)
(fun function_parameter =>
let '(block_stream, _stop) := function_parameter in
_return
(Lwt_stream.map_s
(fun function_parameter =>
let
'(block, {| Tezos_base.Block_header.shell := shell |} as header) :=
function_parameter in
op_gtgteqquestion
(Event.emit None
(make block header
(* ❌ Variants not supported *)
variant))
(fun function_parameter =>
let 'tt := function_parameter in
raw_info cctxt (Some chain) block shell)) block_stream)).
Definition blocks_from_current_cycle {D F H J L M a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(variant * Tezos_shell_services__Block_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(variant * Tezos_shell_services__Block_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(variant * Tezos_shell_services__Block_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(variant * Tezos_shell_services__Block_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(L * p * q * i * o)) * M))))) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(variant * Tezos_shell_services__Block_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
(variant * Tezos_shell_services__Block_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
(variant * Tezos_shell_services__Block_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(variant * Tezos_shell_services__Block_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) * M)))))
(op_staroptstar : option variant)
: Tezos_shell_services__Block_services.block ->
(option int32) ->
unit ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(list Tezos_base__TzPervasives.Block_hash.t)) :=
let chain :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Variants not supported *)
variant
end in
fun block =>
fun op_staroptstar =>
let offset :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Constant of type int32 is converted to int *)
0
end in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Shell_services.Blocks.hash cctxt (Some chain) (Some block) tt)
(fun hash =>
op_gtgteqquestion
(Shell_services.Blocks.Header.shell_header cctxt (Some chain)
(Some block) tt)
(fun function_parameter =>
let '{| level := level |} := function_parameter in
op_gtgteq
(Alpha_services.Helpers.levels_in_current_cycle cctxt
(Some offset) (chain, block))
(fun function_parameter =>
match function_parameter with
|
Stdlib.Error
(cons (Tezos_error_monad.Error_monad.Not_found _) _) =>
return_nil
| (Stdlib.Error _) as err => Lwt._return err
| Stdlib.Ok (first, last) =>
let length :=
Int32.to_int
(Int32.sub level (Raw_level.to_int32 first)) in
op_gtgteqquestion
(Shell_services.Blocks.list cctxt (Some chain)
(Some (cons hash [])) (Some length) None tt)
(fun blocks =>
let blocks :=
List.remove
(Z.sub length
(Int32.to_int (Raw_level.diff last first)))
(List.hd blocks) in
if Int32.equal level (Raw_level.to_int32 last) then
_return (cons hash blocks)
else
_return blocks)
end))).
src/proto_alpha/lib_delegate/client_baking_denunciation.ml 449 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make_semantic (struct
let name = Protocol.name ^ ".baking.denunciation"
end)
open Protocol
open Alpha_context
open Protocol_client_context
open Client_baking_blocks
open Logging
module HLevel = Hashtbl.Make (struct
type t = Chain_id.t * Raw_level.t
let equal (c, l) (c', l') = Chain_id.equal c c' && Raw_level.equal l l'
let hash (c, lvl) = Hashtbl.hash (c, lvl)
end)
module Delegate_Map = Map.Make (Signature.Public_key_hash)
type state = {
(* Endorsements seen so far *)
endorsements_table : Kind.endorsement operation Delegate_Map.t HLevel.t;
(* Blocks received so far *)
blocks_table : Block_hash.t Delegate_Map.t HLevel.t;
(* Maximum delta of level to register *)
preserved_levels : int;
(* Highest level seen in a block *)
mutable highest_level_encountered : Raw_level.t;
}
let create_state ~preserved_levels =
Lwt.return
{
endorsements_table = HLevel.create preserved_levels;
blocks_table = HLevel.create preserved_levels;
preserved_levels;
highest_level_encountered = Raw_level.root (* 0l *);
}
(* We choose a previous offset (5 blocks from head) to ensure that the
injected operation is branched from a valid predecessor. *)
let get_block_offset level =
match Environment.wrap_error (Raw_level.of_int32 5l) with
| Ok min_level ->
Lwt.return (if Raw_level.(level < min_level) then `Head 0 else `Head 5)
| Error errs ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Invalid level conversion : %a"
-% t event "invalid_level_conversion"
-% a errs_tag errs)
>>= fun () -> Lwt.return (`Head 0)
let process_endorsements (cctxt : #Protocol_client_context.full) state
(endorsements : Alpha_block_services.operation list) level =
iter_s
(fun {Alpha_block_services.shell; chain_id; receipt; hash; protocol_data; _}
->
let chain = `Hash chain_id in
match (protocol_data, receipt) with
| ( Operation_data
({contents = Single (Endorsement _); _} as protocol_data),
Apply_results.(
Operation_metadata
{contents = Single_result (Endorsement_result {delegate; _})}) )
-> (
let new_endorsement : Kind.endorsement Alpha_context.operation =
{shell; protocol_data}
in
let map =
match
HLevel.find_opt state.endorsements_table (chain_id, level)
with
| None ->
Delegate_Map.empty
| Some x ->
x
in
(* If a previous endorsement made by this pkh is found for
the same level we inject a double_endorsement *)
match Delegate_Map.find_opt delegate map with
| None ->
return
@@ HLevel.add
state.endorsements_table
(chain_id, level)
(Delegate_Map.add delegate new_endorsement map)
| Some existing_endorsement
when Block_hash.(
existing_endorsement.shell.branch
<> new_endorsement.shell.branch) ->
get_block_offset level
>>= fun block ->
Alpha_block_services.hash cctxt ~chain ~block ()
>>=? fun block_hash ->
Alpha_services.Forge.double_endorsement_evidence
cctxt
(`Hash chain_id, block)
~branch:block_hash
~op1:existing_endorsement
~op2:new_endorsement
()
>>=? fun bytes ->
let bytes = Signature.concat bytes Signature.zero in
lwt_log_notice
Tag.DSL.(
fun f ->
f "Double endorsement detected"
-% t event "double_endorsement_detected"
-% t
conflicting_endorsements_tag
(existing_endorsement, new_endorsement))
>>= fun () ->
(* A denunciation may have already occured *)
Shell_services.Injection.operation cctxt ~chain bytes
>>=? fun op_hash ->
lwt_log_notice
Tag.DSL.(
fun f ->
f "Double endorsement evidence injected %a"
-% t event "double_endorsement_denounced"
-% t signed_operation_tag bytes
-% a Operation_hash.Logging.tag op_hash)
>>= fun () ->
return
@@ HLevel.replace
state.endorsements_table
(chain_id, level)
(Delegate_Map.add delegate new_endorsement map)
| Some _ ->
(* This endorsement is already present in another
block but endorse the same predecessor *)
return_unit )
| _ ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Inconsistent endorsement found %a"
-% t event "inconsistent_endorsement"
-% a Operation_hash.Logging.tag hash)
>>= fun () -> return_unit)
endorsements
>>=? fun () -> return_unit
let process_block (cctxt : #Protocol_client_context.full) state
(header : Alpha_block_services.block_info) =
let { Alpha_block_services.chain_id;
hash;
metadata = {protocol_data = {baker; level = {level; _}; _}; _};
_ } =
header
in
let chain = `Hash chain_id in
let map =
match HLevel.find_opt state.blocks_table (chain_id, level) with
| None ->
Delegate_Map.empty
| Some x ->
x
in
match Delegate_Map.find_opt baker map with
| None ->
return
@@ HLevel.add
state.blocks_table
(chain_id, level)
(Delegate_Map.add baker hash map)
| Some existing_hash when Block_hash.( = ) existing_hash hash ->
(* This case should never happen *)
lwt_debug
Tag.DSL.(
fun f ->
f
"Double baking detected but block hashes are equivalent. \
Skipping..."
-% t event "double_baking_but_not")
>>= fun () ->
return
@@ HLevel.replace
state.blocks_table
(chain_id, level)
(Delegate_Map.add baker hash map)
| Some existing_hash ->
(* If a previous endorsement made by this pkh is found for
the same level we inject a double_endorsement *)
Alpha_block_services.header
cctxt
~chain
~block:(`Hash (existing_hash, 0))
()
>>=? fun ({shell; protocol_data; _} : Alpha_block_services.block_header) ->
let bh1 = {Alpha_context.Block_header.shell; protocol_data} in
Alpha_block_services.header cctxt ~chain ~block:(`Hash (hash, 0)) ()
>>=? fun ({shell; protocol_data; _} : Alpha_block_services.block_header) ->
let bh2 = {Alpha_context.Block_header.shell; protocol_data} in
(* If the blocks are on different chains then skip it *)
get_block_offset level
>>= fun block ->
Alpha_block_services.hash cctxt ~chain ~block ()
>>=? fun block_hash ->
Alpha_services.Forge.double_baking_evidence
cctxt
(chain, block)
~branch:block_hash
~bh1
~bh2
()
>>=? fun bytes ->
let bytes = Signature.concat bytes Signature.zero in
lwt_log_notice
Tag.DSL.(
fun f ->
f "Double baking detected" -% t event "double_baking_detected")
>>= fun () ->
(* A denunciation may have already occured *)
Shell_services.Injection.operation cctxt ~chain bytes
>>=? fun op_hash ->
lwt_log_notice
Tag.DSL.(
fun f ->
f "Double baking evidence injected %a"
-% t event "double_baking_denounced"
-% t signed_operation_tag bytes
-% a Operation_hash.Logging.tag op_hash)
>>= fun () ->
return
@@ HLevel.replace
state.blocks_table
(chain_id, level)
(Delegate_Map.add baker hash map)
(* Remove levels that are lower than the [highest_level_encountered] minus [preserved_levels] *)
let cleanup_old_operations state =
let highest_level_encountered =
Int32.to_int (Raw_level.to_int32 state.highest_level_encountered)
in
let diff = highest_level_encountered - state.preserved_levels in
let threshold =
if diff < 0 then Raw_level.root
else
Raw_level.of_int32 (Int32.of_int diff)
|> function Ok threshold -> threshold | Error _ -> Raw_level.root
in
let filter hmap =
HLevel.filter_map_inplace
(fun (_, level) x ->
if Raw_level.(level < threshold) then None else Some x)
hmap
in
filter state.endorsements_table ;
filter state.blocks_table ;
()
let endorsements_index = 0
(* Each new block is processed :
- Checking that every endorser operated only once at this level
- Checking that every baker injected only once at this level
*)
let process_new_block (cctxt : #Protocol_client_context.full) state
{hash; chain_id; level; protocol; next_protocol; _} =
if Protocol_hash.(protocol <> next_protocol) then
lwt_log_error
Tag.DSL.(
fun f ->
f "Protocol changing detected. Skipping the block."
-% t event "protocol_change_detected"
(* TODO which protocols -- in tag *))
>>= fun () -> return_unit
else
lwt_debug
Tag.DSL.(
fun f ->
f "Block level : %a"
-% t event "accuser_saw_block"
-% a level_tag level
-% t Block_hash.Logging.tag hash)
>>= fun () ->
let chain = `Hash chain_id in
let block = `Hash (hash, 0) in
state.highest_level_encountered <-
Raw_level.max level state.highest_level_encountered ;
(* Processing blocks *)
Alpha_block_services.info cctxt ~chain ~block ()
>>= (function
| Ok block_info ->
process_block cctxt state block_info
| Error errs ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Error while fetching operations in block %a@\n%a"
-% t event "fetch_operations_error"
-% a Block_hash.Logging.tag hash
-% a errs_tag errs)
>>= fun () -> return_unit)
>>=? fun () ->
(* Processing endorsements *)
Alpha_block_services.Operations.operations cctxt ~chain ~block ()
>>= (function
| Ok operations ->
if List.length operations > endorsements_index then
let endorsements = List.nth operations endorsements_index in
process_endorsements cctxt state endorsements level
else return_unit
| Error errs ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Error while fetching operations in block %a@\n%a"
-% t event "fetch_operations_error"
-% a Block_hash.Logging.tag hash
-% a errs_tag errs)
>>= fun () -> return_unit)
>>=? fun () ->
cleanup_old_operations state ;
return_unit
let create (cctxt : #Protocol_client_context.full) ~preserved_levels
valid_blocks_stream =
let process_block cctxt state bi =
process_new_block cctxt state bi
>>= function
| Ok () ->
lwt_log_notice
Tag.DSL.(
fun f ->
f "Block %a registered"
-% t event "accuser_processed_block"
-% a Block_hash.Logging.tag bi.Client_baking_blocks.hash)
>>= return
| Error errs ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Error while processing block %a@\n%a"
-% t event "accuser_block_error"
-% a Block_hash.Logging.tag bi.hash
-% a errs_tag errs)
>>= return
in
let state_maker _ = create_state ~preserved_levels >>= return in
Client_baking_scheduling.main
~name:"accuser"
~cctxt
~stream:valid_blocks_stream
~state_maker
~pre_loop:(fun _ _ _ -> return_unit)
~compute_timeout:(fun _ -> Lwt_utils.never_ending ())
~timeout_k:(fun _ _ () -> return_unit)
~event_k:process_block
src/proto_alpha/lib_delegate/client_baking_denunciation.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Import Protocol.
Import Alpha_context.
Import Protocol_client_context.
Import Client_baking_blocks.
Import Logging.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Record state := {
endorsements_table :
HLevel.t
(Delegate_Map.(Stdlib__map.S.t)
(Tezos_protocol_alpha.Protocol.Alpha_context.operation
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement));
blocks_table :
HLevel.t
(Delegate_Map.(Stdlib__map.S.t) Tezos_base__TzPervasives.Block_hash.t);
preserved_levels : Z;
highest_level_encountered :
Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t }.
Definition create_state (preserved_levels : Z) : Lwt.t state :=
Lwt._return
{| endorsements_table := HLevel.create preserved_levels;
blocks_table := HLevel.create preserved_levels;
preserved_levels := preserved_levels;
highest_level_encountered := Raw_level.root |}.
Definition get_block_offset
(level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
: Lwt.t variant :=
match
Environment.wrap_error
(Raw_level.of_int32
(* ❌ Constant of type int32 is converted to int *)
5) with
| Stdlib.Ok min_level =>
Lwt._return
(if op_lt level min_level then
(* ❌ Variants not supported *)
variant
else
(* ❌ Variants not supported *)
variant)
| Stdlib.Error errs =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Invalid level conversion : " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Invalid level conversion : %a" % string))
(t event "invalid_level_conversion" % string)) (a errs_tag errs)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return
(* ❌ Variants not supported *)
variant)
end.
Definition process_endorsements {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (state : state)
(endorsements :
list
Tezos_client_alpha.Protocol_client_context.Alpha_block_services.operation)
(level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
(iter_s
(fun function_parameter =>
let '{|
Alpha_block_services.chain_id := chain_id;
Alpha_block_services.hash := hash;
Alpha_block_services.shell := shell;
Alpha_block_services.protocol_data := protocol_data;
Alpha_block_services.receipt := receipt
|} := function_parameter in
let chain :=
(* ❌ Variants not supported *)
variant in
match (protocol_data, receipt) with
|
(Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data
({|
contents :=
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Endorsement
_)
|} as protocol_data),
Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata {|
contents :=
Tezos_protocol_alpha.Protocol.Apply_results.Single_result
(Tezos_protocol_alpha.Protocol.Apply_results.Endorsement_result
{| delegate := delegate |})
|}) =>
let new_endorsement :=
{| shell := shell; protocol_data := protocol_data |} in
let map :=
match HLevel.find_opt (endorsements_table state) (chain_id, level)
with
| None => Delegate_Map.(Stdlib__map.S.empty)
| Some x => x
end in
match Delegate_Map.(Stdlib__map.S.find_opt) delegate map with
| None =>
apply _return
(HLevel.add (endorsements_table state) (chain_id, level)
(Delegate_Map.(Stdlib__map.S.add) delegate new_endorsement map))
| Some existing_endorsement =>
op_gtgteq (get_block_offset level)
(fun block =>
op_gtgteqquestion
(Alpha_block_services.hash cctxt (Some chain) (Some block) tt)
(fun block_hash =>
op_gtgteqquestion
(Alpha_services.Forge.double_endorsement_evidence cctxt
((* ❌ Variants not supported *)
variant, block) block_hash existing_endorsement
new_endorsement tt)
(fun bytes =>
let bytes := Signature.concat string Signature.zero in
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Double endorsement detected" % string
CamlinternalFormatBasics.End_of_format)
"Double endorsement detected" % string))
(t event
"double_endorsement_detected" % string))
(t conflicting_endorsements_tag
(existing_endorsement, new_endorsement))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Shell_services.Injection.operation cctxt None
(Some chain) string)
(fun op_hash =>
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Double endorsement evidence injected "
% string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Double endorsement evidence injected %a"
% string))
(t event
"double_endorsement_denounced" %
string))
(t signed_operation_tag string))
(a Operation_hash.Logging.tag op_hash)))
(fun function_parameter =>
let 'tt := function_parameter in
apply _return
(HLevel.replace (endorsements_table state)
(chain_id, level)
(Delegate_Map.(Stdlib__map.S.add)
delegate new_endorsement map))))))))
| Some _ => return_unit
end
| _ =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Inconsistent endorsement found " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Inconsistent endorsement found %a" % string))
(t event "inconsistent_endorsement" % string))
(a Operation_hash.Logging.tag hash)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end) endorsements)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit).
Definition process_block {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (state : state)
(header :
Tezos_client_alpha.Protocol_client_context.Alpha_block_services.block_info)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{|
Alpha_block_services.chain_id := chain_id;
Alpha_block_services.hash := hash;
Alpha_block_services.metadata := {|
protocol_data := {| baker := baker; level := {| level := level |} |}
|}
|} := header in
let chain :=
(* ❌ Variants not supported *)
variant in
let map :=
match HLevel.find_opt (blocks_table state) (chain_id, level) with
| None => Delegate_Map.(Stdlib__map.S.empty)
| Some x => x
end in
match Delegate_Map.(Stdlib__map.S.find_opt) baker map with
| None =>
apply _return
(HLevel.add (blocks_table state) (chain_id, level)
(Delegate_Map.(Stdlib__map.S.add) baker hash map))
| Some existing_hash =>
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Double baking detected but block hashes are equivalent. Skipping..."
% string CamlinternalFormatBasics.End_of_format)
"Double baking detected but block hashes are equivalent. Skipping..."
% string)) (t event "double_baking_but_not" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
apply _return
(HLevel.replace (blocks_table state) (chain_id, level)
(Delegate_Map.(Stdlib__map.S.add) baker hash map)))
| Some existing_hash =>
op_gtgteqquestion
(Alpha_block_services.header cctxt (Some chain)
(Some
(* ❌ Variants not supported *)
variant) tt)
(fun function_parameter =>
let '{| shell := shell; protocol_data := protocol_data |} :=
function_parameter in
let bh1 :=
{| Alpha_context.Block_header.shell := shell;
Alpha_context.Block_header.protocol_data := protocol_data |} in
op_gtgteqquestion
(Alpha_block_services.header cctxt (Some chain)
(Some
(* ❌ Variants not supported *)
variant) tt)
(fun function_parameter =>
let '{| shell := shell; protocol_data := protocol_data |} :=
function_parameter in
let bh2 :=
{| Alpha_context.Block_header.shell := shell;
Alpha_context.Block_header.protocol_data := protocol_data |} in
op_gtgteq (get_block_offset level)
(fun block =>
op_gtgteqquestion
(Alpha_block_services.hash cctxt (Some chain) (Some block) tt)
(fun block_hash =>
op_gtgteqquestion
(Alpha_services.Forge.double_baking_evidence cctxt
(chain, block) block_hash bh1 bh2 tt)
(fun bytes =>
let bytes := Signature.concat string Signature.zero in
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Double baking detected" % string
CamlinternalFormatBasics.End_of_format)
"Double baking detected" % string))
(t event "double_baking_detected" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Shell_services.Injection.operation cctxt None
(Some chain) string)
(fun op_hash =>
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Double baking evidence injected "
% string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Double baking evidence injected %a"
% string))
(t event
"double_baking_denounced" % string))
(t signed_operation_tag string))
(a Operation_hash.Logging.tag op_hash)))
(fun function_parameter =>
let 'tt := function_parameter in
apply _return
(HLevel.replace (blocks_table state)
(chain_id, level)
(Delegate_Map.(Stdlib__map.S.add) baker
hash map))))))))))
end.
Definition cleanup_old_operations (state : state) : unit :=
let highest_level_encountered :=
Int32.to_int (Raw_level.to_int32 (highest_level_encountered state)) in
let diff := Z.sub highest_level_encountered (preserved_levels state) in
let threshold :=
if OCaml.Stdlib.lt diff 0 then
Raw_level.root
else
OCaml.Stdlib.reverse_apply (Raw_level.of_int32 (Int32.of_int diff))
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok threshold => threshold
| Stdlib.Error _ => Raw_level.root
end) in
let filter {A : Type} (hmap : HLevel.t A) : unit :=
HLevel.filter_map_inplace
(fun function_parameter =>
let '(_, level) := function_parameter in
fun x =>
if op_lt level threshold then
None
else
Some x) hmap in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := filter (endorsements_table state) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := filter (blocks_table state) in
tt.
Definition endorsements_index : Z := 0.
Definition process_new_block {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (state : state)
(function_parameter : Tezos_baking_alpha.Client_baking_blocks.block_info)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{|
hash := hash;
chain_id := chain_id;
protocol := protocol;
next_protocol := next_protocol;
level := level
|} := function_parameter in
if op_ltgt protocol next_protocol then
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Protocol changing detected. Skipping the block." % string
CamlinternalFormatBasics.End_of_format)
"Protocol changing detected. Skipping the block." % string))
(t event "protocol_change_detected" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
else
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Block level : " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Block level : %a" % string))
(t event "accuser_saw_block" % string)) (a level_tag level))
(t Block_hash.Logging.tag hash)))
(fun function_parameter =>
let 'tt := function_parameter in
let chain :=
(* ❌ Variants not supported *)
variant in
let block :=
(* ❌ Variants not supported *)
variant in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "highest_level_encountered" % string
(Raw_level.max level (highest_level_encountered state)) in
op_gtgteqquestion
(op_gtgteq
(Alpha_block_services.info cctxt (Some chain) (Some block) tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok block_info => process_block cctxt state block_info
| Stdlib.Error errs =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error while fetching operations in block " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Error while fetching operations in block %a@
%a"
% string))
(t event "fetch_operations_error" % string))
(a Block_hash.Logging.tag hash)) (a errs_tag errs)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_gtgteq
(Alpha_block_services.Operations.operations cctxt (Some chain)
(Some block) tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok operations =>
if
OCaml.Stdlib.gt (List.length operations)
endorsements_index then
let endorsements := List.nth operations endorsements_index
in
process_endorsements cctxt state endorsements level
else
return_unit
| Stdlib.Error errs =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error while fetching operations in block "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Error while fetching operations in block %a@
%a"
% string))
(t event "fetch_operations_error" % string))
(a Block_hash.Logging.tag hash)) (a errs_tag errs)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end))
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := cleanup_old_operations state in
return_unit))).
Definition create {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (preserved_levels : Z)
(valid_blocks_stream :
Lwt_stream.t
(Tezos_base__TzPervasives.tzresult
Tezos_baking_alpha.Client_baking_blocks.block_info))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let process_block {O P Q R S T U : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (O * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (P * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (Q * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (R * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (S * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (T * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * U)))))))))))))))))))))))))
* U) (state : state) (bi :
Tezos_baking_alpha.Client_baking_blocks.block_info)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq (process_new_block cctxt state bi)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt =>
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" registered" % string
CamlinternalFormatBasics.End_of_format)))
"Block %a registered" % string))
(t event "accuser_processed_block" % string))
(a Block_hash.Logging.tag (Client_baking_blocks.hash bi))))
_return
| Stdlib.Error errs =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error while processing block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Error while processing block %a@
%a" % string))
(t event "accuser_block_error" % string))
(a Block_hash.Logging.tag (hash bi))) (a errs_tag errs)))
_return
end) in
let state_maker {O : Type} (function_parameter : O)
: Lwt.t (Tezos_base__TzPervasives.tzresult state) :=
let '_ := function_parameter in
op_gtgteq (create_state preserved_levels) _return in
Client_baking_scheduling.main "accuser" % string cctxt valid_blocks_stream
state_maker
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
return_unit)
(fun function_parameter =>
let '_ := function_parameter in
Lwt_utils.never_ending tt)
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
return_unit) process_block.
src/proto_alpha/lib_delegate/client_baking_endorsement.ml 860 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
[@@@ocaml.warning "-30"]
open Protocol
open Alpha_context
open Protocol_client_context
include Internal_event.Legacy_logging.Make_semantic (struct
let name = Protocol.name ^ ".baking.endorsement"
end)
open Logging
let get_signing_slots cctxt ~chain ~block delegate level =
Alpha_services.Delegate.Endorsing_rights.get
cctxt
~levels:[level]
~delegates:[delegate]
(chain, block)
>>=? function [{slots; _}] -> return_some slots | _ -> return_none
let inject_endorsement (cctxt : #Protocol_client_context.full) ?async ~chain
~block hash level delegate_sk delegate_pkh =
Alpha_services.Forge.endorsement cctxt (chain, block) ~branch:hash ~level ()
>>=? fun bytes ->
let wallet = (cctxt :> Client_context.wallet) in
(* Double-check the right to inject an endorsement *)
let open Client_baking_highwatermarks in
wallet#with_lock (fun () ->
Client_baking_files.resolve_location cctxt ~chain `Endorsement
>>=? fun endorsement_location ->
may_inject_endorsement
cctxt
endorsement_location
~delegate:delegate_pkh
level
>>=? function
| true ->
record_endorsement
cctxt
endorsement_location
~delegate:delegate_pkh
level
>>=? fun () -> return_true
| false ->
return_false)
>>=? fun is_allowed_to_endorse ->
if is_allowed_to_endorse then
Chain_services.chain_id cctxt ~chain ()
>>=? fun chain_id ->
Client_keys.append
cctxt
delegate_sk
~watermark:(Endorsement chain_id)
bytes
>>=? fun signed_bytes ->
Shell_services.Injection.operation cctxt ?async ~chain signed_bytes
>>=? fun oph -> return oph
else
lwt_log_error
Tag.DSL.(
fun f ->
f "Level %a : previously endorsed."
-% t event "double_endorsement_near_miss"
-% a level_tag level)
>>= fun () -> fail (Level_previously_endorsed level)
let forge_endorsement (cctxt : #Protocol_client_context.full) ?async ~chain
~block ~src_sk src_pk =
let src_pkh = Signature.Public_key.hash src_pk in
Alpha_block_services.metadata cctxt ~chain ~block ()
>>=? fun {protocol_data = {level = {level; _}; _}; _} ->
Shell_services.Blocks.hash cctxt ~chain ~block ()
>>=? fun hash ->
inject_endorsement cctxt ?async ~chain ~block hash level src_sk src_pkh
>>=? fun oph ->
Client_keys.get_key cctxt src_pkh
>>=? fun (name, _pk, _sk) ->
lwt_log_notice
Tag.DSL.(
fun f ->
f "Injected endorsement for block '%a' (level %a, contract %s) '%a'"
-% t event "injected_endorsement"
-% a Block_hash.Logging.tag hash
-% a level_tag level
-% s Client_keys.Logging.tag name
-% t Signature.Public_key_hash.Logging.tag src_pkh
-% a Operation_hash.Logging.tag oph)
>>= fun () -> return oph
(** Worker *)
type state = {
delegates : public_key_hash list;
delay : int64;
mutable pending : endorsements option;
}
and endorsements = {
time : Time.Protocol.t;
delegates : public_key_hash list;
block : Client_baking_blocks.block_info;
}
let create_state delegates delay = {delegates; delay; pending = None}
let get_delegates cctxt state =
match state.delegates with
| [] ->
Client_keys.get_keys cctxt
>>=? fun keys ->
let delegates = List.map (fun (_, pkh, _, _) -> pkh) keys in
return Signature.Public_key_hash.Set.(delegates |> of_list |> elements)
| _ :: _ as delegates ->
return delegates
let endorse_for_delegate cctxt block delegate_pkh =
let {Client_baking_blocks.hash; level; chain_id; _} = block in
Client_keys.get_key cctxt delegate_pkh
>>=? fun (name, _pk, delegate_sk) ->
lwt_debug
Tag.DSL.(
fun f ->
f "Endorsing %a for %s (level %a)!"
-% t event "endorsing"
-% a Block_hash.Logging.tag hash
-% s Client_keys.Logging.tag name
-% a level_tag level)
>>= fun () ->
let chain = `Hash chain_id in
let block = `Hash (hash, 0) in
inject_endorsement cctxt ~chain ~block hash level delegate_sk delegate_pkh
>>=? fun oph ->
lwt_log_notice
Tag.DSL.(
fun f ->
f "Injected endorsement for block '%a' (level %a, contract %s) '%a'"
-% t event "injected_endorsement"
-% a Block_hash.Logging.tag hash
-% a level_tag level
-% s Client_keys.Logging.tag name
-% t Signature.Public_key_hash.Logging.tag delegate_pkh
-% a Operation_hash.Logging.tag oph)
>>= fun () -> return_unit
let allowed_to_endorse cctxt bi delegate =
Client_keys.Public_key_hash.name cctxt delegate
>>=? fun name ->
lwt_debug
Tag.DSL.(
fun f ->
f "Checking if allowed to endorse block %a for %s"
-% t event "check_endorsement_ok"
-% a Block_hash.Logging.tag bi.Client_baking_blocks.hash
-% s Client_keys.Logging.tag name)
>>= fun () ->
let chain = `Hash bi.chain_id in
let block = `Hash (bi.hash, 0) in
let level = bi.level in
get_signing_slots cctxt ~chain ~block delegate level
>>=? function
| None | Some [] ->
lwt_debug
Tag.DSL.(
fun f ->
f "No slot found for %a/%s"
-% t event "endorsement_no_slots_found"
-% a Block_hash.Logging.tag bi.hash
-% s Client_keys.Logging.tag name)
>>= fun () -> return_false
| Some (_ :: _ as slots) -> (
lwt_debug
Tag.DSL.(
fun f ->
f "Found slots for %a/%s (%a)"
-% t event "endorsement_slots_found"
-% a Block_hash.Logging.tag bi.hash
-% s Client_keys.Logging.tag name
-% a endorsement_slots_tag slots)
>>= fun () ->
cctxt#with_lock (fun () ->
Client_baking_files.resolve_location cctxt ~chain `Endorsement
>>=? fun endorsement_location ->
Client_baking_highwatermarks.may_inject_endorsement
cctxt
endorsement_location
~delegate
level)
>>=? function
| false ->
lwt_debug
Tag.DSL.(
fun f ->
f "Level %a (or higher) previously endorsed: do not endorse."
-% t event "previously_endorsed"
-% a level_tag level)
>>= fun () -> return_false
| true ->
return_true )
let prepare_endorsement ~(max_past : int64) ()
(cctxt : #Protocol_client_context.full) state bi =
let past =
Time.Protocol.diff
(Time.System.to_protocol (Systime_os.now ()))
bi.Client_baking_blocks.timestamp
in
if past > max_past then
lwt_log_info
Tag.DSL.(
fun f ->
f "Ignore block %a: forged too far the past"
-% t event "endorsement_stale_block"
-% a Block_hash.Logging.tag bi.hash)
>>= fun () -> return_unit
else
lwt_log_info
Tag.DSL.(
fun f ->
f "Received new block %a"
-% t event "endorsement_got_block"
-% a Block_hash.Logging.tag bi.hash)
>>= fun () ->
let time =
Time.Protocol.add
(Time.System.to_protocol (Systime_os.now ()))
state.delay
in
get_delegates cctxt state
>>=? fun delegates ->
filter_p (allowed_to_endorse cctxt bi) delegates
>>=? fun delegates ->
state.pending <- Some {time; block = bi; delegates} ;
return_unit
let compute_timeout state =
match state.pending with
| None ->
Lwt_utils.never_ending ()
| Some {time; block; delegates} -> (
match Client_baking_scheduling.sleep_until time with
| None ->
Lwt.return (block, delegates)
| Some timeout ->
let timespan =
let timespan =
Ptime.diff (Time.System.of_protocol_exn time) (Systime_os.now ())
in
if Ptime.Span.compare timespan Ptime.Span.zero > 0 then timespan
else Ptime.Span.zero
in
lwt_log_info
Tag.DSL.(
fun f ->
f "Waiting until %a (%a) to inject endorsements"
-% t event "wait_before_injecting"
-% a timestamp_tag (Time.System.of_protocol_exn time)
-% a timespan_tag timespan)
>>= fun () -> timeout >>= fun () -> Lwt.return (block, delegates) )
let create (cctxt : #Protocol_client_context.full) ?(max_past = 110L) ~delay
delegates block_stream =
let state_maker _ =
let state = create_state delegates (Int64.of_int delay) in
return state
in
let timeout_k cctxt state (block, delegates) =
state.pending <- None ;
iter_s
(fun delegate ->
endorse_for_delegate cctxt block delegate
>>= function
| Ok () ->
return_unit
| Error errs ->
lwt_log_error
Tag.DSL.(
fun f ->
f
"@[<v 2>Error while injecting endorsement for delegate %a \
: @[%a@]@]@."
-% t event "error_while_endorsing"
-% a Signature.Public_key_hash.Logging.tag delegate
-% a errs_tag errs)
>>= fun () ->
(* We continue anyway *)
return_unit)
delegates
in
let event_k cctxt state bi =
state.pending <- None ;
prepare_endorsement ~max_past () cctxt state bi
in
Client_baking_scheduling.main
~name:"endorser"
~cctxt
~stream:block_stream
~state_maker
~pre_loop:(prepare_endorsement ~max_past ())
~compute_timeout
~timeout_k
~event_k
src/proto_alpha/lib_delegate/client_baking_endorsement.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Import Protocol_client_context.
(* ❌ Structure item `include` not handled. *)
include
Import Logging.
Definition get_signing_slots {D E F H J L M a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(D * E) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(D * E) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(D * E) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(D * E) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (L * a * b * c * q * i * o)) * M)))) * M *
(D * E)) (chain : D) (block : E)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash)
(level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult (option (list Z))) :=
op_gtgteqquestion
(Alpha_services.Delegate.Endorsing_rights.get cctxt (Some (cons level []))
None (Some (cons delegate [])) (chain, block))
(fun function_parameter =>
match function_parameter with
| cons {| slots := slots |} [] => return_some slots
| _ => return_none
end).
Definition inject_endorsement {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (async : option bool)
(chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Shell_services.block)
(hash :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)
(delegate_sk : Tezos_client_base.Client_keys.sk_uri)
(delegate_pkh : Tezos_base__TzPervasives.Signature.public_key_hash)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Operation_hash.t) :=
op_gtgteqquestion
(Alpha_services.Forge.endorsement cctxt (chain, block) hash level tt)
(fun bytes =>
let wallet := cctxt in
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_baking_files.resolve_location cctxt chain
(* ❌ Variants not supported *)
variant)
(fun endorsement_location =>
op_gtgteqquestion
(may_inject_endorsement cctxt endorsement_location
delegate_pkh level)
(fun function_parameter =>
match function_parameter with
| true =>
op_gtgteqquestion
(record_endorsement cctxt endorsement_location
delegate_pkh level)
(fun function_parameter =>
let 'tt := function_parameter in
return_true)
| false => return_false
end))))
(fun is_allowed_to_endorse =>
if is_allowed_to_endorse then
op_gtgteqquestion (Chain_services.chain_id cctxt (Some chain) tt)
(fun chain_id =>
op_gtgteqquestion
(Client_keys.append cctxt
(Some
(Tezos_base__TzPervasives.Signature.Endorsement chain_id))
delegate_sk string)
(fun signed_bytes =>
op_gtgteqquestion
(Shell_services.Injection.operation cctxt async
(Some chain) signed_bytes) (fun oph => _return oph)))
else
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Level " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" : previously endorsed." % string
CamlinternalFormatBasics.End_of_format)))
"Level %a : previously endorsed." % string))
(t event "double_endorsement_near_miss" % string))
(a level_tag level)))
(fun function_parameter =>
let 'tt := function_parameter in
fail (Tezos_base__TzPervasives.Level_previously_endorsed level)))).
Definition forge_endorsement {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (async : option bool)
(chain : Tezos_shell_services__Block_services.chain)
(block : Tezos_shell_services__Block_services.block)
(src_sk : Tezos_client_base.Client_keys.sk_uri)
(src_pk : Tezos_base__TzPervasives.Signature.Public_key.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Operation_hash.t) :=
let src_pkh := Signature.Public_key.hash src_pk in
op_gtgteqquestion
(Alpha_block_services.metadata cctxt (Some chain) (Some block) tt)
(fun function_parameter =>
let '{| protocol_data := {| level := {| level := level |} |} |} :=
function_parameter in
op_gtgteqquestion
(Shell_services.Blocks.hash cctxt (Some chain) (Some block) tt)
(fun hash =>
op_gtgteqquestion
(inject_endorsement cctxt async chain block hash level src_sk
src_pkh)
(fun oph =>
op_gtgteqquestion (Client_keys.get_key cctxt src_pkh)
(fun function_parameter =>
let '(name, _pk, _sk) := function_parameter in
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Injected endorsement for block '" %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"' (level " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", contract " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
") '" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))))))))
"Injected endorsement for block '%a' (level %a, contract %s) '%a'"
% string))
(t event "injected_endorsement" % string))
(a Block_hash.Logging.tag hash))
(a level_tag level))
(s Client_keys.Logging.tag name))
(t Signature.Public_key_hash.Logging.tag src_pkh))
(a Operation_hash.Logging.tag oph)))
(fun function_parameter =>
let 'tt := function_parameter in
_return oph))))).
.
Definition create_state
(delegates : list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
(delay : int64) : state :=
{| delegates := delegates; delay := delay; pending := None |}.
Definition get_delegates {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (state : state)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list Tezos_base__TzPervasives.Signature.Public_key_hash.Set.elt)) :=
match delegates state with
| [] =>
op_gtgteqquestion (Client_keys.get_keys cctxt)
(fun keys =>
let delegates :=
List.map
(fun function_parameter =>
let '(_, pkh, _, _) := function_parameter in
pkh) keys in
_return
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply delegates of_list) elements))
| (cons _ _) as delegates => _return delegates
end.
Definition endorse_for_delegate {E F H J L M N a b c i o p q : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) * b) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) * b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o)
->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) *
(M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format
a b) -> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option
Tezos_data_encoding.Data_encoding.json)
->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) * N)))))))))))))))))))))))))
*
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a)
* b) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t *
a) * b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json)
->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) * N)))))))))))))))))))))
(block : Tezos_baking_alpha.Client_baking_blocks.block_info)
(delegate_pkh : Tezos_client_base.Client_keys.Public_key_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{|
Client_baking_blocks.hash := hash;
Client_baking_blocks.chain_id := chain_id;
Client_baking_blocks.level := level
|} := block in
op_gtgteqquestion (Client_keys.get_key cctxt delegate_pkh)
(fun function_parameter =>
let '(name, _pk, delegate_sk) := function_parameter in
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Endorsing " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" for " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (level " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
")!" % string
CamlinternalFormatBasics.End_of_format)))))))
"Endorsing %a for %s (level %a)!" % string))
(t event "endorsing" % string))
(a Block_hash.Logging.tag hash))
(s Client_keys.Logging.tag name)) (a level_tag level)))
(fun function_parameter =>
let 'tt := function_parameter in
let chain :=
(* ❌ Variants not supported *)
variant in
let block :=
(* ❌ Variants not supported *)
variant in
op_gtgteqquestion
(inject_endorsement cctxt None chain block hash level delegate_sk
delegate_pkh)
(fun oph =>
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Injected endorsement for block '" %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"' (level " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", contract " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
") '" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"'" % char
CamlinternalFormatBasics.End_of_format)))))))))
"Injected endorsement for block '%a' (level %a, contract %s) '%a'"
% string))
(t event "injected_endorsement" % string))
(a Block_hash.Logging.tag hash))
(a level_tag level))
(s Client_keys.Logging.tag name))
(t Signature.Public_key_hash.Logging.tag delegate_pkh))
(a Operation_hash.Logging.tag oph)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))).
Definition allowed_to_endorse {E F H J L M N a b c i o p q : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i
o) ->
(variant * variant) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t *
a) q i o) ->
(variant * variant) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t
* a) * b) q i o) ->
(variant * variant) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t
* a) * b) * c) q i o) ->
(variant * variant) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) ->
a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o)
->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) *
(M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format
a b) -> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option
Tezos_data_encoding.Data_encoding.json)
->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) * N)))))))))))))))))))))))))
*
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(variant * variant) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
(variant * variant) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
(variant * variant) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(variant * variant) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json)
->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) * N)))))))))))))))))))))
(bi : Tezos_baking_alpha.Client_baking_blocks.block_info)
(delegate : Tezos_client_base.Client_keys.Public_key_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
op_gtgteqquestion (Client_keys.Public_key_hash.name cctxt delegate)
(fun name =>
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Checking if allowed to endorse block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" for " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"Checking if allowed to endorse block %a for %s" % string))
(t event "check_endorsement_ok" % string))
(a Block_hash.Logging.tag (Client_baking_blocks.hash bi)))
(s Client_keys.Logging.tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
let chain :=
(* ❌ Variants not supported *)
variant in
let block :=
(* ❌ Variants not supported *)
variant in
let level := level bi in
op_gtgteqquestion (get_signing_slots cctxt chain block delegate level)
(fun function_parameter =>
match function_parameter with
| None | Some [] =>
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No slot found for " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"/" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))))
"No slot found for %a/%s" % string))
(t event "endorsement_no_slots_found" % string))
(a Block_hash.Logging.tag (hash bi)))
(s Client_keys.Logging.tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
return_false)
| Some ((cons _ _) as slots) =>
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Found slots for " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"/" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))))))
"Found slots for %a/%s (%a)" % string))
(t event "endorsement_slots_found" % string))
(a Block_hash.Logging.tag (hash bi)))
(s Client_keys.Logging.tag name))
(a endorsement_slots_tag slots)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_baking_files.resolve_location cctxt chain
(* ❌ Variants not supported *)
variant)
(fun endorsement_location =>
Client_baking_highwatermarks.may_inject_endorsement
cctxt endorsement_location delegate level)))
(fun function_parameter =>
match function_parameter with
| false =>
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Level " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (or higher) previously endorsed: do not endorse."
% string
CamlinternalFormatBasics.End_of_format)))
"Level %a (or higher) previously endorsed: do not endorse."
% string))
(t event "previously_endorsed" % string))
(a level_tag level)))
(fun function_parameter =>
let 'tt := function_parameter in
return_false)
| true => return_true
end))
end))).
Definition prepare_endorsement {D F H J L M N a b c i o p q : Type}
(max_past : int64) (function_parameter : unit)
: (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a)
* (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) ->
state ->
Tezos_baking_alpha.Client_baking_blocks.block_info ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let 'tt := function_parameter in
fun cctxt =>
fun state =>
fun bi =>
let past :=
Time.Protocol.diff (Time.System.to_protocol (Systime_os.now tt))
(Client_baking_blocks.timestamp bi) in
if OCaml.Stdlib.gt past max_past then
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Ignore block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
": forged too far the past" % string
CamlinternalFormatBasics.End_of_format)))
"Ignore block %a: forged too far the past" % string))
(t event "endorsement_stale_block" % string))
(a Block_hash.Logging.tag (hash bi))))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
else
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Received new block " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Received new block %a" % string))
(t event "endorsement_got_block" % string))
(a Block_hash.Logging.tag (hash bi))))
(fun function_parameter =>
let 'tt := function_parameter in
let time :=
Time.Protocol.add (Time.System.to_protocol (Systime_os.now tt))
(delay state) in
op_gtgteqquestion (get_delegates cctxt state)
(fun delegates =>
op_gtgteqquestion
(filter_p (allowed_to_endorse cctxt bi) delegates)
(fun delegates =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "pending" % string
(Some
{| time := time; delegates := delegates; block := bi
|}) in
return_unit))).
Definition compute_timeout (state : state)
: Lwt.t
(Tezos_baking_alpha.Client_baking_blocks.block_info *
(list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)) :=
match pending state with
| None => Lwt_utils.never_ending tt
| Some {| time := time; delegates := delegates; block := block |} =>
match Client_baking_scheduling.sleep_until time with
| None => Lwt._return (block, delegates)
| Some timeout =>
let timespan :=
let timespan :=
Ptime.diff (Time.System.of_protocol_exn time) (Systime_os.now tt) in
if OCaml.Stdlib.gt (Ptime.Span.compare timespan Ptime.Span.zero) 0 then
timespan
else
Ptime.Span.zero in
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Waiting until " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
") to inject endorsements" % string
CamlinternalFormatBasics.End_of_format)))))
"Waiting until %a (%a) to inject endorsements" % string))
(t event "wait_before_injecting" % string))
(a timestamp_tag (Time.System.of_protocol_exn time)))
(a timespan_tag timespan)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq timeout
(fun function_parameter =>
let 'tt := function_parameter in
Lwt._return (block, delegates)))
end
end.
Definition create {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (op_staroptstar : option int64)
: Z ->
(list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash) ->
(Lwt_stream.t
(Tezos_base__TzPervasives.tzresult
Tezos_baking_alpha.Client_baking_blocks.block_info)) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let max_past :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Constant of type int64 is converted to int *)
110
end in
fun delay =>
fun delegates =>
fun block_stream =>
let state_maker {O : Type} (function_parameter : O)
: Lwt.t (Tezos_base__TzPervasives.tzresult state) :=
let '_ := function_parameter in
let state := create_state delegates (Int64.of_int delay) in
_return state in
let timeout_k {O P Q R S T U : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
* (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (O * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (P * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) * b) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (Q * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) * b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block)
->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) *
(R * a * b * c * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i
o) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
o)) * (S * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q
i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) *
(T * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain
*
((option Z) *
((((Tezos_client_base.Client_context.lwt_format
a b) -> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option
Tezos_data_encoding.Data_encoding.json)
->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) *
(a)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a))
* U)))))))))))))))))))))))))
*
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i
o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (O * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t *
a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (P * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) * b) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (Q * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) * b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (R * a * b * c * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult o))
* (S * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) *
(T * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format
a b) -> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option
Tezos_data_encoding.Data_encoding.json)
->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) * U)))))))))))))))))))))
(state : state) (function_parameter :
Tezos_baking_alpha.Client_baking_blocks.block_info *
(list Tezos_client_base.Client_keys.Public_key_hash.t))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '(block, delegates) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "pending" % string None in
iter_s
(fun delegate =>
op_gtgteq (endorse_for_delegate cctxt block delegate)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => return_unit
| Stdlib.Error errs =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Error while injecting endorsement for delegate "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" : " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format)))))))))
"@[<v 2>Error while injecting endorsement for delegate %a : @[%a@]@]@."
% string))
(t event "error_while_endorsing" % string))
(a Signature.Public_key_hash.Logging.tag delegate))
(a errs_tag errs)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end)) delegates in
let event_k {O P Q R S T U : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (O * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i
o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (P * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
b) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (Q * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a)
* b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (R * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
* (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q ->
i ->
Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (S * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (T * p * q * i * o))
*
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format
a b) -> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option
Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a))
* U)))))))))))))))))))))))))
* U) (state : state) (bi :
Tezos_baking_alpha.Client_baking_blocks.block_info)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "pending" % string None in
prepare_endorsement max_past tt cctxt state bi in
Client_baking_scheduling.main "endorser" % string cctxt block_stream
state_maker (prepare_endorsement max_past tt) compute_timeout
timeout_k event_k.
src/proto_alpha/lib_delegate/client_baking_files.ml 46 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type _ location = {filename : string; chain : Chain_services.chain}
let resolve_location (cctxt : #Client_context.full) ~chain (kind : 'a) :
'a location tzresult Lwt.t =
let basename =
match kind with
| `Block ->
"block"
| `Endorsement ->
"endorsement"
| `Nonce ->
"nonce"
in
let test_filename chain_id =
Format.kasprintf return "test_%a_%s" Chain_id.pp_short chain_id basename
in
( match chain with
| `Main ->
return basename
| `Test ->
Chain_services.chain_id cctxt ~chain:`Test ()
>>=? fun chain_id -> test_filename chain_id
| `Hash chain_id ->
Chain_services.chain_id cctxt ~chain:`Main ()
>>=? fun main_chain_id ->
if Chain_id.(chain_id = main_chain_id) then return basename
else test_filename chain_id )
>>=? fun filename -> return {filename; chain}
let filename {filename; _} = filename
let chain {chain; _} = chain
src/proto_alpha/lib_delegate/client_baking_files.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record location {_ : Type} := {
filename : string;
chain : Tezos_shell_services.Chain_services.chain }.
Arguments location : clear implicits.
Definition resolve_location {F G I a b i o p q : Type}
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * I)))))))))))))))))))))
* I) (chain : Tezos_shell_services.Chain_services.chain) (kind : variant)
: Lwt.t (Tezos_base__TzPervasives.tzresult (location variant)) :=
let basename :=
match kind with
| Block => "block" % string
| Endorsement => "endorsement" % string
| Nonce => "nonce" % string
end in
let test_filename (chain_id : Tezos_base__TzPervasives.Chain_id.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
Format.kasprintf _return
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "test_" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal "_" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format)))) "test_%a_%s" % string)
Chain_id.pp_short chain_id basename in
op_gtgteqquestion
match chain with
| Main => _return basename
| Test =>
op_gtgteqquestion
(Chain_services.chain_id cctxt
(Some
(* ❌ Variants not supported *)
variant) tt) (fun chain_id => test_filename chain_id)
| Hash chain_id =>
op_gtgteqquestion
(Chain_services.chain_id cctxt
(Some
(* ❌ Variants not supported *)
variant) tt)
(fun main_chain_id =>
if op_eq chain_id main_chain_id then
_return basename
else
test_filename chain_id)
end (fun filename => _return {| filename := filename; chain := chain |}).
Definition filename {A : Type} (function_parameter : location A) : string :=
let '{| filename := filename |} := function_parameter in
filename.
Definition chain {A : Type} (function_parameter : location A)
: Tezos_shell_services.Chain_services.chain :=
let '{| chain := chain |} := function_parameter in
chain.
src/proto_alpha/lib_delegate/client_baking_forge.ml 1402 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Protocol_client_context
include Internal_event.Legacy_logging.Make_semantic (struct
let name = Protocol.name ^ ".baking.forge"
end)
open Logging
(* Just proving a point *)
let[@warning "-32"] time_protocol__is__protocol_time :
Alpha_context.Timestamp.t -> Time.Protocol.t =
fun x -> x
(* The index of the different components of the protocol's validation passes *)
(* TODO: ideally, we would like this to be more abstract and possibly part of
the protocol, while retaining the generality of lists *)
(* Hypothesis : we suppose [List.length Protocol.Main.validation_passes = 4] *)
let endorsements_index = 0
let votes_index = 1
let anonymous_index = 2
let managers_index = 3
let default_max_priority = 64
let default_minimal_fees =
match Tez.of_mutez 100L with None -> assert false | Some t -> t
let default_minimal_nanotez_per_gas_unit = Z.of_int 100
let default_minimal_nanotez_per_byte = Z.of_int 1000
type slot =
Time.Protocol.t * (Client_baking_blocks.block_info * int * public_key_hash)
type state = {
context_path : string;
mutable index : Context.index;
(* Nonces file location *)
nonces_location : [`Nonce] Client_baking_files.location;
(* see [get_delegates] below to find delegates when the list is empty *)
delegates : public_key_hash list;
(* lazy-initialisation with retry-on-error *)
constants : Constants.t;
(* Minimal operation fee required to include an operation in a block *)
minimal_fees : Tez.t;
(* Minimal operation fee per gas required to include an operation in a block *)
minimal_nanotez_per_gas_unit : Z.t;
(* Minimal operation fee per byte required to include an operation in a block *)
minimal_nanotez_per_byte : Z.t;
(* truly mutable *)
mutable best_slot : slot option;
}
let create_state ?(minimal_fees = default_minimal_fees)
?(minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit)
?(minimal_nanotez_per_byte = default_minimal_nanotez_per_byte) context_path
index nonces_location delegates constants =
{
context_path;
index;
nonces_location;
delegates;
constants;
minimal_fees;
minimal_nanotez_per_gas_unit;
minimal_nanotez_per_byte;
best_slot = None;
}
let get_delegates cctxt state =
match state.delegates with
| [] ->
Client_keys.get_keys cctxt
>>=? fun keys -> return (List.map (fun (_, pkh, _, _) -> pkh) keys)
| _ ->
return state.delegates
let generate_seed_nonce () =
match Nonce.of_bytes (Rand.generate Constants.nonce_length) with
| Error _errs ->
assert false
| Ok nonce ->
nonce
let forge_block_header (cctxt : #Protocol_client_context.full) ~chain block
delegate_sk shell priority seed_nonce_hash =
Client_baking_pow.mine cctxt chain block shell (fun proof_of_work_nonce ->
{Block_header.priority; seed_nonce_hash; proof_of_work_nonce})
>>=? fun contents ->
let unsigned_header =
Data_encoding.Binary.to_bytes_exn
Alpha_context.Block_header.unsigned_encoding
(shell, contents)
in
Shell_services.Chain.chain_id cctxt ~chain ()
>>=? fun chain_id ->
Client_keys.append
cctxt
delegate_sk
~watermark:(Block_header chain_id)
unsigned_header
let forge_faked_protocol_data ~priority ~seed_nonce_hash =
Alpha_context.Block_header.
{
contents =
{
priority;
seed_nonce_hash;
proof_of_work_nonce = Client_baking_pow.empty_proof_of_work_nonce;
};
signature = Signature.zero;
}
let assert_valid_operations_hash shell_header operations =
let operations_hash =
Operation_list_list_hash.compute
(List.map
Operation_list_hash.compute
(List.map (List.map Tezos_base.Operation.hash) operations))
in
fail_unless
(Operation_list_list_hash.equal
operations_hash
shell_header.Tezos_base.Block_header.operations_hash)
(failure "Client_baking_forge.inject_block: inconsistent header.")
let compute_endorsing_power cctxt ~chain ~block operations =
Shell_services.Chain.chain_id cctxt ~chain ()
>>=? fun chain_id ->
fold_left_s
(fun sum -> function
| { Alpha_context.protocol_data =
Operation_data {contents = Single (Endorsement _); _};
_ } as op ->
Delegate_services.Endorsing_power.get
cctxt
(chain, block)
op
chain_id
>>=? fun power -> return (sum + power) | _ -> return sum)
0
operations
let inject_block cctxt ?(force = false) ?seed_nonce_hash ~chain ~shell_header
~priority ~delegate_pkh ~delegate_sk ~level operations =
assert_valid_operations_hash shell_header operations
>>=? fun () ->
let block = `Hash (shell_header.Tezos_base.Block_header.predecessor, 0) in
forge_block_header
cctxt
~chain
block
delegate_sk
shell_header
priority
seed_nonce_hash
>>=? fun signed_header ->
(* Record baked blocks to prevent double baking *)
let open Client_baking_highwatermarks in
cctxt#with_lock (fun () ->
Client_baking_files.resolve_location cctxt ~chain `Block
>>=? fun block_location ->
may_inject_block cctxt block_location ~delegate:delegate_pkh level
>>=? function
| true ->
record_block cctxt block_location ~delegate:delegate_pkh level
>>=? fun () -> return_true
| false ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Level %a : previously baked"
-% t event "double_bake_near_miss"
-% a level_tag level)
>>= fun () -> return force)
>>=? function
| false ->
fail (Level_previously_baked level)
| true ->
Shell_services.Injection.block
cctxt
~force
~chain
signed_header
operations
>>=? fun block_hash ->
lwt_log_info
Tag.DSL.(
fun f ->
f "Client_baking_forge.inject_block: inject %a"
-% t event "inject_baked_block"
-% a Block_hash.Logging.tag block_hash
-% t signed_header_tag signed_header
-% t operations_tag operations)
>>= fun () -> return block_hash
type error += Failed_to_preapply of Tezos_base.Operation.t * error list
type error += Forking_test_chain
let () =
register_error_kind
`Permanent
~id:"Client_baking_forge.failed_to_preapply"
~title:"Fail to preapply an operation"
~description:""
~pp:(fun ppf (op, err) ->
let h = Tezos_base.Operation.hash op in
Format.fprintf
ppf
"@[Failed to preapply %a:@ @[<v 4>%a@]@]"
Operation_hash.pp_short
h
pp_print_error
err)
Data_encoding.(
obj2
(req "operation" (dynamic_size Tezos_base.Operation.encoding))
(req "error" RPC_error.encoding))
(function Failed_to_preapply (hash, err) -> Some (hash, err) | _ -> None)
(fun (hash, err) -> Failed_to_preapply (hash, err))
let get_manager_operation_gas_and_fee op =
let {protocol_data = Operation_data {contents; _}; _} = op in
let open Operation in
let l = to_list (Contents_list contents) in
fold_left_s
(fun ((total_fee, total_gas) as acc) -> function
| Contents (Manager_operation {fee; gas_limit; _}) ->
(Lwt.return @@ Environment.wrap_error @@ Tez.(total_fee +? fee))
>>=? fun total_fee -> return (total_fee, Z.add total_gas gas_limit)
| _ -> return acc)
(Tez.zero, Z.zero)
l
(* Sort operation consisdering potential gas and storage usage.
Weight = fee / (max ( (size/size_total), (gas/gas_total))) *)
let sort_manager_operations ~max_size ~hard_gas_limit_per_block ~minimal_fees
~minimal_nanotez_per_gas_unit ~minimal_nanotez_per_byte
(operations : packed_operation list) =
let compute_weight op (fee, gas) =
let size = Data_encoding.Binary.length Operation.encoding op in
let size_f = Q.of_int size in
let gas_f = Q.of_bigint gas in
let fee_f = Q.of_int64 (Tez.to_mutez fee) in
let size_ratio = Q.(size_f / Q.of_int max_size) in
let gas_ratio = Q.(gas_f / Q.of_bigint hard_gas_limit_per_block) in
(size, gas, Q.(fee_f / max size_ratio gas_ratio))
in
filter_map_s
(fun op ->
get_manager_operation_gas_and_fee op
>>=? fun (fee, gas) ->
if Tez.(fee < minimal_fees) then return_none
else
let ((size, gas, _ratio) as weight) = compute_weight op (fee, gas) in
let open Environment in
let fees_in_nanotez =
Z.mul (Z.of_int64 (Tez.to_mutez fee)) (Z.of_int 1000)
in
let enough_fees_for_gas =
let minimal_fees_in_nanotez =
Z.mul minimal_nanotez_per_gas_unit gas
in
Z.compare minimal_fees_in_nanotez fees_in_nanotez <= 0
in
let enough_fees_for_size =
let minimal_fees_in_nanotez =
Z.mul minimal_nanotez_per_byte (Z.of_int size)
in
Z.compare minimal_fees_in_nanotez fees_in_nanotez <= 0
in
if enough_fees_for_size && enough_fees_for_gas then
return_some (op, weight)
else return_none)
operations
>>=? fun operations ->
(* We sort by the biggest weight *)
return
(List.sort
(fun (_, (_, _, w)) (_, (_, _, w')) -> Q.compare w' w)
operations)
let retain_operations_up_to_quota operations quota =
let {Tezos_protocol_environment.max_op; max_size} = quota in
let operations =
match max_op with Some n -> List.sub operations n | None -> operations
in
let exception Full of packed_operation list in
let operations =
try
List.fold_left
(fun (ops, size) op ->
let operation_size =
Data_encoding.Binary.length Alpha_context.Operation.encoding op
in
let new_size = size + operation_size in
if new_size > max_size then raise (Full ops)
else (op :: ops, new_size))
([], 0)
operations
|> fst
with Full ops -> ops
in
List.rev operations
let trim_manager_operations ~max_size ~hard_gas_limit_per_block
manager_operations =
map_s
(fun op ->
get_manager_operation_gas_and_fee op
>>=? fun (_fee, gas) ->
let size = Data_encoding.Binary.length Operation.encoding op in
return (op, (size, gas)))
manager_operations
>>=? fun manager_operations ->
List.fold_left
(fun (total_size, total_gas, (good_ops, bad_ops)) (op, (size, gas)) ->
let new_size = total_size + size in
let new_gas = Z.(total_gas + gas) in
if new_size > max_size || Z.gt new_gas hard_gas_limit_per_block then
(new_size, new_gas, (good_ops, op :: bad_ops))
else (new_size, new_gas, (op :: good_ops, bad_ops)))
(0, Z.zero, ([], []))
manager_operations
|> fun (_, _, (good_ops, bad_ops)) ->
(* We keep the overflowing operations, it may be used for client-side validation *)
return (List.rev good_ops, List.rev bad_ops)
(* We classify operations, sort managers operation by interest and add bad ones at the end *)
(* Hypothesis : we suppose that the received manager operations have a valid gas_limit *)
(** [classify_operations] classify the operation in 4 lists indexed as such :
- 0 -> Endorsements
- 1 -> Votes and proposals
- 2 -> Anonymous operations
- 3 -> High-priority manager operations.
Returns two list :
- A desired set of operations to be included
- Potentially overflowing operations *)
let classify_operations (cctxt : #Protocol_client_context.full) ~chain ~block
~hard_gas_limit_per_block ~minimal_fees ~minimal_nanotez_per_gas_unit
~minimal_nanotez_per_byte (ops : packed_operation list) =
Alpha_block_services.live_blocks cctxt ~chain ~block ()
>>=? fun live_blocks ->
(* Remove operations that are too old *)
let ops =
List.filter
(fun {shell = {branch; _}; _} -> Block_hash.Set.mem branch live_blocks)
ops
in
let validation_passes_len = List.length Main.validation_passes in
let t = Array.make validation_passes_len [] in
List.iter
(fun (op : packed_operation) ->
List.iter
(fun pass -> t.(pass) <- op :: t.(pass))
(Main.acceptable_passes op))
ops ;
let t = Array.map List.rev t in
(* Retrieve the optimist maximum paying manager operations *)
let manager_operations = t.(managers_index) in
let {Environment.Updater.max_size; _} =
List.nth Main.validation_passes managers_index
in
sort_manager_operations
~max_size
~hard_gas_limit_per_block
~minimal_fees
~minimal_nanotez_per_gas_unit
~minimal_nanotez_per_byte
manager_operations
>>=? fun ordered_operations ->
(* Greedy heuristic *)
trim_manager_operations
~max_size
~hard_gas_limit_per_block
(List.map fst ordered_operations)
>>=? fun (desired_manager_operations, overflowing_manager_operations) ->
t.(managers_index) <- desired_manager_operations ;
return (Array.to_list t, overflowing_manager_operations)
let forge (op : Operation.packed) : Operation.raw =
{
shell = op.shell;
proto =
Data_encoding.Binary.to_bytes_exn
Alpha_context.Operation.protocol_data_encoding
op.protocol_data;
}
let ops_of_mempool (ops : Alpha_block_services.Mempool.t) =
(* We only retain the applied, unprocessed and delayed operations *)
List.rev
( Operation_hash.Map.fold (fun _ op acc -> op :: acc) ops.unprocessed
@@ Operation_hash.Map.fold
(fun _ (op, _) acc -> op :: acc)
ops.branch_delayed
@@ List.rev_map (fun (_, op) -> op) ops.applied )
let unopt_operations cctxt chain mempool = function
| None -> (
match mempool with
| None ->
Alpha_block_services.Mempool.pending_operations cctxt ~chain ()
>>=? fun mpool ->
let ops = ops_of_mempool mpool in
return ops
| Some file ->
Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file file
>>=? fun json ->
let mpool =
Data_encoding.Json.destruct
Alpha_block_services.S.Mempool.encoding
json
in
let ops = ops_of_mempool mpool in
return ops )
| Some operations ->
return operations
let all_ops_valid (results : error Preapply_result.t list) =
let open Operation_hash.Map in
List.for_all
(fun (result : error Preapply_result.t) ->
is_empty result.refused
&& is_empty result.branch_refused
&& is_empty result.branch_delayed)
results
let decode_priority cctxt chain block ~priority ~endorsing_power =
match priority with
| `Set priority ->
Alpha_services.Delegate.Minimal_valid_time.get
cctxt
(chain, block)
priority
endorsing_power
>>=? fun minimal_timestamp -> return (priority, minimal_timestamp)
| `Auto (src_pkh, max_priority) -> (
Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, block)
>>=? fun {level; _} ->
Alpha_services.Delegate.Baking_rights.get
cctxt
?max_priority
~levels:[level]
~delegates:[src_pkh]
(chain, block)
>>=? fun possibilities ->
try
let {Alpha_services.Delegate.Baking_rights.priority = prio; _} =
List.find
(fun p -> p.Alpha_services.Delegate.Baking_rights.level = level)
possibilities
in
Alpha_services.Delegate.Minimal_valid_time.get
cctxt
(chain, block)
prio
endorsing_power
>>=? fun minimal_timestamp -> return (prio, minimal_timestamp)
with Not_found ->
failwith "No slot found at level %a" Raw_level.pp level )
let unopt_timestamp ?(force = false) timestamp minimal_timestamp =
let timestamp =
match timestamp with
| None ->
minimal_timestamp
| Some timestamp ->
timestamp
in
if (not force) && timestamp < minimal_timestamp then
failwith
"Proposed timestamp %a is earlier than minimal timestamp %a"
Time.Protocol.pp_hum
timestamp
Time.Protocol.pp_hum
minimal_timestamp
else return timestamp
let merge_preapps (old : error Preapply_result.t)
(neu : error Preapply_result.t) =
let merge _ a b =
(* merge ops *)
match (a, b) with
| (None, None) ->
None
| (Some x, None) ->
Some x
| (_, Some y) ->
Some y
in
let merge = Operation_hash.Map.merge merge in
(* merge op maps *)
(* merge preapplies *)
{
Preapply_result.applied = [];
refused = merge old.refused neu.refused;
branch_refused = merge old.branch_refused neu.branch_refused;
branch_delayed = merge old.branch_delayed neu.branch_delayed;
}
let error_of_op (result : error Preapply_result.t) op =
let op = forge op in
let h = Tezos_base.Operation.hash op in
try
Some
(Failed_to_preapply (op, snd @@ Operation_hash.Map.find h result.refused))
with Not_found -> (
try
Some
(Failed_to_preapply
(op, snd @@ Operation_hash.Map.find h result.branch_refused))
with Not_found -> (
try
Some
(Failed_to_preapply
(op, snd @@ Operation_hash.Map.find h result.branch_delayed))
with Not_found -> None ) )
let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority
?protocol_data
((operations : packed_operation list list), overflowing_operations) =
(* Retrieve the minimal valid time for when the block can be baked with 0 endorsements *)
Delegate_services.Minimal_valid_time.get cctxt (chain, block) priority 0
>>=? fun min_valid_timestamp ->
let open Client_baking_simulator in
lwt_debug
Tag.DSL.(
fun f ->
f "starting client-side validation after %a"
-% t event "baking_local_validation_start"
-% a Block_hash.Logging.tag block_info.Client_baking_blocks.hash)
>>= fun () ->
begin_construction
~timestamp:min_valid_timestamp
?protocol_data
state.index
block_info
>>= (function
| Ok inc ->
return inc
| Error errs ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Error while fetching current context : %a"
-% t event "context_fetch_error"
-% a errs_tag errs)
>>= fun () ->
lwt_log_notice
Tag.DSL.(
fun f ->
f "Retrying to open the context" -% t event "reopen_context")
>>= fun () ->
Client_baking_simulator.load_context
~context_path:state.context_path
>>= fun index ->
begin_construction
~timestamp:min_valid_timestamp
?protocol_data
index
block_info
>>=? fun inc ->
state.index <- index ;
return inc)
>>=? fun initial_inc ->
let endorsements = List.nth operations endorsements_index in
let votes = List.nth operations votes_index in
let anonymous = List.nth operations anonymous_index in
let managers = List.nth operations managers_index in
let validate_operation inc op =
add_operation inc op
>>= function
| Error errs ->
lwt_debug
Tag.DSL.(
fun f ->
f
"@[<v 4>Client-side validation: invalid operation filtered %a@\n\
%a@]"
-% t event "baking_rejected_invalid_operation"
-% a Operation_hash.Logging.tag (Operation.hash_packed op)
-% a errs_tag errs)
>>= fun () -> Lwt.return_none
| Ok (resulting_state, _receipt) ->
Lwt.return_some resulting_state
in
let filter_valid_operations inc ops =
Lwt_list.fold_left_s
(fun (inc, acc) op ->
validate_operation inc op
>>= function
| None ->
Lwt.return (inc, acc)
| Some inc' ->
Lwt.return (inc', op :: acc))
(inc, [])
ops
in
(* First pass : we filter out invalid operations by applying them in the correct order *)
filter_valid_operations initial_inc endorsements
>>= fun (inc, endorsements) ->
filter_valid_operations inc votes
>>= fun (inc, votes) ->
filter_valid_operations inc anonymous
>>= fun (manager_inc, anonymous) ->
(* Retrieve the correct index order *)
let managers = List.sort Protocol.compare_operations managers in
let overflowing_operations =
List.sort Protocol.compare_operations overflowing_operations
in
filter_valid_operations manager_inc (managers @ overflowing_operations)
>>= fun (inc, managers) ->
finalize_construction inc
>>=? fun _ ->
let quota : Environment.Updater.quota list = Main.validation_passes in
let {Constants.hard_gas_limit_per_block; _} = state.constants.parametric in
let votes =
retain_operations_up_to_quota (List.rev votes) (List.nth quota votes_index)
in
let anonymous =
retain_operations_up_to_quota
(List.rev anonymous)
(List.nth quota anonymous_index)
in
trim_manager_operations
~max_size:(List.nth quota managers_index).max_size
~hard_gas_limit_per_block
managers
>>=? fun (accepted_managers, _overflowing_managers) ->
(* Retrieve the correct index order *)
let accepted_managers =
List.sort Protocol.compare_operations accepted_managers
in
(* Second pass : make sure we only keep valid operations *)
filter_valid_operations manager_inc accepted_managers
>>= fun (_, accepted_managers) ->
(* Put the operations back in order *)
let operations =
List.map List.rev [endorsements; votes; anonymous; accepted_managers]
in
(* Construct a context with the valid operations and a correct timestamp *)
compute_endorsing_power cctxt ~chain ~block endorsements
>>=? fun current_endorsing_power ->
Delegate_services.Minimal_valid_time.get
cctxt
(chain, block)
priority
current_endorsing_power
>>=? fun expected_validity ->
(* Finally, we construct a block with the minimal possible timestamp
given the endorsing power *)
begin_construction
~timestamp:expected_validity
?protocol_data
state.index
block_info
>>=? fun inc ->
fold_left_s
(fun inc op -> add_operation inc op >>=? fun (inc, _receipt) -> return inc)
inc
(List.flatten operations)
>>=? fun final_inc ->
finalize_construction final_inc
>>=? fun (validation_result, metadata) ->
return
(final_inc, (validation_result, metadata), operations, expected_validity)
(* Build the block header : mimics node prevalidation *)
let finalize_block_header shell_header ~timestamp validation_result operations
=
let {Tezos_protocol_environment.context; fitness; message; _} =
validation_result
in
let validation_passes = List.length Main.validation_passes in
let operations_hash : Operation_list_list_hash.t =
Operation_list_list_hash.compute
(List.map
(fun sl ->
Operation_list_hash.compute (List.map Operation.hash_packed sl))
operations)
in
let context = Shell_context.unwrap_disk_context context in
Context.get_test_chain context
>>= (function
| Not_running ->
return context
| Running {expiration; _} ->
if Time.Protocol.(expiration <= timestamp) then
Context.set_test_chain context Not_running
>>= fun context -> return context
else return context
| Forking _ ->
fail Forking_test_chain)
>>=? fun context ->
let context = Context.hash ~time:timestamp ?message context in
let header =
Tezos_base.Block_header.
{
shell_header with
level = Int32.succ shell_header.level;
validation_passes;
operations_hash;
fitness;
context;
}
in
return header
let forge_block cctxt ?force ?operations ?(best_effort = operations = None)
?(sort = best_effort) ?(minimal_fees = default_minimal_fees)
?(minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit)
?(minimal_nanotez_per_byte = default_minimal_nanotez_per_byte) ?timestamp
?mempool ?context_path ?seed_nonce_hash ~chain ~priority ~delegate_pkh
~delegate_sk block =
(* making the arguments usable *)
unopt_operations cctxt chain mempool operations
>>=? fun operations_arg ->
compute_endorsing_power cctxt ~chain ~block operations_arg
>>=? fun endorsing_power ->
decode_priority cctxt chain block ~priority ~endorsing_power
>>=? fun (priority, minimal_timestamp) ->
unopt_timestamp ?force timestamp minimal_timestamp
>>=? fun timestamp ->
(* get basic building blocks *)
let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in
Alpha_services.Constants.all cctxt (chain, block)
>>=? fun Constants.
{ parametric = {hard_gas_limit_per_block; endorsers_per_block; _};
_ } ->
classify_operations
cctxt
~chain
~hard_gas_limit_per_block
~block
~minimal_fees
~minimal_nanotez_per_gas_unit
~minimal_nanotez_per_byte
operations_arg
>>=? fun (operations, overflowing_ops) ->
(* Ensure that we retain operations up to the quota *)
let quota : Environment.Updater.quota list = Main.validation_passes in
let endorsements =
List.sub (List.nth operations endorsements_index) endorsers_per_block
in
let votes =
retain_operations_up_to_quota
(List.nth operations votes_index)
(List.nth quota votes_index)
in
let anonymous =
retain_operations_up_to_quota
(List.nth operations anonymous_index)
(List.nth quota anonymous_index)
in
(* Size/Gas check already occured in classify operations *)
let managers = List.nth operations managers_index in
let operations = [endorsements; votes; anonymous; managers] in
( match context_path with
| None ->
Alpha_block_services.Helpers.Preapply.block
cctxt
~chain
~block
~timestamp
~sort
~protocol_data
operations
>>=? fun (shell_header, result) ->
let operations =
List.map (fun l -> List.map snd l.Preapply_result.applied) result
in
(* everything went well (or we don't care about errors): GO! *)
if best_effort || all_ops_valid result then
return (shell_header, operations)
(* some errors (and we care about them) *)
else
let result =
List.fold_left merge_preapps Preapply_result.empty result
in
Lwt.return_error @@ List.filter_map (error_of_op result) operations_arg
| Some context_path ->
assert sort ;
assert best_effort ;
Context.init ~readonly:true context_path
>>= fun index ->
Client_baking_blocks.info cctxt ~chain block
>>=? fun bi ->
Alpha_services.Constants.all cctxt (chain, `Head 0)
>>=? fun constants ->
Client_baking_files.resolve_location cctxt ~chain `Nonce
>>=? fun nonces_location ->
let state =
{
context_path;
index;
nonces_location;
constants;
delegates = [];
best_slot = None;
minimal_fees = default_minimal_fees;
minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit;
minimal_nanotez_per_byte = default_minimal_nanotez_per_byte;
}
in
filter_and_apply_operations
cctxt
state
~chain
~block
~priority
~protocol_data
bi
(operations, overflowing_ops)
>>=? fun ( final_context,
(validation_result, _),
operations,
min_valid_timestamp ) ->
let current_protocol = bi.next_protocol in
let context =
Shell_context.unwrap_disk_context validation_result.context
in
Context.get_protocol context
>>= fun next_protocol ->
if Protocol_hash.equal current_protocol next_protocol then
finalize_block_header
final_context.header
~timestamp:min_valid_timestamp
validation_result
operations
>>= function
| Error (Forking_test_chain :: _) ->
Alpha_block_services.Helpers.Preapply.block
cctxt
~chain
~block
~timestamp:min_valid_timestamp
~sort
~protocol_data
operations
>>=? fun (shell_header, _result) ->
return (shell_header, List.map (List.map forge) operations)
| Error _ as errs ->
Lwt.return errs
| Ok shell_header ->
return (shell_header, List.map (List.map forge) operations)
else
lwt_log_notice
Tag.DSL.(
fun f ->
f "New protocol detected: using shell validation"
-% t event "shell_prevalidation_notice")
>>= fun () ->
Alpha_block_services.Helpers.Preapply.block
cctxt
~chain
~block
~timestamp:min_valid_timestamp
~sort
~protocol_data
operations
>>=? fun (shell_header, _result) ->
return (shell_header, List.map (List.map forge) operations) )
>>=? fun (shell_header, operations) ->
(* Now for some logging *)
let total_op_count = List.length operations_arg in
let valid_op_count = List.length (List.concat operations) in
lwt_log_notice
Tag.DSL.(
fun f ->
f
"found %d valid operations (%d refused) for timestamp %a (fitness %a)"
-% t event "found_valid_operations"
-% s valid_ops valid_op_count
-% s refused_ops (total_op_count - valid_op_count)
-% a timestamp_tag (Time.System.of_protocol_exn timestamp)
-% a fitness_tag shell_header.fitness)
>>= fun () ->
( match Environment.wrap_error (Raw_level.of_int32 shell_header.level) with
| Ok level ->
return level
| Error errs as err ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Error on raw_level conversion : %a"
-% t event "block_injection_failed"
-% a errs_tag errs)
>>= fun () -> Lwt.return err )
>>=? fun level ->
inject_block
cctxt
?force
~chain
~shell_header
~priority
?seed_nonce_hash
~delegate_pkh
~delegate_sk
~level
operations
>>= function
| Ok hash ->
return hash
| Error errs as error ->
lwt_log_error
Tag.DSL.(
fun f ->
f
"@[<v 4>Error while injecting block@ @[Included operations : \
%a@]@ %a@]"
-% t event "block_injection_failed"
-% a raw_operations_tag (List.concat operations)
-% a errs_tag errs)
>>= fun () -> Lwt.return error
let shell_prevalidation (cctxt : #Protocol_client_context.full) ~chain ~block
~timestamp seed_nonce_hash operations
((_, (bi, priority, delegate)) as _slot) =
let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in
Alpha_block_services.Helpers.Preapply.block
cctxt
~chain
~block
~timestamp
~sort:true
~protocol_data
operations
>>= function
| Error errs ->
lwt_log_error
Tag.DSL.(
fun f ->
f
"Shell-side validation: error while prevalidating operations:@\n\
%a"
-% t event "built_invalid_block_error"
-% a errs_tag errs)
>>= fun () -> return_none
| Ok (shell_header, operations) ->
let raw_ops =
List.map (fun l -> List.map snd l.Preapply_result.applied) operations
in
return_some
(bi, priority, shell_header, raw_ops, delegate, seed_nonce_hash)
let filter_outdated_endorsements expected_level ops =
List.filter
(function
| { Alpha_context.protocol_data =
Operation_data {contents = Single (Endorsement {level; _}); _};
_ } ->
Raw_level.equal expected_level level
| _ ->
true)
ops
(** [fetch_operations] retrieve the operations present in the
mempool. If no endorsements are present in the initial set, it
waits until it's able to build a valid block. *)
let fetch_operations (cctxt : #Protocol_client_context.full) ~chain
(_, (head, priority, _delegate)) =
Alpha_block_services.Mempool.monitor_operations
cctxt
~chain
~applied:true
~branch_delayed:true
~refused:false
~branch_refused:false
()
>>=? fun (operation_stream, _stop) ->
(* Hypothesis : the first call to the stream returns instantly, even if the mempool is empty. *)
Lwt_stream.get operation_stream
>>= function
| None ->
(* New head received : aborting block construction *)
return_none
| Some current_mempool ->
let block = `Hash (head.Client_baking_blocks.hash, 0) in
let operations =
ref (filter_outdated_endorsements head.level current_mempool)
in
(* Actively request our peers' for missing operations *)
Shell_services.Mempool.request_operations cctxt ~chain ()
>>=? fun () ->
let compute_minimal_valid_time () =
compute_endorsing_power cctxt ~chain ~block !operations
>>=? fun current_endorsing_power ->
Delegate_services.Minimal_valid_time.get
cctxt
(chain, block)
priority
current_endorsing_power
in
let compute_timeout () =
compute_minimal_valid_time ()
>>=? fun expected_validity ->
match Client_baking_scheduling.sleep_until expected_validity with
| None ->
return_unit
| Some timeout ->
timeout >>= fun () -> return_unit
in
let last_get_event = ref None in
let get_event () =
match !last_get_event with
| None ->
let t = Lwt_stream.get operation_stream in
last_get_event := Some t ;
t
| Some t ->
t
in
let rec loop () =
Lwt.choose
[ (compute_timeout () >|= fun _ -> `Timeout);
(get_event () >|= fun e -> `Event e) ]
>>= function
| `Event (Some op_list) ->
last_get_event := None ;
let op_list = filter_outdated_endorsements head.level op_list in
operations := op_list @ !operations ;
loop ()
| `Timeout ->
(* Retrieve the remaining operations present in the stream
before block construction *)
let remaining_operations =
filter_outdated_endorsements
head.level
(List.flatten (Lwt_stream.get_available operation_stream))
in
operations := remaining_operations @ !operations ;
compute_minimal_valid_time ()
>>=? fun expected_validity ->
return_some (!operations, expected_validity)
| `Event None ->
(* Got new head while waiting:
- not enough endorsements received ;
- late at baking *)
return_none
in
loop ()
(** Given a delegate baking slot [build_block] constructs a full block
with consistent operations that went through the client-side
validation *)
let build_block cctxt state seed_nonce_hash
((slot_timestamp, (bi, priority, delegate)) as slot) =
let chain = `Hash bi.Client_baking_blocks.chain_id in
let block = `Hash (bi.hash, 0) in
Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, block)
>>=? fun next_level ->
let seed_nonce_hash =
if next_level.Level.expected_commitment then Some seed_nonce_hash else None
in
Client_keys.Public_key_hash.name cctxt delegate
>>=? fun name ->
lwt_debug
Tag.DSL.(
fun f ->
f "Try baking after %a (slot %d) for %s (%a)"
-% t event "try_baking"
-% a Block_hash.Logging.tag bi.hash
-% s bake_priority_tag priority
-% s Client_keys.Logging.tag name
-% a timestamp_tag (Time.System.of_protocol_exn slot_timestamp))
>>= fun () ->
fetch_operations cctxt ~chain slot
>>=? function
| None ->
lwt_log_notice
Tag.DSL.(
fun f ->
f
"Received a new head while waiting for operations. Aborting \
this block."
-% t event "new_head_received")
>>= fun () -> return_none
| Some (operations, timestamp) -> (
let hard_gas_limit_per_block =
state.constants.parametric.hard_gas_limit_per_block
in
classify_operations
cctxt
~chain
~hard_gas_limit_per_block
~minimal_fees:state.minimal_fees
~minimal_nanotez_per_gas_unit:state.minimal_nanotez_per_gas_unit
~minimal_nanotez_per_byte:state.minimal_nanotez_per_byte
~block
operations
>>=? fun (operations, overflowing_ops) ->
let next_version =
match
Tezos_base.Block_header.get_forced_protocol_upgrade
~level:(Raw_level.to_int32 next_level.Level.level)
with
| None ->
bi.next_protocol
| Some hash ->
hash
in
if Protocol_hash.(Protocol.hash <> next_version) then
(* Let the shell validate this *)
shell_prevalidation
cctxt
~chain
~block
~timestamp
seed_nonce_hash
operations
slot
else
let protocol_data =
forge_faked_protocol_data ~priority ~seed_nonce_hash
in
filter_and_apply_operations
cctxt
state
~chain
~block
~priority
~protocol_data
bi
(operations, overflowing_ops)
>>= function
| Error errs ->
lwt_log_error
Tag.DSL.(
fun f ->
f
"Client-side validation: error while filtering invalid \
operations :@\n\
@[<v 4>%a@]"
-% t event "client_side_validation_error"
-% a errs_tag errs)
>>= fun () ->
lwt_log_notice
Tag.DSL.(
fun f ->
f "Building a block using shell validation"
-% t event "shell_prevalidation_notice")
>>= fun () ->
shell_prevalidation
cctxt
~chain
~block
~timestamp
seed_nonce_hash
operations
slot
| Ok
(final_context, (validation_result, _), operations, valid_timestamp)
->
( if
Time.System.(Systime_os.now () < of_protocol_exn valid_timestamp)
then
lwt_log_notice
Tag.DSL.(
fun f ->
f "[%a] not ready to inject yet, waiting until %a"
-% a timestamp_tag (Systime_os.now ())
-% a
timestamp_tag
(Time.System.of_protocol_exn valid_timestamp)
-% t event "waiting_before_injection")
>>= fun () ->
match Client_baking_scheduling.sleep_until valid_timestamp with
| None ->
Lwt.return_unit
| Some timeout ->
timeout
else Lwt.return_unit )
>>= fun () ->
lwt_debug
Tag.DSL.(
fun f ->
f
"Try forging locally the block header for %a (slot %d) \
for %s (%a)"
-% t event "try_forging"
-% a Block_hash.Logging.tag bi.hash
-% s bake_priority_tag priority
-% s Client_keys.Logging.tag name
-% a timestamp_tag (Time.System.of_protocol_exn timestamp))
>>= fun () ->
let current_protocol = bi.next_protocol in
let context =
Shell_context.unwrap_disk_context validation_result.context
in
Context.get_protocol context
>>= fun next_protocol ->
if Protocol_hash.equal current_protocol next_protocol then
finalize_block_header
final_context.header
~timestamp:valid_timestamp
validation_result
operations
>>= function
| Error (Forking_test_chain :: _) ->
shell_prevalidation
cctxt
~chain
~block
~timestamp
seed_nonce_hash
operations
slot
| Error _ as errs ->
Lwt.return errs
| Ok shell_header ->
let raw_ops = List.map (List.map forge) operations in
return_some
( bi,
priority,
shell_header,
raw_ops,
delegate,
seed_nonce_hash )
else
lwt_log_notice
Tag.DSL.(
fun f ->
f "New protocol detected: using shell validation"
-% t event "shell_prevalidation_notice")
>>= fun () ->
shell_prevalidation
cctxt
~chain
~block
~timestamp
seed_nonce_hash
operations
slot )
(** [bake cctxt state] create a single block when woken up to do
so. All the necessary information is available in the
[state.best_slot]. *)
let bake (cctxt : #Protocol_client_context.full) ~chain state =
( match state.best_slot with
| None ->
assert false (* unreachable *)
| Some slot ->
return slot )
>>=? fun slot ->
let seed_nonce = generate_seed_nonce () in
let seed_nonce_hash = Nonce.hash seed_nonce in
build_block cctxt state seed_nonce_hash slot
>>=? function
| Some (head, priority, shell_header, operations, delegate, seed_nonce_hash)
-> (
let level = Raw_level.succ head.level in
Client_keys.Public_key_hash.name cctxt delegate
>>=? fun name ->
lwt_log_info
Tag.DSL.(
fun f ->
f "Injecting block (priority %d, fitness %a) for %s after %a..."
-% t event "start_injecting_block"
-% s bake_priority_tag priority
-% a fitness_tag shell_header.fitness
-% s Client_keys.Logging.tag name
-% a Block_hash.Logging.predecessor_tag shell_header.predecessor
-% t Signature.Public_key_hash.Logging.tag delegate)
>>= fun () ->
Client_keys.get_key cctxt delegate
>>=? fun (_, _, delegate_sk) ->
inject_block
cctxt
~chain
~force:false
~shell_header
~priority
?seed_nonce_hash
~delegate_pkh:delegate
~delegate_sk
~level
operations
>>= function
| Error errs ->
lwt_log_error
Tag.DSL.(
fun f ->
f
"@[<v 4>Error while injecting block@ @[Included operations \
: %a@]@ %a@]"
-% t event "block_injection_failed"
-% a raw_operations_tag (List.concat operations)
-% a errs_tag errs)
>>= fun () -> return_unit
| Ok block_hash ->
lwt_log_notice
Tag.DSL.(
fun f ->
f
"Injected block %a for %s after %a (level %a, priority %d, \
fitness %a, operations %a)."
-% t event "injected_block"
-% a Block_hash.Logging.tag block_hash
-% s Client_keys.Logging.tag name
-% a Block_hash.Logging.tag shell_header.predecessor
-% a level_tag level
-% s bake_priority_tag priority
-% a fitness_tag shell_header.fitness
-% a operations_tag operations)
>>= fun () ->
( if seed_nonce_hash <> None then
cctxt#with_lock (fun () ->
let open Client_baking_nonces in
load cctxt state.nonces_location
>>=? fun nonces ->
let nonces = add nonces block_hash seed_nonce in
save cctxt state.nonces_location nonces)
|> trace_exn (Failure "Error while recording nonce")
else return_unit )
>>=? fun () -> return_unit )
| None ->
return_unit
(** [get_baking_slots] calls the node via RPC to retrieve the potential
slots for the given delegates within a given range of priority *)
let get_baking_slots cctxt ?(max_priority = default_max_priority) new_head
delegates =
let chain = `Hash new_head.Client_baking_blocks.chain_id in
let block = `Hash (new_head.hash, 0) in
let level = Raw_level.succ new_head.level in
Alpha_services.Delegate.Baking_rights.get
cctxt
~max_priority
~levels:[level]
~delegates
(chain, block)
>>= function
| Error errs ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Error while fetching baking possibilities:\n%a"
-% t event "baking_slot_fetch_errors"
-% a errs_tag errs)
>>= fun () -> Lwt.return_nil
| Ok [] ->
Lwt.return_nil
| Ok slots ->
let slots =
List.filter_map
(function
| {Alpha_services.Delegate.Baking_rights.timestamp = None; _} ->
None
| {timestamp = Some timestamp; priority; delegate; _} ->
Some (timestamp, (new_head, priority, delegate)))
slots
in
Lwt.return slots
(** [compute_best_slot_on_current_level] retrieves, among the given
delegates, the highest priority slot for the current level. Then,
it registers this slot in the state so the timeout knows when to
wake up. *)
let compute_best_slot_on_current_level ?max_priority
(cctxt : #Protocol_client_context.full) state new_head =
get_delegates cctxt state
>>=? fun delegates ->
let level = Raw_level.succ new_head.Client_baking_blocks.level in
get_baking_slots cctxt ?max_priority new_head delegates
>>= function
| [] ->
lwt_log_notice
Tag.DSL.(
fun f ->
let max_priority =
Option.unopt ~default:default_max_priority max_priority
in
f "No slot found at level %a (max_priority = %d)"
-% t event "no_slot_found" -% a level_tag level
-% s bake_priority_tag max_priority)
>>= fun () -> return_none
(* No slot found *)
| h :: t ->
(* One or more slot found, fetching the best (lowest) priority.
We do not suppose that the received slots are sorted. *)
let ((timestamp, (_, priority, delegate)) as best_slot) =
List.fold_left
(fun ((_, (_, priority, _)) as acc) ((_, (_, priority', _)) as slot) ->
if priority < priority' then acc else slot)
h
t
in
Client_keys.Public_key_hash.name cctxt delegate
>>=? fun name ->
lwt_log_notice
Tag.DSL.(
fun f ->
f
"New baking slot found (level %a, priority %d) at %a for %s \
after %a."
-% t event "have_baking_slot" -% a level_tag level
-% s bake_priority_tag priority
-% a timestamp_tag (Time.System.of_protocol_exn timestamp)
-% s Client_keys.Logging.tag name
-% a Block_hash.Logging.tag new_head.hash
-% t Signature.Public_key_hash.Logging.tag delegate)
>>= fun () ->
(* Found at least a slot *)
return_some best_slot
(** [reveal_potential_nonces] reveal registered nonces *)
let reveal_potential_nonces (cctxt : #Client_context.full) constants ~chain
~block =
cctxt#with_lock (fun () ->
Client_baking_files.resolve_location cctxt ~chain `Nonce
>>=? fun nonces_location ->
Client_baking_nonces.load cctxt nonces_location
>>= function
| Error err ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Cannot read nonces: %a" -% t event "read_nonce_fail"
-% a errs_tag err)
>>= fun () -> return_unit
| Ok nonces -> (
Client_baking_nonces.get_unrevealed_nonces
cctxt
nonces_location
nonces
>>= function
| Error err ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Cannot retrieve unrevealed nonces: %a"
-% t event "nonce_retrieval_fail"
-% a errs_tag err)
>>= fun () -> return_unit
| Ok [] ->
return_unit
| Ok nonces_to_reveal -> (
Client_baking_revelation.inject_seed_nonce_revelation
cctxt
~chain
~block
nonces_to_reveal
>>= function
| Error err ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Cannot inject nonces: %a"
-% t event "nonce_injection_fail"
-% a errs_tag err)
>>= fun () -> return_unit
| Ok () ->
(* If some nonces are to be revealed it means:
- We entered a new cycle and we can clear old nonces ;
- A revelation was not included yet in the cycle beggining.
So, it is safe to only filter outdated_nonces there *)
Client_baking_nonces.filter_outdated_nonces
cctxt
~constants
nonces_location
nonces
>>=? fun live_nonces ->
Client_baking_nonces.save cctxt nonces_location live_nonces
>>=? fun () -> return_unit ) ))
(** [create] starts the main loop of the baker. The loop monitors new blocks and
starts individual baking operations when baking-slots are available to any of
the [delegates] *)
let create (cctxt : #Protocol_client_context.full) ?minimal_fees
?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?max_priority
~chain ~context_path delegates block_stream =
let state_maker bi =
Alpha_services.Constants.all cctxt (chain, `Head 0)
>>=? fun constants ->
Client_baking_simulator.load_context ~context_path
>>= fun index ->
Client_baking_simulator.check_context_consistency
index
bi.Client_baking_blocks.context
>>=? fun () ->
Client_baking_files.resolve_location cctxt ~chain `Nonce
>>=? fun nonces_location ->
let state =
create_state
?minimal_fees
?minimal_nanotez_per_gas_unit
?minimal_nanotez_per_byte
context_path
index
nonces_location
delegates
constants
in
return state
in
let event_k cctxt state new_head =
reveal_potential_nonces
cctxt
state.constants
~chain
~block:(`Hash (new_head.Client_baking_blocks.hash, 0))
>>= fun _ignore_nonce_err ->
compute_best_slot_on_current_level ?max_priority cctxt state new_head
>>=? fun slot ->
state.best_slot <- slot ;
return_unit
in
let compute_timeout state =
match state.best_slot with
| None ->
(* No slot, just wait for new blocks which will give more info *)
Lwt_utils.never_ending ()
| Some (timestamp, _) -> (
match Client_baking_scheduling.sleep_until timestamp with
| None ->
Lwt.return_unit
| Some timeout ->
timeout )
in
let timeout_k cctxt state () =
bake cctxt ~chain state
>>=? fun () ->
(* Stopping the timeout and waiting for the next block *)
state.best_slot <- None ;
return_unit
in
Client_baking_scheduling.main
~name:"baker"
~cctxt
~stream:block_stream
~state_maker
~pre_loop:event_k
~compute_timeout
~timeout_k
~event_k
src/proto_alpha/lib_delegate/client_baking_forge.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Import Protocol_client_context.
(* ❌ Structure item `include` not handled. *)
include
Import Logging.
Definition time_protocol__is__protocol_time
(x : Tezos_protocol_alpha.Protocol.Alpha_context.Timestamp.t)
: Tezos_base__TzPervasives.Time.Protocol.t := x.
Definition endorsements_index : Z := 0.
Definition votes_index : Z := 1.
Definition anonymous_index : Z := 2.
Definition managers_index : Z := 3.
Definition default_max_priority : Z := 64.
Definition default_minimal_fees
: Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
match
Tez.of_mutez
(* ❌ Constant of type int64 is converted to int *)
100 with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some t => t
end.
Definition default_minimal_nanotez_per_gas_unit : Z.t := Z.of_int 100.
Definition default_minimal_nanotez_per_byte : Z.t := Z.of_int 1000.
Definition slot :=
Tezos_base__TzPervasives.Time.Protocol.t *
(Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash).
Record state := {
context_path : string;
index : Tezos_storage.Context.index;
nonces_location : Tezos_baking_alpha.Client_baking_files.location variant;
delegates : list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash;
constants : Tezos_protocol_alpha.Protocol.Alpha_context.Constants.t;
minimal_fees : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
minimal_nanotez_per_gas_unit : Z.t;
minimal_nanotez_per_byte : Z.t;
best_slot : option slot }.
Definition create_state
(op_staroptstar : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
: (option Z.t) ->
(option Z.t) ->
string ->
Tezos_storage.Context.index ->
(Tezos_baking_alpha.Client_baking_files.location variant) ->
(list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
->
Tezos_protocol_alpha.Protocol.Alpha_context.Constants.t -> state :=
let minimal_fees :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_minimal_fees
end in
fun op_staroptstar =>
let minimal_nanotez_per_gas_unit :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_minimal_nanotez_per_gas_unit
end in
fun op_staroptstar =>
let minimal_nanotez_per_byte :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_minimal_nanotez_per_byte
end in
fun context_path =>
fun index =>
fun nonces_location =>
fun delegates =>
fun constants =>
{| context_path := context_path; index := index;
nonces_location := nonces_location; delegates := delegates;
constants := constants; minimal_fees := minimal_fees;
minimal_nanotez_per_gas_unit := minimal_nanotez_per_gas_unit;
minimal_nanotez_per_byte := minimal_nanotez_per_byte;
best_slot := None |}.
Definition get_delegates {B a : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (state : state)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list Tezos_client_base.Client_keys.Public_key_hash.t)) :=
match delegates state with
| [] =>
op_gtgteqquestion (Client_keys.get_keys cctxt)
(fun keys =>
_return
(List.map
(fun function_parameter =>
let '(_, pkh, _, _) := function_parameter in
pkh) keys))
| _ => _return (delegates state)
end.
Definition generate_seed_nonce (function_parameter : unit)
: Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
let 'tt := function_parameter in
match Nonce.of_bytes (Rand.generate Constants.nonce_length) with
| Stdlib.Error _errs =>
(* ❌ Assert instruction is not handled. *)
assert false
| Stdlib.Ok nonce => nonce
end.
Definition forge_block_header {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain)
(block : Tezos_shell_services.Block_services.block)
(delegate_sk : Tezos_client_base.Client_keys.sk_uri)
(shell : Tezos_base__TzPervasives.Block_header.shell_header) (priority : Z)
(seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
op_gtgteqquestion
(Client_baking_pow.mine cctxt chain block shell
(fun proof_of_work_nonce =>
{| Block_header.priority := priority;
Block_header.seed_nonce_hash := seed_nonce_hash;
Block_header.proof_of_work_nonce := proof_of_work_nonce |}))
(fun contents =>
let unsigned_header :=
Data_encoding.Binary.to_bytes_exn
Alpha_context.Block_header.unsigned_encoding (shell, contents) in
op_gtgteqquestion (Shell_services.Chain.chain_id cctxt (Some chain) tt)
(fun chain_id =>
Client_keys.append cctxt
(Some (Tezos_base__TzPervasives.Signature.Block_header chain_id))
delegate_sk unsigned_header)).
Definition forge_faked_protocol_data
(priority : Z)
(seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
: Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.protocol_data :=
{|
contents :=
{| priority := priority; seed_nonce_hash := seed_nonce_hash;
proof_of_work_nonce := Client_baking_pow.empty_proof_of_work_nonce |};
signature := Signature.zero |}.
Definition assert_valid_operations_hash
(shell_header : Tezos_base.Block_header.shell_header)
(operations : list (list Tezos_base.Operation.t))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let operations_hash :=
Operation_list_list_hash.compute
(List.map Operation_list_hash.compute
(List.map (List.map Tezos_base.Operation.hash) operations)) in
fail_unless
(Operation_list_list_hash.equal operations_hash
(Tezos_base.Block_header.operations_hash shell_header))
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Client_baking_forge.inject_block: inconsistent header." % string
CamlinternalFormatBasics.End_of_format)
"Client_baking_forge.inject_block: inconsistent header." % string)).
Definition compute_endorsing_power {E F G I K M N a b c i o p q : Type}
(cctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.Chain.chain * F) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
(Tezos_shell_services.Shell_services.Chain.chain * F) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
(Tezos_shell_services.Shell_services.Chain.chain * F) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(Tezos_shell_services.Shell_services.Chain.chain * F) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (M * a * b * c * q * i * o)) * N))))) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.Chain.chain * F) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
(Tezos_shell_services.Shell_services.Chain.chain * F) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
(Tezos_shell_services.Shell_services.Chain.chain * F) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(Tezos_shell_services.Shell_services.Chain.chain * F) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (M * a * b * c * q * i * o)) * N)))))
(chain : Tezos_shell_services.Shell_services.Chain.chain) (block : F)
(operations :
list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
: Lwt.t (Tezos_base__TzPervasives.tzresult Z) :=
op_gtgteqquestion (Shell_services.Chain.chain_id cctxt (Some chain) tt)
(fun chain_id =>
fold_left_s
(fun sum =>
fun function_parameter =>
match function_parameter with
|
{|
Alpha_context.protocol_data :=
Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data {|
contents :=
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Endorsement
_)
|}
|} as op =>
op_gtgteqquestion
(Delegate_services.Endorsing_power.get cctxt (chain, block) op
chain_id) (fun power => _return (Z.add sum power))
| _ => _return sum
end) 0 operations).
Definition inject_block {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (op_staroptstar : option bool)
: (option Tezos_raw_protocol_alpha.Nonce_hash.t) ->
Tezos_shell_services.Shell_services.chain ->
Tezos_base.Block_header.shell_header ->
Z ->
Tezos_base__TzPervasives.Signature.public_key_hash ->
Tezos_client_base.Client_keys.sk_uri ->
Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
(list (list Tezos_base.Operation.t)) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Block_hash.t) :=
let force :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun seed_nonce_hash =>
fun chain =>
fun shell_header =>
fun priority =>
fun delegate_pkh =>
fun delegate_sk =>
fun level =>
fun operations =>
op_gtgteqquestion
(assert_valid_operations_hash shell_header operations)
(fun function_parameter =>
let 'tt := function_parameter in
let block :=
(* ❌ Variants not supported *)
variant in
op_gtgteqquestion
(forge_block_header cctxt chain block delegate_sk
shell_header priority seed_nonce_hash)
(fun signed_header =>
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_baking_files.resolve_location cctxt
chain
(* ❌ Variants not supported *)
variant)
(fun block_location =>
op_gtgteqquestion
(may_inject_block cctxt block_location
delegate_pkh level)
(fun function_parameter =>
match function_parameter with
| true =>
op_gtgteqquestion
(record_block cctxt block_location
delegate_pkh level)
(fun function_parameter =>
let 'tt := function_parameter in
return_true)
| false =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Level " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" : previously baked"
% string
CamlinternalFormatBasics.End_of_format)))
"Level %a : previously baked"
% string))
(t event
"double_bake_near_miss" %
string))
(a level_tag level)))
(fun function_parameter =>
let 'tt := function_parameter in
_return force)
end))))
(fun function_parameter =>
match function_parameter with
| false =>
fail
(Tezos_base__TzPervasives.Level_previously_baked
level)
| true =>
op_gtgteqquestion
(Shell_services.Injection.block cctxt None
(Some force) (Some chain) signed_header
operations)
(fun block_hash =>
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Client_baking_forge.inject_block: inject "
% string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Client_baking_forge.inject_block: inject %a"
% string))
(t event
"inject_baked_block" %
string))
(a Block_hash.Logging.tag
block_hash))
(t signed_header_tag signed_header))
(t operations_tag operations)))
(fun function_parameter =>
let 'tt := function_parameter in
_return block_hash))
end))).
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition get_manager_operation_gas_and_fee
(op : Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez * Z.t)) :=
let '{|
protocol_data :=
Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data {|
contents := contents |}
|} := op in
let l :=
to_list (Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list contents)
in
fold_left_s
(fun function_parameter =>
let '(total_fee, total_gas) as acc := function_parameter in
fun function_parameter =>
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Alpha_context.Contents
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation {|
fee := fee; gas_limit := gas_limit |}) =>
op_gtgteqquestion
(apply Lwt._return
(apply Environment.wrap_error (op_plusquestion total_fee fee)))
(fun total_fee => _return (total_fee, (Z.add total_gas gas_limit)))
| _ => _return acc
end) (Tez.zero, Z.zero) l.
Definition sort_manager_operations
(max_size : Z) (hard_gas_limit_per_block : Z.t)
(minimal_fees : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(minimal_nanotez_per_gas_unit : Tezos_protocol_alpha.Protocol.Environment.Z.t)
(minimal_nanotez_per_byte : Tezos_protocol_alpha.Protocol.Environment.Z.t)
(operations :
list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation *
(Z * Tezos_protocol_alpha.Protocol.Environment.Z.t * Q.t)))) :=
let compute_weight
(op : Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
(function_parameter :
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez * Z.t)
: Z * Z.t * Q.t :=
let '(fee, gas) := function_parameter in
let size := Data_encoding.Binary.length Operation.encoding op in
let size_f := Q.of_int size in
let gas_f := Q.of_bigint gas in
let fee_f := Q.of_int64 (Tez.to_mutez fee) in
let size_ratio := op_div size_f (Q.of_int max_size) in
let gas_ratio := op_div gas_f (Q.of_bigint hard_gas_limit_per_block) in
(size, gas, (op_div fee_f (max size_ratio gas_ratio))) in
op_gtgteqquestion
(filter_map_s
(fun op =>
op_gtgteqquestion (get_manager_operation_gas_and_fee op)
(fun function_parameter =>
let '(fee, gas) := function_parameter in
if op_lt fee minimal_fees then
return_none
else
let '(size, gas, _ratio) as weight := compute_weight op (fee, gas)
in
let fees_in_nanotez :=
Z.mul (Z.of_int64 (Tez.to_mutez fee)) (Z.of_int 1000) in
let enough_fees_for_gas :=
let minimal_fees_in_nanotez :=
Z.mul minimal_nanotez_per_gas_unit gas in
OCaml.Stdlib.le
(Z.compare minimal_fees_in_nanotez fees_in_nanotez) 0 in
let enough_fees_for_size :=
let minimal_fees_in_nanotez :=
Z.mul minimal_nanotez_per_byte (Z.of_int size) in
OCaml.Stdlib.le
(Z.compare minimal_fees_in_nanotez fees_in_nanotez) 0 in
if andb enough_fees_for_size enough_fees_for_gas then
return_some (op, weight)
else
return_none)) operations)
(fun operations =>
_return
(List.sort
(fun function_parameter =>
let '(_, (_, _, w)) := function_parameter in
fun function_parameter =>
let '(_, (_, _, w')) := function_parameter in
Q.compare w' w) operations)).
Definition retain_operations_up_to_quota
(operations :
list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
(quota : Tezos_protocol_environment.quota)
: list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation :=
let '{|
Tezos_protocol_environment.max_size := max_size;
Tezos_protocol_environment.max_op := max_op
|} := quota in
let operations :=
match max_op with
| Some n => List.sub operations n
| None => operations
end in
(* ❌ Let of exception is not handled *)
let_exception.
Definition trim_manager_operations
(max_size : Z) (hard_gas_limit_per_block : Z.t)
(manager_operations :
list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
((list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) *
(list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation))) :=
op_gtgteqquestion
(map_s
(fun op =>
op_gtgteqquestion (get_manager_operation_gas_and_fee op)
(fun function_parameter =>
let '(_fee, gas) := function_parameter in
let size := Data_encoding.Binary.length Operation.encoding op in
_return (op, (size, gas)))) manager_operations)
(fun manager_operations =>
OCaml.Stdlib.reverse_apply
(List.fold_left
(fun function_parameter =>
let '(total_size, total_gas, (good_ops, bad_ops)) :=
function_parameter in
fun function_parameter =>
let '(op, (size, gas)) := function_parameter in
let new_size := Z.add total_size size in
let new_gas := op_plus total_gas gas in
if
orb (OCaml.Stdlib.gt new_size max_size)
(Z.gt new_gas hard_gas_limit_per_block) then
(new_size, new_gas, (good_ops, (cons op bad_ops)))
else
(new_size, new_gas, ((cons op good_ops), bad_ops)))
(0, Z.zero, ([], [])) manager_operations)
(fun function_parameter =>
let '(_, _, (good_ops, bad_ops)) := function_parameter in
_return ((List.rev good_ops), (List.rev bad_ops)))).
Definition classify_operations {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services__Block_services.chain)
(block : Tezos_shell_services__Block_services.block)
(hard_gas_limit_per_block : Z.t)
(minimal_fees : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(minimal_nanotez_per_gas_unit : Tezos_protocol_alpha.Protocol.Environment.Z.t)
(minimal_nanotez_per_byte : Tezos_protocol_alpha.Protocol.Environment.Z.t)
(ops : list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
((list (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation))
* (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation))) :=
op_gtgteqquestion
(Alpha_block_services.live_blocks cctxt (Some chain) (Some block) tt)
(fun live_blocks =>
let ops :=
List.filter
(fun function_parameter =>
let '{| shell := {| branch := branch |} |} := function_parameter in
Block_hash.Set.mem branch live_blocks) ops in
let validation_passes_len := List.length Main.validation_passes in
let t := Array.make validation_passes_len [] in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun op =>
List.iter
(fun pass => Array.set t pass (cons op (Array.get t pass)))
(Main.acceptable_passes op)) ops in
let t := Array.map List.rev t in
let manager_operations := Array.get t managers_index in
let '{| Environment.Updater.max_size := max_size |} :=
List.nth Main.validation_passes managers_index in
op_gtgteqquestion
(sort_manager_operations max_size hard_gas_limit_per_block minimal_fees
minimal_nanotez_per_gas_unit minimal_nanotez_per_byte
manager_operations)
(fun ordered_operations =>
op_gtgteqquestion
(trim_manager_operations max_size hard_gas_limit_per_block
(List.map fst ordered_operations))
(fun function_parameter =>
let
'(desired_manager_operations, overflowing_manager_operations) :=
function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Array.set t managers_index desired_manager_operations in
_return ((Array.to_list t), overflowing_manager_operations)))).
Definition forge
(op : Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
: Tezos_protocol_alpha.Protocol.Alpha_context.Operation.raw :=
{| shell := shell op;
proto :=
Data_encoding.Binary.to_bytes_exn
Alpha_context.Operation.protocol_data_encoding (protocol_data op) |}.
Definition ops_of_mempool
(ops :
Tezos_client_alpha.Protocol_client_context.Alpha_block_services.Mempool.t)
: list Tezos_protocol_alpha.Protocol.operation :=
List.rev
(apply
(Operation_hash.Map.fold
(fun function_parameter =>
let '_ := function_parameter in
fun op => fun acc => cons op acc) (unprocessed ops))
(apply
(Operation_hash.Map.fold
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '(op, _) := function_parameter in
fun acc => cons op acc) (branch_delayed ops))
(List.rev_map
(fun function_parameter =>
let '(_, op) := function_parameter in
op) (applied ops)))).
Definition unopt_operations {E F i o p q : Type}
(cctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(chain : Tezos_shell_services__Block_services.chain) (mempool : option string)
(function_parameter : option (list Tezos_protocol_alpha.Protocol.operation))
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list Tezos_protocol_alpha.Protocol.operation)) :=
match function_parameter with
| None =>
match mempool with
| None =>
op_gtgteqquestion
(Alpha_block_services.Mempool.pending_operations cctxt (Some chain) tt)
(fun mpool =>
let ops := ops_of_mempool mpool in
_return ops)
| Some file =>
op_gtgteqquestion (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file file)
(fun json =>
let mpool :=
Data_encoding.Json.destruct Alpha_block_services.S.Mempool.encoding
json in
let ops := ops_of_mempool mpool in
_return ops)
end
| Some operations => _return operations
end.
Definition all_ops_valid
(results :
list
(Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error))
: bool :=
List.for_all
(fun result =>
andb (is_empty (refused result))
(andb (is_empty (branch_refused result))
(is_empty (branch_delayed result)))) results.
Definition decode_priority {D E F H J L M a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(D * E) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(D * E) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(D * E) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(D * E) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (L * a * b * c * q * i * o)) * M)))) * M *
(D * E)) (chain : D) (block : E) (priority : variant)
(endorsing_power : Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Z * Tezos_protocol_environment_alpha__Environment.Time.t)) :=
match priority with
| Set priority =>
op_gtgteqquestion
(Alpha_services.Delegate.Minimal_valid_time.get cctxt (chain, block)
priority endorsing_power)
(fun minimal_timestamp => _return (priority, minimal_timestamp))
| Auto (src_pkh, max_priority) =>
op_gtgteqquestion
(Alpha_services.Helpers.current_level cctxt
(Some
(* ❌ Constant of type int32 is converted to int *)
1) (chain, block))
(fun function_parameter =>
let '{| level := level |} := function_parameter in
op_gtgteqquestion
(Alpha_services.Delegate.Baking_rights.get cctxt
(Some (cons level [])) None (Some (cons src_pkh [])) None
max_priority (chain, block))
(fun possibilities =>
(* ❌ Try-with are not handled *)
try
(let '{|
Alpha_services.Delegate.Baking_rights.priority := prio |} :=
List.find
(fun p =>
equiv_decb (Alpha_services.Delegate.Baking_rights.level p)
level) possibilities in
op_gtgteqquestion
(Alpha_services.Delegate.Minimal_valid_time.get cctxt
(chain, block) prio endorsing_power)
(fun minimal_timestamp => _return (prio, minimal_timestamp)))))
end.
Definition unopt_timestamp (op_staroptstar : option bool)
: (option Tezos_base__TzPervasives.Time.Protocol.t) ->
Tezos_base__TzPervasives.Time.Protocol.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Time.Protocol.t) :=
let force :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun timestamp =>
fun minimal_timestamp =>
let timestamp :=
match timestamp with
| None => minimal_timestamp
| Some timestamp => timestamp
end in
if andb (negb force) (OCaml.Stdlib.lt timestamp minimal_timestamp) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Proposed timestamp " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is earlier than minimal timestamp " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"Proposed timestamp %a is earlier than minimal timestamp %a" %
string) Time.Protocol.pp_hum timestamp Time.Protocol.pp_hum
minimal_timestamp
else
_return timestamp.
Definition merge_preapps
(old :
Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error)
(neu :
Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error)
: Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error :=
let merge {A B : Type} (function_parameter : A)
: (option B) -> (option B) -> option B :=
let '_ := function_parameter in
fun a =>
fun b =>
match (a, b) with
| (None, None) => None
| (Some x, None) => Some x
| (_, Some y) => Some y
end in
let merge := Operation_hash.Map.merge merge in
{| Preapply_result.applied := [];
Preapply_result.refused := merge (refused old) (refused neu);
Preapply_result.branch_refused :=
merge (branch_refused old) (branch_refused neu);
Preapply_result.branch_delayed :=
merge (branch_delayed old) (branch_delayed neu) |}.
Definition error_of_op
(result :
Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error)
(op : Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
: option Tezos_base__TzPervasives.error :=
let op := forge op in
let h := Tezos_base.Operation.hash op in
(* ❌ Try-with are not handled *)
try
(Some
(Tezos_base__TzPervasives.Failed_to_preapply op
(apply snd (Operation_hash.Map.find h (refused result))))).
Definition filter_and_apply_operations {D E G I K M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.Chain.chain * D) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Shell_services.Chain.chain * D) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Shell_services.Chain.chain * D) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(Tezos_shell_services.Shell_services.Chain.chain * D) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(M * p * q * i * o)) * N))))) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(M * p * q * i * o)) * N) *
(Tezos_shell_services.Shell_services.Chain.chain * D)) (state : state)
(chain : Tezos_shell_services.Shell_services.Chain.chain) (block : D)
(block_info : Tezos_baking_alpha.Client_baking_blocks.block_info)
(priority : Z)
(protocol_data : option Tezos_protocol_alpha.Protocol.block_header_data)
(function_parameter :
(list (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)) *
(list Tezos_protocol_alpha.Protocol.operation))
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_baking_alpha.Client_baking_simulator.incremental *
(Tezos_protocol_environment.validation_result *
Tezos_protocol_alpha.Protocol.block_header_metadata) *
(list
(list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)) *
Tezos_protocol_environment_alpha__Environment.Time.t)) :=
let '(_ as operations, overflowing_operations) := function_parameter in
op_gtgteqquestion
(Delegate_services.Minimal_valid_time.get cctxt (chain, block) priority 0)
(fun min_valid_timestamp =>
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"starting client-side validation after " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"starting client-side validation after %a" % string))
(t event "baking_local_validation_start" % string))
(a Block_hash.Logging.tag (Client_baking_blocks.hash block_info))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_gtgteq
(begin_construction min_valid_timestamp protocol_data
(index state) block_info)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok inc => _return inc
| Stdlib.Error errs =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error while fetching current context : " %
string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Error while fetching current context : %a" %
string))
(t event "context_fetch_error" % string))
(a errs_tag errs)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Retrying to open the context" % string
CamlinternalFormatBasics.End_of_format)
"Retrying to open the context" % string))
(t event "reopen_context" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Client_baking_simulator.load_context
(context_path state))
(fun index =>
op_gtgteqquestion
(begin_construction min_valid_timestamp
protocol_data index block_info)
(fun inc =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "index" % string
index in
_return inc))))
end))
(fun initial_inc =>
let endorsements := List.nth operations endorsements_index in
let votes := List.nth operations votes_index in
let anonymous := List.nth operations anonymous_index in
let managers := List.nth operations managers_index in
let validate_operation
(inc : Tezos_baking_alpha.Client_baking_simulator.incremental)
(op :
Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
: Lwt.t
(option Tezos_baking_alpha.Client_baking_simulator.incremental) :=
op_gtgteq (add_operation inc op)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error errs =>
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 4>" % string
CamlinternalFormatBasics.End_of_format)
"<v 4>" % string))
(CamlinternalFormatBasics.String_literal
"Client-side validation: invalid operation filtered "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@[<v 4>Client-side validation: invalid operation filtered %a@
%a@]"
% string))
(t event
"baking_rejected_invalid_operation" % string))
(a Operation_hash.Logging.tag
(Operation.hash_packed op))) (a errs_tag errs)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_none)
| Stdlib.Ok (resulting_state, _receipt) =>
Lwt.return_some resulting_state
end) in
let filter_valid_operations
(inc : Tezos_baking_alpha.Client_baking_simulator.incremental)
(ops :
list
Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
: Lwt.t
(Tezos_baking_alpha.Client_baking_simulator.incremental *
(list
Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)) :=
Lwt_list.fold_left_s
(fun function_parameter =>
let '(inc, acc) := function_parameter in
fun op =>
op_gtgteq (validate_operation inc op)
(fun function_parameter =>
match function_parameter with
| None => Lwt._return (inc, acc)
| Some inc' => Lwt._return (inc', (cons op acc))
end)) (inc, []) ops in
op_gtgteq (filter_valid_operations initial_inc endorsements)
(fun function_parameter =>
let '(inc, endorsements) := function_parameter in
op_gtgteq (filter_valid_operations inc votes)
(fun function_parameter =>
let '(inc, votes) := function_parameter in
op_gtgteq (filter_valid_operations inc anonymous)
(fun function_parameter =>
let '(manager_inc, anonymous) := function_parameter in
let managers :=
List.sort Protocol.compare_operations managers in
let overflowing_operations :=
List.sort Protocol.compare_operations
overflowing_operations in
op_gtgteq
(filter_valid_operations manager_inc
(OCaml.Stdlib.app managers overflowing_operations))
(fun function_parameter =>
let '(inc, managers) := function_parameter in
op_gtgteqquestion (finalize_construction inc)
(fun function_parameter =>
let '_ := function_parameter in
let quota := Main.validation_passes in
let '{|
Constants.hard_gas_limit_per_block := hard_gas_limit_per_block
|} := parametric (constants state) in
let votes :=
retain_operations_up_to_quota
(List.rev votes)
(List.nth quota votes_index) in
let anonymous :=
retain_operations_up_to_quota
(List.rev anonymous)
(List.nth quota anonymous_index) in
op_gtgteqquestion
(trim_manager_operations
(max_size (List.nth quota managers_index))
hard_gas_limit_per_block managers)
(fun function_parameter =>
let
'(accepted_managers,
_overflowing_managers) :=
function_parameter in
let accepted_managers :=
List.sort Protocol.compare_operations
accepted_managers in
op_gtgteq
(filter_valid_operations manager_inc
accepted_managers)
(fun function_parameter =>
let '(_, accepted_managers) :=
function_parameter in
let operations :=
List.map List.rev
(cons endorsements
(cons votes
(cons anonymous
(cons accepted_managers []))))
in
op_gtgteqquestion
(compute_endorsing_power cctxt chain
block endorsements)
(fun current_endorsing_power =>
op_gtgteqquestion
(Delegate_services.Minimal_valid_time.get
cctxt (chain, block) priority
current_endorsing_power)
(fun expected_validity =>
op_gtgteqquestion
(begin_construction
expected_validity
protocol_data
(index state) block_info)
(fun inc =>
op_gtgteqquestion
(fold_left_s
(fun inc =>
fun op =>
op_gtgteqquestion
(add_operation
inc op)
(fun
function_parameter
=>
let
'(inc,
_receipt) :=
function_parameter
in
_return inc))
inc
(List.flatten
operations))
(fun final_inc =>
op_gtgteqquestion
(finalize_construction
final_inc)
(fun
function_parameter
=>
let
'(validation_result,
metadata) :=
function_parameter
in
_return
(final_inc,
(validation_result,
metadata),
operations,
expected_validity)))))))))))))))).
Definition finalize_block_header
(shell_header : Tezos_base.Block_header.shell_header)
(timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
(validation_result : Tezos_protocol_environment.validation_result)
(operations :
list (list Tezos_raw_protocol_alpha__Alpha_context.packed_operation))
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base.Block_header.shell_header) :=
let '{|
Tezos_protocol_environment.context := context;
Tezos_protocol_environment.fitness := fitness;
Tezos_protocol_environment.message := message
|} := validation_result in
let validation_passes := List.length Main.validation_passes in
let operations_hash :=
Operation_list_list_hash.compute
(List.map
(fun sl =>
Operation_list_hash.compute (List.map Operation.hash_packed sl))
operations) in
let context := Shell_context.unwrap_disk_context context in
op_gtgteqquestion
(op_gtgteq (Context.get_test_chain context)
(fun function_parameter =>
match function_parameter with
| Tezos_base__TzPervasives.Test_chain_status.Not_running =>
_return context
|
Tezos_base__TzPervasives.Test_chain_status.Running {|
expiration := expiration |} =>
if op_lteq expiration timestamp then
op_gtgteq
(Context.set_test_chain context
Tezos_base__TzPervasives.Test_chain_status.Not_running)
(fun context => _return context)
else
_return context
| Tezos_base__TzPervasives.Test_chain_status.Forking _ =>
fail Tezos_base__TzPervasives.Forking_test_chain
end))
(fun context =>
let context := Context.hash timestamp message context in
let header :=
(* ❌ Record substitution not handled *)
record_substitution in
_return header).
Definition forge_block {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (force : option bool)
(operations :
option (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation))
(op_staroptstar : option bool)
: (option bool) ->
(option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
(option Tezos_protocol_alpha.Protocol.Environment.Z.t) ->
(option Tezos_protocol_alpha.Protocol.Environment.Z.t) ->
(option Tezos_base__TzPervasives.Time.Protocol.t) ->
(option string) ->
(option string) ->
(option Tezos_raw_protocol_alpha.Nonce_hash.t) ->
Tezos_shell_services__Block_services.chain ->
variant ->
Tezos_base__TzPervasives.Signature.public_key_hash ->
Tezos_client_base.Client_keys.sk_uri ->
Tezos_shell_services.Shell_services.block ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_base__TzPervasives.Block_hash.t) :=
let best_effort :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => equiv_decb operations None
end in
fun op_staroptstar =>
let sort :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => best_effort
end in
fun op_staroptstar =>
let minimal_fees :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_minimal_fees
end in
fun op_staroptstar =>
let minimal_nanotez_per_gas_unit :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_minimal_nanotez_per_gas_unit
end in
fun op_staroptstar =>
let minimal_nanotez_per_byte :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_minimal_nanotez_per_byte
end in
fun timestamp =>
fun mempool =>
fun context_path =>
fun seed_nonce_hash =>
fun chain =>
fun priority =>
fun delegate_pkh =>
fun delegate_sk =>
fun block =>
op_gtgteqquestion
(unopt_operations cctxt chain mempool operations)
(fun operations_arg =>
op_gtgteqquestion
(compute_endorsing_power cctxt chain block
operations_arg)
(fun endorsing_power =>
op_gtgteqquestion
(decode_priority cctxt chain block
priority endorsing_power)
(fun function_parameter =>
let '(priority, minimal_timestamp) :=
function_parameter in
op_gtgteqquestion
(unopt_timestamp force timestamp
minimal_timestamp)
(fun timestamp =>
let protocol_data :=
forge_faked_protocol_data priority
seed_nonce_hash in
op_gtgteqquestion
(Alpha_services.Constants.all
cctxt (chain, block))
(fun function_parameter =>
let '{|
parametric := {|
endorsers_per_block :=
endorsers_per_block;
hard_gas_limit_per_block
:=
hard_gas_limit_per_block
|}
|} := function_parameter in
op_gtgteqquestion
(classify_operations cctxt
chain block
hard_gas_limit_per_block
minimal_fees
minimal_nanotez_per_gas_unit
minimal_nanotez_per_byte
operations_arg)
(fun function_parameter =>
let
'(operations,
overflowing_ops) :=
function_parameter in
let quota :=
Main.validation_passes in
let endorsements :=
List.sub
(List.nth operations
endorsements_index)
endorsers_per_block in
let votes :=
retain_operations_up_to_quota
(List.nth operations
votes_index)
(List.nth quota
votes_index) in
let anonymous :=
retain_operations_up_to_quota
(List.nth operations
anonymous_index)
(List.nth quota
anonymous_index) in
let managers :=
List.nth operations
managers_index in
let operations :=
cons endorsements
(cons votes
(cons anonymous
(cons managers [])))
in
op_gtgteqquestion
match context_path with
| None =>
op_gtgteqquestion
(Alpha_block_services.Helpers.Preapply.block
cctxt (Some chain)
(Some block)
(Some sort)
(Some timestamp)
protocol_data
operations)
(fun
function_parameter
=>
let
'(shell_header,
result) :=
function_parameter
in
let operations :=
List.map
(fun l =>
List.map snd
(Preapply_result.applied
l)) result
in
if
orb best_effort
(all_ops_valid
result) then
_return
(shell_header,
operations)
else
let result :=
List.fold_left
merge_preapps
Preapply_result.empty
result in
apply
Lwt.return_error
(List.filter_map
(error_of_op
result)
operations_arg))
| Some context_path =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert sort in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert best_effort in
op_gtgteq
(Context.init None
None (Some true)
context_path)
(fun index =>
op_gtgteqquestion
(Client_baking_blocks.info
cctxt
(Some chain)
block)
(fun bi =>
op_gtgteqquestion
(Alpha_services.Constants.all
cctxt
(chain,
(* ❌ Variants not supported *)
variant))
(fun constants
=>
op_gtgteqquestion
(Client_baking_files.resolve_location
cctxt
chain
(* ❌ Variants not supported *)
variant)
(fun
nonces_location
=>
let
state :=
{|
context_path :=
context_path;
index :=
index;
nonces_location :=
nonces_location;
delegates :=
[];
constants :=
constants;
minimal_fees :=
default_minimal_fees;
minimal_nanotez_per_gas_unit :=
default_minimal_nanotez_per_gas_unit;
minimal_nanotez_per_byte :=
default_minimal_nanotez_per_byte;
best_slot :=
None
|}
in
op_gtgteqquestion
(filter_and_apply_operations
cctxt
state
chain
block
bi
priority
(Some
protocol_data)
(operations,
overflowing_ops))
(fun
function_parameter
=>
let
'(final_context,
(validation_result,
_),
operations,
min_valid_timestamp) :=
function_parameter
in
let
current_protocol :=
next_protocol
bi
in
let
context :=
Shell_context.unwrap_disk_context
(context
validation_result)
in
op_gtgteq
(Context.get_protocol
context)
(fun
next_protocol
=>
if
Protocol_hash.equal
current_protocol
next_protocol
then
op_gtgteq
(finalize_block_header
(header
final_context)
min_valid_timestamp
validation_result
operations)
(fun
function_parameter
=>
match
function_parameter
with
|
Stdlib.Error
(cons
Tezos_base__TzPervasives.Forking_test_chain
_)
=>
op_gtgteqquestion
(Alpha_block_services.Helpers.Preapply.block
cctxt
(Some
chain)
(Some
block)
(Some
sort)
(Some
min_valid_timestamp)
protocol_data
operations)
(fun
function_parameter
=>
let
'(shell_header,
_result) :=
function_parameter
in
_return
(shell_header,
(List.map
(List.map
forge)
operations)))
|
(Stdlib.Error
_)
as
errs
=>
Lwt._return
errs
|
Stdlib.Ok
shell_header
=>
_return
(shell_header,
(List.map
(List.map
forge)
operations))
end)
else
op_gtgteq
(lwt_log_notice
(fun
f
=>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"New protocol detected: using shell validation"
%
string
CamlinternalFormatBasics.End_of_format)
"New protocol detected: using shell validation"
%
string))
(t
event
"shell_prevalidation_notice"
%
string)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(Alpha_block_services.Helpers.Preapply.block
cctxt
(Some
chain)
(Some
block)
(Some
sort)
(Some
min_valid_timestamp)
protocol_data
operations)
(fun
function_parameter
=>
let
'(shell_header,
_result) :=
function_parameter
in
_return
(shell_header,
(List.map
(List.map
forge)
operations))))))))))
end
(fun function_parameter =>
let
'(shell_header,
operations) :=
function_parameter in
let total_op_count :=
List.length
operations_arg in
let valid_op_count :=
List.length
(List.concat
operations) in
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"found "
%
string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" valid operations ("
%
string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" refused) for timestamp "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (fitness "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")"
%
char
CamlinternalFormatBasics.End_of_format)))))))))
"found %d valid operations (%d refused) for timestamp %a (fitness %a)"
%
string))
(t event
"found_valid_operations"
%
string))
(s
valid_ops
valid_op_count))
(s
refused_ops
(Z.sub
total_op_count
valid_op_count)))
(a
timestamp_tag
(Time.System.of_protocol_exn
timestamp)))
(a fitness_tag
(fitness
shell_header))))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteqquestion
match
Environment.wrap_error
(Raw_level.of_int32
(level
shell_header))
with
| Stdlib.Ok level
=> _return level
|
(Stdlib.Error
errs) as err
=>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error on raw_level conversion : "
%
string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Error on raw_level conversion : %a"
%
string))
(t
event
"block_injection_failed"
%
string))
(a
errs_tag
errs)))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
Lwt._return
err)
end
(fun level =>
op_gtgteq
(inject_block
cctxt force
seed_nonce_hash
chain
shell_header
priority
delegate_pkh
delegate_sk
level
operations)
(fun
function_parameter
=>
match
function_parameter
with
|
Stdlib.Ok
hash =>
_return
hash
|
(Stdlib.Error
errs) as
error =>
op_gtgteq
(lwt_log_error
(fun f
=>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 4>"
%
string
CamlinternalFormatBasics.End_of_format)
"<v 4>"
%
string))
(CamlinternalFormatBasics.String_literal
"Error while injecting block"
%
string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ "
%
string
1
0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
""
%
string))
(CamlinternalFormatBasics.String_literal
"Included operations : "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ "
%
string
1
0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))
"@[<v 4>Error while injecting block@ @[Included operations : %a@]@ %a@]"
%
string))
(t
event
"block_injection_failed"
%
string))
(a
raw_operations_tag
(List.concat
operations)))
(a
errs_tag
errs)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
Lwt._return
error)
end)))))))))).
Definition shell_prevalidation {D F H J L M N O P Q a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services__Block_services.chain)
(block : Tezos_shell_services__Block_services.block)
(timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
(seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
(operations : list (list Tezos_protocol_alpha.Protocol.operation))
(function_parameter : O * (P * Z * Q))
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option
(P * Z * Tezos_base__TzPervasives.Block_header.shell_header *
(list (list Tezos_base.Operation.t)) * Q *
(option Tezos_raw_protocol_alpha.Nonce_hash.t)))) :=
let '(_, (bi, priority, delegate)) as _slot := function_parameter in
let protocol_data := forge_faked_protocol_data priority seed_nonce_hash in
op_gtgteq
(Alpha_block_services.Helpers.Preapply.block cctxt (Some chain) (Some block)
(Some true) (Some timestamp) protocol_data operations)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error errs =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Shell-side validation: error while prevalidating operations:"
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))
"Shell-side validation: error while prevalidating operations:@
%a"
% string))
(t event "built_invalid_block_error" % string))
(a errs_tag errs)))
(fun function_parameter =>
let 'tt := function_parameter in
return_none)
| Stdlib.Ok (shell_header, operations) =>
let raw_ops :=
List.map (fun l => List.map snd (Preapply_result.applied l))
operations in
return_some
(bi, priority, shell_header, raw_ops, delegate, seed_nonce_hash)
end).
Definition filter_outdated_endorsements
(expected_level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
(ops : list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
: list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation :=
List.filter
(fun function_parameter =>
match function_parameter with
| {|
Alpha_context.protocol_data :=
Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data {|
contents :=
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Endorsement
{|
level := level
|})
|}
|} => Raw_level.equal expected_level level
| _ => true
end) ops.
Definition fetch_operations {D F H J L M N O P a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services__Block_services.chain)
(function_parameter :
O * (Tezos_baking_alpha.Client_baking_blocks.block_info * Z * P))
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option
((list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) *
Tezos_protocol_environment_alpha__Environment.Time.t))) :=
let '(_, (head, priority, _delegate)) := function_parameter in
op_gtgteqquestion
(Alpha_block_services.Mempool.monitor_operations cctxt (Some chain)
(Some true) (Some true) (Some false) (Some false) tt)
(fun function_parameter =>
let '(operation_stream, _stop) := function_parameter in
op_gtgteq (Lwt_stream.get operation_stream)
(fun function_parameter =>
match function_parameter with
| None => return_none
| Some current_mempool =>
let block :=
(* ❌ Variants not supported *)
variant in
let operations :=
Stdlib.ref
(filter_outdated_endorsements (level head) current_mempool) in
op_gtgteqquestion
(Shell_services.Mempool.request_operations cctxt (Some chain) tt)
(fun function_parameter =>
let 'tt := function_parameter in
let compute_minimal_valid_time (function_parameter : unit)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_environment_alpha__Environment.Time.t) :=
let 'tt := function_parameter in
op_gtgteqquestion
(compute_endorsing_power cctxt chain block
(Stdlib.op_exclamation operations))
(fun current_endorsing_power =>
Delegate_services.Minimal_valid_time.get cctxt
(chain, block) priority current_endorsing_power) in
let compute_timeout (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (compute_minimal_valid_time tt)
(fun expected_validity =>
match
Client_baking_scheduling.sleep_until expected_validity
with
| None => return_unit
| Some timeout =>
op_gtgteq timeout
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
end) in
let last_get_event := Stdlib.ref None in
let get_event (function_parameter : unit)
: Lwt.t
(option (list Tezos_protocol_alpha.Protocol.operation)) :=
let 'tt := function_parameter in
match Stdlib.op_exclamation last_get_event with
| None =>
let t := Lwt_stream.get operation_stream in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq last_get_event (Some t) in
t
| Some t => t
end in
let fix loop (function_parameter : unit)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option
((list
Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
* Tezos_protocol_environment_alpha__Environment.Time.t))) :=
let 'tt := function_parameter in
op_gtgteq
(Lwt.choose
(cons
(op_gtpipeeq (compute_timeout tt)
(fun function_parameter =>
let '_ := function_parameter in
(* ❌ Variants not supported *)
variant))
(cons
(op_gtpipeeq (get_event tt)
(fun e =>
(* ❌ Variants not supported *)
variant)) [])))
(fun function_parameter =>
match function_parameter with
| Event (Some op_list) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq last_get_event None in
let op_list :=
filter_outdated_endorsements (level head) op_list in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq operations
(OCaml.Stdlib.app op_list
(Stdlib.op_exclamation operations)) in
loop tt
| Timeout =>
let remaining_operations :=
filter_outdated_endorsements (level head)
(List.flatten
(Lwt_stream.get_available operation_stream)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.op_coloneq operations
(OCaml.Stdlib.app remaining_operations
(Stdlib.op_exclamation operations)) in
op_gtgteqquestion (compute_minimal_valid_time tt)
(fun expected_validity =>
return_some
((Stdlib.op_exclamation operations),
expected_validity))
| Event None => return_none
end) in
loop tt)
end)).
Definition build_block {E F H J L M N a b c i o p q : Type}
(cctxt :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i
o) ->
(variant * variant) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t *
a) q i o) ->
(variant * variant) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t
* a) * b) q i o) ->
(variant * variant) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t
* a) * b) * c) q i o) ->
(variant * variant) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) ->
a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o)
->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) *
(M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format
a b) -> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option
Tezos_data_encoding.Data_encoding.json)
->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) * N)))))))))))))))))))))))))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q ->
i ->
Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o))
*
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a
b) -> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json)
->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) * N)))))))))))))))))))))
* (variant * variant)) (state : state)
(seed_nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t)
(function_parameter :
Tezos_base__Time.Protocol.t *
(Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
Tezos_client_base.Client_keys.Public_key_hash.t))
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option
(Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
Tezos_base__TzPervasives.Block_header.shell_header *
(list (list Tezos_base.Operation.t)) *
Tezos_client_base.Client_keys.Public_key_hash.t *
(option Tezos_raw_protocol_alpha.Nonce_hash.t)))) :=
let '(slot_timestamp, (bi, priority, delegate)) as slot := function_parameter
in
let chain :=
(* ❌ Variants not supported *)
variant in
let block :=
(* ❌ Variants not supported *)
variant in
op_gtgteqquestion
(Alpha_services.Helpers.current_level cctxt
(Some
(* ❌ Constant of type int32 is converted to int *)
1) (chain, block))
(fun next_level =>
let seed_nonce_hash :=
if Level.expected_commitment next_level then
Some seed_nonce_hash
else
None in
op_gtgteqquestion (Client_keys.Public_key_hash.name cctxt delegate)
(fun name =>
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Try baking after " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (slot " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
") for " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))))))))
"Try baking after %a (slot %d) for %s (%a)" %
string)) (t event "try_baking" % string))
(a Block_hash.Logging.tag (hash bi)))
(s bake_priority_tag priority))
(s Client_keys.Logging.tag name))
(a timestamp_tag (Time.System.of_protocol_exn slot_timestamp))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (fetch_operations cctxt chain slot)
(fun function_parameter =>
match function_parameter with
| None =>
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Received a new head while waiting for operations. Aborting this block."
% string
CamlinternalFormatBasics.End_of_format)
"Received a new head while waiting for operations. Aborting this block."
% string))
(t event "new_head_received" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
return_none)
| Some (operations, timestamp) =>
let hard_gas_limit_per_block :=
hard_gas_limit_per_block (parametric (constants state)) in
op_gtgteqquestion
(classify_operations cctxt chain block
hard_gas_limit_per_block (minimal_fees state)
(minimal_nanotez_per_gas_unit state)
(minimal_nanotez_per_byte state) operations)
(fun function_parameter =>
let '(operations, overflowing_ops) := function_parameter
in
let next_version :=
match
Tezos_base.Block_header.get_forced_protocol_upgrade
(Raw_level.to_int32 (Level.level next_level)) with
| None => next_protocol bi
| Some hash => hash
end in
if op_ltgt Protocol.hash next_version then
shell_prevalidation cctxt chain block timestamp
seed_nonce_hash operations slot
else
let protocol_data :=
forge_faked_protocol_data priority seed_nonce_hash
in
op_gtgteq
(filter_and_apply_operations cctxt state chain block
bi priority (Some protocol_data)
(operations, overflowing_ops))
(fun function_parameter =>
match function_parameter with
| Stdlib.Error errs =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Client-side validation: error while filtering invalid operations :"
% string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 4>" % string
CamlinternalFormatBasics.End_of_format)
"<v 4>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))
"Client-side validation: error while filtering invalid operations :@
@[<v 4>%a@]"
% string))
(t event
"client_side_validation_error" %
string)) (a errs_tag errs)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Building a block using shell validation"
% string
CamlinternalFormatBasics.End_of_format)
"Building a block using shell validation"
% string))
(t event
"shell_prevalidation_notice" %
string)))
(fun function_parameter =>
let 'tt := function_parameter in
shell_prevalidation cctxt chain block
timestamp seed_nonce_hash operations
slot))
|
Stdlib.Ok
(final_context, (validation_result, _),
operations, valid_timestamp) =>
op_gtgteq
(if
op_lt (Systime_os.now tt)
(of_protocol_exn valid_timestamp) then
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal
"[" % char
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"] not ready to inject yet, waiting until "
% string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))
"[%a] not ready to inject yet, waiting until %a"
% string))
(a timestamp_tag
(Systime_os.now tt)))
(a timestamp_tag
(Time.System.of_protocol_exn
valid_timestamp)))
(t event
"waiting_before_injection" %
string)))
(fun function_parameter =>
let 'tt := function_parameter in
match
Client_baking_scheduling.sleep_until
valid_timestamp with
| None => Lwt.return_unit
| Some timeout => timeout
end)
else
Lwt.return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Try forging locally the block header for "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (slot " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
") for " %
string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" (" %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" %
char
CamlinternalFormatBasics.End_of_format)))))))))
"Try forging locally the block header for %a (slot %d) for %s (%a)"
% string))
(t event
"try_forging" % string))
(a Block_hash.Logging.tag
(hash bi)))
(s bake_priority_tag priority))
(s Client_keys.Logging.tag name))
(a timestamp_tag
(Time.System.of_protocol_exn
timestamp))))
(fun function_parameter =>
let 'tt := function_parameter in
let current_protocol := next_protocol bi
in
let context :=
Shell_context.unwrap_disk_context
(context validation_result) in
op_gtgteq (Context.get_protocol context)
(fun next_protocol =>
if
Protocol_hash.equal
current_protocol next_protocol
then
op_gtgteq
(finalize_block_header
(header final_context)
valid_timestamp
validation_result operations)
(fun function_parameter =>
match function_parameter with
|
Stdlib.Error
(cons
Tezos_base__TzPervasives.Forking_test_chain
_) =>
shell_prevalidation cctxt
chain block timestamp
seed_nonce_hash operations
slot
| (Stdlib.Error _) as errs =>
Lwt._return errs
| Stdlib.Ok shell_header =>
let raw_ops :=
List.map (List.map forge)
operations in
return_some
(bi, priority,
shell_header, raw_ops,
delegate,
seed_nonce_hash)
end)
else
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"New protocol detected: using shell validation"
% string
CamlinternalFormatBasics.End_of_format)
"New protocol detected: using shell validation"
% string))
(t event
"shell_prevalidation_notice"
% string)))
(fun function_parameter =>
let 'tt := function_parameter
in
shell_prevalidation cctxt
chain block timestamp
seed_nonce_hash operations
slot))))
end))
end)))).
Definition bake {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Shell_services.chain) (state : state)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
match best_slot state with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some slot => _return slot
end
(fun slot =>
let seed_nonce := generate_seed_nonce tt in
let seed_nonce_hash := Nonce.hash seed_nonce in
op_gtgteqquestion (build_block cctxt state seed_nonce_hash slot)
(fun function_parameter =>
match function_parameter with
|
Some
(head, priority, shell_header, operations, delegate,
seed_nonce_hash) =>
let level := Raw_level.succ (level head) in
op_gtgteqquestion (Client_keys.Public_key_hash.name cctxt delegate)
(fun name =>
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Injecting block (priority " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
", fitness " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
") for " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" after " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
"..." % string
CamlinternalFormatBasics.End_of_format)))))))))
"Injecting block (priority %d, fitness %a) for %s after %a..."
% string))
(t event "start_injecting_block" % string))
(s bake_priority_tag priority))
(a fitness_tag (fitness shell_header)))
(s Client_keys.Logging.tag name))
(a Block_hash.Logging.predecessor_tag
(predecessor shell_header)))
(t Signature.Public_key_hash.Logging.tag delegate)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Client_keys.get_key cctxt delegate)
(fun function_parameter =>
let '(_, _, delegate_sk) := function_parameter in
op_gtgteq
(inject_block cctxt (Some false) seed_nonce_hash chain
shell_header priority delegate delegate_sk level
operations)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error errs =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 4>" % string
CamlinternalFormatBasics.End_of_format)
"<v 4>" % string))
(CamlinternalFormatBasics.String_literal
"Error while injecting block"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.String_literal
"Included operations : "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1
0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))))))
"@[<v 4>Error while injecting block@ @[Included operations : %a@]@ %a@]"
% string))
(t event
"block_injection_failed" % string))
(a raw_operations_tag
(List.concat operations)))
(a errs_tag errs)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Ok block_hash =>
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Injected block " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" for " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" after " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (level "
% string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", priority "
%
string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
", fitness "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", operations "
%
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
")."
%
string
CamlinternalFormatBasics.End_of_format)))))))))))))))
"Injected block %a for %s after %a (level %a, priority %d, fitness %a, operations %a)."
% string))
(t event
"injected_block" % string))
(a Block_hash.Logging.tag
block_hash))
(s Client_keys.Logging.tag name))
(a Block_hash.Logging.tag
(predecessor shell_header)))
(a level_tag level))
(s bake_priority_tag priority))
(a fitness_tag (fitness shell_header)))
(a operations_tag operations)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(if nequiv_decb seed_nonce_hash None then
OCaml.Stdlib.reverse_apply
((* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(load cctxt
(nonces_location state))
(fun nonces =>
let nonces :=
add nonces block_hash
seed_nonce in
save cctxt
(nonces_location state) nonces)))
(trace_exn
(OCaml.Failure
"Error while recording nonce" %
string))
else
return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))
end))))
| None => return_unit
end)).
Definition get_baking_slots {D F H J K a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(variant * variant) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(variant * variant) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(variant * variant) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(variant * variant) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) * K)))) * K *
(variant * variant)) (op_staroptstar : option Z)
: Tezos_baking_alpha.Client_baking_blocks.block_info ->
(list
Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash)
->
Lwt.t
(list
(Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t *
(Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t))) :=
let max_priority :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_max_priority
end in
fun new_head =>
fun delegates =>
let chain :=
(* ❌ Variants not supported *)
variant in
let block :=
(* ❌ Variants not supported *)
variant in
let level := Raw_level.succ (level new_head) in
op_gtgteq
(Alpha_services.Delegate.Baking_rights.get cctxt (Some (cons level []))
None (Some delegates) None (Some max_priority) (chain, block))
(fun function_parameter =>
match function_parameter with
| Stdlib.Error errs =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error while fetching baking possibilities:
" %
string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Error while fetching baking possibilities:
%a" %
string))
(t event "baking_slot_fetch_errors" % string))
(a errs_tag errs)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_nil)
| Stdlib.Ok [] => Lwt.return_nil
| Stdlib.Ok slots =>
let slots :=
List.filter_map
(fun function_parameter =>
match function_parameter with
| {|
Alpha_services.Delegate.Baking_rights.timestamp := None
|} => None
| {|
delegate := delegate;
priority := priority;
timestamp := Some timestamp
|} => Some (timestamp, (new_head, priority, delegate))
end) slots in
Lwt._return slots
end).
Definition compute_best_slot_on_current_level
{D F H J L M N a b c i o p q : Type}
(max_priority : option Z)
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (state : state)
(new_head : Tezos_baking_alpha.Client_baking_blocks.block_info)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(option
(Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t *
(Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)))) :=
op_gtgteqquestion (get_delegates cctxt state)
(fun delegates =>
let level := Raw_level.succ (Client_baking_blocks.level new_head) in
op_gtgteq (get_baking_slots cctxt max_priority new_head delegates)
(fun function_parameter =>
match function_parameter with
| [] =>
op_gtgteq
(lwt_log_notice
(fun f =>
let max_priority :=
Option.unopt default_max_priority max_priority in
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No slot found at level " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (max_priority = " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))))
"No slot found at level %a (max_priority = %d)" %
string)) (t event "no_slot_found" % string))
(a level_tag level)) (s bake_priority_tag max_priority)))
(fun function_parameter =>
let 'tt := function_parameter in
return_none)
| cons h t =>
let '(timestamp, (_, priority, delegate)) as best_slot :=
List.fold_left
(fun function_parameter =>
let '(_, (_, priority, _)) as acc := function_parameter in
fun function_parameter =>
let '(_, (_, priority', _)) as slot := function_parameter in
if OCaml.Stdlib.lt priority priority' then
acc
else
slot) h t in
op_gtgteqquestion (Client_keys.Public_key_hash.name cctxt delegate)
(fun name =>
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"New baking slot found (level " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", priority " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
") at " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" for " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" after " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format)))))))))))
"New baking slot found (level %a, priority %d) at %a for %s after %a."
% string))
(t event "have_baking_slot" % string))
(a level_tag level))
(s bake_priority_tag priority))
(a timestamp_tag
(Time.System.of_protocol_exn timestamp)))
(s Client_keys.Logging.tag name))
(a Block_hash.Logging.tag (hash new_head)))
(t Signature.Public_key_hash.Logging.tag delegate)))
(fun function_parameter =>
let 'tt := function_parameter in
return_some best_slot))
end)).
Definition reveal_potential_nonces {F G I J K M N a b c i o p q : Type}
(cctxt :
((Z -> Lwt.t unit) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (F * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (G * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) -> a)
* (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a)
-> Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a (Tezos_base__TzPervasives.tzresult string))
-> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
q i o) ->
(Tezos_shell_services.Shell_services.chain
*
Tezos_shell_services.Shell_services.block)
->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (I * q * i * o))
*
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) q i o) ->
(Tezos_shell_services.Shell_services.chain
*
Tezos_shell_services.Shell_services.block)
->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) *
(J * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) * b) q i o) ->
(Tezos_shell_services.Shell_services.chain
*
Tezos_shell_services.Shell_services.block)
->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) *
(K * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
* a) * b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain
*
Tezos_shell_services.Shell_services.block)
->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) *
(M * a * b * c * q * i * o))
* N)))))))))))))))))))))))))
*
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (I * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (K * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (M * a * b * c * q * i * o)) * N)))))
(constants : Tezos_protocol_alpha.Protocol.Alpha_context.Constants.t)
(chain : Tezos_shell_services.Chain_services.chain)
(block : Tezos_shell_services.Block_services.block)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
(* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_baking_files.resolve_location cctxt chain
(* ❌ Variants not supported *)
variant)
(fun nonces_location =>
op_gtgteq (Client_baking_nonces.load cctxt nonces_location)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error err =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot read nonces: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Cannot read nonces: %a" % string))
(t event "read_nonce_fail" % string)) (a errs_tag err)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Ok nonces =>
op_gtgteq
(Client_baking_nonces.get_unrevealed_nonces cctxt
nonces_location nonces)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error err =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot retrieve unrevealed nonces: " %
string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Cannot retrieve unrevealed nonces: %a" %
string))
(t event "nonce_retrieval_fail" % string))
(a errs_tag err)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Ok [] => return_unit
| Stdlib.Ok nonces_to_reveal =>
op_gtgteq
(Client_baking_revelation.inject_seed_nonce_revelation
cctxt chain block None nonces_to_reveal)
(fun function_parameter =>
match function_parameter with
| Stdlib.Error err =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot inject nonces: " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Cannot inject nonces: %a" % string))
(t event "nonce_injection_fail" % string))
(a errs_tag err)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Stdlib.Ok tt =>
op_gtgteqquestion
(Client_baking_nonces.filter_outdated_nonces cctxt
(Some constants) nonces_location nonces)
(fun live_nonces =>
op_gtgteqquestion
(Client_baking_nonces.save cctxt
nonces_location live_nonces)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))
end)
end)
end))).
Definition create {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N)
(minimal_fees : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
(minimal_nanotez_per_gas_unit : option Z.t)
(minimal_nanotez_per_byte : option Z.t) (max_priority : option Z)
(chain : Tezos_shell_services.Shell_services.chain) (context_path : string)
(delegates : list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
(block_stream :
Lwt_stream.t
(Tezos_base__TzPervasives.tzresult
Tezos_baking_alpha.Client_baking_blocks.block_info))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let state_maker (bi : Tezos_baking_alpha.Client_baking_blocks.block_info)
: Lwt.t (Tezos_base__TzPervasives.tzresult state) :=
op_gtgteqquestion
(Alpha_services.Constants.all cctxt
(chain,
(* ❌ Variants not supported *)
variant))
(fun constants =>
op_gtgteq (Client_baking_simulator.load_context context_path)
(fun index =>
op_gtgteqquestion
(Client_baking_simulator.check_context_consistency index
(Client_baking_blocks.context bi))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_baking_files.resolve_location cctxt chain
(* ❌ Variants not supported *)
variant)
(fun nonces_location =>
let state :=
create_state minimal_fees minimal_nanotez_per_gas_unit
minimal_nanotez_per_byte context_path index
nonces_location delegates constants in
_return state)))) in
let event_k {O P Q R S T U : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (O * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (P * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (Q * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (R * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (S * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (T * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * U)))))))))))))))))))))))))
* U) (state : state) (new_head :
Tezos_baking_alpha.Client_baking_blocks.block_info)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq
(reveal_potential_nonces cctxt (constants state) chain
(* ❌ Variants not supported *)
variant)
(fun _ignore_nonce_err =>
op_gtgteqquestion
(compute_best_slot_on_current_level max_priority cctxt state new_head)
(fun slot =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "best_slot" % string slot in
return_unit)) in
let compute_timeout (state : state) : Lwt.t unit :=
match best_slot state with
| None => Lwt_utils.never_ending tt
| Some (timestamp, _) =>
match Client_baking_scheduling.sleep_until timestamp with
| None => Lwt.return_unit
| Some timeout => timeout
end
end in
let timeout_k {O P Q R S T U : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (O * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (P * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (Q * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (R * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (S * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (T * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * U)))))))))))))))))))))))))
* U) (state : state) (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (bake cctxt chain state)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Set record field not handled. *)
set_record_field state "best_slot" % string None in
return_unit) in
Client_baking_scheduling.main "baker" % string cctxt block_stream state_maker
event_k compute_timeout timeout_k event_k.
src/proto_alpha/lib_delegate/client_baking_highwatermarks.ml 637 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol_client_context
open Protocol
open Alpha_context
type error += Level_previously_endorsed of Raw_level.t
type error += Level_previously_baked of Raw_level.t
let () =
let open Data_encoding in
register_error_kind
`Permanent
~id:"highwatermarks.block_already_baked"
~title:"Block already baked"
~description:"Trying to bake a block for a level that was previously done"
~pp:(fun ppf level ->
Format.fprintf ppf "Level %a previously baked " Raw_level.pp level)
(obj1 (req "level" Raw_level.encoding))
(function Level_previously_baked level -> Some level | _ -> None)
(fun level -> Level_previously_baked level) ;
register_error_kind
`Permanent
~id:"highwatermarks.block_already_endorsed"
~title:"Fail to preapply an operation"
~description:
"Trying to endorse a block for a level that was previously done"
~pp:(fun ppf level ->
Format.fprintf ppf "Level %a previously endorsed " Raw_level.pp level)
(obj1 (req "level" Raw_level.encoding))
(function Level_previously_endorsed level -> Some level | _ -> None)
(fun level -> Level_previously_endorsed level)
type t = (string * Raw_level.t) list
let encoding =
let open Data_encoding in
def "highwatermarks" @@ assoc Raw_level.encoding
let empty = []
(* We do not lock these functions. The caller will be already locked. *)
let load_highwatermarks (cctxt : #Protocol_client_context.full) filename :
t tzresult Lwt.t =
cctxt#load filename encoding ~default:empty
let save_highwatermarks (cctxt : #Protocol_client_context.full) filename
highwatermarks : unit tzresult Lwt.t =
cctxt#write filename highwatermarks encoding
let retrieve_highwatermark cctxt filename = load_highwatermarks cctxt filename
let may_inject (cctxt : #Protocol_client_context.full) location ~delegate level
=
retrieve_highwatermark cctxt (Client_baking_files.filename location)
>>=? fun highwatermark ->
let delegate = Signature.Public_key_hash.to_short_b58check delegate in
List.find_opt
(fun (delegate', _) -> String.compare delegate delegate' = 0)
highwatermark
|> function
| None ->
return_true
| Some (_, past_level) ->
return Raw_level.(past_level < level)
let may_inject_block = may_inject
let may_inject_endorsement = may_inject
let record (cctxt : #Protocol_client_context.full) location ~delegate level =
let filename = Client_baking_files.filename location in
let delegate = Signature.Public_key_hash.to_short_b58check delegate in
load_highwatermarks cctxt filename
>>=? fun highwatermarks ->
let level =
match List.assoc_opt delegate highwatermarks with
| None ->
level
| Some lower_prev_level when level >= lower_prev_level ->
level
| Some higher_prev_level ->
higher_prev_level
(* should only happen in `forced` mode *)
in
save_highwatermarks
cctxt
filename
( (delegate, level)
:: List.filter
(fun (delegate', _) -> String.compare delegate delegate' <> 0)
highwatermarks )
let record_block = record
let record_endorsement = record
src/proto_alpha/lib_delegate/client_baking_highwatermarks.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol_client_context.
Import Protocol.
Import Alpha_context.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition t :=
list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t).
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
(list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)) :=
apply
(let arg := def "highwatermarks" % string in
fun eta => arg None None eta) (assoc Raw_level.encoding).
Definition empty {A : Type} : list A := [].
Definition load_highwatermarks {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (filename : string) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
(* ❌ Sending method message is not handled *)
send filename empty encoding.
Definition save_highwatermarks {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (filename : string)
(highwatermarks :
list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
(* ❌ Sending method message is not handled *)
send filename highwatermarks encoding.
Definition retrieve_highwatermark {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (filename : string) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
load_highwatermarks cctxt filename.
Definition may_inject {D F H J L M N O a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (location : Tezos_baking_alpha.Client_baking_files.location O)
(delegate : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
op_gtgteqquestion
(retrieve_highwatermark cctxt (Client_baking_files.filename location))
(fun highwatermark =>
let delegate := Signature.Public_key_hash.to_short_b58check delegate in
OCaml.Stdlib.reverse_apply
(List.find_opt
(fun function_parameter =>
let '(delegate', _) := function_parameter in
equiv_decb (String.compare delegate delegate') 0) highwatermark)
(fun function_parameter =>
match function_parameter with
| None => return_true
| Some (_, past_level) => _return (op_lt past_level level)
end)).
Definition may_inject_block {D F H J L M N O a b c i o p q : Type}
: (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a)
* (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) ->
(Tezos_baking_alpha.Client_baking_files.location O) ->
Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
Lwt.t (Tezos_base__TzPervasives.tzresult bool) := may_inject.
Definition may_inject_endorsement {D F H J L M N O a b c i o p q : Type}
: (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a)
* (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) ->
(Tezos_baking_alpha.Client_baking_files.location O) ->
Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
Lwt.t (Tezos_base__TzPervasives.tzresult bool) := may_inject.
Definition record {D F H J L M N O a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (location : Tezos_baking_alpha.Client_baking_files.location O)
(delegate : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let filename := Client_baking_files.filename location in
let delegate := Signature.Public_key_hash.to_short_b58check delegate in
op_gtgteqquestion (load_highwatermarks cctxt filename)
(fun highwatermarks =>
let level :=
match List.assoc_opt delegate highwatermarks with
| None => level
| Some lower_prev_level => level
| Some higher_prev_level => higher_prev_level
end in
save_highwatermarks cctxt filename
(cons (delegate, level)
(List.filter
(fun function_parameter =>
let '(delegate', _) := function_parameter in
nequiv_decb (String.compare delegate delegate') 0) highwatermarks))).
Definition record_block {D F H J L M N O a b c i o p q : Type}
: (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a)
* (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) ->
(Tezos_baking_alpha.Client_baking_files.location O) ->
Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) := record.
Definition record_endorsement {D F H J L M N O a b c i o p q : Type}
: (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b) ->
a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a
unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) -> Lwt.t a)
* (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) ->
(Tezos_baking_alpha.Client_baking_files.location O) ->
Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) := record.
src/proto_alpha/lib_delegate/client_baking_lib.ml 380 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
let bake_block (cctxt : #Protocol_client_context.full) ?minimal_fees
?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?force
?max_priority ?(minimal_timestamp = false) ?mempool ?context_path ?src_sk
~chain ~head delegate =
( match src_sk with
| None ->
Client_keys.get_key cctxt delegate
>>=? fun (_, _, src_sk) -> return src_sk
| Some sk ->
return sk )
>>=? fun src_sk ->
Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, head)
>>=? fun level ->
let (seed_nonce, seed_nonce_hash) =
if level.expected_commitment then
let seed_nonce = Client_baking_forge.generate_seed_nonce () in
let seed_nonce_hash = Nonce.hash seed_nonce in
(Some seed_nonce, Some seed_nonce_hash)
else (None, None)
in
let timestamp =
if minimal_timestamp then None
else Some Time.System.(to_protocol (Systime_os.now ()))
in
Client_baking_forge.forge_block
cctxt
?force
?minimal_fees
?minimal_nanotez_per_gas_unit
?minimal_nanotez_per_byte
?timestamp
?seed_nonce_hash
?mempool
?context_path
~chain
~priority:(`Auto (delegate, max_priority))
~delegate_pkh:delegate
~delegate_sk:src_sk
head
>>=? fun block_hash ->
( match seed_nonce with
| None ->
return_unit
| Some seed_nonce ->
cctxt#with_lock (fun () ->
let open Client_baking_nonces in
Client_baking_files.resolve_location cctxt ~chain `Nonce
>>=? fun nonces_location ->
load cctxt nonces_location
>>=? fun nonces ->
let nonces = add nonces block_hash seed_nonce in
save cctxt nonces_location nonces)
|> trace_exn (Failure "Error while recording block") )
>>=? fun () ->
cctxt#message "Injected block %a" Block_hash.pp_short block_hash
>>= fun () -> return_unit
let endorse_block cctxt ~chain delegate =
Client_keys.get_key cctxt delegate
>>=? fun (_src_name, src_pk, src_sk) ->
Client_baking_endorsement.forge_endorsement
cctxt
~chain
~block:cctxt#block
~src_sk
src_pk
>>=? fun oph ->
cctxt#answer "Operation successfully injected in the node."
>>= fun () ->
cctxt#answer "Operation hash is '%a'." Operation_hash.pp oph
>>= fun () -> return_unit
let get_predecessor_cycle (cctxt : #Client_context.printer) cycle =
match Cycle.pred cycle with
| None ->
if Cycle.(cycle = root) then
cctxt#error "No predecessor for the first cycle"
else
cctxt#error "Cannot compute the predecessor of cycle %a" Cycle.pp cycle
| Some cycle ->
Lwt.return cycle
let do_reveal cctxt ~chain ~block nonces =
Client_baking_revelation.inject_seed_nonce_revelation
cctxt
~chain
~block
nonces
>>=? fun () -> return_unit
let reveal_block_nonces (cctxt : #Protocol_client_context.full) ~chain ~block
block_hashes =
cctxt#with_lock (fun () ->
Client_baking_files.resolve_location cctxt ~chain `Nonce
>>=? fun nonces_location ->
Client_baking_nonces.load cctxt nonces_location)
>>=? fun nonces ->
Lwt_list.filter_map_p
(fun hash ->
Lwt.catch
(fun () ->
Client_baking_blocks.info cctxt (`Hash (hash, 0))
>>= function
| Ok bi -> Lwt.return_some bi | Error _ -> Lwt.fail Not_found)
(fun _ ->
cctxt#warning
"Cannot find block %a in the chain. (ignoring)@."
Block_hash.pp_short
hash
>>= fun () -> Lwt.return_none))
block_hashes
>>= fun block_infos ->
filter_map_s
(fun (bi : Client_baking_blocks.block_info) ->
match Client_baking_nonces.find_opt nonces bi.hash with
| None ->
cctxt#warning
"Cannot find nonces for block %a (ignoring)@."
Block_hash.pp_short
bi.hash
>>= fun () -> return_none
| Some nonce ->
return_some (bi.hash, (bi.level, nonce)))
block_infos
>>=? fun nonces ->
let nonces = List.map snd nonces in
do_reveal cctxt ~chain ~block nonces
let reveal_nonces (cctxt : #Protocol_client_context.full) ~chain ~block () =
let open Client_baking_nonces in
cctxt#with_lock (fun () ->
Client_baking_files.resolve_location cctxt ~chain `Nonce
>>=? fun nonces_location ->
load cctxt nonces_location
>>=? fun nonces ->
get_unrevealed_nonces cctxt nonces_location nonces
>>=? fun nonces_to_reveal ->
do_reveal cctxt ~chain ~block nonces_to_reveal
>>=? fun () ->
filter_outdated_nonces cctxt nonces_location nonces
>>=? fun nonces ->
save cctxt nonces_location nonces >>=? fun () -> return_unit)
src/proto_alpha/lib_delegate/client_baking_lib.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Definition bake_block {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N)
(minimal_fees : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(minimal_nanotez_per_gas_unit : option Z.t)
(minimal_nanotez_per_byte : option Z.t) (force : option bool)
(max_priority : option Z) (op_staroptstar : option bool)
: (option string) ->
(option string) ->
(option Tezos_client_base.Client_keys.sk_uri) ->
Tezos_shell_services.Shell_services.chain ->
Tezos_shell_services.Shell_services.block ->
Tezos_client_base.Client_keys.Public_key_hash.t ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let minimal_timestamp :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun mempool =>
fun context_path =>
fun src_sk =>
fun chain =>
fun head =>
fun delegate =>
op_gtgteqquestion
match src_sk with
| None =>
op_gtgteqquestion (Client_keys.get_key cctxt delegate)
(fun function_parameter =>
let '(_, _, src_sk) := function_parameter in
_return src_sk)
| Some sk => _return sk
end
(fun src_sk =>
op_gtgteqquestion
(Alpha_services.Helpers.current_level cctxt
(Some
(* ❌ Constant of type int32 is converted to int *)
1) (chain, head))
(fun level =>
let '(seed_nonce, seed_nonce_hash) :=
if expected_commitment level then
let seed_nonce :=
Client_baking_forge.generate_seed_nonce tt in
let seed_nonce_hash := Nonce.hash seed_nonce in
((Some seed_nonce), (Some seed_nonce_hash))
else
(None, None) in
let timestamp :=
if minimal_timestamp then
None
else
Some (to_protocol (Systime_os.now tt)) in
op_gtgteqquestion
(Client_baking_forge.forge_block cctxt force None None
None minimal_fees minimal_nanotez_per_gas_unit
minimal_nanotez_per_byte timestamp mempool
context_path seed_nonce_hash chain
(* ❌ Variants not supported *)
variant delegate src_sk head)
(fun block_hash =>
op_gtgteqquestion
match seed_nonce with
| None => return_unit
| Some seed_nonce =>
OCaml.Stdlib.reverse_apply
((* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_baking_files.resolve_location
cctxt chain
(* ❌ Variants not supported *)
variant)
(fun nonces_location =>
op_gtgteqquestion
(load cctxt nonces_location)
(fun nonces =>
let nonces :=
add nonces block_hash seed_nonce
in
save cctxt nonces_location nonces))))
(trace_exn
(OCaml.Failure
"Error while recording block" % string))
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Injected block " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Injected block %a" % string)
Block_hash.pp_short block_hash)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))).
Definition endorse_block {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Chain_services.chain)
(delegate : Tezos_client_base.Client_keys.Public_key_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (Client_keys.get_key cctxt delegate)
(fun function_parameter =>
let '(_src_name, src_pk, src_sk) := function_parameter in
op_gtgteqquestion
(Client_baking_endorsement.forge_endorsement cctxt None chain
(* ❌ Sending method message is not handled *)
send src_sk src_pk)
(fun oph =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Operation successfully injected in the node." % string
CamlinternalFormatBasics.End_of_format)
"Operation successfully injected in the node." % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Operation hash is '" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal "'." % string
CamlinternalFormatBasics.End_of_format)))
"Operation hash is '%a'." % string) Operation_hash.pp oph)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))).
Definition get_predecessor_cycle {C a b : Type}
(cctxt :
((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
* C))))) * C)
(cycle : Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.cycle)
: Lwt.t Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.cycle :=
match Cycle.pred cycle with
| None =>
if op_eq cycle root then
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No predecessor for the first cycle" % string
CamlinternalFormatBasics.End_of_format)
"No predecessor for the first cycle" % string)
else
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot compute the predecessor of cycle " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Cannot compute the predecessor of cycle %a" % string) Cycle.pp cycle
| Some cycle => Lwt._return cycle
end.
Definition do_reveal {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Chain_services.chain)
(block : Tezos_shell_services.Block_services.block)
(nonces :
list
(Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t *
Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
(Client_baking_revelation.inject_seed_nonce_revelation cctxt chain block
None nonces)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit).
Definition reveal_block_nonces {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Chain_services.chain)
(block : Tezos_shell_services.Block_services.block)
(block_hashes : list Tezos_base__TzPervasives.Block_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_baking_files.resolve_location cctxt chain
(* ❌ Variants not supported *)
variant)
(fun nonces_location =>
Client_baking_nonces.load cctxt nonces_location)))
(fun nonces =>
op_gtgteq
(Lwt_list.filter_map_p
(fun hash =>
Lwt.catch
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Client_baking_blocks.info cctxt None
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok bi => Lwt.return_some bi
| Stdlib.Error _ => Lwt.fail OCaml.Not_found
end))
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot find block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" in the chain. (ignoring)" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Cannot find block %a in the chain. (ignoring)@." % string)
Block_hash.pp_short hash)
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_none))) block_hashes)
(fun block_infos =>
op_gtgteqquestion
(filter_map_s
(fun bi =>
match Client_baking_nonces.find_opt nonces (hash bi) with
| None =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot find nonces for block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (ignoring)" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Cannot find nonces for block %a (ignoring)@." % string)
Block_hash.pp_short (hash bi))
(fun function_parameter =>
let 'tt := function_parameter in
return_none)
| Some nonce => return_some ((hash bi), ((level bi), nonce))
end) block_infos)
(fun nonces =>
let nonces := List.map snd nonces in
do_reveal cctxt chain block nonces))).
Definition reveal_nonces {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services.Chain_services.chain)
(block : Tezos_shell_services.Block_services.block)
(function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let 'tt := function_parameter in
(* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_baking_files.resolve_location cctxt chain
(* ❌ Variants not supported *)
variant)
(fun nonces_location =>
op_gtgteqquestion (load cctxt nonces_location)
(fun nonces =>
op_gtgteqquestion
(get_unrevealed_nonces cctxt nonces_location nonces)
(fun nonces_to_reveal =>
op_gtgteqquestion
(do_reveal cctxt chain block nonces_to_reveal)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(filter_outdated_nonces cctxt None nonces_location
nonces)
(fun nonces =>
op_gtgteqquestion (save cctxt nonces_location nonces)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))))).
src/proto_alpha/lib_delegate/client_baking_nonces.ml 183 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
include Internal_event.Legacy_logging.Make_semantic (struct
let name = Protocol.name ^ ".baking.nonces"
end)
type t = Nonce.t Block_hash.Map.t
let empty = Block_hash.Map.empty
let encoding =
let open Data_encoding in
def "seed_nonce"
@@ conv
(fun m ->
Block_hash.Map.fold (fun hash nonce acc -> (hash, nonce) :: acc) m [])
(fun l ->
List.fold_left
(fun map (hash, nonce) -> Block_hash.Map.add hash nonce map)
Block_hash.Map.empty
l)
@@ list (obj2 (req "block" Block_hash.encoding) (req "nonce" Nonce.encoding))
let load (wallet : #Client_context.wallet) location =
wallet#load (Client_baking_files.filename location) ~default:empty encoding
let save (wallet : #Client_context.wallet) location nonces =
wallet#write (Client_baking_files.filename location) nonces encoding
let mem nonces hash = Block_hash.Map.mem hash nonces
let find_opt nonces hash = Block_hash.Map.find_opt hash nonces
let add nonces hash nonce = Block_hash.Map.add hash nonce nonces
let add_all nonces nonces_to_add =
Block_hash.Map.fold
(fun hash nonce acc -> add acc hash nonce)
nonces_to_add
nonces
let remove nonces hash = Block_hash.Map.remove hash nonces
let remove_all nonces nonces_to_remove =
Block_hash.Map.fold
(fun hash _ acc -> remove acc hash)
nonces_to_remove
nonces
let get_block_level_opt cctxt ~chain ~block =
Shell_services.Blocks.Header.shell_header cctxt ~chain ~block ()
>>= function
| Ok {level; _} ->
Lwt.return_some level
| Error errs ->
lwt_warn
Tag.DSL.(
fun f ->
f
"@[<v 2>Cannot retrieve block %a header associated to nonce:@ \
@[%a@]@]@."
-% t event "cannot_retrieve_block_header"
-% a Logging.block_tag block -% a errs_tag errs)
>>= fun () -> Lwt.return_none
let get_outdated_nonces cctxt ?constants ~chain nonces =
( match constants with
| None ->
Alpha_services.Constants.all cctxt (chain, `Head 0)
| Some constants ->
return constants )
>>=? fun {Constants.parametric = {blocks_per_cycle; preserved_cycles; _}; _} ->
get_block_level_opt cctxt ~chain ~block:(`Head 0)
>>= function
| None ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Cannot fetch chain's head level. Aborting nonces filtering."
-% t event "cannot_retrieve_head_level")
>>= fun () -> return (empty, empty)
| Some current_level ->
let current_cycle = Int32.(div current_level blocks_per_cycle) in
let is_older_than_preserved_cycles block_level =
let block_cycle = Int32.(div block_level blocks_per_cycle) in
Int32.sub current_cycle block_cycle > Int32.of_int preserved_cycles
in
Block_hash.Map.fold
(fun hash nonce acc ->
acc
>>=? fun (orphans, outdated) ->
get_block_level_opt cctxt ~chain ~block:(`Hash (hash, 0))
>>= function
| Some level ->
if is_older_than_preserved_cycles level then
return (orphans, add outdated hash nonce)
else acc
| None ->
return (add orphans hash nonce, outdated))
nonces
(return (empty, empty))
let filter_outdated_nonces cctxt ?constants location nonces =
let chain = Client_baking_files.chain location in
get_outdated_nonces cctxt ?constants ~chain nonces
>>=? fun (orphans, outdated_nonces) ->
( if Block_hash.Map.cardinal orphans >= 50 then
lwt_warn
Tag.DSL.(
fun f ->
f
"Found too many nonces associated to blocks unknown by the node \
in '$TEZOS_CLIENT/%s'. After checking that these blocks were \
never included in the chain (e.g. via a block explorer), \
consider using `tezos-client filter orphan nonces` to clear them."
-% s
Logging.filename_tag
(Client_baking_files.filename location ^ "s")
-% t event "too_many_orphans")
>>= fun () -> Lwt.return_unit
else Lwt.return_unit )
>>= fun () -> return (remove_all nonces outdated_nonces)
let get_unrevealed_nonces cctxt location nonces =
let chain = Client_baking_files.chain location in
Client_baking_blocks.blocks_from_current_cycle
cctxt
~chain
(`Head 0)
~offset:(-1l)
()
>>=? fun blocks ->
filter_map_s
(fun hash ->
match find_opt nonces hash with
| None ->
return_none
| Some nonce -> (
get_block_level_opt cctxt ~chain ~block:(`Hash (hash, 0))
>>= function
| Some level -> (
Lwt.return (Environment.wrap_error (Raw_level.of_int32 level))
>>=? fun level ->
Alpha_services.Nonce.get cctxt (chain, `Head 0) level
>>=? function
| Missing nonce_hash when Nonce.check_hash nonce nonce_hash ->
lwt_log_notice
Tag.DSL.(
fun f ->
f "Found nonce to reveal for %a (level: %a)"
-% t event "found_nonce"
-% a Block_hash.Logging.tag hash
-% a Logging.level_tag level)
>>= fun () -> return_some (level, nonce)
| Missing _nonce_hash ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Incoherent nonce for level %a"
-% t event "bad_nonce" -% a Logging.level_tag level)
>>= fun () -> return_none
| Forgotten ->
return_none
| Revealed _ ->
return_none )
| None ->
return_none ))
blocks
src/proto_alpha/lib_delegate/client_baking_nonces.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
(* ❌ Structure item `include` not handled. *)
include
Definition t :=
Tezos_base__TzPervasives.Block_hash.Map.t
Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t.
Definition empty {A : Type} : Tezos_base__TzPervasives.Block_hash.Map.t A :=
Block_hash.Map.empty.
Definition encoding
: Tezos_base__TzPervasives.Data_encoding.encoding
(Tezos_base__TzPervasives.Block_hash.Map.t
Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce) :=
apply
(let arg := def "seed_nonce" % string in
fun eta => arg None None eta)
(apply
(let arg :=
conv
(fun m =>
Block_hash.Map.fold
(fun hash => fun nonce => fun acc => cons (hash, nonce) acc) m [])
(fun l =>
List.fold_left
(fun map =>
fun function_parameter =>
let '(hash, nonce) := function_parameter in
Block_hash.Map.add hash nonce map) Block_hash.Map.empty l) in
fun eta => arg None eta)
(list None
(obj2 (req None None "block" % string Block_hash.encoding)
(req None None "nonce" % string Nonce.encoding)))).
Definition load {B C a : Type}
(wallet :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (location : Tezos_baking_alpha.Client_baking_files.location C)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Block_hash.Map.t
Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce)) :=
(* ❌ Sending method message is not handled *)
send (Client_baking_files.filename location) empty encoding.
Definition save {B C a : Type}
(wallet :
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
* B) (location : Tezos_baking_alpha.Client_baking_files.location C)
(nonces :
Tezos_base__TzPervasives.Block_hash.Map.t
Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
(* ❌ Sending method message is not handled *)
send (Client_baking_files.filename location) nonces encoding.
Definition mem {A : Type}
(nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
(hash : Tezos_base__TzPervasives.Block_hash.Map.key) : bool :=
Block_hash.Map.mem hash nonces.
Definition find_opt {A : Type}
(nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
(hash : Tezos_base__TzPervasives.Block_hash.Map.key) : option A :=
Block_hash.Map.find_opt hash nonces.
Definition add {A : Type}
(nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
(hash : Tezos_base__TzPervasives.Block_hash.Map.key) (nonce : A)
: Tezos_base__TzPervasives.Block_hash.Map.t A :=
Block_hash.Map.add hash nonce nonces.
Definition add_all {A : Type}
(nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
(nonces_to_add : Tezos_base__TzPervasives.Block_hash.Map.t A)
: Tezos_base__TzPervasives.Block_hash.Map.t A :=
Block_hash.Map.fold (fun hash => fun nonce => fun acc => add acc hash nonce)
nonces_to_add nonces.
Definition remove {A : Type}
(nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
(hash : Tezos_base__TzPervasives.Block_hash.Map.key)
: Tezos_base__TzPervasives.Block_hash.Map.t A :=
Block_hash.Map.remove hash nonces.
Definition remove_all {A B : Type}
(nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
(nonces_to_remove : Tezos_base__TzPervasives.Block_hash.Map.t B)
: Tezos_base__TzPervasives.Block_hash.Map.t A :=
Block_hash.Map.fold
(fun hash =>
fun function_parameter =>
let '_ := function_parameter in
fun acc => remove acc hash) nonces_to_remove nonces.
Definition get_block_level_opt {E F i o p q : Type}
(cctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * F) * F)
(chain : Tezos_shell_services__Block_services.chain)
(block : Tezos_shell_services__Block_services.block)
: Lwt.t (option Stdlib.Int32.t) :=
op_gtgteq
(Shell_services.Blocks.Header.shell_header cctxt (Some chain) (Some block)
tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok {| level := level |} => Lwt.return_some level
| Stdlib.Error errs =>
op_gtgteq
(lwt_warn
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Cannot retrieve block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" header associated to nonce:" % string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break "@ " % string
1 0)
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format
"" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))))))))
"@[<v 2>Cannot retrieve block %a header associated to nonce:@ @[%a@]@]@."
% string))
(t event "cannot_retrieve_block_header" % string))
(a Logging.block_tag block)) (a errs_tag errs)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_none)
end).
Definition get_outdated_nonces {E F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(Tezos_shell_services__Block_services.chain * variant) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
(Tezos_shell_services__Block_services.chain * variant) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
(Tezos_shell_services__Block_services.chain * variant) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(Tezos_shell_services__Block_services.chain * variant) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (L * a * b * c * q * i * o)) * M))))) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * M) *
(Tezos_shell_services__Block_services.chain * variant))
(constants : option Tezos_raw_protocol_alpha.Alpha_context.Constants.t)
(chain : Tezos_shell_services__Block_services.chain)
(nonces : Tezos_base__TzPervasives.Block_hash.Map.t N)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
((Tezos_base__TzPervasives.Block_hash.Map.t N) *
(Tezos_base__TzPervasives.Block_hash.Map.t N))) :=
op_gtgteqquestion
match constants with
| None =>
Alpha_services.Constants.all cctxt
(chain,
(* ❌ Variants not supported *)
variant)
| Some constants => _return constants
end
(fun function_parameter =>
let '{|
Constants.parametric := {|
preserved_cycles := preserved_cycles;
blocks_per_cycle := blocks_per_cycle
|}
|} := function_parameter in
op_gtgteq
(get_block_level_opt cctxt chain
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
match function_parameter with
| None =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Cannot fetch chain's head level. Aborting nonces filtering."
% string CamlinternalFormatBasics.End_of_format)
"Cannot fetch chain's head level. Aborting nonces filtering."
% string))
(t event "cannot_retrieve_head_level" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
_return (empty, empty))
| Some current_level =>
let current_cycle := div current_level blocks_per_cycle in
let is_older_than_preserved_cycles (block_level : int32) : bool :=
let block_cycle := div block_level blocks_per_cycle in
OCaml.Stdlib.gt (Int32.sub current_cycle block_cycle)
(Int32.of_int preserved_cycles) in
Block_hash.Map.fold
(fun hash =>
fun nonce =>
fun acc =>
op_gtgteqquestion acc
(fun function_parameter =>
let '(orphans, outdated) := function_parameter in
op_gtgteq
(get_block_level_opt cctxt chain
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
match function_parameter with
| Some level =>
if is_older_than_preserved_cycles level then
_return (orphans, (add outdated hash nonce))
else
acc
| None =>
_return ((add orphans hash nonce), outdated)
end))) nonces (_return (empty, empty))
end)).
Definition filter_outdated_nonces {E F H J L M N O a b c i o p q : Type}
(cctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(Tezos_shell_services__Block_services.chain * variant) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
(Tezos_shell_services__Block_services.chain * variant) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
(Tezos_shell_services__Block_services.chain * variant) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(Tezos_shell_services__Block_services.chain * variant) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (L * a * b * c * q * i * o)) * M))))) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) * M) *
(Tezos_shell_services__Block_services.chain * variant))
(constants : option Tezos_raw_protocol_alpha.Alpha_context.Constants.t)
(location : Tezos_baking_alpha.Client_baking_files.location N)
(nonces : Tezos_base__TzPervasives.Block_hash.Map.t O)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_base__TzPervasives.Block_hash.Map.t O)) :=
let chain := Client_baking_files.chain location in
op_gtgteqquestion (get_outdated_nonces cctxt constants chain nonces)
(fun function_parameter =>
let '(orphans, outdated_nonces) := function_parameter in
op_gtgteq
(if OCaml.Stdlib.ge (Block_hash.Map.cardinal orphans) 50 then
op_gtgteq
(lwt_warn
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Found too many nonces associated to blocks unknown by the node in '$TEZOS_CLIENT/"
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"'. After checking that these blocks were never included in the chain (e.g. via a block explorer), consider using `tezos-client filter orphan nonces` to clear them."
% string CamlinternalFormatBasics.End_of_format)))
"Found too many nonces associated to blocks unknown by the node in '$TEZOS_CLIENT/%s'. After checking that these blocks were never included in the chain (e.g. via a block explorer), consider using `tezos-client filter orphan nonces` to clear them."
% string))
(s Logging.filename_tag
(String.append (Client_baking_files.filename location)
"s" % string))) (t event "too_many_orphans" % string)))
(fun function_parameter =>
let 'tt := function_parameter in
Lwt.return_unit)
else
Lwt.return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
_return (remove_all nonces outdated_nonces))).
Definition get_unrevealed_nonces {D F H J L M N O a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
(Uri.t *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option Tezos_data_encoding.Data_encoding.json))) *
N)))))))) * N)
(location : Tezos_baking_alpha.Client_baking_files.location O)
(nonces :
Tezos_base__TzPervasives.Block_hash.Map.t
Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
(Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.raw_level *
Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce))) :=
let chain := Client_baking_files.chain location in
op_gtgteqquestion
(Client_baking_blocks.blocks_from_current_cycle cctxt (Some chain)
(* ❌ Variants not supported *)
variant
(Some
(* ❌ Constant of type int32 is converted to int *)
(-1)) tt)
(fun blocks =>
filter_map_s
(fun hash =>
match find_opt nonces hash with
| None => return_none
| Some nonce =>
op_gtgteq
(get_block_level_opt cctxt chain
(* ❌ Variants not supported *)
variant)
(fun function_parameter =>
match function_parameter with
| Some level =>
op_gtgteqquestion
(Lwt._return
(Environment.wrap_error (Raw_level.of_int32 level)))
(fun level =>
op_gtgteqquestion
(Alpha_services.Nonce.get cctxt
(chain,
(* ❌ Variants not supported *)
variant) level)
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Alpha_services.Nonce.Missing
nonce_hash =>
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Found nonce to reveal for " %
string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" (level: " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Char_literal
")" % char
CamlinternalFormatBasics.End_of_format)))))
"Found nonce to reveal for %a (level: %a)"
% string))
(t event "found_nonce" % string))
(a Block_hash.Logging.tag hash))
(a Logging.level_tag level)))
(fun function_parameter =>
let 'tt := function_parameter in
return_some (level, nonce))
|
Tezos_protocol_alpha.Protocol.Alpha_services.Nonce.Missing
_nonce_hash =>
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Incoherent nonce for level " %
string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Incoherent nonce for level %a" %
string))
(t event "bad_nonce" % string))
(a Logging.level_tag level)))
(fun function_parameter =>
let 'tt := function_parameter in
return_none)
|
Tezos_protocol_alpha.Protocol.Alpha_services.Nonce.Forgotten
=> return_none
|
Tezos_protocol_alpha.Protocol.Alpha_services.Nonce.Revealed
_ => return_none
end))
| None => return_none
end)
end) blocks).
src/proto_alpha/lib_delegate/client_baking_pow.ml 22 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
let default_constant = "\x00\x00\x00\x05"
let is_updated_constant =
let commit_hash =
if TzString.is_hex Tezos_version.Current_git_info.commit_hash then
Hex.to_string (`Hex Tezos_version.Current_git_info.commit_hash)
else Tezos_version.Current_git_info.commit_hash
in
if String.length commit_hash >= 4 then String.sub commit_hash 0 4
else default_constant
let is_updated_constant_len = String.length is_updated_constant
(* add a version to the pow *)
let init_proof_of_work_nonce () =
let buf =
Bytes.make Alpha_context.Constants.proof_of_work_nonce_size '\000'
in
Bytes.blit_string is_updated_constant 0 buf 0 is_updated_constant_len ;
let max_z_len =
Alpha_context.Constants.proof_of_work_nonce_size - is_updated_constant_len
in
let rec aux z =
let z_len = (Z.numbits z + 7) / 8 in
if z_len > max_z_len then Seq.Nil
else (
Bytes.blit_string (Z.to_bits z) 0 buf is_updated_constant_len z_len ;
Seq.Cons (buf, fun () -> aux (Z.succ z)) )
in
aux Z.zero
(* This was used before November 2018 *)
(* (\* Random proof of work *\)
* let generate_proof_of_work_nonce () =
* Rand.generate Alpha_context.Constants.proof_of_work_nonce_size *)
let empty_proof_of_work_nonce =
Bytes.make Constants_repr.proof_of_work_nonce_size '\000'
let mine cctxt chain block shell builder =
Alpha_services.Constants.all cctxt (chain, block)
>>=? fun constants ->
let threshold = constants.parametric.proof_of_work_threshold in
let rec loop nonce_seq =
match nonce_seq with
| Seq.Nil ->
failwith
"Client_baking_pow.mine: couldn't find nonce for required proof of \
work"
| Seq.Cons (nonce, seq) ->
let block = builder nonce in
if Baking.check_header_proof_of_work_stamp shell block threshold then
return block
else loop (seq ())
in
loop (init_proof_of_work_nonce ())
src/proto_alpha/lib_delegate/client_baking_pow.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Definition default_constant : string := " " % string.
Definition is_updated_constant : string :=
let commit_hash :=
if TzString.is_hex Tezos_version.Current_git_info.commit_hash then
Hex.to_string
(* ❌ Variants not supported *)
variant
else
Tezos_version.Current_git_info.commit_hash in
if OCaml.Stdlib.ge (String.length commit_hash) 4 then
String.sub commit_hash 0 4
else
default_constant.
Definition is_updated_constant_len : Z := String.length is_updated_constant.
Definition init_proof_of_work_nonce (function_parameter : unit)
: Stdlib.Seq.node string :=
let 'tt := function_parameter in
let buf :=
Stdlib.Bytes.make Alpha_context.Constants.proof_of_work_nonce_size
"000" % char in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.Bytes.blit_string is_updated_constant 0 buf 0 is_updated_constant_len
in
let max_z_len :=
Z.sub Alpha_context.Constants.proof_of_work_nonce_size
is_updated_constant_len in
let fix aux (z : Z.t) : Stdlib.Seq.node string :=
let z_len := Z.div (Z.add (Z.numbits z) 7) 8 in
if OCaml.Stdlib.gt z_len max_z_len then
Stdlib.Seq.Nil
else
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Stdlib.Bytes.blit_string (Z.to_bits z) 0 buf is_updated_constant_len
z_len in
Stdlib.Seq.Cons buf
(fun function_parameter =>
let 'tt := function_parameter in
aux (Z.succ z)) in
aux Z.zero.
Definition empty_proof_of_work_nonce : string :=
Stdlib.Bytes.make Constants_repr.proof_of_work_nonce_size "000" % char.
Definition mine {D E F H J L M a b c i o q : Type}
(cctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
(D * E) ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (F * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
(D * E) ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (H * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
(D * E) ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (J * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
(D * E) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (L * a * b * c * q * i * o)) * M)))) * M *
(D * E)) (chain : D) (block : E)
(shell : Tezos_raw_protocol_alpha.Alpha_context.Block_header.shell_header)
(builder :
string -> Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents) :=
op_gtgteqquestion (Alpha_services.Constants.all cctxt (chain, block))
(fun constants =>
let threshold := proof_of_work_threshold (parametric constants) in
let fix loop (nonce_seq : Stdlib.Seq.node string)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents) :=
match nonce_seq with
| Stdlib.Seq.Nil =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Client_baking_pow.mine: couldn't find nonce for required proof of work"
% string CamlinternalFormatBasics.End_of_format)
"Client_baking_pow.mine: couldn't find nonce for required proof of work"
% string)
| Stdlib.Seq.Cons nonce seq =>
let block := builder nonce in
if Baking.check_header_proof_of_work_stamp shell block threshold then
_return block
else
loop (seq tt)
end in
loop (init_proof_of_work_nonce tt)).
src/proto_alpha/lib_delegate/client_baking_revelation.ml 89 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
include Internal_event.Legacy_logging.Make_semantic (struct
let name = Protocol.name ^ ".baking.nonce_revelation"
end)
let inject_seed_nonce_revelation (cctxt : #Protocol_client_context.full) ~chain
~block ?async nonces =
Shell_services.Blocks.hash cctxt ~chain ~block ()
>>=? fun hash ->
match nonces with
| [] ->
lwt_log_notice
Tag.DSL.(
fun f ->
f "Nothing to reveal for block %a"
-% t event "no_nonce_reveal"
-% a Block_hash.Logging.tag hash)
>>= fun () -> return_unit
| _ ->
iter_s
(fun (level, nonce) ->
Alpha_services.Forge.seed_nonce_revelation
cctxt
(chain, block)
~branch:hash
~level
~nonce
()
>>=? fun bytes ->
let bytes = Signature.concat bytes Signature.zero in
Shell_services.Injection.operation cctxt ?async ~chain bytes
>>=? fun oph ->
lwt_log_notice
Tag.DSL.(
fun f ->
f
"Revealing nonce %a from level %a for chain %a, block %a \
with operation %a"
-% t event "reveal_nonce" -% a Logging.nonce_tag nonce
-% a Logging.level_tag level -% a Logging.chain_tag chain
-% a Logging.block_tag block
-% a Operation_hash.Logging.tag oph)
>>= fun () -> return_unit)
nonces
src/proto_alpha/lib_delegate/client_baking_revelation.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
(* ❌ Structure item `include` not handled. *)
include
Definition inject_seed_nonce_revelation {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (chain : Tezos_shell_services__Block_services.chain)
(block : Tezos_shell_services__Block_services.block) (async : option bool)
(nonces :
list
(Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t *
Tezos_raw_protocol_alpha.Alpha_context.Nonce.t))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
(Shell_services.Blocks.hash cctxt (Some chain) (Some block) tt)
(fun hash =>
match nonces with
| [] =>
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Nothing to reveal for block " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Nothing to reveal for block %a" % string))
(t event "no_nonce_reveal" % string))
(a Block_hash.Logging.tag hash)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| _ =>
iter_s
(fun function_parameter =>
let '(level, nonce) := function_parameter in
op_gtgteqquestion
(Alpha_services.Forge.seed_nonce_revelation cctxt (chain, block)
hash level nonce tt)
(fun bytes =>
let bytes := Signature.concat string Signature.zero in
op_gtgteqquestion
(Shell_services.Injection.operation cctxt async (Some chain)
string)
(fun oph =>
op_gtgteq
(lwt_log_notice
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Revealing nonce " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" from level " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" for chain " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
", block " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" with operation " %
string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))))))))))
"Revealing nonce %a from level %a for chain %a, block %a with operation %a"
% string))
(t event "reveal_nonce" % string))
(a Logging.nonce_tag nonce))
(a Logging.level_tag level))
(a Logging.chain_tag chain))
(a Logging.block_tag block))
(a Operation_hash.Logging.tag oph)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))) nonces
end).
src/proto_alpha/lib_delegate/client_baking_scheduling.ml 310 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Internal_event.Legacy_logging.Make_semantic (struct
let name = Protocol.name ^ ".baking.scheduling"
end)
open Logging
let sleep_until time =
(* Sleeping is a system op, baking is a protocol op, this is where we convert *)
let time = Time.System.of_protocol_exn time in
let delay = Ptime.diff time (Tezos_stdlib_unix.Systime_os.now ()) in
if Ptime.Span.compare delay Ptime.Span.zero < 0 then None
else Some (Lwt_unix.sleep (Ptime.Span.to_float_s delay))
let rec wait_for_first_event ~name stream =
Lwt_stream.get stream
>>= function
| None | Some (Error _) ->
lwt_log_info
Tag.DSL.(
fun f ->
f "Can't fetch the current event. Waiting for new event."
-% t event "cannot_fetch_event"
-% t worker_tag name)
>>= fun () ->
(* NOTE: this is not a tight loop because of Lwt_stream.get *)
wait_for_first_event ~name stream
| Some (Ok bi) ->
Lwt.return bi
let log_errors_and_continue ~name p =
p
>>= function
| Ok () ->
Lwt.return_unit
| Error errs ->
lwt_log_error
Tag.DSL.(
fun f ->
f "Error while baking:@\n%a"
-% t event "daemon_error" -% t worker_tag name -% a errs_tag errs)
let main ~(name : string) ~(cctxt : #Protocol_client_context.full)
~(stream : 'event tzresult Lwt_stream.t)
~(state_maker : 'event -> 'state tzresult Lwt.t)
~(pre_loop :
#Protocol_client_context.full -> 'state -> 'event -> unit tzresult Lwt.t)
~(compute_timeout : 'state -> 'timesup Lwt.t)
~(timeout_k :
#Protocol_client_context.full ->
'state ->
'timesup ->
unit tzresult Lwt.t)
~(event_k :
#Protocol_client_context.full -> 'state -> 'event -> unit tzresult Lwt.t)
=
lwt_log_info
Tag.DSL.(
fun f ->
f "Setting up before the %s can start."
-% t event "daemon_setup" -% s worker_tag name)
>>= fun () ->
wait_for_first_event ~name stream
>>= fun first_event ->
(* statefulness *)
let last_get_event = ref None in
let get_event () =
match !last_get_event with
| None ->
let t = Lwt_stream.get stream in
last_get_event := Some t ;
t
| Some t ->
t
in
state_maker first_event
>>=? fun state ->
log_errors_and_continue ~name @@ pre_loop cctxt state first_event
>>= fun () ->
(* main loop *)
let rec worker_loop () =
(* event construction *)
let timeout = compute_timeout state in
Lwt.choose
[ (Lwt_exit.termination_thread >|= fun _ -> `Termination);
(timeout >|= fun timesup -> `Timeout timesup);
(get_event () >|= fun e -> `Event e) ]
>>= function
(* event matching *)
| `Termination ->
return_unit
| `Event (None | Some (Error _)) ->
(* exit when the node is unavailable *)
last_get_event := None ;
lwt_log_error
Tag.DSL.(
fun f ->
f "Connection to node lost, %s exiting."
-% t event "daemon_connection_lost"
-% s worker_tag name)
>>= fun () -> return_unit
| `Event (Some (Ok event)) ->
(* new event: cancel everything and execute callback *)
last_get_event := None ;
(* TODO: pretty-print events (requires passing a pp as argument) *)
log_errors_and_continue ~name @@ event_k cctxt state event
>>= fun () -> worker_loop ()
| `Timeout timesup ->
(* main event: it's time *)
lwt_debug
Tag.DSL.(
fun f ->
f "Waking up for %s." -% t event "daemon_wakeup"
-% s worker_tag name)
>>= fun () ->
(* core functionality *)
log_errors_and_continue ~name @@ timeout_k cctxt state timesup
>>= fun () -> worker_loop ()
in
(* ignition *)
lwt_log_info
Tag.DSL.(
fun f ->
f "Starting %s daemon" -% t event "daemon_start" -% s worker_tag name)
>>= fun () -> worker_loop ()
src/proto_alpha/lib_delegate/client_baking_scheduling.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Import Logging.
Definition sleep_until (time : Tezos_base__Time.Protocol.t)
: option (Lwt.t unit) :=
let time := Time.System.of_protocol_exn time in
let delay := Ptime.diff time (Tezos_stdlib_unix.Systime_os.now tt) in
if OCaml.Stdlib.lt (Ptime.Span.compare delay Ptime.Span.zero) 0 then
None
else
Some (Lwt_unix.sleep (Ptime.Span.to_float_s delay)).
Fixpoint wait_for_first_event {A B : Type}
(name : string) (stream : Lwt_stream.t (sum A B)) : Lwt.t A :=
op_gtgteq (Lwt_stream.get stream)
(fun function_parameter =>
match function_parameter with
| None | Some (Stdlib.Error _) =>
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Can't fetch the current event. Waiting for new event."
% string CamlinternalFormatBasics.End_of_format)
"Can't fetch the current event. Waiting for new event." %
string)) (t event "cannot_fetch_event" % string))
(t worker_tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
wait_for_first_event name stream)
| Some (Stdlib.Ok bi) => Lwt._return bi
end).
Definition log_errors_and_continue
(name : string) (p : Lwt.t (sum unit Tezos_base__TzPervasives.trace))
: Lwt.t unit :=
op_gtgteq p
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok tt => Lwt.return_unit
| Stdlib.Error errs =>
lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error while baking:" % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Force_newline
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format)))
"Error while baking:@
%a" % string))
(t event "daemon_error" % string)) (t worker_tag name))
(a errs_tag errs))
end).
Definition main
{D F H J L M N Q R S T U V X Y Z [ \ ] _ ` a b c event i o op_caret p q state
timesup : Type}
(name : string)
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (stream : Lwt_stream.t (Tezos_base__TzPervasives.tzresult event))
(state_maker : event -> Lwt.t (Tezos_base__TzPervasives.tzresult state))
(pre_loop :
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (Q * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (R * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (S * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (T * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (U * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (V * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) -> state -> event -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
(compute_timeout : state -> Lwt.t timesup)
(timeout_k :
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (X * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (Y * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (Z * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * ([ * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (\ * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (] * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) -> state -> timesup -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
(event_k :
(((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (op_caret * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (_ * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (` * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (a * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (b * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (c * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) -> state -> event -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Setting up before the " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" can start." % string
CamlinternalFormatBasics.End_of_format)))
"Setting up before the %s can start." % string))
(t event "daemon_setup" % string)) (s worker_tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (wait_for_first_event name stream)
(fun first_event =>
let last_get_event := Stdlib.ref None in
let get_event (function_parameter : unit)
: Lwt.t (option (Tezos_base__TzPervasives.tzresult event)) :=
let 'tt := function_parameter in
match Stdlib.op_exclamation last_get_event with
| None =>
let t := Lwt_stream.get stream in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq last_get_event (Some t) in
t
| Some t => t
end in
op_gtgteqquestion (state_maker first_event)
(fun state =>
op_gtgteq
(apply (log_errors_and_continue name)
(pre_loop cctxt state first_event))
(fun function_parameter =>
let 'tt := function_parameter in
let fix worker_loop (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let 'tt := function_parameter in
let timeout := compute_timeout state in
op_gtgteq
(Lwt.choose
(cons
(op_gtpipeeq Lwt_exit.termination_thread
(fun function_parameter =>
let '_ := function_parameter in
(* ❌ Variants not supported *)
variant))
(cons
(op_gtpipeeq timeout
(fun timesup =>
(* ❌ Variants not supported *)
variant))
(cons
(op_gtpipeeq (get_event tt)
(fun e =>
(* ❌ Variants not supported *)
variant)) []))))
(fun function_parameter =>
match function_parameter with
| Termination => return_unit
| Event (None | Some (Stdlib.Error _)) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq last_get_event None in
op_gtgteq
(lwt_log_error
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Connection to node lost, " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" exiting." % string
CamlinternalFormatBasics.End_of_format)))
"Connection to node lost, %s exiting." %
string))
(t event "daemon_connection_lost" % string))
(s worker_tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
| Event (Some (Stdlib.Ok event)) =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Stdlib.op_coloneq last_get_event None in
op_gtgteq
(apply (log_errors_and_continue name)
(event_k cctxt state event))
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop tt)
| Timeout timesup =>
op_gtgteq
(lwt_debug
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Waking up for " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"." % char
CamlinternalFormatBasics.End_of_format)))
"Waking up for %s." % string))
(t event "daemon_wakeup" % string))
(s worker_tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(apply (log_errors_and_continue name)
(timeout_k cctxt state timesup))
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop tt))
end) in
op_gtgteq
(lwt_log_info
(fun f =>
op_minuspercent
(op_minuspercent
(f
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Starting " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" daemon" % string
CamlinternalFormatBasics.End_of_format)))
"Starting %s daemon" % string))
(t event "daemon_start" % string))
(s worker_tag name)))
(fun function_parameter =>
let 'tt := function_parameter in
worker_loop tt))))).
src/proto_alpha/lib_delegate/client_baking_simulator.ml 10 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol_client_context
open Protocol
open Alpha_context
type error += Failed_to_checkout_context
type error += Invalid_context
let ( >>=?? ) x k = x >>= fun x -> Lwt.return (Environment.wrap_error x) >>=? k
let () =
register_error_kind
`Permanent
~id:"Client_baking_simulator.failed_to_checkout_context"
~title:"Failed to checkout context"
~description:"The given context hash does not exists in the context."
~pp:(fun ppf () -> Format.fprintf ppf "Failed to checkout the context")
Data_encoding.unit
(function Failed_to_checkout_context -> Some () | _ -> None)
(fun () -> Failed_to_checkout_context) ;
register_error_kind
`Permanent
~id:"Client_baking_simulator.invalid_context"
~title:"Invalid context"
~description:"Occurs when the context is inconsistent."
~pp:(fun ppf () -> Format.fprintf ppf "The given context is invalid.")
Data_encoding.unit
(function Invalid_context -> Some () | _ -> None)
(fun () -> Invalid_context)
type incremental = {
predecessor : Client_baking_blocks.block_info;
context : Tezos_protocol_environment.Context.t;
state : Protocol.validation_state;
rev_operations : Operation.packed list;
header : Tezos_base.Block_header.shell_header;
}
let load_context ~context_path = Context.init ~readonly:true context_path
let check_context_consistency index context_hash =
(* Hypothesis : the version key exists *)
let version_key = ["version"] in
Context.checkout index context_hash
>>= function
| None ->
fail Failed_to_checkout_context
| Some context -> (
Context.mem context version_key
>>= function true -> return_unit | false -> fail Invalid_context )
let begin_construction ~timestamp ?protocol_data index predecessor =
let {Client_baking_blocks.context; _} = predecessor in
Shell_context.checkout index context
>>= function
| None ->
fail Failed_to_checkout_context
| Some context ->
let header : Tezos_base.Block_header.shell_header =
Tezos_base.Block_header.
{
predecessor = predecessor.hash;
proto_level = predecessor.proto_level;
validation_passes = 0;
fitness = predecessor.fitness;
timestamp;
level = Raw_level.to_int32 predecessor.level;
context = Context_hash.zero;
operations_hash = Operation_list_list_hash.zero;
}
in
Protocol.begin_construction
~chain_id:predecessor.chain_id
~predecessor_context:context
~predecessor_timestamp:predecessor.timestamp
~predecessor_fitness:predecessor.fitness
~predecessor_level:(Raw_level.to_int32 predecessor.level)
~predecessor:predecessor.hash
?protocol_data
~timestamp
()
>>=?? fun state ->
return {predecessor; context; state; rev_operations = []; header}
let add_operation st (op : Operation.packed) =
Protocol.apply_operation st.state op
>>=?? fun (state, receipt) ->
return ({st with state; rev_operations = op :: st.rev_operations}, receipt)
let finalize_construction inc = Protocol.finalize_block inc.state >>=?? return
src/proto_alpha/lib_delegate/client_baking_simulator.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol_client_context.
Import Protocol.
Import Alpha_context.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition op_gtgteqquestionquestion {A B : Type}
(x : Lwt.t (Tezos_protocol_alpha.Protocol.Environment.Error_monad.tzresult A))
(k : A -> Lwt.t (Tezos_base__TzPervasives.tzresult B))
: Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
op_gtgteq x
(fun x => op_gtgteqquestion (Lwt._return (Environment.wrap_error x)) k).
Record incremental := {
predecessor : Tezos_baking_alpha.Client_baking_blocks.block_info;
context : Tezos_protocol_environment.Context.t;
state : Tezos_protocol_alpha.Protocol.validation_state;
rev_operations :
list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed;
header : Tezos_base.Block_header.shell_header }.
Definition load_context (context_path : string)
: Lwt.t Tezos_storage.Context.index :=
Context.init None None (Some true) context_path.
Definition check_context_consistency
(index : Tezos_storage.Context.index)
(context_hash : Tezos_base__TzPervasives.Context_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let version_key := cons "version" % string [] in
op_gtgteq (Context.checkout index context_hash)
(fun function_parameter =>
match function_parameter with
| None => fail Tezos_base__TzPervasives.Failed_to_checkout_context
| Some context =>
op_gtgteq (Context.mem context version_key)
(fun function_parameter =>
match function_parameter with
| true => return_unit
| false => fail Tezos_base__TzPervasives.Invalid_context
end)
end).
Definition begin_construction
(timestamp : Tezos_base.Time.Protocol.t)
(protocol_data : option Tezos_protocol_alpha.Protocol.block_header_data)
(index : Tezos_storage.Context.index)
(predecessor : Tezos_baking_alpha.Client_baking_blocks.block_info)
: Lwt.t (Tezos_base__TzPervasives.tzresult incremental) :=
let '{| Client_baking_blocks.context := context |} := predecessor in
op_gtgteq (Shell_context.checkout index context)
(fun function_parameter =>
match function_parameter with
| None => fail Tezos_base__TzPervasives.Failed_to_checkout_context
| Some context =>
let header :=
{| level := Raw_level.to_int32 (level predecessor);
proto_level := proto_level predecessor;
predecessor := hash predecessor; timestamp := timestamp;
validation_passes := 0;
operations_hash := Operation_list_list_hash.zero;
fitness := fitness predecessor; context := Context_hash.zero |} in
op_gtgteqquestionquestion
(Protocol.begin_construction (chain_id predecessor) context
(timestamp predecessor) (Raw_level.to_int32 (level predecessor))
(fitness predecessor) (hash predecessor) timestamp protocol_data tt)
(fun state =>
_return
{| predecessor := predecessor; context := context; state := state;
rev_operations := []; header := header |})
end).
Definition add_operation
(st : incremental)
(op : Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(incremental * Tezos_protocol_alpha.Protocol.operation_receipt)) :=
op_gtgteqquestionquestion (Protocol.apply_operation (state st) op)
(fun function_parameter =>
let '(state, receipt) := function_parameter in
_return
((* ❌ Record substitution not handled *)
record_substitution, receipt)).
Definition finalize_construction (inc : incremental)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_protocol_environment_alpha__Environment.Updater.validation_result *
Tezos_protocol_alpha.Protocol.block_header_metadata)) :=
op_gtgteqquestionquestion (Protocol.finalize_block (state inc)) _return.
src/proto_alpha/lib_delegate/client_daemon.ml 437 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let rec retry (cctxt : #Protocol_client_context.full) ~delay ~tries f x =
f x
>>= function
| Ok _ as r ->
Lwt.return r
| Error
(RPC_client_errors.Request_failed {error = Connection_failed _; _} :: _)
as err
when tries > 0 -> (
cctxt#message "Connection refused, retrying in %.2f seconds..." delay
>>= fun () ->
Lwt.pick
[ (Lwt_unix.sleep delay >|= fun () -> `Continue);
(Lwt_exit.termination_thread >|= fun _ -> `Killed) ]
>>= function
| `Killed ->
Lwt.return err
| `Continue ->
retry cctxt ~delay:(delay *. 1.5) ~tries:(tries - 1) f x )
| Error _ as err ->
Lwt.return err
let await_bootstrapped_node (cctxt : #Protocol_client_context.full) =
(* Waiting for the node to be synchronized *)
cctxt#message "Waiting for the node to be synchronized with its peers..."
>>= fun () ->
retry cctxt ~tries:5 ~delay:1. Shell_services.Monitor.bootstrapped cctxt
>>=? fun (block_stream, _stopper) ->
let rec waiting_loop () =
Lwt_stream.get block_stream
>>= function None -> Lwt.return_unit | Some _ -> waiting_loop ()
in
waiting_loop ()
>>= fun () -> cctxt#message "Node synchronized." >>= fun () -> return_unit
let monitor_fork_testchain (cctxt : #Protocol_client_context.full)
~cleanup_nonces =
(* Waiting for the node to be synchronized *)
cctxt#message "Waiting for the test chain to be forked..."
>>= fun () ->
Shell_services.Monitor.active_chains cctxt
>>=? fun (stream, _) ->
let rec loop () =
Lwt_stream.next stream
>>= fun l ->
let testchain =
List.find_opt
(function Shell_services.Monitor.Active_test _ -> true | _ -> false)
l
in
match testchain with
| Some (Active_test {protocol; expiration_date; _})
when Protocol_hash.equal Protocol.hash protocol ->
let abort_daemon () =
cctxt#message
"Test chain's expiration date reached (%a)... Stopping the \
daemon.@."
Time.Protocol.pp_hum
expiration_date
>>= fun () ->
if cleanup_nonces then
(* Clean-up existing nonces *)
cctxt#with_lock (fun () ->
Client_baking_files.resolve_location cctxt ~chain:`Test `Nonce
>>=? fun nonces_location ->
Client_baking_nonces.(save cctxt nonces_location empty))
else return_unit >>=? fun () -> exit 0
in
let canceler = Lwt_canceler.create () in
Lwt_canceler.on_cancel canceler (fun () ->
abort_daemon () >>= function _ -> Lwt.return_unit) ;
let now = Time.System.(to_protocol (Systime_os.now ())) in
let delay = Int64.to_int (Time.Protocol.diff expiration_date now) in
if delay <= 0 then (* Testchain already expired... Retrying. *)
loop ()
else
let timeout =
Lwt_timeout.create delay (fun () ->
Lwt_canceler.cancel canceler |> ignore)
in
Lwt_timeout.start timeout ; return_unit
| None ->
loop ()
| Some _ ->
loop ()
(* Got a testchain for a different protocol, skipping *)
in
Lwt.pick
[ (Lwt_exit.termination_thread >>= fun _ -> failwith "Interrupted...");
loop () ]
>>=? fun () -> cctxt#message "Test chain forked." >>= fun () -> return_unit
module Endorser = struct
let run (cctxt : #Protocol_client_context.full) ~chain ~delay delegates =
await_bootstrapped_node cctxt
>>=? fun _ ->
( if chain = `Test then monitor_fork_testchain cctxt ~cleanup_nonces:false
else return_unit )
>>=? fun () ->
Client_baking_blocks.monitor_heads
~next_protocols:(Some [Protocol.hash])
cctxt
chain
>>=? fun block_stream ->
cctxt#message "Endorser started."
>>= fun () ->
Client_baking_endorsement.create cctxt ~delay delegates block_stream
end
module Baker = struct
let run (cctxt : #Protocol_client_context.full) ?minimal_fees
?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?max_priority
~chain ~context_path delegates =
await_bootstrapped_node cctxt
>>=? fun _ ->
( if chain = `Test then monitor_fork_testchain cctxt ~cleanup_nonces:true
else return_unit )
>>=? fun () ->
Client_baking_blocks.monitor_heads
~next_protocols:(Some [Protocol.hash])
cctxt
chain
>>=? fun block_stream ->
cctxt#message "Baker started."
>>= fun () ->
Client_baking_forge.create
cctxt
?minimal_fees
?minimal_nanotez_per_gas_unit
?minimal_nanotez_per_byte
?max_priority
~chain
~context_path
delegates
block_stream
end
module Accuser = struct
let run (cctxt : #Protocol_client_context.full) ~chain ~preserved_levels =
await_bootstrapped_node cctxt
>>=? fun _ ->
( if chain = `Test then monitor_fork_testchain cctxt ~cleanup_nonces:true
else return_unit )
>>=? fun () ->
Client_baking_blocks.monitor_valid_blocks
~next_protocols:(Some [Protocol.hash])
cctxt
~chains:[chain]
()
>>=? fun valid_blocks_stream ->
cctxt#message "Accuser started."
>>= fun () ->
Client_baking_denunciation.create
cctxt
~preserved_levels
valid_blocks_stream
end
src/proto_alpha/lib_delegate/client_daemon.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Fixpoint retry {D F H J L M N O P a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (delay : Z) (tries : Z)
(f : O -> Lwt.t (sum P (list Tezos_base__TzPervasives.error))) (x : O)
: Lwt.t (sum P (list Tezos_base__TzPervasives.error)) :=
op_gtgteq (f x)
(fun function_parameter =>
match function_parameter with
| (Stdlib.Ok _) as r => Lwt._return r
|
(Stdlib.Error
(cons
(Tezos_base__TzPervasives.Request_failed {|
error := Tezos_rpc_http.RPC_client_errors.Connection_failed _
|}) _)) as err =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Connection refused, retrying in " % string
(CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Lit_precision 2)
(CamlinternalFormatBasics.String_literal
" seconds..." % string
CamlinternalFormatBasics.End_of_format)))
"Connection refused, retrying in %.2f seconds..." % string) delay)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(Lwt.pick
(cons
(op_gtpipeeq (Lwt_unix.sleep delay)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Variants not supported *)
variant))
(cons
(op_gtpipeeq Lwt_exit.termination_thread
(fun function_parameter =>
let '_ := function_parameter in
(* ❌ Variants not supported *)
variant)) [])))
(fun function_parameter =>
match function_parameter with
| Killed => Lwt._return err
| Continue =>
retry cctxt
(Stdlib.op_starpoint delay
(* ❌ Float constant 1.5 is approximated by the integer 1 *)
1) (Z.sub tries 1) f x
end))
| (Stdlib.Error _) as err => Lwt._return err
end).
Definition await_bootstrapped_node {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Waiting for the node to be synchronized with its peers..." % string
CamlinternalFormatBasics.End_of_format)
"Waiting for the node to be synchronized with its peers..." % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(retry cctxt
(* ❌ Float constant 1. is approximated by the integer 1 *)
1 5 Shell_services.Monitor.bootstrapped cctxt)
(fun function_parameter =>
let '(block_stream, _stopper) := function_parameter in
let fix waiting_loop (function_parameter : unit) : Lwt.t unit :=
let 'tt := function_parameter in
op_gtgteq (Lwt_stream.get block_stream)
(fun function_parameter =>
match function_parameter with
| None => Lwt.return_unit
| Some _ => waiting_loop tt
end) in
op_gtgteq (waiting_loop tt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Node synchronized." % string
CamlinternalFormatBasics.End_of_format)
"Node synchronized." % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))).
Definition monitor_fork_testchain {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
* c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
*
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json) ->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a))
* (a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) * N)))))))))))))))))))))))))
* N) (cleanup_nonces : bool)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Waiting for the test chain to be forked..." % string
CamlinternalFormatBasics.End_of_format)
"Waiting for the test chain to be forked..." % string))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Shell_services.Monitor.active_chains cctxt)
(fun function_parameter =>
let '(stream, _) := function_parameter in
let fix loop (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteq (Lwt_stream.next stream)
(fun l =>
let testchain :=
List.find_opt
(fun function_parameter =>
match function_parameter with
|
Tezos_shell_services.Shell_services.Monitor.Active_test
_ => true
| _ => false
end) l in
match testchain with
|
Some
(Tezos_shell_services.Shell_services.Monitor.Active_test {|
protocol := protocol;
expiration_date := expiration_date
|}) =>
let abort_daemon (function_parameter : unit)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Test chain's expiration date reached (" % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
")... Stopping the daemon." % string
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Flush_newline
CamlinternalFormatBasics.End_of_format))))
"Test chain's expiration date reached (%a)... Stopping the daemon.@."
% string) Time.Protocol.pp_hum expiration_date)
(fun function_parameter =>
let 'tt := function_parameter in
if cleanup_nonces then
(* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_baking_files.resolve_location cctxt
(* ❌ Variants not supported *)
variant
(* ❌ Variants not supported *)
variant)
(fun nonces_location =>
save cctxt nonces_location empty))
else
op_gtgteqquestion return_unit
(fun function_parameter =>
let 'tt := function_parameter in
Stdlib.exit 0)) in
let canceler := Lwt_canceler.create tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Lwt_canceler.on_cancel canceler
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (abort_daemon tt)
(fun function_parameter =>
let '_ := function_parameter in
Lwt.return_unit)) in
let now := to_protocol (Systime_os.now tt) in
let delay :=
Int64.to_int (Time.Protocol.diff expiration_date now) in
if OCaml.Stdlib.le delay 0 then
loop tt
else
let timeout :=
Lwt_timeout.create delay
(fun function_parameter =>
let 'tt := function_parameter in
OCaml.Stdlib.reverse_apply
(Lwt_canceler.cancel canceler) OCaml.Stdlib.ignore)
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Lwt_timeout.start timeout in
return_unit
| None => loop tt
| Some _ => loop tt
end) in
op_gtgteqquestion
(Lwt.pick
(cons
(op_gtgteq Lwt_exit.termination_thread
(fun function_parameter =>
let '_ := function_parameter in
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Interrupted..." % string
CamlinternalFormatBasics.End_of_format)
"Interrupted..." % string))) (cons (loop tt) [])))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Test chain forked." % string
CamlinternalFormatBasics.End_of_format)
"Test chain forked." % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))).
Module Endorser.
Definition run {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json)
->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) *
N)))))))))))))))))))))))))
* N) (chain : variant) (delay : Z)
(delegates :
list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (await_bootstrapped_node cctxt)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(if
equiv_decb chain
(* ❌ Variants not supported *)
variant then
monitor_fork_testchain cctxt false
else
return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_baking_blocks.monitor_heads cctxt
(Some (cons Protocol.hash [])) chain)
(fun block_stream =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Endorser started." % string
CamlinternalFormatBasics.End_of_format)
"Endorser started." % string))
(fun function_parameter =>
let 'tt := function_parameter in
Client_baking_endorsement.create cctxt None delay delegates
block_stream)))).
End Endorser.
Module Baker.
Definition run {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json)
->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) *
N)))))))))))))))))))))))))
* N)
(minimal_fees : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(minimal_nanotez_per_gas_unit : option Z.t)
(minimal_nanotez_per_byte : option Z.t) (max_priority : option Z)
(chain : variant) (context_path : string)
(delegates :
list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (await_bootstrapped_node cctxt)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(if
equiv_decb chain
(* ❌ Variants not supported *)
variant then
monitor_fork_testchain cctxt true
else
return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_baking_blocks.monitor_heads cctxt
(Some (cons Protocol.hash [])) chain)
(fun block_stream =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Baker started." % string
CamlinternalFormatBasics.End_of_format)
"Baker started." % string))
(fun function_parameter =>
let 'tt := function_parameter in
Client_baking_forge.create cctxt minimal_fees
minimal_nanotez_per_gas_unit minimal_nanotez_per_byte
max_priority chain context_path delegates block_stream)))).
End Baker.
Module Accuser.
Definition run {D F H J L M N a b c i o p q : Type}
(cctxt :
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (D * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (F * a * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (H * a * b * q * i * o)) *
((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
b) * c) q i o) ->
(Tezos_shell_services.Shell_services.chain *
Tezos_shell_services.Shell_services.block) ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_alpha.Protocol.Environment.Lwt.t
(Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
o)) * (J * a * b * c * q * i * o)) *
((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
(a)) *
(Uri.t *
(Tezos_shell_services.Shell_services.block *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p ->
q ->
i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
* (L * p * q * i * o)) *
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
(o -> unit) ->
(unit -> unit) ->
p ->
q ->
i ->
Lwt.t
(Tezos_error_monad.Error_monad.tzresult
(unit -> unit))) * (M * p * q * i * o)) *
(Tezos_shell_services.Shell_services.chain *
((option Z) *
((((Tezos_client_base.Client_context.lwt_format a b)
-> a) * (a * b)) *
((Tezos_rpc.RPC_service.meth ->
(option Tezos_data_encoding.Data_encoding.json)
->
Uri.t ->
Lwt.t
(Tezos_rpc.RPC_context.rest_result
Tezos_data_encoding.Data_encoding.json
(option
Tezos_data_encoding.Data_encoding.json)))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult a)) *
(a)) *
((option (Lwt_stream.t string)) *
(((string ->
(Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((unit -> Ptime.t) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
string)) -> a) * (a)) *
((((Tezos_client_base.Client_context.lwt_format
a
(Tezos_base__TzPervasives.tzresult
Bigstring.t)) -> a) * (a)) *
((string ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
string)) *
((Z -> Lwt.t unit) *
((((Tezos_client_base.Client_context.lwt_format
a unit) -> a) * (a)) *
((((unit -> Lwt.t a) ->
Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding
a) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
unit)) * (a)) *
N)))))))))))))))))))))))))
* N) (chain : variant) (preserved_levels : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion (await_bootstrapped_node cctxt)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(if
equiv_decb chain
(* ❌ Variants not supported *)
variant then
monitor_fork_testchain cctxt true
else
return_unit)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Client_baking_blocks.monitor_valid_blocks cctxt
(Some (cons chain [])) None (Some (cons Protocol.hash [])) tt)
(fun valid_blocks_stream =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Accuser started." % string
CamlinternalFormatBasics.End_of_format)
"Accuser started." % string))
(fun function_parameter =>
let 'tt := function_parameter in
Client_baking_denunciation.create cctxt preserved_levels
valid_blocks_stream)))).
End Accuser.
src/proto_alpha/lib_delegate/delegate_commands.ml 40 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Client_proto_args
open Client_baking_lib
let group =
{Clic.name = "delegate"; title = "Commands related to delegate operations."}
let directory_parameter =
Clic.parameter (fun _ p ->
if not (Sys.file_exists p && Sys.is_directory p) then
failwith "Directory doesn't exist: '%s'" p
else return p)
let mempool_arg =
Clic.arg
~long:"mempool"
~placeholder:"file"
~doc:
"When used the client will read the mempool in the provided file \
instead of querying the node through an RPC (useful for debugging \
only)."
string_parameter
let context_path_arg =
Clic.arg
~long:"context"
~placeholder:"path"
~doc:
"When use the client will read in the local context at the provided \
path in order to build the block, instead of relying on the 'preapply' \
RPC."
string_parameter
let pidfile_arg =
Clic.arg
~doc:"write process id in file"
~short:'P'
~long:"pidfile"
~placeholder:"filename"
(Clic.parameter (fun _ s -> return s))
let may_lock_pidfile = function
| None ->
return_unit
| Some pidfile ->
trace (failure "Failed to create the pidfile: %s" pidfile)
@@ Lwt_lock_file.create ~unlink_on_exit:true pidfile
let block_param t =
Clic.param
~name:"block"
~desc:"commitment blocks whose nonce should be revealed"
(Clic.parameter (fun _ str -> Lwt.return (Block_hash.of_b58check str)))
t
let delegate_commands () =
let open Clic in
[ command
~group
~desc:"Forge and inject block using the delegate rights."
(args8
max_priority_arg
minimal_fees_arg
minimal_nanotez_per_gas_unit_arg
minimal_nanotez_per_byte_arg
force_switch
minimal_timestamp_switch
mempool_arg
context_path_arg)
( prefixes ["bake"; "for"]
@@ Client_keys.Public_key_hash.source_param
~name:"baker"
~desc:"name of the delegate owning the baking right"
@@ stop )
(fun ( max_priority,
minimal_fees,
minimal_nanotez_per_gas_unit,
minimal_nanotez_per_byte,
force,
minimal_timestamp,
mempool,
context_path )
delegate
cctxt ->
bake_block
cctxt
~minimal_fees
~minimal_nanotez_per_gas_unit
~minimal_nanotez_per_byte
~force
?max_priority
~minimal_timestamp
?mempool
?context_path
~chain:cctxt#chain
~head:cctxt#block
delegate);
command
~group
~desc:"Forge and inject a seed-nonce revelation operation."
no_options
(prefixes ["reveal"; "nonce"; "for"] @@ seq_of_param block_param)
(fun () block_hashes cctxt ->
reveal_block_nonces
cctxt
~chain:cctxt#chain
~block:cctxt#block
block_hashes);
command
~group
~desc:
"Forge and inject all the possible seed-nonce revelation operations."
no_options
(prefixes ["reveal"; "nonces"] @@ stop)
(fun () cctxt ->
reveal_nonces ~chain:cctxt#chain ~block:cctxt#block cctxt ());
command
~group
~desc:"Forge and inject an endorsement operation."
no_options
( prefixes ["endorse"; "for"]
@@ Client_keys.Public_key_hash.source_param
~name:"baker"
~desc:"name of the delegate owning the endorsement right"
@@ stop )
(fun () delegate cctxt ->
endorse_block cctxt ~chain:cctxt#chain delegate);
command
~group
~desc:
"Clear the nonces file by removing the nonces which blocks cannot be \
found on the chain."
no_options
(prefixes ["filter"; "orphan"; "nonces"] @@ stop)
(fun () (cctxt : #Protocol_client_context.full) ->
cctxt#with_lock (fun () ->
let chain = cctxt#chain in
Client_baking_files.resolve_location cctxt ~chain `Nonce
>>=? fun nonces_location ->
let open Client_baking_nonces in
(* Filtering orphan nonces *)
load cctxt nonces_location
>>=? fun nonces ->
Block_hash.Map.fold
(fun block nonce acc ->
acc
>>= fun acc ->
Shell_services.Blocks.Header.shell_header
cctxt
~chain
~block:(`Hash (block, 0))
()
>>= function
| Ok _ ->
Lwt.return acc
| Error _ ->
Lwt.return (Block_hash.Map.add block nonce acc))
nonces
(Lwt.return empty)
>>= fun orphans ->
if Block_hash.Map.cardinal orphans = 0 then
cctxt#message "No orphan nonces found." >>= fun () -> return_unit
else
(* "Backup-ing" orphan nonces *)
let orphan_nonces_file = "orphan_nonce" in
cctxt#load orphan_nonces_file ~default:empty encoding
>>=? fun orphan_nonces ->
let orphan_nonces = add_all orphan_nonces orphans in
cctxt#write orphan_nonces_file orphan_nonces encoding
>>=? fun () ->
(* Don't forget the 's'. *)
let orphan_nonces_file = orphan_nonces_file ^ "s" in
cctxt#message
"Successfully filtered %d orphan nonces and moved them to \
'$TEZOS_CLIENT/%s'."
(Block_hash.Map.cardinal orphans)
orphan_nonces_file
>>= fun () ->
let filtered_nonces =
Client_baking_nonces.remove_all nonces orphans
in
save cctxt nonces_location filtered_nonces
>>=? fun () -> return_unit));
command
~group
~desc:"List orphan nonces."
no_options
(prefixes ["list"; "orphan"; "nonces"] @@ stop)
(fun () (cctxt : #Protocol_client_context.full) ->
cctxt#with_lock (fun () ->
let open Client_baking_nonces in
let orphan_nonces_file = "orphan_nonce" in
cctxt#load orphan_nonces_file ~default:empty encoding
>>=? fun orphan_nonces ->
let block_hashes =
List.map fst (Block_hash.Map.bindings orphan_nonces)
in
cctxt#message
"@[<v 2>Found %d orphan nonces associated to the potentially \
unknown following blocks:@ %a@]"
(Block_hash.Map.cardinal orphan_nonces)
(Format.pp_print_list ~pp_sep:Format.pp_print_cut Block_hash.pp)
block_hashes
>>= fun () -> return_unit)) ]
let baker_commands () =
let open Clic in
let group =
{
Clic.name = "delegate.baker";
title = "Commands related to the baker daemon.";
}
in
[ command
~group
~desc:"Launch the baker daemon."
(args5
pidfile_arg
max_priority_arg
minimal_fees_arg
minimal_nanotez_per_gas_unit_arg
minimal_nanotez_per_byte_arg)
( prefixes ["run"; "with"; "local"; "node"]
@@ param
~name:"context_path"
~desc:"Path to the node data directory (e.g. $HOME/.tezos-node)"
directory_parameter
@@ seq_of_param Client_keys.Public_key_hash.alias_param )
(fun ( pidfile,
max_priority,
minimal_fees,
minimal_nanotez_per_gas_unit,
minimal_nanotez_per_byte )
node_path
delegates
cctxt ->
may_lock_pidfile pidfile
>>=? fun () ->
Tezos_signer_backends.Encrypted.decrypt_list
cctxt
(List.map fst delegates)
>>=? fun () ->
Client_daemon.Baker.run
cctxt
~chain:cctxt#chain
~minimal_fees
~minimal_nanotez_per_gas_unit
~minimal_nanotez_per_byte
?max_priority
~context_path:(Filename.concat node_path "context")
(List.map snd delegates)) ]
let endorser_commands () =
let open Clic in
let group =
{
Clic.name = "delegate.endorser";
title = "Commands related to endorser daemon.";
}
in
[ command
~group
~desc:"Launch the endorser daemon"
(args2 pidfile_arg endorsement_delay_arg)
(prefixes ["run"] @@ seq_of_param Client_keys.Public_key_hash.alias_param)
(fun (pidfile, endorsement_delay) delegates cctxt ->
may_lock_pidfile pidfile
>>=? fun () ->
Tezos_signer_backends.Encrypted.decrypt_list
cctxt
(List.map fst delegates)
>>=? fun () ->
let delegates = List.map snd delegates in
let delegates_no_duplicates =
Signature.Public_key_hash.Set.(delegates |> of_list |> elements)
in
( if List.length delegates <> List.length delegates_no_duplicates then
cctxt#message
"Warning: the list of public key hash aliases contains duplicate \
hashes, which are ignored"
else Lwt.return () )
>>= fun () ->
Client_daemon.Endorser.run
cctxt
~chain:cctxt#chain
~delay:endorsement_delay
delegates_no_duplicates) ]
let accuser_commands () =
let open Clic in
let group =
{
Clic.name = "delegate.accuser";
title = "Commands related to the accuser daemon.";
}
in
[ command
~group
~desc:"Launch the accuser daemon"
(args2 pidfile_arg preserved_levels_arg)
(prefixes ["run"] @@ stop)
(fun (pidfile, preserved_levels) cctxt ->
may_lock_pidfile pidfile
>>=? fun () ->
Client_daemon.Accuser.run ~chain:cctxt#chain ~preserved_levels cctxt)
]
src/proto_alpha/lib_delegate/delegate_commands.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Client_proto_args.
Import Client_baking_lib.
Definition group : Tezos_base__TzPervasives.Clic.group :=
{| Clic.name := "delegate" % string;
Clic.title := "Commands related to delegate operations." % string |}.
Definition directory_parameter
: Tezos_base__TzPervasives.Clic.parameter string
Tezos_client_alpha.Protocol_client_context.full :=
Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun p =>
if negb (andb (Sys.file_exists p) (Sys.is_directory p)) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Directory doesn't exist: '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "'" % char
CamlinternalFormatBasics.End_of_format)))
"Directory doesn't exist: '%s'" % string) p
else
_return p).
Definition mempool_arg
: Tezos_base__TzPervasives.Clic.arg (option string)
Tezos_client_alpha.Protocol_client_context.full :=
Clic.arg
"When used the client will read the mempool in the provided file instead of querying the node through an RPC (useful for debugging only)."
% string None "mempool" % string "file" % string string_parameter.
Definition context_path_arg
: Tezos_base__TzPervasives.Clic.arg (option string)
Tezos_client_alpha.Protocol_client_context.full :=
Clic.arg
"When use the client will read in the local context at the provided path in order to build the block, instead of relying on the 'preapply' RPC."
% string None "context" % string "path" % string string_parameter.
Definition pidfile_arg
: Tezos_base__TzPervasives.Clic.arg (option string)
Tezos_client_alpha.Protocol_client_context.full :=
Clic.arg "write process id in file" % string (Some "P" % char)
"pidfile" % string "filename" % string
(Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun s => _return s)).
Definition may_lock_pidfile (function_parameter : option string)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match function_parameter with
| None => return_unit
| Some pidfile =>
apply
(trace
(failure
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Failed to create the pidfile: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.End_of_format))
"Failed to create the pidfile: %s" % string) pidfile))
(Lwt_lock_file.create None (Some true) pidfile)
end.
Definition block_param {A B : Type}
(t : Tezos_base__TzPervasives.Clic.params A B)
: Tezos_base__TzPervasives.Clic.params
(Tezos_base__TzPervasives.Block_hash.t -> A) B :=
Clic.param "block" % string
"commitment blocks whose nonce should be revealed" % string
(Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun str => Lwt._return (Block_hash.of_b58check str))) t.
Definition delegate_commands (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_alpha.Protocol_client_context.full) :=
let 'tt := function_parameter in
cons
(command (Some group)
"Forge and inject block using the delegate rights." % string
(args8 max_priority_arg minimal_fees_arg minimal_nanotez_per_gas_unit_arg
minimal_nanotez_per_byte_arg force_switch minimal_timestamp_switch
mempool_arg context_path_arg)
(apply (prefixes (cons "bake" % string (cons "for" % string [])))
(apply
(Client_keys.Public_key_hash.source_param (Some "baker" % string)
(Some "name of the delegate owning the baking right" % string)) stop))
(fun function_parameter =>
let
'(max_priority, minimal_fees, minimal_nanotez_per_gas_unit,
minimal_nanotez_per_byte, force, minimal_timestamp, mempool,
context_path) := function_parameter in
fun delegate =>
fun cctxt =>
bake_block cctxt (Some minimal_fees)
(Some minimal_nanotez_per_gas_unit)
(Some minimal_nanotez_per_byte) (Some force) max_priority
(Some minimal_timestamp) mempool context_path None
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send delegate))
(cons
(command (Some group)
"Forge and inject a seed-nonce revelation operation." % string
no_options
(apply
(prefixes
(cons "reveal" % string
(cons "nonce" % string (cons "for" % string []))))
(seq_of_param block_param))
(fun function_parameter =>
let 'tt := function_parameter in
fun block_hashes =>
fun cctxt =>
reveal_block_nonces cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send block_hashes))
(cons
(command (Some group)
"Forge and inject all the possible seed-nonce revelation operations."
% string no_options
(apply (prefixes (cons "reveal" % string (cons "nonces" % string [])))
stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
reveal_nonces cctxt
(* ❌ Sending method message is not handled *)
send
(* ❌ Sending method message is not handled *)
send tt))
(cons
(command (Some group)
"Forge and inject an endorsement operation." % string no_options
(apply (prefixes (cons "endorse" % string (cons "for" % string [])))
(apply
(Client_keys.Public_key_hash.source_param
(Some "baker" % string)
(Some
"name of the delegate owning the endorsement right" % string))
stop))
(fun function_parameter =>
let 'tt := function_parameter in
fun delegate =>
fun cctxt =>
endorse_block cctxt
(* ❌ Sending method message is not handled *)
send delegate))
(cons
(command (Some group)
"Clear the nonces file by removing the nonces which blocks cannot be found on the chain."
% string no_options
(apply
(prefixes
(cons "filter" % string
(cons "orphan" % string (cons "nonces" % string [])))) stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
(* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
let 'tt := function_parameter in
let chain :=
(* ❌ Sending method message is not handled *)
send in
op_gtgteqquestion
(Client_baking_files.resolve_location cctxt chain
(* ❌ Variants not supported *)
variant)
(fun nonces_location =>
op_gtgteqquestion (load cctxt nonces_location)
(fun nonces =>
op_gtgteq
(Block_hash.Map.fold
(fun block =>
fun nonce =>
fun acc =>
op_gtgteq acc
(fun acc =>
op_gtgteq
(Shell_services.Blocks.Header.shell_header
cctxt (Some chain)
(Some
(* ❌ Variants not supported *)
variant) tt)
(fun function_parameter =>
match function_parameter with
| Stdlib.Ok _ => Lwt._return acc
| Stdlib.Error _ =>
Lwt._return
(Block_hash.Map.add block
nonce acc)
end))) nonces
(Lwt._return empty))
(fun orphans =>
if
equiv_decb (Block_hash.Map.cardinal orphans)
0 then
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"No orphan nonces found." % string
CamlinternalFormatBasics.End_of_format)
"No orphan nonces found." % string))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)
else
let orphan_nonces_file :=
"orphan_nonce" % string in
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send orphan_nonces_file empty encoding)
(fun orphan_nonces =>
let orphan_nonces :=
add_all orphan_nonces orphans in
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send orphan_nonces_file orphan_nonces
encoding)
(fun function_parameter =>
let 'tt := function_parameter in
let orphan_nonces_file :=
String.append orphan_nonces_file
"s" % string in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Successfully filtered " %
string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" orphan nonces and moved them to '$TEZOS_CLIENT/"
% string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"'." % string
CamlinternalFormatBasics.End_of_format)))))
"Successfully filtered %d orphan nonces and moved them to '$TEZOS_CLIENT/%s'."
% string)
(Block_hash.Map.cardinal orphans)
orphan_nonces_file)
(fun function_parameter =>
let 'tt := function_parameter in
let filtered_nonces :=
Client_baking_nonces.remove_all
nonces orphans in
op_gtgteqquestion
(save cctxt nonces_location
filtered_nonces)
(fun function_parameter =>
let 'tt :=
function_parameter in
return_unit))))))))))
(cons
(command (Some group) "List orphan nonces." % string no_options
(apply
(prefixes
(cons "list" % string
(cons "orphan" % string (cons "nonces" % string []))))
stop)
(fun function_parameter =>
let 'tt := function_parameter in
fun cctxt =>
(* ❌ Sending method message is not handled *)
send
(fun function_parameter =>
let 'tt := function_parameter in
let orphan_nonces_file := "orphan_nonce" % string in
op_gtgteqquestion
((* ❌ Sending method message is not handled *)
send orphan_nonces_file empty encoding)
(fun orphan_nonces =>
let block_hashes :=
List.map fst
(Block_hash.Map.bindings orphan_nonces) in
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"<v 2>" % string
CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(CamlinternalFormatBasics.String_literal
"Found " % string
(CamlinternalFormatBasics.Int
CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
(CamlinternalFormatBasics.String_literal
" orphan nonces associated to the potentially unknown following blocks:"
% string
(CamlinternalFormatBasics.Formatting_lit
(CamlinternalFormatBasics.Break
"@ " % string 1 0)
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))
"@[<v 2>Found %d orphan nonces associated to the potentially unknown following blocks:@ %a@]"
% string)
(Block_hash.Map.cardinal orphan_nonces)
(Format.pp_print_list (Some Format.pp_print_cut)
Block_hash.pp) block_hashes)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))) []))))).
Definition baker_commands (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_alpha.Protocol_client_context.full) :=
let 'tt := function_parameter in
let group :=
{| Clic.name := "delegate.baker" % string;
Clic.title := "Commands related to the baker daemon." % string |} in
cons
(command (Some group) "Launch the baker daemon." % string
(args5 pidfile_arg max_priority_arg minimal_fees_arg
minimal_nanotez_per_gas_unit_arg minimal_nanotez_per_byte_arg)
(apply
(prefixes
(cons "run" % string
(cons "with" % string
(cons "local" % string (cons "node" % string [])))))
(apply
(param "context_path" % string
"Path to the node data directory (e.g. $HOME/.tezos-node)" % string
directory_parameter)
(seq_of_param
(let arg := Client_keys.Public_key_hash.alias_param in
fun eta => arg None None eta))))
(fun function_parameter =>
let
'(pidfile, max_priority, minimal_fees, minimal_nanotez_per_gas_unit,
minimal_nanotez_per_byte) := function_parameter in
fun node_path =>
fun delegates =>
fun cctxt =>
op_gtgteqquestion (may_lock_pidfile pidfile)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.decrypt_list cctxt
(List.map fst delegates))
(fun function_parameter =>
let 'tt := function_parameter in
Client_daemon.Baker.run cctxt (Some minimal_fees)
(Some minimal_nanotez_per_gas_unit)
(Some minimal_nanotez_per_byte) max_priority
(* ❌ Sending method message is not handled *)
send (Filename.concat node_path "context" % string)
(List.map snd delegates))))) [].
Definition endorser_commands (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_alpha.Protocol_client_context.full) :=
let 'tt := function_parameter in
let group :=
{| Clic.name := "delegate.endorser" % string;
Clic.title := "Commands related to endorser daemon." % string |} in
cons
(command (Some group) "Launch the endorser daemon" % string
(args2 pidfile_arg endorsement_delay_arg)
(apply (prefixes (cons "run" % string []))
(seq_of_param
(let arg := Client_keys.Public_key_hash.alias_param in
fun eta => arg None None eta)))
(fun function_parameter =>
let '(pidfile, endorsement_delay) := function_parameter in
fun delegates =>
fun cctxt =>
op_gtgteqquestion (may_lock_pidfile pidfile)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Tezos_signer_backends.Encrypted.decrypt_list cctxt
(List.map fst delegates))
(fun function_parameter =>
let 'tt := function_parameter in
let delegates := List.map snd delegates in
let delegates_no_duplicates :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply delegates of_list) elements
in
op_gtgteq
(if
nequiv_decb (List.length delegates)
(List.length delegates_no_duplicates) then
(* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Warning: the list of public key hash aliases contains duplicate hashes, which are ignored"
% string CamlinternalFormatBasics.End_of_format)
"Warning: the list of public key hash aliases contains duplicate hashes, which are ignored"
% string)
else
Lwt._return tt)
(fun function_parameter =>
let 'tt := function_parameter in
Client_daemon.Endorser.run cctxt
(* ❌ Sending method message is not handled *)
send endorsement_delay delegates_no_duplicates))))) [].
Definition accuser_commands (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command
Tezos_client_alpha.Protocol_client_context.full) :=
let 'tt := function_parameter in
let group :=
{| Clic.name := "delegate.accuser" % string;
Clic.title := "Commands related to the accuser daemon." % string |} in
cons
(command (Some group) "Launch the accuser daemon" % string
(args2 pidfile_arg preserved_levels_arg)
(apply (prefixes (cons "run" % string [])) stop)
(fun function_parameter =>
let '(pidfile, preserved_levels) := function_parameter in
fun cctxt =>
op_gtgteqquestion (may_lock_pidfile pidfile)
(fun function_parameter =>
let 'tt := function_parameter in
Client_daemon.Accuser.run cctxt
(* ❌ Sending method message is not handled *)
send preserved_levels))) [].
src/proto_alpha/lib_delegate/delegate_commands_registration.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) let () = Client_commands.register Protocol.hash @@ fun _network -> List.map (Clic.map_command (new Protocol_client_context.wrap_full)) @@ Delegate_commands.delegate_commands ()
src/proto_alpha/lib_delegate/delegate_commands_registration.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations.
src/proto_alpha/lib_delegate/logging.ml 17 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
let timestamp_tag =
Tag.def ~doc:"Timestamp when event occurred" "timestamp" Time.System.pp_hum
let valid_ops = Tag.def ~doc:"Valid Operations" "valid_ops" Format.pp_print_int
let op_count =
Tag.def ~doc:"Number of operations" "op_count" Format.pp_print_int
let refused_ops =
Tag.def ~doc:"Refused Operations" "refused_ops" Format.pp_print_int
let bake_priority_tag =
Tag.def ~doc:"Baking priority" "bake_priority" Format.pp_print_int
let fitness_tag = Tag.def ~doc:"Fitness" "fitness" Fitness.pp
let current_slots_tag =
Tag.def
~doc:"Number of baking slots that can be baked at this time"
"current_slots"
Format.pp_print_int
let future_slots_tag =
Tag.def
~doc:
"Number of baking slots in the foreseeable future but not yet bakeable"
"future_slots"
Format.pp_print_int
let timespan_tag = Tag.def ~doc:"Timespan in seconds" "timespan" Ptime.Span.pp
let filename_tag = Tag.def ~doc:"Filename" "filename" Format.pp_print_text
let signed_header_tag =
Tag.def ~doc:"Signed header" "signed_header" (fun fmt x ->
Hex.pp fmt (Hex.of_bytes x))
let signed_operation_tag =
Tag.def ~doc:"Signed operation" "signed_operation" (fun fmt x ->
Hex.pp fmt (Hex.of_bytes x))
let operations_tag =
Tag.def
~doc:"Block Operations"
"operations"
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf "+")
(fun ppf operations -> Format.fprintf ppf "%d" (List.length operations)))
let raw_operations_tag =
Tag.def ~doc:"Raw operations" "raw_operations" (fun fmt raw_ops ->
let pp_op fmt op =
let json = Data_encoding.Json.construct Operation.raw_encoding op in
Format.fprintf fmt "%a" Data_encoding.Json.pp json
in
Format.fprintf
fmt
"@[<v>%a@]"
(Format.pp_print_list ~pp_sep:Format.pp_print_cut pp_op)
raw_ops)
let bake_op_count_tag =
Tag.def ~doc:"Bake Operation Count" "operation_count" Format.pp_print_int
let endorsement_slot_tag =
Tag.def ~doc:"Endorsement Slot" "endorsement_slot" Format.pp_print_int
let endorsement_slots_tag =
Tag.def
~doc:"Endorsement Slots"
"endorsement_slots"
Format.(fun ppf v -> pp_print_int ppf (List.length v))
let denounced_endorsements_slots_tag =
Tag.def
~doc:"Endorsement Slots"
"denounced_endorsement_slots"
Format.(pp_print_list pp_print_int)
let denouncement_source_tag =
Tag.def ~doc:"Denounce Source" "source" Format.pp_print_text
let level_tag = Tag.def ~doc:"Level" "level" Raw_level.pp
let nonce_tag =
Tag.def
~doc:"Nonce"
"nonce"
Data_encoding.Json.(
fun ppf nonce -> pp ppf (construct Nonce.encoding nonce))
let chain_tag =
Tag.def
~doc:"Chain selector"
"chain"
Format.(
fun ppf chain ->
pp_print_string ppf @@ Block_services.chain_to_string chain)
let block_tag =
Tag.def
~doc:"Block selector"
"block"
Format.(
fun ppf block -> pp_print_string ppf @@ Block_services.to_string block)
let worker_tag =
Tag.def ~doc:"Worker in which event occurred" "worker" Format.pp_print_text
let block_header_tag =
Tag.def ~doc:"Raw block header" "block_header" (fun ppf _ ->
Format.fprintf ppf "[raw block header]")
let conflicting_endorsements_tag =
Tag.def
~doc:"Two conflicting endorsements signed by the same key"
"conflicting_endorsements"
Format.(
fun ppf (a, b) ->
fprintf
ppf
"%a / %a"
Operation_hash.pp
(Operation.hash a)
Operation_hash.pp
(Operation.hash b))
src/proto_alpha/lib_delegate/logging.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Definition timestamp_tag
: Tezos_base__TzPervasives.Tag.def Tezos_base__TzPervasives.Time.System.t :=
Tag.def (Some "Timestamp when event occurred" % string) "timestamp" % string
Time.System.pp_hum.
Definition valid_ops : Tezos_base__TzPervasives.Tag.def Z :=
Tag.def (Some "Valid Operations" % string) "valid_ops" % string
Format.pp_print_int.
Definition op_count : Tezos_base__TzPervasives.Tag.def Z :=
Tag.def (Some "Number of operations" % string) "op_count" % string
Format.pp_print_int.
Definition refused_ops : Tezos_base__TzPervasives.Tag.def Z :=
Tag.def (Some "Refused Operations" % string) "refused_ops" % string
Format.pp_print_int.
Definition bake_priority_tag : Tezos_base__TzPervasives.Tag.def Z :=
Tag.def (Some "Baking priority" % string) "bake_priority" % string
Format.pp_print_int.
Definition fitness_tag
: Tezos_base__TzPervasives.Tag.def
Tezos_protocol_alpha.Protocol.Alpha_context.Fitness.t :=
Tag.def (Some "Fitness" % string) "fitness" % string Fitness.pp.
Definition current_slots_tag : Tezos_base__TzPervasives.Tag.def Z :=
Tag.def
(Some "Number of baking slots that can be baked at this time" % string)
"current_slots" % string Format.pp_print_int.
Definition future_slots_tag : Tezos_base__TzPervasives.Tag.def Z :=
Tag.def
(Some
"Number of baking slots in the foreseeable future but not yet bakeable" %
string) "future_slots" % string Format.pp_print_int.
Definition timespan_tag : Tezos_base__TzPervasives.Tag.def Ptime.span :=
Tag.def (Some "Timespan in seconds" % string) "timespan" % string
Ptime.Span.pp.
Definition filename_tag : Tezos_base__TzPervasives.Tag.def string :=
Tag.def (Some "Filename" % string) "filename" % string Format.pp_print_text.
Definition signed_header_tag : Tezos_base__TzPervasives.Tag.def string :=
Tag.def (Some "Signed header" % string) "signed_header" % string
(fun fmt => fun x => Hex.pp fmt (Hex.of_bytes None x)).
Definition signed_operation_tag : Tezos_base__TzPervasives.Tag.def string :=
Tag.def (Some "Signed operation" % string) "signed_operation" % string
(fun fmt => fun x => Hex.pp fmt (Hex.of_bytes None x)).
Definition operations_tag {A : Type}
: Tezos_base__TzPervasives.Tag.def (list (list A)) :=
Tag.def (Some "Block Operations" % string) "operations" % string
(Format.pp_print_list
(Some
(fun ppf =>
fun function_parameter =>
let 'tt := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Char_literal "+" % char
CamlinternalFormatBasics.End_of_format) "+" % string)))
(fun ppf =>
fun operations =>
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
CamlinternalFormatBasics.No_padding
CamlinternalFormatBasics.No_precision
CamlinternalFormatBasics.End_of_format) "%d" % string)
(List.length operations))).
Definition raw_operations_tag
: Tezos_base__TzPervasives.Tag.def
(list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.raw) :=
Tag.def (Some "Raw operations" % string) "raw_operations" % string
(fun fmt =>
fun raw_ops =>
let pp_op
(fmt : Stdlib.Format.formatter) (op :
Tezos_protocol_alpha.Protocol.Alpha_context.Operation.raw) : unit :=
let json := Data_encoding.Json.construct Operation.raw_encoding op in
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format) "%a" % string)
Data_encoding.Json.pp json in
Format.fprintf fmt
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "<v>" % string
CamlinternalFormatBasics.End_of_format) "<v>" % string))
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))) "@[<v>%a@]" % string)
(Format.pp_print_list (Some Format.pp_print_cut) pp_op) raw_ops).
Definition bake_op_count_tag : Tezos_base__TzPervasives.Tag.def Z :=
Tag.def (Some "Bake Operation Count" % string) "operation_count" % string
Format.pp_print_int.
Definition endorsement_slot_tag : Tezos_base__TzPervasives.Tag.def Z :=
Tag.def (Some "Endorsement Slot" % string) "endorsement_slot" % string
Format.pp_print_int.
Definition endorsement_slots_tag {A : Type}
: Tezos_base__TzPervasives.Tag.def (list A) :=
Tag.def (Some "Endorsement Slots" % string) "endorsement_slots" % string
(fun ppf => fun v => pp_print_int ppf (List.length v)).
Definition denounced_endorsements_slots_tag
: Tezos_base__TzPervasives.Tag.def (list Z) :=
Tag.def (Some "Endorsement Slots" % string)
"denounced_endorsement_slots" % string (pp_print_list None pp_print_int).
Definition denouncement_source_tag : Tezos_base__TzPervasives.Tag.def string :=
Tag.def (Some "Denounce Source" % string) "source" % string
Format.pp_print_text.
Definition level_tag
: Tezos_base__TzPervasives.Tag.def
Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t :=
Tag.def (Some "Level" % string) "level" % string Raw_level.pp.
Definition nonce_tag
: Tezos_base__TzPervasives.Tag.def
Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
Tag.def (Some "Nonce" % string) "nonce" % string
(fun ppf => fun nonce => pp ppf (construct Nonce.encoding nonce)).
Definition chain_tag
: Tezos_base__TzPervasives.Tag.def Tezos_shell_services.Block_services.chain :=
Tag.def (Some "Chain selector" % string) "chain" % string
(fun ppf =>
fun chain =>
apply (pp_print_string ppf) (Block_services.chain_to_string chain)).
Definition block_tag
: Tezos_base__TzPervasives.Tag.def Tezos_shell_services.Block_services.block :=
Tag.def (Some "Block selector" % string) "block" % string
(fun ppf =>
fun block => apply (pp_print_string ppf) (Block_services.to_string block)).
Definition worker_tag : Tezos_base__TzPervasives.Tag.def string :=
Tag.def (Some "Worker in which event occurred" % string) "worker" % string
Format.pp_print_text.
Definition block_header_tag {A : Type} : Tezos_base__TzPervasives.Tag.def A :=
Tag.def (Some "Raw block header" % string) "block_header" % string
(fun ppf =>
fun function_parameter =>
let '_ := function_parameter in
Format.fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"[raw block header]" % string
CamlinternalFormatBasics.End_of_format)
"[raw block header]" % string)).
Definition conflicting_endorsements_tag {A B : Type}
: Tezos_base__TzPervasives.Tag.def
((Tezos_raw_protocol_alpha__Alpha_context.operation A) *
(Tezos_raw_protocol_alpha__Alpha_context.operation B)) :=
Tag.def (Some "Two conflicting endorsements signed by the same key" % string)
"conflicting_endorsements" % string
(fun ppf =>
fun function_parameter =>
let '(a, b) := function_parameter in
fprintf ppf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal " / " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))) "%a / %a" % string)
Operation_hash.pp (Operation.hash a) Operation_hash.pp
(Operation.hash b)).
src/proto_alpha/lib_mempool/filter.ml 68 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Nomadic Development. <contact@tezcore.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
module Proto = Registerer.Registered
type nanotez = Z.t
let nanotez_enc =
Data_encoding.def
"nanotez"
~title:"Thousandths of tez"
~description:"One thousand nanotez make a tez"
Data_encoding.z
type config = {
minimal_fees : Tez.t;
minimal_nanotez_per_gas_unit : nanotez;
minimal_nanotez_per_byte : nanotez;
allow_script_failure : bool;
}
let default_minimal_fees =
match Tez.of_mutez 100L with None -> assert false | Some t -> t
let default_minimal_nanotez_per_gas_unit = Z.of_int 100
let default_minimal_nanotez_per_byte = Z.of_int 1000
let config_encoding : config Data_encoding.t =
let open Data_encoding in
conv
(fun { minimal_fees;
minimal_nanotez_per_gas_unit;
minimal_nanotez_per_byte;
allow_script_failure } ->
( minimal_fees,
minimal_nanotez_per_gas_unit,
minimal_nanotez_per_byte,
allow_script_failure ))
(fun ( minimal_fees,
minimal_nanotez_per_gas_unit,
minimal_nanotez_per_byte,
allow_script_failure ) ->
{
minimal_fees;
minimal_nanotez_per_gas_unit;
minimal_nanotez_per_byte;
allow_script_failure;
})
(obj4
(dft "minimal_fees" Tez.encoding default_minimal_fees)
(dft
"minimal_nanotez_per_gas_unit"
nanotez_enc
default_minimal_nanotez_per_gas_unit)
(dft
"minimal_nanotez_per_byte"
nanotez_enc
default_minimal_nanotez_per_byte)
(dft "allow_script_failure" bool true))
let default_config =
{
minimal_fees = default_minimal_fees;
minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit;
minimal_nanotez_per_byte = default_minimal_nanotez_per_byte;
allow_script_failure = true;
}
let get_manager_operation_gas_and_fee contents =
let open Operation in
let l = to_list (Contents_list contents) in
List.fold_left
(fun acc -> function
| Contents (Manager_operation {fee; gas_limit; _}) -> (
match acc with
| Error _ as e ->
e
| Ok (total_fee, total_gas) -> (
match Tez.(total_fee +? fee) with
| Ok total_fee ->
Ok (total_fee, Z.add total_gas gas_limit)
| Error _ as e ->
e ) ) | _ -> acc)
(Ok (Tez.zero, Z.zero))
l
let pre_filter_manager :
type t. config -> t Kind.manager contents_list -> int -> bool =
fun config op size ->
match get_manager_operation_gas_and_fee op with
| Error _ ->
false
| Ok (fee, gas) ->
let fees_in_nanotez =
Z.mul (Z.of_int64 (Tez.to_mutez fee)) (Z.of_int 1000)
in
let minimal_fees_in_nanotez =
Z.mul (Z.of_int64 (Tez.to_mutez config.minimal_fees)) (Z.of_int 1000)
in
let minimal_fees_for_gas_in_nanotez =
Z.mul config.minimal_nanotez_per_gas_unit gas
in
let minimal_fees_for_size_in_nanotez =
Z.mul config.minimal_nanotez_per_byte (Z.of_int size)
in
Z.compare
fees_in_nanotez
(Z.add
minimal_fees_in_nanotez
(Z.add
minimal_fees_for_gas_in_nanotez
minimal_fees_for_size_in_nanotez))
>= 0
let pre_filter config
(Operation_data {contents; _} as op : Operation.packed_protocol_data) =
let bytes =
Data_encoding.Binary.fixed_length_exn
Tezos_base.Operation.shell_header_encoding
+ Data_encoding.Binary.length Operation.protocol_data_encoding op
in
match contents with
| Single (Endorsement _) ->
true
| Single (Seed_nonce_revelation _) ->
true
| Single (Double_endorsement_evidence _) ->
true
| Single (Double_baking_evidence _) ->
true
| Single (Activate_account _) ->
true
| Single (Proposals _) ->
true
| Single (Ballot _) ->
true
| Single (Manager_operation _) as op ->
pre_filter_manager config op bytes
| Cons (Manager_operation _, _) as op ->
pre_filter_manager config op bytes
open Apply_results
let rec post_filter_manager :
type t.
Alpha_context.t ->
t Kind.manager contents_result_list ->
config ->
bool Lwt.t =
fun ctxt op config ->
match op with
| Single_result (Manager_operation_result {operation_result; _}) -> (
match operation_result with
| Applied _ ->
Lwt.return_true
| Skipped _ | Failed _ | Backtracked _ ->
Lwt.return config.allow_script_failure )
| Cons_result (Manager_operation_result res, rest) -> (
post_filter_manager
ctxt
(Single_result (Manager_operation_result res))
config
>>= function
| false ->
Lwt.return_false
| true ->
post_filter_manager ctxt rest config )
let post_filter config ~validation_state_before:_
~validation_state_after:({ctxt; _} : validation_state) (_op, receipt) =
match receipt with
| No_operation_metadata ->
assert false (* only for multipass validator *)
| Operation_metadata {contents} -> (
match contents with
| Single_result (Endorsement_result _) ->
Lwt.return_true
| Single_result (Seed_nonce_revelation_result _) ->
Lwt.return_true
| Single_result (Double_endorsement_evidence_result _) ->
Lwt.return_true
| Single_result (Double_baking_evidence_result _) ->
Lwt.return_true
| Single_result (Activate_account_result _) ->
Lwt.return_true
| Single_result Proposals_result ->
Lwt.return_true
| Single_result Ballot_result ->
Lwt.return_true
| Single_result (Manager_operation_result _) as op ->
post_filter_manager ctxt op config
| Cons_result (Manager_operation_result _, _) as op ->
post_filter_manager ctxt op config )
src/proto_alpha/lib_mempool/filter.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Proto.
End Proto.
Definition nanotez_enc {A : Type} : A :=
op_startypeminuserrorstar "nanotez" % string "Thousandths of tez" % string
"One thousand nanotez make a tez" % string op_startypeminuserrorstar.
Definition default_minimal_fees {A : Type} : A :=
match
op_startypeminuserrorstar
(* ❌ Constant of type int64 is converted to int *)
100 with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some t => t
end.
Definition default_minimal_nanotez_per_gas_unit {A : Type} : A :=
op_startypeminuserrorstar 100.
Definition default_minimal_nanotez_per_byte {A : Type} : A :=
op_startypeminuserrorstar 1000.
Definition default_config {A : Type} : A := op_startypeminuserrorstar.
Definition get_manager_operation_gas_and_fee {A B : Type} (contents : A) : B :=
op_startypeminuserrorstar.
Definition pre_filter {A B : Type} (config : A) (function_parameter : B)
: bool :=
let '_ := function_parameter in
let bytes :=
Z.add (op_startypeminuserrorstar op_startypeminuserrorstar)
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar) in
match op_startypeminuserrorstar with
| _ => true
| _ => true
| _ => true
| _ => true
| _ => true
| _ => true
| _ => true
| _ => op_startypeminuserrorstar config op_startypeminuserrorstar string
| _ => op_startypeminuserrorstar config op_startypeminuserrorstar string
end.
Definition post_filter {A B C D E F : Type}
(config : A) (function_parameter : B) : C -> (D * E) -> F :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '(_op, receipt) := function_parameter in
match receipt with
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| _ =>
match op_startypeminuserrorstar with
| _ => op_startypeminuserrorstar
| _ => op_startypeminuserrorstar
| _ => op_startypeminuserrorstar
| _ => op_startypeminuserrorstar
| _ => op_startypeminuserrorstar
| _ => op_startypeminuserrorstar
| _ => op_startypeminuserrorstar
| _ =>
op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar config
| _ =>
op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar config
end
end.
src/proto_alpha/lib_parameters/default_parameters.ml 23 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
let constants_mainnet =
Constants_repr.
{
preserved_cycles = 5;
blocks_per_cycle = 4096l;
blocks_per_commitment = 32l;
blocks_per_roll_snapshot = 256l;
blocks_per_voting_period = 32768l;
time_between_blocks = List.map Period_repr.of_seconds_exn [60L; 40L];
endorsers_per_block = 32;
hard_gas_limit_per_operation = Z.of_int 800_000;
hard_gas_limit_per_block = Z.of_int 8_000_000;
proof_of_work_threshold = Int64.(sub (shift_left 1L 46) 1L);
tokens_per_roll = Tez_repr.(mul_exn one 8_000);
michelson_maximum_type_size = 1000;
seed_nonce_revelation_tip =
(match Tez_repr.(one /? 8L) with Ok c -> c | Error _ -> assert false);
origination_size = 257;
block_security_deposit = Tez_repr.(mul_exn one 512);
endorsement_security_deposit = Tez_repr.(mul_exn one 64);
block_reward = Tez_repr.(mul_exn one 16);
endorsement_reward = Tez_repr.(mul_exn one 2);
hard_storage_limit_per_operation = Z.of_int 60_000;
cost_per_byte = Tez_repr.of_mutez_exn 1_000L;
test_chain_duration = Int64.mul 32768L 60L;
quorum_min = 20_00l;
(* quorum is in centile of a percentage *)
quorum_max = 70_00l;
min_proposal_quorum = 5_00l;
initial_endorsers = 24;
delay_per_missing_endorsement = Period_repr.of_seconds_exn 8L;
}
let constants_sandbox =
Constants_repr.
{
constants_mainnet with
preserved_cycles = 2;
blocks_per_cycle = 8l;
blocks_per_commitment = 4l;
blocks_per_roll_snapshot = 4l;
blocks_per_voting_period = 64l;
time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L];
proof_of_work_threshold = Int64.of_int (-1);
initial_endorsers = 1;
delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L;
}
let constants_test =
Constants_repr.
{
constants_mainnet with
blocks_per_cycle = 128l;
blocks_per_commitment = 4l;
blocks_per_roll_snapshot = 32l;
blocks_per_voting_period = 256l;
time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L];
proof_of_work_threshold = Int64.of_int (-1);
initial_endorsers = 1;
delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L;
}
let bootstrap_accounts_strings =
[ "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav";
"edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9";
"edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV";
"edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU";
"edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" ]
let boostrap_balance = Tez_repr.of_mutez_exn 4_000_000_000_000L
let bootstrap_accounts =
List.map
(fun s ->
let public_key = Signature.Public_key.of_b58check_exn s in
let public_key_hash = Signature.Public_key.hash public_key in
Parameters_repr.
{
public_key_hash;
public_key = Some public_key;
amount = boostrap_balance;
})
bootstrap_accounts_strings
(* TODO this could be generated from OCaml together with the faucet
for now these are harcoded values in the tests *)
let commitments =
let json_result =
Data_encoding.Json.from_string
{json|
[
[ "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ],
[ "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ],
[ "btz1LtoNCjiW23txBTenALaf5H6NKF1L3c1gw", "217487035428348" ],
[ "btz1SUd3mMhEBcWudrn8u361MVAec4WYCcFoy", "4092742372031" ],
[ "btz1MvBXf4orko1tsGmzkjLbpYSgnwUjEe81r", "17590039016550" ],
[ "btz1LoDZ3zsjgG3k3cqTpUMc9bsXbchu9qMXT", "26322312350555" ],
[ "btz1RMfq456hFV5AeDiZcQuZhoMv2dMpb9hpP", "244951387881443" ],
[ "btz1Y9roTh4A7PsMBkp8AgdVFrqUDNaBE59y1", "80065050465525" ],
[ "btz1Q1N2ePwhVw5ED3aaRVek6EBzYs1GDkSVD", "3569618927693" ],
[ "btz1VFFVsVMYHd5WfaDTAt92BeQYGK8Ri4eLy", "9034781424478" ]
]|json}
in
match json_result with
| Error err ->
raise (Failure err)
| Ok json ->
Data_encoding.Json.destruct
(Data_encoding.list Commitment_repr.encoding)
json
let make_bootstrap_account (pkh, pk, amount) =
Parameters_repr.{public_key_hash = pkh; public_key = Some pk; amount}
let parameters_of_constants ?(bootstrap_accounts = bootstrap_accounts)
?(bootstrap_contracts = []) ?(with_commitments = false) constants =
let commitments = if with_commitments then commitments else [] in
Parameters_repr.
{
bootstrap_accounts;
bootstrap_contracts;
commitments;
constants;
security_deposit_ramp_up_cycles = None;
no_reward_cycles = None;
}
let json_of_parameters parameters =
Data_encoding.Json.construct Parameters_repr.encoding parameters
src/proto_alpha/lib_parameters/default_parameters.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Definition constants_mainnet {A : Type} : A := op_startypeminuserrorstar.
Definition constants_sandbox {A : Type} : A := op_startypeminuserrorstar.
Definition constants_test {A : Type} : A := op_startypeminuserrorstar.
Definition bootstrap_accounts_strings : list string :=
cons "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav" % string
(cons "edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9" % string
(cons "edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV" % string
(cons "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU" % string
(cons
"edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" % string [])))).
Definition boostrap_balance {A : Type} : A :=
op_startypeminuserrorstar
(* ❌ Constant of type int64 is converted to int *)
4000000000000.
Definition bootstrap_accounts {A : Type} : list A :=
List.map
(fun s =>
let public_key := Signature.Public_key.of_b58check_exn s in
let public_key_hash := Signature.Public_key.hash public_key in
op_startypeminuserrorstar) bootstrap_accounts_strings.
Definition commitments {A : Type} : list A :=
let json_result :=
Data_encoding.Json.from_string
"
[
[ ""btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa"", ""23932454669343"" ],
[ ""btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv"", ""72954577464032"" ],
[ ""btz1LtoNCjiW23txBTenALaf5H6NKF1L3c1gw"", ""217487035428348"" ],
[ ""btz1SUd3mMhEBcWudrn8u361MVAec4WYCcFoy"", ""4092742372031"" ],
[ ""btz1MvBXf4orko1tsGmzkjLbpYSgnwUjEe81r"", ""17590039016550"" ],
[ ""btz1LoDZ3zsjgG3k3cqTpUMc9bsXbchu9qMXT"", ""26322312350555"" ],
[ ""btz1RMfq456hFV5AeDiZcQuZhoMv2dMpb9hpP"", ""244951387881443"" ],
[ ""btz1Y9roTh4A7PsMBkp8AgdVFrqUDNaBE59y1"", ""80065050465525"" ],
[ ""btz1Q1N2ePwhVw5ED3aaRVek6EBzYs1GDkSVD"", ""3569618927693"" ],
[ ""btz1VFFVsVMYHd5WfaDTAt92BeQYGK8Ri4eLy"", ""9034781424478"" ]
]"
% string in
match json_result with
| Stdlib.Error err => Stdlib.raise (OCaml.Failure err)
| Stdlib.Ok json =>
Data_encoding.Json.destruct
(Data_encoding.list None op_startypeminuserrorstar) json
end.
Definition make_bootstrap_account {A B C D : Type}
(function_parameter : A * B * C) : D :=
let '(pkh, pk, amount) := function_parameter in
op_startypeminuserrorstar.
Definition parameters_of_constants {A B C D : Type}
(op_staroptstar : option (list A))
: (option (list B)) -> (option bool) -> C -> D :=
let bootstrap_accounts :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => bootstrap_accounts
end in
fun op_staroptstar =>
let bootstrap_contracts :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun op_staroptstar =>
let with_commitments :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun constants =>
let commitments :=
if with_commitments then
commitments
else
[] in
op_startypeminuserrorstar.
Definition json_of_parameters {A : Type} (parameters : A)
: Tezos_base__TzPervasives.Data_encoding.Json.json :=
Data_encoding.Json.construct op_startypeminuserrorstar parameters.
src/proto_alpha/lib_parameters/gen.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Prints the json encoding of the parametric constants of protocol alpha.
$ dune utop src/proto_alpha/lib_protocol/test/helpers/ constants.ml
*)
let () =
let print_usage_and_fail s =
Printf.eprintf "Usage: %s [ --sandbox | --test | --mainnet ]" Sys.argv.(0) ;
raise (Invalid_argument s)
in
let dump parameters file =
let str =
Data_encoding.Json.to_string
(Default_parameters.json_of_parameters parameters)
in
let fd = open_out file in
output_string fd str ; close_out fd
in
if Array.length Sys.argv < 2 then print_usage_and_fail ""
else
match Sys.argv.(1) with
| "--sandbox" ->
dump
Default_parameters.(parameters_of_constants constants_sandbox)
"sandbox-parameters.json"
| "--test" ->
dump
Default_parameters.(
parameters_of_constants ~with_commitments:true constants_sandbox)
"test-parameters.json"
| "--mainnet" ->
dump
Default_parameters.(
parameters_of_constants ~with_commitments:true constants_mainnet)
"mainnet-parameters.json"
| s ->
print_usage_and_fail s
src/proto_alpha/lib_parameters/gen.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations.
src/proto_alpha/lib_protocol/alpha_context.ml 70 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = Raw_context.t
type context = t
module type BASIC_DATA = sig
type t
include Compare.S with type t := t
val encoding : t Data_encoding.t
val pp : Format.formatter -> t -> unit
end
module Tez = Tez_repr
module Period = Period_repr
module Timestamp = struct
include Time_repr
let current = Raw_context.current_timestamp
end
include Operation_repr
module Operation = struct
type 'kind t = 'kind operation = {
shell : Operation.shell_header;
protocol_data : 'kind protocol_data;
}
type packed = packed_operation
let unsigned_encoding = unsigned_operation_encoding
include Operation_repr
end
module Block_header = Block_header_repr
module Vote = struct
include Vote_repr
include Vote_storage
end
module Raw_level = Raw_level_repr
module Cycle = Cycle_repr
module Script_int = Script_int_repr
module Script_timestamp = struct
include Script_timestamp_repr
let now ctxt =
let {Constants_repr.time_between_blocks; _} = Raw_context.constants ctxt in
match time_between_blocks with
| [] ->
failwith
"Internal error: 'time_between_block' constants is an empty list."
| first_delay :: _ ->
let current_timestamp = Raw_context.predecessor_timestamp ctxt in
Time.add current_timestamp (Period_repr.to_seconds first_delay)
|> Timestamp.to_seconds |> of_int64
end
module Script = struct
include Michelson_v1_primitives
include Script_repr
let force_decode ctxt lexpr =
Lwt.return
( Script_repr.force_decode lexpr
>>? fun (v, cost) ->
Raw_context.consume_gas ctxt cost >|? fun ctxt -> (v, ctxt) )
let force_bytes ctxt lexpr =
Lwt.return
( Script_repr.force_bytes lexpr
>>? fun (b, cost) ->
Raw_context.consume_gas ctxt cost >|? fun ctxt -> (b, ctxt) )
module Legacy_support = Legacy_script_support_repr
end
module Fees = Fees_storage
type public_key = Signature.Public_key.t
type public_key_hash = Signature.Public_key_hash.t
type signature = Signature.t
module Constants = struct
include Constants_repr
include Constants_storage
end
module Voting_period = Voting_period_repr
module Gas = struct
include Gas_limit_repr
type error += Gas_limit_too_high = Raw_context.Gas_limit_too_high
let check_limit = Raw_context.check_gas_limit
let set_limit = Raw_context.set_gas_limit
let set_unlimited = Raw_context.set_gas_unlimited
let consume = Raw_context.consume_gas
let check_enough = Raw_context.check_enough_gas
let level = Raw_context.gas_level
let consumed = Raw_context.gas_consumed
let block_level = Raw_context.block_gas_level
end
module Level = struct
include Level_repr
include Level_storage
end
module Contract = struct
include Contract_repr
include Contract_storage
let originate c contract ~balance ~script ~delegate =
originate c contract ~balance ~script ~delegate
let init_origination_nonce = Raw_context.init_origination_nonce
let unset_origination_nonce = Raw_context.unset_origination_nonce
end
module Big_map = struct
type id = Z.t
let fresh = Storage.Big_map.Next.incr
let fresh_temporary = Raw_context.fresh_temporary_big_map
let mem c m k = Storage.Big_map.Contents.mem (c, m) k
let get_opt c m k = Storage.Big_map.Contents.get_option (c, m) k
let rpc_arg = Storage.Big_map.rpc_arg
let cleanup_temporary c =
Raw_context.temporary_big_maps c Storage.Big_map.remove_rec c
>>= fun c -> Lwt.return (Raw_context.reset_temporary_big_map c)
let exists c id =
Lwt.return
(Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))
>>=? fun c ->
Storage.Big_map.Key_type.get_option c id
>>=? fun kt ->
match kt with
| None ->
return (c, None)
| Some kt ->
Storage.Big_map.Value_type.get c id
>>=? fun kv -> return (c, Some (kt, kv))
end
module Delegate = Delegate_storage
module Roll = struct
include Roll_repr
include Roll_storage
end
module Nonce = Nonce_storage
module Seed = struct
include Seed_repr
include Seed_storage
end
module Fitness = struct
include Fitness_repr
include Fitness
type fitness = t
include Fitness_storage
end
module Bootstrap = Bootstrap_storage
module Commitment = struct
include Commitment_repr
include Commitment_storage
end
module Global = struct
let get_block_priority = Storage.Block_priority.get
let set_block_priority = Storage.Block_priority.set
end
let prepare_first_block = Init_storage.prepare_first_block
let prepare = Init_storage.prepare
let finalize ?commit_message:message c =
let fitness = Fitness.from_int64 (Fitness.current c) in
let context = Raw_context.recover c in
{
Updater.context;
fitness;
message;
max_operations_ttl = 60;
last_allowed_fork_level =
Raw_level.to_int32 @@ Level.last_allowed_fork_level c;
}
let activate = Raw_context.activate
let fork_test_chain = Raw_context.fork_test_chain
let record_endorsement = Raw_context.record_endorsement
let allowed_endorsements = Raw_context.allowed_endorsements
let init_endorsements = Raw_context.init_endorsements
let included_endorsements = Raw_context.included_endorsements
let reset_internal_nonce = Raw_context.reset_internal_nonce
let fresh_internal_nonce = Raw_context.fresh_internal_nonce
let record_internal_nonce = Raw_context.record_internal_nonce
let internal_nonce_already_recorded =
Raw_context.internal_nonce_already_recorded
let add_deposit = Raw_context.add_deposit
let add_fees = Raw_context.add_fees
let add_rewards = Raw_context.add_rewards
let get_deposits = Raw_context.get_deposits
let get_fees = Raw_context.get_fees
let get_rewards = Raw_context.get_rewards
let description = Raw_context.description
src/proto_alpha/lib_protocol/alpha_context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := Tezos_raw_protocol_alpha.Raw_context.t.
Definition context := t.
Module BASIC_DATA.
Record signature {t : Type} := {
t := t;
include;
encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t t;
pp : Tezos_protocol_environment_alpha__Environment.Format.formatter ->
t -> unit;
}.
Arguments signature : clear implicits.
End BASIC_DATA.
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
Module Timestamp.
(* ❌ Structure item `include` not handled. *)
include
Definition current
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_protocol_environment_alpha__Environment.Time.t :=
Raw_context.current_timestamp.
End Timestamp.
(* ❌ Structure item `include` not handled. *)
include
Module Operation.
Record t {kind : Type} := {
shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
protocol_data : protocol_data kind }.
Arguments t : clear implicits.
Definition packed := packed_operation.
Definition unsigned_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.t
(Tezos_protocol_environment_alpha__Environment.Operation.shell_header *
packed_contents_list) := unsigned_operation_encoding.
(* ❌ Structure item `include` not handled. *)
include
End Operation.
(* ❌ This kind of module is not handled. *)
unhandled_module
Module Vote.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
End Vote.
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
Module Script_timestamp.
(* ❌ Structure item `include` not handled. *)
include
Definition now (ctxt : Tezos_raw_protocol_alpha.Raw_context.context) : t :=
let '{| Constants_repr.time_between_blocks := time_between_blocks |} :=
Raw_context.constants ctxt in
match time_between_blocks with
| [] =>
failwith
"Internal error: 'time_between_block' constants is an empty list." %
string
| cons first_delay _ =>
let current_timestamp := Raw_context.predecessor_timestamp ctxt in
op_pipegt
(op_pipegt
(Time.add current_timestamp (Period_repr.to_seconds first_delay))
Timestamp.to_seconds) of_int64
end.
End Script_timestamp.
Module Script.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition force_decode
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
(lexpr : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Script_repr.expr *
Tezos_raw_protocol_alpha.Raw_context.context)) :=
Lwt._return
(op_gtgtquestion (Script_repr.force_decode lexpr)
(fun function_parameter =>
let '(v, cost) := function_parameter in
op_gtpipequestion (Raw_context.consume_gas ctxt cost)
(fun ctxt => (v, ctxt)))).
Definition force_bytes
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
(lexpr : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_protocol_environment_alpha__Environment.MBytes.t *
Tezos_raw_protocol_alpha.Raw_context.context)) :=
Lwt._return
(op_gtgtquestion (Script_repr.force_bytes lexpr)
(fun function_parameter =>
let '(b, cost) := function_parameter in
op_gtpipequestion (Raw_context.consume_gas ctxt cost)
(fun ctxt => (b, ctxt)))).
(* ❌ This kind of module is not handled. *)
unhandled_module
End Script.
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition public_key :=
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t.
Definition public_key_hash :=
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t.
Definition signature :=
Tezos_protocol_environment_alpha__Environment.Signature.t.
Module Constants.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
End Constants.
(* ❌ This kind of module is not handled. *)
unhandled_module
Module Gas.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition check_limit
: Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
Raw_context.check_gas_limit.
Definition set_limit
: Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_raw_protocol_alpha.Raw_context.t := Raw_context.set_gas_limit.
Definition set_unlimited
: Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_raw_protocol_alpha.Raw_context.t := Raw_context.set_gas_unlimited.
Definition consume
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_raw_protocol_alpha.Gas_limit_repr.cost ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.context :=
Raw_context.consume_gas.
Definition check_enough
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_raw_protocol_alpha.Gas_limit_repr.cost ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
Raw_context.check_enough_gas.
Definition level
: Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_raw_protocol_alpha.Gas_limit_repr.t := Raw_context.gas_level.
Definition consumed
: Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_protocol_environment_alpha__Environment.Z.t :=
Raw_context.gas_consumed.
Definition block_level
: Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_protocol_environment_alpha__Environment.Z.t :=
Raw_context.block_gas_level.
End Gas.
Module Level.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
End Level.
Module Contract.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition originate
(c : Tezos_raw_protocol_alpha.Raw_context.t)
(contract : Tezos_raw_protocol_alpha.Contract_repr.t)
(balance : Tezos_raw_protocol_alpha.Tez_repr.t)
(script : Tezos_raw_protocol_alpha.Script_repr.t * (option big_map_diff))
(delegate :
option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
originate c None contract balance script delegate.
Definition init_origination_nonce
: Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
-> Tezos_raw_protocol_alpha.Raw_context.t :=
Raw_context.init_origination_nonce.
Definition unset_origination_nonce
: Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_raw_protocol_alpha.Raw_context.t :=
Raw_context.unset_origination_nonce.
End Contract.
Module Big_map.
Definition id := Tezos_protocol_environment_alpha__Environment.Z.t.
Definition fresh
: Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t *
Tezos_protocol_environment_alpha__Environment.Z.t)) :=
Storage.Big_map.Next.incr.
Definition fresh_temporary
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_raw_protocol_alpha.Raw_context.context *
Tezos_protocol_environment_alpha__Environment.Z.t :=
Raw_context.fresh_temporary_big_map.
Definition mem
(c : Tezos_raw_protocol_alpha.Raw_context.t)
(m : Tezos_protocol_environment_alpha__Environment.Z.t)
(k : Tezos_raw_protocol_alpha.Storage.Big_map.Contents.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * bool)) :=
Storage.Big_map.Contents.mem (c, m) k.
Definition get_opt
(c : Tezos_raw_protocol_alpha.Raw_context.t)
(m : Tezos_protocol_environment_alpha__Environment.Z.t)
(k : Tezos_raw_protocol_alpha.Storage.Big_map.Contents.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t *
(option Tezos_raw_protocol_alpha.Storage.Big_map.Contents.value))) :=
Storage.Big_map.Contents.get_option (c, m) k.
Definition rpc_arg
: Tezos_protocol_environment_alpha__Environment.RPC_arg.t
Tezos_protocol_environment_alpha__Environment.Z.t :=
Storage.Big_map.rpc_arg.
Definition cleanup_temporary
(c : Tezos_raw_protocol_alpha.Raw_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.context :=
op_gtgteq (Raw_context.temporary_big_maps c Storage.Big_map.remove_rec c)
(fun c => Lwt._return (Raw_context.reset_temporary_big_map c)).
Definition _exists
(c : Tezos_raw_protocol_alpha.Raw_context.context)
(id : Tezos_raw_protocol_alpha.Storage.Big_map.Key_type.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.context *
(option
(Tezos_raw_protocol_alpha.Storage.Big_map.Key_type.value *
Tezos_raw_protocol_alpha.Storage.Big_map.Value_type.value)))) :=
op_gtgteqquestion
(Lwt._return
(Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)))
(fun c =>
op_gtgteqquestion (Storage.Big_map.Key_type.get_option c id)
(fun kt =>
match kt with
| None => _return (c, None)
| Some kt =>
op_gtgteqquestion (Storage.Big_map.Value_type.get c id)
(fun kv => _return (c, (Some (kt, kv))))
end)).
End Big_map.
(* ❌ This kind of module is not handled. *)
unhandled_module
Module Roll.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
End Roll.
(* ❌ This kind of module is not handled. *)
unhandled_module
Module Seed.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
End Seed.
Module Fitness.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
Definition fitness := t.
(* ❌ Structure item `include` not handled. *)
include
End Fitness.
(* ❌ This kind of module is not handled. *)
unhandled_module
Module Commitment.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Structure item `include` not handled. *)
include
End Commitment.
Module Global.
Definition get_block_priority
: Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
Storage.Block_priority.get.
Definition set_block_priority
: Tezos_raw_protocol_alpha.Raw_context.t ->
Z ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
Storage.Block_priority.set.
End Global.
Definition prepare_first_block
: Tezos_protocol_environment_alpha__Environment.Context.t ->
(Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_raw_protocol_alpha.Script_repr.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_raw_protocol_alpha.Script_repr.t *
(option Tezos_raw_protocol_alpha.Contract_storage.big_map_diff)) *
Tezos_raw_protocol_alpha.Raw_context.t))) ->
int32 ->
Tezos_protocol_environment_alpha__Environment.Time.t ->
Tezos_protocol_environment_alpha__Environment.Fitness.(Tezos_protocol_environment_alpha__Environment.T.S.t)
->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
Init_storage.prepare_first_block.
Definition prepare
: Tezos_protocol_environment_alpha__Environment.Context.t ->
Tezos_protocol_environment_alpha__Environment.Int32.t ->
Tezos_protocol_environment_alpha__Environment.Time.t ->
Tezos_protocol_environment_alpha__Environment.Time.t ->
Tezos_protocol_environment_alpha__Environment.Fitness.(Tezos_protocol_environment_alpha__Environment.T.S.t)
->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.context) :=
Init_storage.prepare.
Definition finalize
(message : option string) (c : Tezos_raw_protocol_alpha.Raw_context.context)
: Tezos_protocol_environment_alpha__Environment.Updater.validation_result :=
let fitness := Fitness.from_int64 (Fitness.current c) in
let context := Raw_context.recover c in
{| Updater.context := context; Updater.fitness := fitness;
Updater.message := message; Updater.max_operations_ttl := 60;
Updater.last_allowed_fork_level :=
op_atat Raw_level.to_int32 (Level.last_allowed_fork_level c) |}.
Definition activate
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t := Raw_context.activate.
Definition fork_test_chain
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
->
Tezos_protocol_environment_alpha__Environment.Time.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t := Raw_context.fork_test_chain.
Definition record_endorsement
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
Tezos_raw_protocol_alpha.Raw_context.context :=
Raw_context.record_endorsement.
Definition allowed_endorsements
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
(list Z) * bool) := Raw_context.allowed_endorsements.
Definition init_endorsements
: Tezos_raw_protocol_alpha.Raw_context.context ->
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
(list Z) * bool)) -> Tezos_raw_protocol_alpha.Raw_context.context :=
Raw_context.init_endorsements.
Definition included_endorsements
: Tezos_raw_protocol_alpha.Raw_context.context -> Z :=
Raw_context.included_endorsements.
Definition reset_internal_nonce
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_raw_protocol_alpha.Raw_context.context :=
Raw_context.reset_internal_nonce.
Definition fresh_internal_nonce
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.context * Z) :=
Raw_context.fresh_internal_nonce.
Definition record_internal_nonce
: Tezos_raw_protocol_alpha.Raw_context.context ->
Z -> Tezos_raw_protocol_alpha.Raw_context.context :=
Raw_context.record_internal_nonce.
Definition internal_nonce_already_recorded
: Tezos_raw_protocol_alpha.Raw_context.context -> Z -> bool :=
Raw_context.internal_nonce_already_recorded.
Definition add_deposit
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
Tezos_raw_protocol_alpha.Tez_repr.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.context) :=
Raw_context.add_deposit.
Definition add_fees
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_raw_protocol_alpha.Tez_repr.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.context) := Raw_context.add_fees.
Definition add_rewards
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_raw_protocol_alpha.Tez_repr.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.context) :=
Raw_context.add_rewards.
Definition get_deposits
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
Tezos_raw_protocol_alpha.Tez_repr.t := Raw_context.get_deposits.
Definition get_fees
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_raw_protocol_alpha.Tez_repr.t := Raw_context.get_fees.
Definition get_rewards
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_raw_protocol_alpha.Tez_repr.t := Raw_context.get_rewards.
Definition description
: Tezos_raw_protocol_alpha.Storage_description.t
Tezos_raw_protocol_alpha.Raw_context.context := Raw_context.description.
src/proto_alpha/lib_protocol/alpha_services.ml 52 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
let custom_root = RPC_path.open_root
module Seed = struct
module S = struct
open Data_encoding
let seed =
RPC_service.post_service
~description:"Seed of the cycle to which the block belongs."
~query:RPC_query.empty
~input:empty
~output:Seed.seed_encoding
RPC_path.(custom_root / "context" / "seed")
end
let () =
let open Services_registration in
register0 S.seed (fun ctxt () () ->
let l = Level.current ctxt in
Seed.for_cycle ctxt l.cycle)
let get ctxt block = RPC_context.make_call0 S.seed ctxt block () ()
end
module Nonce = struct
type info = Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten
let info_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Revealed"
(obj1 (req "nonce" Nonce.encoding))
(function Revealed nonce -> Some nonce | _ -> None)
(fun nonce -> Revealed nonce);
case
(Tag 1)
~title:"Missing"
(obj1 (req "hash" Nonce_hash.encoding))
(function Missing nonce -> Some nonce | _ -> None)
(fun nonce -> Missing nonce);
case
(Tag 2)
~title:"Forgotten"
empty
(function Forgotten -> Some () | _ -> None)
(fun () -> Forgotten) ]
module S = struct
let get =
RPC_service.get_service
~description:"Info about the nonce of a previous block."
~query:RPC_query.empty
~output:info_encoding
RPC_path.(custom_root / "context" / "nonces" /: Raw_level.rpc_arg)
end
let register () =
let open Services_registration in
register1 S.get (fun ctxt raw_level () () ->
let level = Level.from_raw ctxt raw_level in
Nonce.get ctxt level
>>= function
| Ok (Revealed nonce) ->
return (Revealed nonce)
| Ok (Unrevealed {nonce_hash; _}) ->
return (Missing nonce_hash)
| Error _ ->
return Forgotten)
let get ctxt block level =
RPC_context.make_call1 S.get ctxt block level () ()
end
module Contract = Contract_services
module Constants = Constants_services
module Delegate = Delegate_services
module Helpers = Helpers_services
module Forge = Helpers_services.Forge
module Parse = Helpers_services.Parse
module Voting = Voting_services
let register () =
Contract.register () ;
Constants.register () ;
Delegate.register () ;
Helpers.register () ;
Nonce.register () ;
Voting.register ()
src/proto_alpha/lib_protocol/alpha_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Definition custom_root {A : Type}
: Tezos_protocol_environment_alpha__Environment.RPC_path.context A :=
RPC_path.open_root.
Module Seed.
Module S.
Import Data_encoding.
Definition seed
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
unit Tezos_raw_protocol_alpha.Alpha_context.Seed.seed :=
RPC_service.post_service
(Some "Seed of the cycle to which the block belongs." % string)
RPC_query.empty empty Seed.seed_encoding
(op_div (op_div custom_root "context" % string) "seed" % string).
End S.
Definition get {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Seed.seed) :=
RPC_context.make_call0 S.seed ctxt block tt tt.
End Seed.
Module Nonce.
Inductive info : Type :=
| Revealed : Tezos_raw_protocol_alpha.Alpha_context.Nonce.t -> info
| Missing : Tezos_raw_protocol_alpha.Nonce_hash.t -> info
| Forgotten : info.
Definition info_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding info :=
union None
(cons
(case "Revealed" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
(obj1 (req None None "nonce" % string Nonce.encoding))
(fun function_parameter =>
match function_parameter with
| Revealed nonce => Some nonce
| _ => None
end) (fun nonce => Revealed nonce))
(cons
(case "Missing" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
(obj1 (req None None "hash" % string Nonce_hash.encoding))
(fun function_parameter =>
match function_parameter with
| Missing nonce => Some nonce
| _ => None
end) (fun nonce => Missing nonce))
(cons
(case "Forgotten" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 2)
empty
(fun function_parameter =>
match function_parameter with
| Forgotten => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Forgotten)) []))).
Module S.
Definition get
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
Tezos_raw_protocol_alpha.Alpha_context.Raw_level.raw_level) unit unit
info :=
RPC_service.get_service
(Some "Info about the nonce of a previous block." % string)
RPC_query.empty info_encoding
(op_divcolon
(op_div (op_div custom_root "context" % string) "nonces" % string)
Raw_level.rpc_arg).
End S.
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
register1 S.get
(fun ctxt =>
fun raw_level =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
let level := Level.from_raw ctxt None raw_level in
op_gtgteq (Nonce.get ctxt level)
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
(Tezos_raw_protocol_alpha.Alpha_context.Nonce.Revealed
nonce) => _return (Revealed nonce)
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
(Tezos_raw_protocol_alpha.Alpha_context.Nonce.Unrevealed
{| nonce_hash := nonce_hash |}) =>
_return (Missing nonce_hash)
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ => _return Forgotten
end)).
Definition get {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.raw_level)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
info) := RPC_context.make_call1 S.get ctxt block level tt tt.
End Nonce.
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Contract.register tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Constants.register tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Delegate.register tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Helpers.register tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Nonce.register tt in
Voting.register tt.
src/proto_alpha/lib_protocol/amendment.ml 67 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
(** Returns the proposal submitted by the most delegates.
Returns None in case of a tie, if proposal quorum is below required
minimum or if there are no proposals. *)
let select_winning_proposal ctxt =
Vote.get_proposals ctxt
>>=? fun proposals ->
let merge proposal vote winners =
match winners with
| None ->
Some ([proposal], vote)
| Some (winners, winners_vote) as previous ->
if Compare.Int32.(vote = winners_vote) then
Some (proposal :: winners, winners_vote)
else if Compare.Int32.(vote > winners_vote) then Some ([proposal], vote)
else previous
in
match Protocol_hash.Map.fold merge proposals None with
| Some ([proposal], vote) ->
Vote.listing_size ctxt
>>=? fun max_vote ->
let min_proposal_quorum = Constants.min_proposal_quorum ctxt in
let min_vote_to_pass =
Int32.div (Int32.mul min_proposal_quorum max_vote) 100_00l
in
if Compare.Int32.(vote >= min_vote_to_pass) then return_some proposal
else return_none
| _ ->
return_none
(* in case of a tie, let's do nothing. *)
(** A proposal is approved if it has supermajority and the participation reaches
the current quorum.
Supermajority means the yays are more 8/10 of casted votes.
The participation is the ratio of all received votes, including passes, with
respect to the number of possible votes.
The participation EMA (exponential moving average) uses the last
participation EMA and the current participation./
The expected quorum is calculated using the last participation EMA, capped
by the min/max quorum protocol constants. *)
let check_approval_and_update_participation_ema ctxt =
Vote.get_ballots ctxt
>>=? fun ballots ->
Vote.listing_size ctxt
>>=? fun maximum_vote ->
Vote.get_participation_ema ctxt
>>=? fun participation_ema ->
Vote.get_current_quorum ctxt
>>=? fun expected_quorum ->
(* Note overflows: considering a maximum of 8e8 tokens, with roll size as
small as 1e3, there is a maximum of 8e5 rolls and thus votes.
In 'participation' an Int64 is used because in the worst case 'all_votes is
8e5 and after the multiplication is 8e9, making it potentially overflow a
signed Int32 which is 2e9. *)
let casted_votes = Int32.add ballots.yay ballots.nay in
let all_votes = Int32.add casted_votes ballots.pass in
let supermajority = Int32.div (Int32.mul 8l casted_votes) 10l in
let participation =
(* in centile of percentage *)
Int64.(
to_int32 (div (mul (of_int32 all_votes) 100_00L) (of_int32 maximum_vote)))
in
let outcome =
Compare.Int32.(
participation >= expected_quorum && ballots.yay >= supermajority)
in
let new_participation_ema =
Int32.(div (add (mul 8l participation_ema) (mul 2l participation)) 10l)
in
Vote.set_participation_ema ctxt new_participation_ema
>>=? fun ctxt -> return (ctxt, outcome)
(** Implements the state machine of the amendment procedure.
Note that [freeze_listings], that computes the vote weight of each delegate,
is run at the beginning of each voting period.
*)
let start_new_voting_period ctxt =
Vote.get_current_period_kind ctxt
>>=? function
| Proposal -> (
select_winning_proposal ctxt
>>=? fun proposal ->
Vote.clear_proposals ctxt
>>= fun ctxt ->
Vote.clear_listings ctxt
>>=? fun ctxt ->
match proposal with
| None ->
Vote.freeze_listings ctxt >>=? fun ctxt -> return ctxt
| Some proposal ->
Vote.init_current_proposal ctxt proposal
>>=? fun ctxt ->
Vote.freeze_listings ctxt
>>=? fun ctxt ->
Vote.set_current_period_kind ctxt Testing_vote
>>=? fun ctxt -> return ctxt )
| Testing_vote ->
check_approval_and_update_participation_ema ctxt
>>=? fun (ctxt, approved) ->
Vote.clear_ballots ctxt
>>= fun ctxt ->
Vote.clear_listings ctxt
>>=? fun ctxt ->
if approved then
let expiration =
(* in two days maximum... *)
Time.add
(Timestamp.current ctxt)
(Constants.test_chain_duration ctxt)
in
Vote.get_current_proposal ctxt
>>=? fun proposal ->
fork_test_chain ctxt proposal expiration
>>= fun ctxt ->
Vote.set_current_period_kind ctxt Testing >>=? fun ctxt -> return ctxt
else
Vote.clear_current_proposal ctxt
>>=? fun ctxt ->
Vote.freeze_listings ctxt
>>=? fun ctxt ->
Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> return ctxt
| Testing ->
Vote.freeze_listings ctxt
>>=? fun ctxt ->
Vote.set_current_period_kind ctxt Promotion_vote
>>=? fun ctxt -> return ctxt
| Promotion_vote ->
check_approval_and_update_participation_ema ctxt
>>=? fun (ctxt, approved) ->
( if approved then
Vote.get_current_proposal ctxt
>>=? fun proposal -> activate ctxt proposal >>= fun ctxt -> return ctxt
else return ctxt )
>>=? fun ctxt ->
Vote.clear_ballots ctxt
>>= fun ctxt ->
Vote.clear_listings ctxt
>>=? fun ctxt ->
Vote.clear_current_proposal ctxt
>>=? fun ctxt ->
Vote.freeze_listings ctxt
>>=? fun ctxt ->
Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> return ctxt
type error +=
| (* `Branch *)
Invalid_proposal
| Unexpected_proposal
| Unauthorized_proposal
| Too_many_proposals
| Empty_proposal
| Unexpected_ballot
| Unauthorized_ballot
let () =
let open Data_encoding in
(* Invalid proposal *)
register_error_kind
`Branch
~id:"invalid_proposal"
~title:"Invalid proposal"
~description:"Ballot provided for a proposal that is not the current one."
~pp:(fun ppf () -> Format.fprintf ppf "Invalid proposal")
empty
(function Invalid_proposal -> Some () | _ -> None)
(fun () -> Invalid_proposal) ;
(* Unexpected proposal *)
register_error_kind
`Branch
~id:"unexpected_proposal"
~title:"Unexpected proposal"
~description:"Proposal recorded outside of a proposal period."
~pp:(fun ppf () -> Format.fprintf ppf "Unexpected proposal")
empty
(function Unexpected_proposal -> Some () | _ -> None)
(fun () -> Unexpected_proposal) ;
(* Unauthorized proposal *)
register_error_kind
`Branch
~id:"unauthorized_proposal"
~title:"Unauthorized proposal"
~description:
"The delegate provided for the proposal is not in the voting listings."
~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized proposal")
empty
(function Unauthorized_proposal -> Some () | _ -> None)
(fun () -> Unauthorized_proposal) ;
(* Unexpected ballot *)
register_error_kind
`Branch
~id:"unexpected_ballot"
~title:"Unexpected ballot"
~description:"Ballot recorded outside of a voting period."
~pp:(fun ppf () -> Format.fprintf ppf "Unexpected ballot")
empty
(function Unexpected_ballot -> Some () | _ -> None)
(fun () -> Unexpected_ballot) ;
(* Unauthorized ballot *)
register_error_kind
`Branch
~id:"unauthorized_ballot"
~title:"Unauthorized ballot"
~description:
"The delegate provided for the ballot is not in the voting listings."
~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized ballot")
empty
(function Unauthorized_ballot -> Some () | _ -> None)
(fun () -> Unauthorized_ballot) ;
(* Too many proposals *)
register_error_kind
`Branch
~id:"too_many_proposals"
~title:"Too many proposals"
~description:
"The delegate reached the maximum number of allowed proposals."
~pp:(fun ppf () -> Format.fprintf ppf "Too many proposals")
empty
(function Too_many_proposals -> Some () | _ -> None)
(fun () -> Too_many_proposals) ;
(* Empty proposal *)
register_error_kind
`Branch
~id:"empty_proposal"
~title:"Empty proposal"
~description:"Proposal lists cannot be empty."
~pp:(fun ppf () -> Format.fprintf ppf "Empty proposal")
empty
(function Empty_proposal -> Some () | _ -> None)
(fun () -> Empty_proposal)
(* @return [true] if [List.length l] > [n] w/o computing length *)
let rec longer_than l n =
if Compare.Int.(n < 0) then assert false
else
match l with
| [] ->
false
| _ :: rest ->
if Compare.Int.(n = 0) then true
else (* n > 0 *)
longer_than rest (n - 1)
let record_proposals ctxt delegate proposals =
(match proposals with [] -> fail Empty_proposal | _ :: _ -> return_unit)
>>=? fun () ->
Vote.get_current_period_kind ctxt
>>=? function
| Proposal ->
Vote.in_listings ctxt delegate
>>= fun in_listings ->
if in_listings then
Vote.recorded_proposal_count_for_delegate ctxt delegate
>>=? fun count ->
fail_when
(longer_than proposals (Constants.max_proposals_per_delegate - count))
Too_many_proposals
>>=? fun () ->
fold_left_s
(fun ctxt proposal -> Vote.record_proposal ctxt proposal delegate)
ctxt
proposals
>>=? fun ctxt -> return ctxt
else fail Unauthorized_proposal
| Testing_vote | Testing | Promotion_vote ->
fail Unexpected_proposal
let record_ballot ctxt delegate proposal ballot =
Vote.get_current_period_kind ctxt
>>=? function
| Testing_vote | Promotion_vote ->
Vote.get_current_proposal ctxt
>>=? fun current_proposal ->
fail_unless
(Protocol_hash.equal proposal current_proposal)
Invalid_proposal
>>=? fun () ->
Vote.has_recorded_ballot ctxt delegate
>>= fun has_ballot ->
fail_when has_ballot Unauthorized_ballot
>>=? fun () ->
Vote.in_listings ctxt delegate
>>= fun in_listings ->
if in_listings then Vote.record_ballot ctxt delegate ballot
else fail Unauthorized_ballot
| Testing | Proposal ->
fail Unexpected_ballot
let last_of_a_voting_period ctxt l =
Compare.Int32.(
Int32.succ l.Level.voting_period_position
= Constants.blocks_per_voting_period ctxt)
let may_start_new_voting_period ctxt =
let level = Level.current ctxt in
if last_of_a_voting_period ctxt level then start_new_voting_period ctxt
else return ctxt
src/proto_alpha/lib_protocol/amendment.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Definition select_winning_proposal
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option
Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.key)) :=
op_gtgteqquestion (Vote.get_proposals ctxt)
(fun proposals =>
let merge {A : Type}
(proposal : A) (vote :
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(winners :
option
((list A) *
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)))
: option
((list A) *
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)) :=
match winners with
| None => Some ((cons proposal []), vote)
| (Some (winners, winners_vote)) as previous =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
vote winners_vote then
Some ((cons proposal winners), winners_vote)
else
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
vote winners_vote then
Some ((cons proposal []), vote)
else
previous
end in
match Protocol_hash.Map.fold merge proposals None with
| Some (cons proposal [], vote) =>
op_gtgteqquestion (Vote.listing_size ctxt)
(fun max_vote =>
let min_proposal_quorum := Constants.min_proposal_quorum ctxt in
let min_vote_to_pass :=
Int32.div (Int32.mul min_proposal_quorum max_vote)
(* ❌ Constant of type int32 is converted to int *)
10000 in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
vote min_vote_to_pass then
return_some proposal
else
return_none)
| _ => return_none
end).
Definition check_approval_and_update_participation_ema
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha__Alpha_context.context * bool)) :=
op_gtgteqquestion (Vote.get_ballots ctxt)
(fun ballots =>
op_gtgteqquestion (Vote.listing_size ctxt)
(fun maximum_vote =>
op_gtgteqquestion (Vote.get_participation_ema ctxt)
(fun participation_ema =>
op_gtgteqquestion (Vote.get_current_quorum ctxt)
(fun expected_quorum =>
let casted_votes := Int32.add (yay ballots) (nay ballots) in
let all_votes := Int32.add casted_votes (pass ballots) in
let supermajority :=
Int32.div
(Int32.mul
(* ❌ Constant of type int32 is converted to int *)
8 casted_votes)
(* ❌ Constant of type int32 is converted to int *)
10 in
let participation :=
to_int32
(div
(mul (of_int32 all_votes)
(* ❌ Constant of type int64 is converted to int *)
10000) (of_int32 maximum_vote)) in
let outcome :=
op_andand
(Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
participation expected_quorum)
(Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
(yay ballots) supermajority) in
let new_participation_ema :=
div
(add
(mul
(* ❌ Constant of type int32 is converted to int *)
8 participation_ema)
(mul
(* ❌ Constant of type int32 is converted to int *)
2 participation))
(* ❌ Constant of type int32 is converted to int *)
10 in
op_gtgteqquestion
(Vote.set_participation_ema ctxt new_participation_ema)
(fun ctxt => _return (ctxt, outcome)))))).
Definition start_new_voting_period
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha__Alpha_context.context) :=
op_gtgteqquestion (Vote.get_current_period_kind ctxt)
(fun function_parameter =>
match function_parameter with
| Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Proposal =>
op_gtgteqquestion (select_winning_proposal ctxt)
(fun proposal =>
op_gtgteq (Vote.clear_proposals ctxt)
(fun ctxt =>
op_gtgteqquestion (Vote.clear_listings ctxt)
(fun ctxt =>
match proposal with
| None =>
op_gtgteqquestion (Vote.freeze_listings ctxt)
(fun ctxt => _return ctxt)
| Some proposal =>
op_gtgteqquestion
(Vote.init_current_proposal ctxt proposal)
(fun ctxt =>
op_gtgteqquestion (Vote.freeze_listings ctxt)
(fun ctxt =>
op_gtgteqquestion
(Vote.set_current_period_kind ctxt
Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing_vote)
(fun ctxt => _return ctxt)))
end)))
| Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing_vote =>
op_gtgteqquestion (check_approval_and_update_participation_ema ctxt)
(fun function_parameter =>
let '(ctxt, approved) := function_parameter in
op_gtgteq (Vote.clear_ballots ctxt)
(fun ctxt =>
op_gtgteqquestion (Vote.clear_listings ctxt)
(fun ctxt =>
if approved then
let expiration :=
Time.add (Timestamp.current ctxt)
(Constants.test_chain_duration ctxt) in
op_gtgteqquestion (Vote.get_current_proposal ctxt)
(fun proposal =>
op_gtgteq (fork_test_chain ctxt proposal expiration)
(fun ctxt =>
op_gtgteqquestion
(Vote.set_current_period_kind ctxt
Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing)
(fun ctxt => _return ctxt)))
else
op_gtgteqquestion (Vote.clear_current_proposal ctxt)
(fun ctxt =>
op_gtgteqquestion (Vote.freeze_listings ctxt)
(fun ctxt =>
op_gtgteqquestion
(Vote.set_current_period_kind ctxt
Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Proposal)
(fun ctxt => _return ctxt))))))
| Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing =>
op_gtgteqquestion (Vote.freeze_listings ctxt)
(fun ctxt =>
op_gtgteqquestion
(Vote.set_current_period_kind ctxt
Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Promotion_vote)
(fun ctxt => _return ctxt))
| Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Promotion_vote =>
op_gtgteqquestion (check_approval_and_update_participation_ema ctxt)
(fun function_parameter =>
let '(ctxt, approved) := function_parameter in
op_gtgteqquestion
(if approved then
op_gtgteqquestion (Vote.get_current_proposal ctxt)
(fun proposal =>
op_gtgteq (activate ctxt proposal)
(fun ctxt => _return ctxt))
else
_return ctxt)
(fun ctxt =>
op_gtgteq (Vote.clear_ballots ctxt)
(fun ctxt =>
op_gtgteqquestion (Vote.clear_listings ctxt)
(fun ctxt =>
op_gtgteqquestion (Vote.clear_current_proposal ctxt)
(fun ctxt =>
op_gtgteqquestion (Vote.freeze_listings ctxt)
(fun ctxt =>
op_gtgteqquestion
(Vote.set_current_period_kind ctxt
Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Proposal)
(fun ctxt => _return ctxt)))))))
end).
(* ❌ Structure item `typext` not handled. *)
type_extension
Fixpoint longer_than {A : Type}
(l : list A)
(n :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: bool :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
n 0 then
(* ❌ Assert instruction is not handled. *)
assert false
else
match l with
| [] => false
| cons _ rest =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
n 0 then
true
else
longer_than rest (op_minus n 1)
end.
Definition record_proposals
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(delegate : Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
(proposals :
list
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha__Alpha_context.context) :=
op_gtgteqquestion
match proposals with
| [] =>
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_proposal
| cons _ _ => return_unit
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Vote.get_current_period_kind ctxt)
(fun function_parameter =>
match function_parameter with
| Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Proposal =>
op_gtgteq (Vote.in_listings ctxt delegate)
(fun in_listings =>
if in_listings then
op_gtgteqquestion
(Vote.recorded_proposal_count_for_delegate ctxt delegate)
(fun count =>
op_gtgteqquestion
(fail_when
(longer_than proposals
(op_minus Constants.max_proposals_per_delegate count))
Tezos_protocol_environment_alpha__Environment.Error_monad.Too_many_proposals)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fold_left_s
(fun ctxt =>
fun proposal =>
Vote.record_proposal ctxt proposal delegate)
ctxt proposals) (fun ctxt => _return ctxt)))
else
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Unauthorized_proposal)
|
Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing_vote |
Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing |
Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Promotion_vote
=>
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_proposal
end)).
Definition record_ballot
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(delegate : Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
(proposal :
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(ballot : Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha__Alpha_context.context) :=
op_gtgteqquestion (Vote.get_current_period_kind ctxt)
(fun function_parameter =>
match function_parameter with
|
Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing_vote |
Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Promotion_vote
=>
op_gtgteqquestion (Vote.get_current_proposal ctxt)
(fun current_proposal =>
op_gtgteqquestion
(fail_unless
(Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
proposal current_proposal)
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_proposal)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Vote.has_recorded_ballot ctxt delegate)
(fun has_ballot =>
op_gtgteqquestion
(fail_when has_ballot
Tezos_protocol_environment_alpha__Environment.Error_monad.Unauthorized_ballot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Vote.in_listings ctxt delegate)
(fun in_listings =>
if in_listings then
Vote.record_ballot ctxt delegate ballot
else
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Unauthorized_ballot)))))
|
Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing |
Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Proposal =>
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_ballot
end).
Definition last_of_a_voting_period
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(l : Tezos_raw_protocol_alpha.Alpha_context.Level.t) : bool :=
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(Int32.succ (Level.voting_period_position l))
(Constants.blocks_per_voting_period ctxt).
Definition may_start_new_voting_period
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha__Alpha_context.context) :=
let level := Level.current ctxt in
if last_of_a_voting_period ctxt level then
start_new_voting_period ctxt
else
_return ctxt.
src/proto_alpha/lib_protocol/apply.ml 261 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Tezos Protocol Implementation - Main Entry Points *)
open Alpha_context
type error += Wrong_voting_period of Voting_period.t * Voting_period.t
(* `Temporary *)
type error += Wrong_endorsement_predecessor of Block_hash.t * Block_hash.t
(* `Temporary *)
type error += Duplicate_endorsement of Signature.Public_key_hash.t
(* `Branch *)
type error += Invalid_endorsement_level
type error += Invalid_commitment of {expected : bool}
type error += Internal_operation_replay of packed_internal_operation
type error += Invalid_double_endorsement_evidence (* `Permanent *)
type error +=
| Inconsistent_double_endorsement_evidence of {
delegate1 : Signature.Public_key_hash.t;
delegate2 : Signature.Public_key_hash.t;
}
(* `Permanent *)
type error += Unrequired_double_endorsement_evidence (* `Branch*)
type error +=
| Too_early_double_endorsement_evidence of {
level : Raw_level.t;
current : Raw_level.t;
}
(* `Temporary *)
type error +=
| Outdated_double_endorsement_evidence of {
level : Raw_level.t;
last : Raw_level.t;
}
(* `Permanent *)
type error +=
| Invalid_double_baking_evidence of {
hash1 : Block_hash.t;
level1 : Int32.t;
hash2 : Block_hash.t;
level2 : Int32.t;
}
(* `Permanent *)
type error +=
| Inconsistent_double_baking_evidence of {
delegate1 : Signature.Public_key_hash.t;
delegate2 : Signature.Public_key_hash.t;
}
(* `Permanent *)
type error += Unrequired_double_baking_evidence (* `Branch*)
type error +=
| Too_early_double_baking_evidence of {
level : Raw_level.t;
current : Raw_level.t;
}
(* `Temporary *)
type error +=
| Outdated_double_baking_evidence of {
level : Raw_level.t;
last : Raw_level.t;
}
(* `Permanent *)
type error += Invalid_activation of {pkh : Ed25519.Public_key_hash.t}
type error += Multiple_revelation
type error += Gas_quota_exceeded_init_deserialize (* Permanent *)
type error +=
| Not_enough_endorsements_for_priority of {
required : int;
priority : int;
endorsements : int;
timestamp : Time.t;
}
let () =
register_error_kind
`Temporary
~id:"operation.wrong_endorsement_predecessor"
~title:"Wrong endorsement predecessor"
~description:
"Trying to include an endorsement in a block that is not the successor \
of the endorsed one"
~pp:(fun ppf (e, p) ->
Format.fprintf
ppf
"Wrong predecessor %a, expected %a"
Block_hash.pp
p
Block_hash.pp
e)
Data_encoding.(
obj2
(req "expected" Block_hash.encoding)
(req "provided" Block_hash.encoding))
(function
| Wrong_endorsement_predecessor (e, p) -> Some (e, p) | _ -> None)
(fun (e, p) -> Wrong_endorsement_predecessor (e, p)) ;
register_error_kind
`Temporary
~id:"operation.wrong_voting_period"
~title:"Wrong voting period"
~description:
"Trying to onclude a proposal or ballot meant for another voting period"
~pp:(fun ppf (e, p) ->
Format.fprintf
ppf
"Wrong voting period %a, current is %a"
Voting_period.pp
p
Voting_period.pp
e)
Data_encoding.(
obj2
(req "current" Voting_period.encoding)
(req "provided" Voting_period.encoding))
(function Wrong_voting_period (e, p) -> Some (e, p) | _ -> None)
(fun (e, p) -> Wrong_voting_period (e, p)) ;
register_error_kind
`Branch
~id:"operation.duplicate_endorsement"
~title:"Duplicate endorsement"
~description:"Two endorsements received from same delegate"
~pp:(fun ppf k ->
Format.fprintf
ppf
"Duplicate endorsement from delegate %a (possible replay attack)."
Signature.Public_key_hash.pp_short
k)
Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
(function Duplicate_endorsement k -> Some k | _ -> None)
(fun k -> Duplicate_endorsement k) ;
register_error_kind
`Temporary
~id:"operation.invalid_endorsement_level"
~title:"Unexpected level in endorsement"
~description:
"The level of an endorsement is inconsistent with the provided block \
hash."
~pp:(fun ppf () -> Format.fprintf ppf "Unexpected level in endorsement.")
Data_encoding.unit
(function Invalid_endorsement_level -> Some () | _ -> None)
(fun () -> Invalid_endorsement_level) ;
register_error_kind
`Permanent
~id:"block.invalid_commitment"
~title:"Invalid commitment in block header"
~description:"The block header has invalid commitment."
~pp:(fun ppf expected ->
if expected then
Format.fprintf ppf "Missing seed's nonce commitment in block header."
else
Format.fprintf
ppf
"Unexpected seed's nonce commitment in block header.")
Data_encoding.(obj1 (req "expected" bool))
(function Invalid_commitment {expected} -> Some expected | _ -> None)
(fun expected -> Invalid_commitment {expected}) ;
register_error_kind
`Permanent
~id:"internal_operation_replay"
~title:"Internal operation replay"
~description:"An internal operation was emitted twice by a script"
~pp:(fun ppf (Internal_operation {nonce; _}) ->
Format.fprintf
ppf
"Internal operation %d was emitted twice by a script"
nonce)
Operation.internal_operation_encoding
(function Internal_operation_replay op -> Some op | _ -> None)
(fun op -> Internal_operation_replay op) ;
register_error_kind
`Permanent
~id:"block.invalid_double_endorsement_evidence"
~title:"Invalid double endorsement evidence"
~description:"A double-endorsement evidence is malformed"
~pp:(fun ppf () ->
Format.fprintf ppf "Malformed double-endorsement evidence")
Data_encoding.empty
(function Invalid_double_endorsement_evidence -> Some () | _ -> None)
(fun () -> Invalid_double_endorsement_evidence) ;
register_error_kind
`Permanent
~id:"block.inconsistent_double_endorsement_evidence"
~title:"Inconsistent double endorsement evidence"
~description:
"A double-endorsement evidence is inconsistent (two distinct delegates)"
~pp:(fun ppf (delegate1, delegate2) ->
Format.fprintf
ppf
"Inconsistent double-endorsement evidence (distinct delegate: %a and \
%a)"
Signature.Public_key_hash.pp_short
delegate1
Signature.Public_key_hash.pp_short
delegate2)
Data_encoding.(
obj2
(req "delegate1" Signature.Public_key_hash.encoding)
(req "delegate2" Signature.Public_key_hash.encoding))
(function
| Inconsistent_double_endorsement_evidence {delegate1; delegate2} ->
Some (delegate1, delegate2)
| _ ->
None)
(fun (delegate1, delegate2) ->
Inconsistent_double_endorsement_evidence {delegate1; delegate2}) ;
register_error_kind
`Branch
~id:"block.unrequired_double_endorsement_evidence"
~title:"Unrequired double endorsement evidence"
~description:"A double-endorsement evidence is unrequired"
~pp:(fun ppf () ->
Format.fprintf
ppf
"A valid double-endorsement operation cannot be applied: the \
associated delegate has previously been denunciated in this cycle.")
Data_encoding.empty
(function Unrequired_double_endorsement_evidence -> Some () | _ -> None)
(fun () -> Unrequired_double_endorsement_evidence) ;
register_error_kind
`Temporary
~id:"block.too_early_double_endorsement_evidence"
~title:"Too early double endorsement evidence"
~description:"A double-endorsement evidence is in the future"
~pp:(fun ppf (level, current) ->
Format.fprintf
ppf
"A double-endorsement evidence is in the future (current level: %a, \
endorsement level: %a)"
Raw_level.pp
current
Raw_level.pp
level)
Data_encoding.(
obj2 (req "level" Raw_level.encoding) (req "current" Raw_level.encoding))
(function
| Too_early_double_endorsement_evidence {level; current} ->
Some (level, current)
| _ ->
None)
(fun (level, current) ->
Too_early_double_endorsement_evidence {level; current}) ;
register_error_kind
`Permanent
~id:"block.outdated_double_endorsement_evidence"
~title:"Outdated double endorsement evidence"
~description:"A double-endorsement evidence is outdated."
~pp:(fun ppf (level, last) ->
Format.fprintf
ppf
"A double-endorsement evidence is outdated (last acceptable level: \
%a, endorsement level: %a)"
Raw_level.pp
last
Raw_level.pp
level)
Data_encoding.(
obj2 (req "level" Raw_level.encoding) (req "last" Raw_level.encoding))
(function
| Outdated_double_endorsement_evidence {level; last} ->
Some (level, last)
| _ ->
None)
(fun (level, last) -> Outdated_double_endorsement_evidence {level; last}) ;
register_error_kind
`Permanent
~id:"block.invalid_double_baking_evidence"
~title:"Invalid double baking evidence"
~description:
"A double-baking evidence is inconsistent (two distinct level)"
~pp:(fun ppf (hash1, level1, hash2, level2) ->
Format.fprintf
ppf
"Invalid double-baking evidence (hash: %a and %a, levels: %ld and %ld)"
Block_hash.pp
hash1
Block_hash.pp
hash2
level1
level2)
Data_encoding.(
obj4
(req "hash1" Block_hash.encoding)
(req "level1" int32)
(req "hash2" Block_hash.encoding)
(req "level2" int32))
(function
| Invalid_double_baking_evidence {hash1; level1; hash2; level2} ->
Some (hash1, level1, hash2, level2)
| _ ->
None)
(fun (hash1, level1, hash2, level2) ->
Invalid_double_baking_evidence {hash1; level1; hash2; level2}) ;
register_error_kind
`Permanent
~id:"block.inconsistent_double_baking_evidence"
~title:"Inconsistent double baking evidence"
~description:
"A double-baking evidence is inconsistent (two distinct delegates)"
~pp:(fun ppf (delegate1, delegate2) ->
Format.fprintf
ppf
"Inconsistent double-baking evidence (distinct delegate: %a and %a)"
Signature.Public_key_hash.pp_short
delegate1
Signature.Public_key_hash.pp_short
delegate2)
Data_encoding.(
obj2
(req "delegate1" Signature.Public_key_hash.encoding)
(req "delegate2" Signature.Public_key_hash.encoding))
(function
| Inconsistent_double_baking_evidence {delegate1; delegate2} ->
Some (delegate1, delegate2)
| _ ->
None)
(fun (delegate1, delegate2) ->
Inconsistent_double_baking_evidence {delegate1; delegate2}) ;
register_error_kind
`Branch
~id:"block.unrequired_double_baking_evidence"
~title:"Unrequired double baking evidence"
~description:"A double-baking evidence is unrequired"
~pp:(fun ppf () ->
Format.fprintf
ppf
"A valid double-baking operation cannot be applied: the associated \
delegate has previously been denunciated in this cycle.")
Data_encoding.empty
(function Unrequired_double_baking_evidence -> Some () | _ -> None)
(fun () -> Unrequired_double_baking_evidence) ;
register_error_kind
`Temporary
~id:"block.too_early_double_baking_evidence"
~title:"Too early double baking evidence"
~description:"A double-baking evidence is in the future"
~pp:(fun ppf (level, current) ->
Format.fprintf
ppf
"A double-baking evidence is in the future (current level: %a, \
baking level: %a)"
Raw_level.pp
current
Raw_level.pp
level)
Data_encoding.(
obj2 (req "level" Raw_level.encoding) (req "current" Raw_level.encoding))
(function
| Too_early_double_baking_evidence {level; current} ->
Some (level, current)
| _ ->
None)
(fun (level, current) -> Too_early_double_baking_evidence {level; current}) ;
register_error_kind
`Permanent
~id:"block.outdated_double_baking_evidence"
~title:"Outdated double baking evidence"
~description:"A double-baking evidence is outdated."
~pp:(fun ppf (level, last) ->
Format.fprintf
ppf
"A double-baking evidence is outdated (last acceptable level: %a, \
baking level: %a)"
Raw_level.pp
last
Raw_level.pp
level)
Data_encoding.(
obj2 (req "level" Raw_level.encoding) (req "last" Raw_level.encoding))
(function
| Outdated_double_baking_evidence {level; last} ->
Some (level, last)
| _ ->
None)
(fun (level, last) -> Outdated_double_baking_evidence {level; last}) ;
register_error_kind
`Permanent
~id:"operation.invalid_activation"
~title:"Invalid activation"
~description:
"The given key and secret do not correspond to any existing \
preallocated contract"
~pp:(fun ppf pkh ->
Format.fprintf
ppf
"Invalid activation. The public key %a does not match any commitment."
Ed25519.Public_key_hash.pp
pkh)
Data_encoding.(obj1 (req "pkh" Ed25519.Public_key_hash.encoding))
(function Invalid_activation {pkh} -> Some pkh | _ -> None)
(fun pkh -> Invalid_activation {pkh}) ;
register_error_kind
`Permanent
~id:"block.multiple_revelation"
~title:"Multiple revelations were included in a manager operation"
~description:
"A manager operation should not contain more than one revelation"
~pp:(fun ppf () ->
Format.fprintf
ppf
"Multiple revelations were included in a manager operation")
Data_encoding.empty
(function Multiple_revelation -> Some () | _ -> None)
(fun () -> Multiple_revelation) ;
register_error_kind
`Permanent
~id:"gas_exhausted.init_deserialize"
~title:"Not enough gas for initial deserialization of script expresions"
~description:
"Gas limit was not high enough to deserialize the transaction \
parameters or origination script code or initial storage, making the \
operation impossible to parse within the provided gas bounds."
Data_encoding.empty
(function Gas_quota_exceeded_init_deserialize -> Some () | _ -> None)
(fun () -> Gas_quota_exceeded_init_deserialize) ;
register_error_kind
`Permanent
~id:"operation.not_enought_endorsements_for_priority"
~title:"Not enough endorsements for priority"
~description:
"The block being validated does not include the required minimum number \
of endorsements for this priority."
~pp:(fun ppf (required, endorsements, priority, timestamp) ->
Format.fprintf
ppf
"Wrong number of endorsements (%i) for priority (%i), %i are expected \
at %a"
endorsements
priority
required
Time.pp_hum
timestamp)
Data_encoding.(
obj4
(req "required" int31)
(req "endorsements" int31)
(req "priority" int31)
(req "timestamp" Time.encoding))
(function
| Not_enough_endorsements_for_priority
{required; endorsements; priority; timestamp} ->
Some (required, endorsements, priority, timestamp)
| _ ->
None)
(fun (required, endorsements, priority, timestamp) ->
Not_enough_endorsements_for_priority
{required; endorsements; priority; timestamp})
open Apply_results
let apply_manager_operation_content :
type kind.
Alpha_context.t ->
Script_ir_translator.unparsing_mode ->
payer:Contract.t ->
source:Contract.t ->
chain_id:Chain_id.t ->
internal:bool ->
kind manager_operation ->
( context
* kind successful_manager_operation_result
* packed_internal_operation list )
tzresult
Lwt.t =
fun ctxt mode ~payer ~source ~chain_id ~internal operation ->
let before_operation =
(* This context is not used for backtracking. Only to compute
gas consumption and originations for the operation result. *)
ctxt
in
Contract.must_exist ctxt source
>>=? fun () ->
Lwt.return (Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation)
>>=? fun ctxt ->
match operation with
| Reveal _ ->
return
(* No-op: action already performed by `precheck_manager_contents`. *)
( ctxt,
( Reveal_result
{consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt}
: kind successful_manager_operation_result ),
[] )
| Transaction {amount; parameters; destination; entrypoint} -> (
Contract.spend ctxt source amount
>>=? fun ctxt ->
( match Contract.is_implicit destination with
| None ->
return (ctxt, [], false)
| Some _ -> (
Contract.allocated ctxt destination
>>=? function
| true ->
return (ctxt, [], false)
| false ->
Fees.origination_burn ctxt
>>=? fun (ctxt, origination_burn) ->
return
( ctxt,
[(Delegate.Contract payer, Delegate.Debited origination_burn)],
true ) ) )
>>=? fun (ctxt, maybe_burn_balance_update, allocated_destination_contract)
->
Contract.credit ctxt destination amount
>>=? fun ctxt ->
Contract.get_script ctxt destination
>>=? fun (ctxt, script) ->
match script with
| None ->
( match entrypoint with
| "default" ->
return ()
| entrypoint ->
fail (Script_tc_errors.No_such_entrypoint entrypoint) )
>>=? (fun () ->
Script.force_decode ctxt parameters
>>=? fun (arg, ctxt) ->
(* see [note] *)
(* [note]: for toplevel ops, cost is nil since the
lazy value has already been forced at precheck, so
we compute and consume the full cost again *)
let cost_arg = Script.deserialized_cost arg in
Lwt.return (Gas.consume ctxt cost_arg)
>>=? fun ctxt ->
match Micheline.root arg with
| Prim (_, D_Unit, [], _) ->
(* Allow [Unit] parameter to non-scripted contracts. *)
return ctxt
| _ ->
fail
(Script_interpreter.Bad_contract_parameter destination))
>>=? fun ctxt ->
let result =
Transaction_result
{
storage = None;
big_map_diff = None;
balance_updates =
Delegate.cleanup_balance_updates
( [ (Delegate.Contract source, Delegate.Debited amount);
(Contract destination, Credited amount) ]
@ maybe_burn_balance_update );
originated_contracts = [];
consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
storage_size = Z.zero;
paid_storage_size_diff = Z.zero;
allocated_destination_contract;
}
in
return (ctxt, result, [])
| Some script ->
Script.force_decode ctxt parameters
>>=? fun (parameter, ctxt) ->
(* see [note] *)
let cost_parameter = Script.deserialized_cost parameter in
Lwt.return (Gas.consume ctxt cost_parameter)
>>=? fun ctxt ->
let step_constants =
let open Script_interpreter in
{source; payer; self = destination; amount; chain_id}
in
Script_interpreter.execute
ctxt
mode
step_constants
~script
~parameter
~entrypoint
>>=? fun {ctxt; storage; big_map_diff; operations} ->
Contract.update_script_storage ctxt destination storage big_map_diff
>>=? fun ctxt ->
Fees.record_paid_storage_space ctxt destination
>>=? fun (ctxt, new_size, paid_storage_size_diff, fees) ->
Contract.originated_from_current_nonce
~since:before_operation
~until:ctxt
>>=? fun originated_contracts ->
let result =
Transaction_result
{
storage = Some storage;
big_map_diff;
balance_updates =
Delegate.cleanup_balance_updates
[ (Contract payer, Debited fees);
(Contract source, Debited amount);
(Contract destination, Credited amount) ];
originated_contracts;
consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
storage_size = new_size;
paid_storage_size_diff;
allocated_destination_contract;
}
in
return (ctxt, result, operations) )
| Origination {delegate; script; preorigination; credit} ->
Script.force_decode ctxt script.storage
>>=? fun (unparsed_storage, ctxt) ->
(* see [note] *)
Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage))
>>=? fun ctxt ->
Script.force_decode ctxt script.code
>>=? fun (unparsed_code, ctxt) ->
(* see [note] *)
Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code))
>>=? fun ctxt ->
Script_ir_translator.parse_script ctxt ~legacy:false script
>>=? fun (Ex_script parsed_script, ctxt) ->
Script_ir_translator.collect_big_maps
ctxt
parsed_script.storage_type
parsed_script.storage
>>=? fun (to_duplicate, ctxt) ->
let to_update = Script_ir_translator.no_big_map_id in
Script_ir_translator.extract_big_map_diff
ctxt
Optimized
parsed_script.storage_type
parsed_script.storage
~to_duplicate
~to_update
~temporary:false
>>=? fun (storage, big_map_diff, ctxt) ->
Script_ir_translator.unparse_data
ctxt
Optimized
parsed_script.storage_type
storage
>>=? fun (storage, ctxt) ->
let storage = Script.lazy_expr (Micheline.strip_locations storage) in
let script = {script with storage} in
Contract.spend ctxt source credit
>>=? fun ctxt ->
( match preorigination with
| Some contract ->
assert internal ;
(* The preorigination field is only used to early return
the address of an originated contract in Michelson.
It cannot come from the outside. *)
return (ctxt, contract)
| None ->
Contract.fresh_contract_from_current_nonce ctxt )
>>=? fun (ctxt, contract) ->
Contract.originate
ctxt
contract
~delegate
~balance:credit
~script:(script, big_map_diff)
>>=? fun ctxt ->
Fees.origination_burn ctxt
>>=? fun (ctxt, origination_burn) ->
Fees.record_paid_storage_space ctxt contract
>>=? fun (ctxt, size, paid_storage_size_diff, fees) ->
let result =
Origination_result
{
big_map_diff;
balance_updates =
Delegate.cleanup_balance_updates
[ (Contract payer, Debited fees);
(Contract payer, Debited origination_burn);
(Contract source, Debited credit);
(Contract contract, Credited credit) ];
originated_contracts = [contract];
consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
storage_size = size;
paid_storage_size_diff;
}
in
return (ctxt, result, [])
| Delegation delegate ->
Delegate.set ctxt source delegate
>>=? fun ctxt ->
return
( ctxt,
Delegation_result
{consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt},
[] )
let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops =
let rec apply ctxt applied worklist =
match worklist with
| [] ->
Lwt.return (`Success ctxt, List.rev applied)
| Internal_operation ({source; operation; nonce} as op) :: rest -> (
( if internal_nonce_already_recorded ctxt nonce then
fail (Internal_operation_replay (Internal_operation op))
else
let ctxt = record_internal_nonce ctxt nonce in
apply_manager_operation_content
ctxt
mode
~source
~payer
~chain_id
~internal:true
operation )
>>= function
| Error errors ->
let result =
Internal_operation_result
(op, Failed (manager_kind op.operation, errors))
in
let skipped =
List.rev_map
(fun (Internal_operation op) ->
Internal_operation_result
(op, Skipped (manager_kind op.operation)))
rest
in
Lwt.return (`Failure, List.rev (skipped @ (result :: applied)))
| Ok (ctxt, result, emitted) ->
apply
ctxt
(Internal_operation_result (op, Applied result) :: applied)
(rest @ emitted) )
in
apply ctxt [] ops
let precheck_manager_contents (type kind) ctxt chain_id raw_operation
(op : kind Kind.manager contents) : context tzresult Lwt.t =
let (Manager_operation
{source; fee; counter; operation; gas_limit; storage_limit}) =
op
in
Lwt.return (Gas.check_limit ctxt gas_limit)
>>=? fun () ->
let ctxt = Gas.set_limit ctxt gas_limit in
Lwt.return (Fees.check_storage_limit ctxt storage_limit)
>>=? fun () ->
Contract.must_be_allocated ctxt (Contract.implicit_contract source)
>>=? fun () ->
Contract.check_counter_increment ctxt source counter
>>=? fun () ->
( match operation with
| Reveal pk ->
Contract.reveal_manager_key ctxt source pk
| Transaction {parameters; _} ->
(* Fail quickly if not enough gas for minimal deserialization cost *)
Lwt.return
@@ record_trace Gas_quota_exceeded_init_deserialize
@@ Gas.check_enough ctxt (Script.minimal_deserialize_cost parameters)
>>=? fun () ->
(* Fail if not enough gas for complete deserialization cost *)
trace Gas_quota_exceeded_init_deserialize
@@ Script.force_decode ctxt parameters
>>|? fun (_arg, ctxt) -> ctxt
| Origination {script; _} ->
(* Fail quickly if not enough gas for minimal deserialization cost *)
Lwt.return
@@ record_trace Gas_quota_exceeded_init_deserialize
@@ ( Gas.consume ctxt (Script.minimal_deserialize_cost script.code)
>>? fun ctxt ->
Gas.check_enough ctxt (Script.minimal_deserialize_cost script.storage)
)
>>=? fun () ->
(* Fail if not enough gas for complete deserialization cost *)
trace Gas_quota_exceeded_init_deserialize
@@ Script.force_decode ctxt script.code
>>=? fun (_code, ctxt) ->
trace Gas_quota_exceeded_init_deserialize
@@ Script.force_decode ctxt script.storage
>>|? fun (_storage, ctxt) -> ctxt
| _ ->
return ctxt )
>>=? fun ctxt ->
Contract.get_manager_key ctxt source
>>=? fun public_key ->
(* Currently, the `raw_operation` only contains one signature, so
all operations are required to be from the same manager. This may
change in the future, allowing several managers to group-sign a
sequence of transactions. *)
Operation.check_signature public_key chain_id raw_operation
>>=? fun () ->
Contract.increment_counter ctxt source
>>=? fun ctxt ->
Contract.spend ctxt (Contract.implicit_contract source) fee
>>=? fun ctxt -> add_fees ctxt fee >>=? fun ctxt -> return ctxt
let apply_manager_contents (type kind) ctxt mode chain_id
(op : kind Kind.manager contents) :
( [`Success of context | `Failure]
* kind manager_operation_result
* packed_internal_operation_result list )
Lwt.t =
let (Manager_operation {source; operation; gas_limit; storage_limit}) = op in
let ctxt = Gas.set_limit ctxt gas_limit in
let ctxt = Fees.start_counting_storage_fees ctxt in
let source = Contract.implicit_contract source in
apply_manager_operation_content
ctxt
mode
~source
~payer:source
~internal:false
~chain_id
operation
>>= function
| Ok (ctxt, operation_results, internal_operations) -> (
apply_internal_manager_operations
ctxt
mode
~payer:source
~chain_id
internal_operations
>>= function
| (`Success ctxt, internal_operations_results) -> (
Fees.burn_storage_fees ctxt ~storage_limit ~payer:source
>>= function
| Ok ctxt ->
Lwt.return
( `Success ctxt,
Applied operation_results,
internal_operations_results )
| Error errors ->
Lwt.return
( `Failure,
Backtracked (operation_results, Some errors),
internal_operations_results ) )
| (`Failure, internal_operations_results) ->
Lwt.return
(`Failure, Applied operation_results, internal_operations_results)
)
| Error errors ->
Lwt.return (`Failure, Failed (manager_kind operation, errors), [])
let skipped_operation_result :
type kind. kind manager_operation -> kind manager_operation_result =
function
| operation -> (
match operation with
| Reveal _ ->
Applied
( Reveal_result {consumed_gas = Z.zero}
: kind successful_manager_operation_result )
| _ ->
Skipped (manager_kind operation) )
let rec mark_skipped :
type kind.
baker:Signature.Public_key_hash.t ->
Level.t ->
kind Kind.manager contents_list ->
kind Kind.manager contents_result_list =
fun ~baker level -> function
| Single (Manager_operation {source; fee; operation}) ->
let source = Contract.implicit_contract source in
Single_result
(Manager_operation_result
{
balance_updates =
Delegate.cleanup_balance_updates
[ (Contract source, Debited fee);
(Fees (baker, level.cycle), Credited fee) ];
operation_result = skipped_operation_result operation;
internal_operation_results = [];
})
| Cons (Manager_operation {source; fee; operation}, rest) ->
let source = Contract.implicit_contract source in
Cons_result
( Manager_operation_result
{
balance_updates =
Delegate.cleanup_balance_updates
[ (Contract source, Debited fee);
(Fees (baker, level.cycle), Credited fee) ];
operation_result = skipped_operation_result operation;
internal_operation_results = [];
},
mark_skipped ~baker level rest )
let rec precheck_manager_contents_list :
type kind.
Alpha_context.t ->
Chain_id.t ->
_ Operation.t ->
kind Kind.manager contents_list ->
context tzresult Lwt.t =
fun ctxt chain_id raw_operation contents_list ->
match contents_list with
| Single (Manager_operation _ as op) ->
precheck_manager_contents ctxt chain_id raw_operation op
| Cons ((Manager_operation _ as op), rest) ->
precheck_manager_contents ctxt chain_id raw_operation op
>>=? fun ctxt ->
precheck_manager_contents_list ctxt chain_id raw_operation rest
let rec apply_manager_contents_list_rec :
type kind.
Alpha_context.t ->
Script_ir_translator.unparsing_mode ->
public_key_hash ->
Chain_id.t ->
kind Kind.manager contents_list ->
([`Success of context | `Failure] * kind Kind.manager contents_result_list)
Lwt.t =
fun ctxt mode baker chain_id contents_list ->
let level = Level.current ctxt in
match contents_list with
| Single (Manager_operation {source; fee; _} as op) ->
let source = Contract.implicit_contract source in
apply_manager_contents ctxt mode chain_id op
>>= fun (ctxt_result, operation_result, internal_operation_results) ->
let result =
Manager_operation_result
{
balance_updates =
Delegate.cleanup_balance_updates
[ (Contract source, Debited fee);
(Fees (baker, level.cycle), Credited fee) ];
operation_result;
internal_operation_results;
}
in
Lwt.return (ctxt_result, Single_result result)
| Cons ((Manager_operation {source; fee; _} as op), rest) -> (
let source = Contract.implicit_contract source in
apply_manager_contents ctxt mode chain_id op
>>= function
| (`Failure, operation_result, internal_operation_results) ->
let result =
Manager_operation_result
{
balance_updates =
Delegate.cleanup_balance_updates
[ (Contract source, Debited fee);
(Fees (baker, level.cycle), Credited fee) ];
operation_result;
internal_operation_results;
}
in
Lwt.return
(`Failure, Cons_result (result, mark_skipped ~baker level rest))
| (`Success ctxt, operation_result, internal_operation_results) ->
let result =
Manager_operation_result
{
balance_updates =
Delegate.cleanup_balance_updates
[ (Contract source, Debited fee);
(Fees (baker, level.cycle), Credited fee) ];
operation_result;
internal_operation_results;
}
in
apply_manager_contents_list_rec ctxt mode baker chain_id rest
>>= fun (ctxt_result, results) ->
Lwt.return (ctxt_result, Cons_result (result, results)) )
let mark_backtracked results =
let rec mark_contents_list :
type kind.
kind Kind.manager contents_result_list ->
kind Kind.manager contents_result_list = function
| Single_result (Manager_operation_result op) ->
Single_result
(Manager_operation_result
{
balance_updates = op.balance_updates;
operation_result =
mark_manager_operation_result op.operation_result;
internal_operation_results =
List.map
mark_internal_operation_results
op.internal_operation_results;
})
| Cons_result (Manager_operation_result op, rest) ->
Cons_result
( Manager_operation_result
{
balance_updates = op.balance_updates;
operation_result =
mark_manager_operation_result op.operation_result;
internal_operation_results =
List.map
mark_internal_operation_results
op.internal_operation_results;
},
mark_contents_list rest )
and mark_internal_operation_results
(Internal_operation_result (kind, result)) =
Internal_operation_result (kind, mark_manager_operation_result result)
and mark_manager_operation_result :
type kind. kind manager_operation_result -> kind manager_operation_result
= function
| (Failed _ | Skipped _ | Backtracked _) as result ->
result
| Applied (Reveal_result _) as result ->
result
| Applied result ->
Backtracked (result, None)
in
mark_contents_list results
let apply_manager_contents_list ctxt mode baker chain_id contents_list =
apply_manager_contents_list_rec ctxt mode baker chain_id contents_list
>>= fun (ctxt_result, results) ->
match ctxt_result with
| `Failure ->
Lwt.return (ctxt (* backtracked *), mark_backtracked results)
| `Success ctxt ->
Big_map.cleanup_temporary ctxt >>= fun ctxt -> Lwt.return (ctxt, results)
let apply_contents_list (type kind) ctxt chain_id mode pred_block baker
(operation : kind operation) (contents_list : kind contents_list) :
(context * kind contents_result_list) tzresult Lwt.t =
match contents_list with
| Single (Endorsement {level}) ->
let block = operation.shell.branch in
fail_unless
(Block_hash.equal block pred_block)
(Wrong_endorsement_predecessor (pred_block, block))
>>=? fun () ->
let current_level = (Level.current ctxt).level in
fail_unless
Raw_level.(succ level = current_level)
Invalid_endorsement_level
>>=? fun () ->
Baking.check_endorsement_rights ctxt chain_id operation
>>=? fun (delegate, slots, used) ->
if used then fail (Duplicate_endorsement delegate)
else
let ctxt = record_endorsement ctxt delegate in
let gap = List.length slots in
Lwt.return
Tez.(Constants.endorsement_security_deposit ctxt *? Int64.of_int gap)
>>=? fun deposit ->
Delegate.freeze_deposit ctxt delegate deposit
>>=? fun ctxt ->
Global.get_block_priority ctxt
>>=? fun block_priority ->
Baking.endorsing_reward ctxt ~block_priority gap
>>=? fun reward ->
Delegate.freeze_rewards ctxt delegate reward
>>=? fun ctxt ->
let level = Level.from_raw ctxt level in
return
( ctxt,
Single_result
(Endorsement_result
{
balance_updates =
Delegate.cleanup_balance_updates
[ ( Contract (Contract.implicit_contract delegate),
Debited deposit );
(Deposits (delegate, level.cycle), Credited deposit);
(Rewards (delegate, level.cycle), Credited reward) ];
delegate;
slots;
}) )
| Single (Seed_nonce_revelation {level; nonce}) ->
let level = Level.from_raw ctxt level in
Nonce.reveal ctxt level nonce
>>=? fun ctxt ->
let seed_nonce_revelation_tip =
Constants.seed_nonce_revelation_tip ctxt
in
add_rewards ctxt seed_nonce_revelation_tip
>>=? fun ctxt ->
return
( ctxt,
Single_result
(Seed_nonce_revelation_result
[ ( Rewards (baker, level.cycle),
Credited seed_nonce_revelation_tip ) ]) )
| Single (Double_endorsement_evidence {op1; op2}) -> (
match (op1.protocol_data.contents, op2.protocol_data.contents) with
| (Single (Endorsement e1), Single (Endorsement e2))
when Raw_level.(e1.level = e2.level)
&& not (Block_hash.equal op1.shell.branch op2.shell.branch) ->
let level = Level.from_raw ctxt e1.level in
let oldest_level = Level.last_allowed_fork_level ctxt in
fail_unless
Level.(level < Level.current ctxt)
(Too_early_double_endorsement_evidence
{level = level.level; current = (Level.current ctxt).level})
>>=? fun () ->
fail_unless
Raw_level.(oldest_level <= level.level)
(Outdated_double_endorsement_evidence
{level = level.level; last = oldest_level})
>>=? fun () ->
Baking.check_endorsement_rights ctxt chain_id op1
>>=? fun (delegate1, _, _) ->
Baking.check_endorsement_rights ctxt chain_id op2
>>=? fun (delegate2, _, _) ->
fail_unless
(Signature.Public_key_hash.equal delegate1 delegate2)
(Inconsistent_double_endorsement_evidence {delegate1; delegate2})
>>=? fun () ->
Delegate.has_frozen_balance ctxt delegate1 level.cycle
>>=? fun valid ->
fail_unless valid Unrequired_double_endorsement_evidence
>>=? fun () ->
Delegate.punish ctxt delegate1 level.cycle
>>=? fun (ctxt, balance) ->
Lwt.return Tez.(balance.deposit +? balance.fees)
>>=? fun burned ->
let reward =
match Tez.(burned /? 2L) with Ok v -> v | Error _ -> Tez.zero
in
add_rewards ctxt reward
>>=? fun ctxt ->
let current_cycle = (Level.current ctxt).cycle in
return
( ctxt,
Single_result
(Double_endorsement_evidence_result
(Delegate.cleanup_balance_updates
[ ( Deposits (delegate1, level.cycle),
Debited balance.deposit );
(Fees (delegate1, level.cycle), Debited balance.fees);
( Rewards (delegate1, level.cycle),
Debited balance.rewards );
(Rewards (baker, current_cycle), Credited reward) ])) )
| (_, _) ->
fail Invalid_double_endorsement_evidence )
| Single (Double_baking_evidence {bh1; bh2}) ->
let hash1 = Block_header.hash bh1 in
let hash2 = Block_header.hash bh2 in
fail_unless
( Compare.Int32.(bh1.shell.level = bh2.shell.level)
&& not (Block_hash.equal hash1 hash2) )
(Invalid_double_baking_evidence
{hash1; level1 = bh1.shell.level; hash2; level2 = bh2.shell.level})
>>=? fun () ->
Lwt.return (Raw_level.of_int32 bh1.shell.level)
>>=? fun raw_level ->
let oldest_level = Level.last_allowed_fork_level ctxt in
fail_unless
Raw_level.(raw_level < (Level.current ctxt).level)
(Too_early_double_baking_evidence
{level = raw_level; current = (Level.current ctxt).level})
>>=? fun () ->
fail_unless
Raw_level.(oldest_level <= raw_level)
(Outdated_double_baking_evidence
{level = raw_level; last = oldest_level})
>>=? fun () ->
let level = Level.from_raw ctxt raw_level in
Roll.baking_rights_owner
ctxt
level
~priority:bh1.protocol_data.contents.priority
>>=? fun delegate1 ->
Baking.check_signature bh1 chain_id delegate1
>>=? fun () ->
Roll.baking_rights_owner
ctxt
level
~priority:bh2.protocol_data.contents.priority
>>=? fun delegate2 ->
Baking.check_signature bh2 chain_id delegate2
>>=? fun () ->
fail_unless
(Signature.Public_key.equal delegate1 delegate2)
(Inconsistent_double_baking_evidence
{
delegate1 = Signature.Public_key.hash delegate1;
delegate2 = Signature.Public_key.hash delegate2;
})
>>=? fun () ->
let delegate = Signature.Public_key.hash delegate1 in
Delegate.has_frozen_balance ctxt delegate level.cycle
>>=? fun valid ->
fail_unless valid Unrequired_double_baking_evidence
>>=? fun () ->
Delegate.punish ctxt delegate level.cycle
>>=? fun (ctxt, balance) ->
Lwt.return Tez.(balance.deposit +? balance.fees)
>>=? fun burned ->
let reward =
match Tez.(burned /? 2L) with Ok v -> v | Error _ -> Tez.zero
in
add_rewards ctxt reward
>>=? fun ctxt ->
let current_cycle = (Level.current ctxt).cycle in
return
( ctxt,
Single_result
(Double_baking_evidence_result
(Delegate.cleanup_balance_updates
[ (Deposits (delegate, level.cycle), Debited balance.deposit);
(Fees (delegate, level.cycle), Debited balance.fees);
(Rewards (delegate, level.cycle), Debited balance.rewards);
(Rewards (baker, current_cycle), Credited reward) ])) )
| Single (Activate_account {id = pkh; activation_code}) -> (
let blinded_pkh =
Blinded_public_key_hash.of_ed25519_pkh activation_code pkh
in
Commitment.get_opt ctxt blinded_pkh
>>=? function
| None ->
fail (Invalid_activation {pkh})
| Some amount ->
Commitment.delete ctxt blinded_pkh
>>=? fun ctxt ->
let contract = Contract.implicit_contract (Signature.Ed25519 pkh) in
Contract.(credit ctxt contract amount)
>>=? fun ctxt ->
return
( ctxt,
Single_result
(Activate_account_result [(Contract contract, Credited amount)])
) )
| Single (Proposals {source; period; proposals}) ->
Roll.delegate_pubkey ctxt source
>>=? fun delegate ->
Operation.check_signature delegate chain_id operation
>>=? fun () ->
let level = Level.current ctxt in
fail_unless
Voting_period.(level.voting_period = period)
(Wrong_voting_period (level.voting_period, period))
>>=? fun () ->
Amendment.record_proposals ctxt source proposals
>>=? fun ctxt -> return (ctxt, Single_result Proposals_result)
| Single (Ballot {source; period; proposal; ballot}) ->
Roll.delegate_pubkey ctxt source
>>=? fun delegate ->
Operation.check_signature delegate chain_id operation
>>=? fun () ->
let level = Level.current ctxt in
fail_unless
Voting_period.(level.voting_period = period)
(Wrong_voting_period (level.voting_period, period))
>>=? fun () ->
Amendment.record_ballot ctxt source proposal ballot
>>=? fun ctxt -> return (ctxt, Single_result Ballot_result)
| Single (Manager_operation _) as op ->
precheck_manager_contents_list ctxt chain_id operation op
>>=? fun ctxt ->
apply_manager_contents_list ctxt mode baker chain_id op
>>= fun (ctxt, result) -> return (ctxt, result)
| Cons (Manager_operation _, _) as op ->
precheck_manager_contents_list ctxt chain_id operation op
>>=? fun ctxt ->
apply_manager_contents_list ctxt mode baker chain_id op
>>= fun (ctxt, result) -> return (ctxt, result)
let apply_operation ctxt chain_id mode pred_block baker hash operation =
let ctxt = Contract.init_origination_nonce ctxt hash in
apply_contents_list
ctxt
chain_id
mode
pred_block
baker
operation
operation.protocol_data.contents
>>=? fun (ctxt, result) ->
let ctxt = Gas.set_unlimited ctxt in
let ctxt = Contract.unset_origination_nonce ctxt in
return (ctxt, {contents = result})
let may_snapshot_roll ctxt =
let level = Alpha_context.Level.current ctxt in
let blocks_per_roll_snapshot = Constants.blocks_per_roll_snapshot ctxt in
if
Compare.Int32.equal
(Int32.rem level.cycle_position blocks_per_roll_snapshot)
(Int32.pred blocks_per_roll_snapshot)
then Alpha_context.Roll.snapshot_rolls ctxt >>=? fun ctxt -> return ctxt
else return ctxt
let may_start_new_cycle ctxt =
Baking.dawn_of_a_new_cycle ctxt
>>=? function
| None ->
return (ctxt, [], [])
| Some last_cycle ->
Seed.cycle_end ctxt last_cycle
>>=? fun (ctxt, unrevealed) ->
Roll.cycle_end ctxt last_cycle
>>=? fun ctxt ->
Delegate.cycle_end ctxt last_cycle unrevealed
>>=? fun (ctxt, update_balances, deactivated) ->
Bootstrap.cycle_end ctxt last_cycle
>>=? fun ctxt -> return (ctxt, update_balances, deactivated)
let begin_full_construction ctxt pred_timestamp protocol_data =
Alpha_context.Global.set_block_priority
ctxt
protocol_data.Block_header.priority
>>=? fun ctxt ->
Baking.check_baking_rights ctxt protocol_data pred_timestamp
>>=? fun (delegate_pk, block_delay) ->
let ctxt = Fitness.increase ctxt in
match Level.pred ctxt (Level.current ctxt) with
| None ->
assert false (* genesis *)
| Some pred_level ->
Baking.endorsement_rights ctxt pred_level
>>=? fun rights ->
let ctxt = init_endorsements ctxt rights in
return (ctxt, protocol_data, delegate_pk, block_delay)
let begin_partial_construction ctxt =
let ctxt = Fitness.increase ctxt in
match Level.pred ctxt (Level.current ctxt) with
| None ->
assert false (* genesis *)
| Some pred_level ->
Baking.endorsement_rights ctxt pred_level
>>=? fun rights ->
let ctxt = init_endorsements ctxt rights in
return ctxt
let begin_application ctxt chain_id block_header pred_timestamp =
Alpha_context.Global.set_block_priority
ctxt
block_header.Block_header.protocol_data.contents.priority
>>=? fun ctxt ->
let current_level = Alpha_context.Level.current ctxt in
Baking.check_proof_of_work_stamp ctxt block_header
>>=? fun () ->
Baking.check_fitness_gap ctxt block_header
>>=? fun () ->
Baking.check_baking_rights
ctxt
block_header.protocol_data.contents
pred_timestamp
>>=? fun (delegate_pk, block_delay) ->
Baking.check_signature block_header chain_id delegate_pk
>>=? fun () ->
let has_commitment =
match block_header.protocol_data.contents.seed_nonce_hash with
| None ->
false
| Some _ ->
true
in
fail_unless
Compare.Bool.(has_commitment = current_level.expected_commitment)
(Invalid_commitment {expected = current_level.expected_commitment})
>>=? fun () ->
let ctxt = Fitness.increase ctxt in
match Level.pred ctxt (Level.current ctxt) with
| None ->
assert false (* genesis *)
| Some pred_level ->
Baking.endorsement_rights ctxt pred_level
>>=? fun rights ->
let ctxt = init_endorsements ctxt rights in
return (ctxt, delegate_pk, block_delay)
let check_minimum_endorsements ctxt protocol_data block_delay
included_endorsements =
let minimum = Baking.minimum_allowed_endorsements ctxt ~block_delay in
let timestamp = Timestamp.current ctxt in
fail_unless
Compare.Int.(included_endorsements >= minimum)
(Not_enough_endorsements_for_priority
{
required = minimum;
priority = protocol_data.Block_header.priority;
endorsements = included_endorsements;
timestamp;
})
let finalize_application ctxt protocol_data delegate ~block_delay =
let included_endorsements = included_endorsements ctxt in
check_minimum_endorsements
ctxt
protocol_data
block_delay
included_endorsements
>>=? fun () ->
let deposit = Constants.block_security_deposit ctxt in
add_deposit ctxt delegate deposit
>>=? fun ctxt ->
Baking.baking_reward
ctxt
~block_priority:protocol_data.priority
~included_endorsements
>>=? fun reward ->
add_rewards ctxt reward
>>=? fun ctxt ->
Signature.Public_key_hash.Map.fold
(fun delegate deposit ctxt ->
ctxt >>=? fun ctxt -> Delegate.freeze_deposit ctxt delegate deposit)
(get_deposits ctxt)
(return ctxt)
>>=? fun ctxt ->
(* end of level (from this point nothing should fail) *)
let fees = Alpha_context.get_fees ctxt in
Delegate.freeze_fees ctxt delegate fees
>>=? fun ctxt ->
let rewards = Alpha_context.get_rewards ctxt in
Delegate.freeze_rewards ctxt delegate rewards
>>=? fun ctxt ->
( match protocol_data.Block_header.seed_nonce_hash with
| None ->
return ctxt
| Some nonce_hash ->
Nonce.record_hash ctxt {nonce_hash; delegate; rewards; fees} )
>>=? fun ctxt ->
(* end of cycle *)
may_snapshot_roll ctxt
>>=? fun ctxt ->
may_start_new_cycle ctxt
>>=? fun (ctxt, balance_updates, deactivated) ->
Amendment.may_start_new_voting_period ctxt
>>=? fun ctxt ->
let cycle = (Level.current ctxt).cycle in
let balance_updates =
Delegate.(
cleanup_balance_updates
( [ (Contract (Contract.implicit_contract delegate), Debited deposit);
(Deposits (delegate, cycle), Credited deposit);
(Rewards (delegate, cycle), Credited reward) ]
@ balance_updates ))
in
let consumed_gas =
Z.sub
(Constants.hard_gas_limit_per_block ctxt)
(Alpha_context.Gas.block_level ctxt)
in
Alpha_context.Vote.get_current_period_kind ctxt
>>=? fun voting_period_kind ->
let receipt =
Apply_results.
{
baker = delegate;
level = Level.current ctxt;
voting_period_kind;
nonce_hash = protocol_data.seed_nonce_hash;
consumed_gas;
deactivated;
balance_updates;
}
in
return (ctxt, receipt)
src/proto_alpha/lib_protocol/apply.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Import Apply_results.
Definition apply_manager_operation_content {kind : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.t)
(mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
(payer : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
(source : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(internal : bool)
(operation : Tezos_raw_protocol_alpha.Alpha_context.manager_operation kind)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.context *
(Tezos_raw_protocol_alpha.Apply_results.successful_manager_operation_result
kind) *
(list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation))) :=
let before_operation := ctxt in
op_gtgteqquestion (Contract.must_exist ctxt source)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation))
(fun ctxt =>
match operation with
| Tezos_raw_protocol_alpha.Alpha_context.Reveal _ =>
_return
(ctxt,
(Tezos_raw_protocol_alpha.Apply_results.Reveal_result
{| consumed_gas := Gas.consumed before_operation ctxt |}), [])
|
Tezos_raw_protocol_alpha.Alpha_context.Transaction {|
amount := amount;
parameters := parameters;
entrypoint := entrypoint;
destination := destination
|} =>
op_gtgteqquestion (Contract.spend ctxt source amount)
(fun ctxt =>
op_gtgteqquestion
match Contract.is_implicit destination with
| None => _return (ctxt, [], false)
| Some _ =>
op_gtgteqquestion (Contract.allocated ctxt destination)
(fun function_parameter =>
match function_parameter with
| true => _return (ctxt, [], false)
| false =>
op_gtgteqquestion (Fees.origination_burn ctxt)
(fun function_parameter =>
let '(ctxt, origination_burn) :=
function_parameter in
_return
(ctxt,
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
payer),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
origination_burn)) []), true))
end)
end
(fun function_parameter =>
let
'(ctxt, maybe_burn_balance_update,
allocated_destination_contract) := function_parameter in
op_gtgteqquestion (Contract.credit ctxt destination amount)
(fun ctxt =>
op_gtgteqquestion (Contract.get_script ctxt destination)
(fun function_parameter =>
let '(ctxt, script) := function_parameter in
match script with
| None =>
op_gtgteqquestion
(op_gtgteqquestion
match entrypoint with
| "default" % string => _return tt
| entrypoint =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.No_such_entrypoint
entrypoint)
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Script.force_decode ctxt parameters)
(fun function_parameter =>
let '(arg, ctxt) := function_parameter
in
let cost_arg :=
Script.deserialized_cost arg in
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt cost_arg))
(fun ctxt =>
match Micheline.root arg with
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim
_
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Unit
[] _ => _return ctxt
| _ =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_contract_parameter
destination)
end))))
(fun ctxt =>
let result :=
Tezos_raw_protocol_alpha.Apply_results.Transaction_result
{| storage := None; big_map_diff := None;
balance_updates :=
Delegate.cleanup_balance_updates
(op_at
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
source),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
amount))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
destination),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
amount)) []))
maybe_burn_balance_update);
originated_contracts := [];
consumed_gas :=
Gas.consumed before_operation ctxt;
storage_size := Z.zero;
paid_storage_size_diff := Z.zero;
allocated_destination_contract :=
allocated_destination_contract |} in
_return (ctxt, result, []))
| Some script =>
op_gtgteqquestion
(Script.force_decode ctxt parameters)
(fun function_parameter =>
let '(parameter, ctxt) := function_parameter
in
let cost_parameter :=
Script.deserialized_cost parameter in
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt cost_parameter))
(fun ctxt =>
let step_constants :=
{| source := source; payer := payer;
self := destination; amount := amount;
chain_id := chain_id |} in
op_gtgteqquestion
(Script_interpreter.execute ctxt mode
step_constants script entrypoint
parameter)
(fun function_parameter =>
let '{|
ctxt := ctxt;
storage := storage;
big_map_diff := big_map_diff;
operations := operations
|} := function_parameter in
op_gtgteqquestion
(Contract.update_script_storage ctxt
destination storage big_map_diff)
(fun ctxt =>
op_gtgteqquestion
(Fees.record_paid_storage_space
ctxt destination)
(fun function_parameter =>
let
'(ctxt, new_size,
paid_storage_size_diff,
fees) :=
function_parameter in
op_gtgteqquestion
(Contract.originated_from_current_nonce
before_operation ctxt)
(fun originated_contracts =>
let result :=
Tezos_raw_protocol_alpha.Apply_results.Transaction_result
{|
storage :=
Some storage;
big_map_diff :=
big_map_diff;
balance_updates :=
Delegate.cleanup_balance_updates
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
payer),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
fees))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
source),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
amount))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
destination),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
amount))
[])));
originated_contracts :=
originated_contracts;
consumed_gas :=
Gas.consumed
before_operation
ctxt;
storage_size :=
new_size;
paid_storage_size_diff :=
paid_storage_size_diff;
allocated_destination_contract :=
allocated_destination_contract
|} in
_return
(ctxt, result,
operations)))))))
end))))
|
Tezos_raw_protocol_alpha.Alpha_context.Origination {|
delegate := delegate;
script := script;
credit := credit;
preorigination := preorigination
|} =>
op_gtgteqquestion (Script.force_decode ctxt (storage script))
(fun function_parameter =>
let '(unparsed_storage, ctxt) := function_parameter in
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt
(Script.deserialized_cost unparsed_storage)))
(fun ctxt =>
op_gtgteqquestion (Script.force_decode ctxt (code script))
(fun function_parameter =>
let '(unparsed_code, ctxt) := function_parameter in
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt
(Script.deserialized_cost unparsed_code)))
(fun ctxt =>
op_gtgteqquestion
(Script_ir_translator.parse_script None ctxt false
script)
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_script
parsed_script, ctxt) := function_parameter
in
op_gtgteqquestion
(Script_ir_translator.collect_big_maps ctxt
(storage_type parsed_script)
(storage parsed_script))
(fun function_parameter =>
let '(to_duplicate, ctxt) :=
function_parameter in
let to_update :=
Script_ir_translator.no_big_map_id in
op_gtgteqquestion
(Script_ir_translator.extract_big_map_diff
ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
false to_duplicate to_update
(storage_type parsed_script)
(storage parsed_script))
(fun function_parameter =>
let '(storage, big_map_diff, ctxt) :=
function_parameter in
op_gtgteqquestion
(Script_ir_translator.unparse_data
ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
(storage_type parsed_script) storage)
(fun function_parameter =>
let '(storage, ctxt) :=
function_parameter in
let storage :=
Script.lazy_expr
(Micheline.strip_locations
storage) in
let script :=
(* ❌ Record substitution not handled *)
record_substitution in
op_gtgteqquestion
(Contract.spend ctxt source credit)
(fun ctxt =>
op_gtgteqquestion
match preorigination with
| Some contract =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert internal in
_return (ctxt, contract)
| None =>
Contract.fresh_contract_from_current_nonce
ctxt
end
(fun function_parameter =>
let '(ctxt, contract) :=
function_parameter in
op_gtgteqquestion
(Contract.originate ctxt
contract credit
(script, big_map_diff)
delegate)
(fun ctxt =>
op_gtgteqquestion
(Fees.origination_burn
ctxt)
(fun
function_parameter
=>
let
'(ctxt,
origination_burn) :=
function_parameter
in
op_gtgteqquestion
(Fees.record_paid_storage_space
ctxt contract)
(fun
function_parameter
=>
let
'(ctxt, size,
paid_storage_size_diff,
fees) :=
function_parameter
in
let result :=
Tezos_raw_protocol_alpha.Apply_results.Origination_result
{|
big_map_diff :=
big_map_diff;
balance_updates :=
Delegate.cleanup_balance_updates
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
payer),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
fees))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
payer),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
origination_burn))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
source),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
credit))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
contract),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
credit))
[]))));
originated_contracts :=
cons
contract
[];
consumed_gas :=
Gas.consumed
before_operation
ctxt;
storage_size :=
size;
paid_storage_size_diff :=
paid_storage_size_diff
|} in
_return
(ctxt, result,
[]))))))))))))))
| Tezos_raw_protocol_alpha.Alpha_context.Delegation delegate =>
op_gtgteqquestion (Delegate.set ctxt source delegate)
(fun ctxt =>
_return
(ctxt,
(Tezos_raw_protocol_alpha.Apply_results.Delegation_result
{| consumed_gas := Gas.consumed before_operation ctxt |}),
[]))
end)).
Definition apply_internal_manager_operations
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
(payer : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(ops : list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(variant *
(list
Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)) :=
let fix apply
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (applied :
list Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)
(worklist :
list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(variant *
(list
Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)) :=
match worklist with
| [] =>
Lwt._return
((* ❌ Variants not supported *)
variant, (List.rev applied))
|
cons
(Tezos_raw_protocol_alpha.Alpha_context.Internal_operation
({| source := source; operation := operation; nonce := nonce |} as op))
rest =>
op_gtgteq
(if internal_nonce_already_recorded ctxt nonce then
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Internal_operation_replay
(Tezos_raw_protocol_alpha.Alpha_context.Internal_operation op))
else
let ctxt := record_internal_nonce ctxt nonce in
apply_manager_operation_content ctxt mode payer source chain_id true
operation)
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
errors =>
let result :=
Tezos_raw_protocol_alpha.Apply_results.Internal_operation_result
op
(Tezos_raw_protocol_alpha.Apply_results.Failed
(manager_kind (operation op)) errors) in
let skipped :=
List.rev_map
(fun function_parameter =>
let
'Tezos_raw_protocol_alpha.Alpha_context.Internal_operation
op := function_parameter in
Tezos_raw_protocol_alpha.Apply_results.Internal_operation_result
op
(Tezos_raw_protocol_alpha.Apply_results.Skipped
(manager_kind (operation op)))) rest in
Lwt._return
((* ❌ Variants not supported *)
variant, (List.rev (op_at skipped (cons result applied))))
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
(ctxt, result, emitted) =>
apply ctxt
(cons
(Tezos_raw_protocol_alpha.Apply_results.Internal_operation_result
op (Tezos_raw_protocol_alpha.Apply_results.Applied result))
applied) (op_at rest emitted)
end)
end in
apply ctxt [] ops.
Definition precheck_manager_contents {A B : Type}
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(raw_operation : Tezos_raw_protocol_alpha__Alpha_context.operation A)
(op :
Tezos_raw_protocol_alpha.Alpha_context.contents
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager B))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Alpha_context.context) :=
let
'Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
source := source;
fee := fee;
counter := counter;
operation := operation;
gas_limit := gas_limit;
storage_limit := storage_limit
|} := op in
op_gtgteqquestion (Lwt._return (Gas.check_limit ctxt gas_limit))
(fun function_parameter =>
let 'tt := function_parameter in
let ctxt := Gas.set_limit ctxt gas_limit in
op_gtgteqquestion
(Lwt._return (Fees.check_storage_limit ctxt storage_limit))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Contract.must_be_allocated ctxt (Contract.implicit_contract source))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Contract.check_counter_increment ctxt source counter)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
match operation with
| Tezos_raw_protocol_alpha.Alpha_context.Reveal pk =>
Contract.reveal_manager_key ctxt source pk
|
Tezos_raw_protocol_alpha.Alpha_context.Transaction {|
parameters := parameters |} =>
op_gtgteqquestion
(op_atat Lwt._return
(op_atat
(record_trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
(Gas.check_enough ctxt
(Script.minimal_deserialize_cost parameters))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtpipequestion
(op_atat
(trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
(Script.force_decode ctxt parameters))
(fun function_parameter =>
let '(_arg, ctxt) := function_parameter in
ctxt))
|
Tezos_raw_protocol_alpha.Alpha_context.Origination {|
script := script |} =>
op_gtgteqquestion
(op_atat Lwt._return
(op_atat
(record_trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
(op_gtgtquestion
(Gas.consume ctxt
(Script.minimal_deserialize_cost (code script)))
(fun ctxt =>
Gas.check_enough ctxt
(Script.minimal_deserialize_cost
(storage script))))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_atat
(trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
(Script.force_decode ctxt (code script)))
(fun function_parameter =>
let '(_code, ctxt) := function_parameter in
op_gtgtpipequestion
(op_atat
(trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
(Script.force_decode ctxt (storage script)))
(fun function_parameter =>
let '(_storage, ctxt) := function_parameter in
ctxt)))
| _ => _return ctxt
end
(fun ctxt =>
op_gtgteqquestion (Contract.get_manager_key ctxt source)
(fun public_key =>
op_gtgteqquestion
(Operation.check_signature public_key chain_id
raw_operation)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Contract.increment_counter ctxt source)
(fun ctxt =>
op_gtgteqquestion
(Contract.spend ctxt
(Contract.implicit_contract source) fee)
(fun ctxt =>
op_gtgteqquestion (add_fees ctxt fee)
(fun ctxt => _return ctxt)))))))))).
Definition apply_manager_contents {A : Type}
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(op :
Tezos_raw_protocol_alpha.Alpha_context.contents
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(variant *
(Tezos_raw_protocol_alpha.Apply_results.manager_operation_result A) *
(list
Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)) :=
let
'Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
source := source;
operation := operation;
gas_limit := gas_limit;
storage_limit := storage_limit
|} := op in
let ctxt := Gas.set_limit ctxt gas_limit in
let ctxt := Fees.start_counting_storage_fees ctxt in
let source := Contract.implicit_contract source in
op_gtgteq
(apply_manager_operation_content ctxt mode source source chain_id false
operation)
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
(ctxt, operation_results, internal_operations) =>
op_gtgteq
(apply_internal_manager_operations ctxt mode source chain_id
internal_operations)
(fun function_parameter =>
match function_parameter with
| (Success ctxt, internal_operations_results) =>
op_gtgteq (Fees.burn_storage_fees ctxt storage_limit source)
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
ctxt =>
Lwt._return
((* ❌ Variants not supported *)
variant,
(Tezos_raw_protocol_alpha.Apply_results.Applied
operation_results), internal_operations_results)
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
errors =>
Lwt._return
((* ❌ Variants not supported *)
variant,
(Tezos_raw_protocol_alpha.Apply_results.Backtracked
operation_results (Some errors)),
internal_operations_results)
end)
| (Failure, internal_operations_results) =>
Lwt._return
((* ❌ Variants not supported *)
variant,
(Tezos_raw_protocol_alpha.Apply_results.Applied
operation_results), internal_operations_results)
end)
| Tezos_protocol_environment_alpha__Environment.Pervasives.Error errors =>
Lwt._return
((* ❌ Variants not supported *)
variant,
(Tezos_raw_protocol_alpha.Apply_results.Failed
(manager_kind operation) errors), [])
end).
Definition skipped_operation_result {kind : Type}
(operation : Tezos_raw_protocol_alpha.Alpha_context.manager_operation kind)
: Tezos_raw_protocol_alpha.Apply_results.manager_operation_result kind :=
match operation with
| Tezos_raw_protocol_alpha.Alpha_context.Reveal _ =>
Tezos_raw_protocol_alpha.Apply_results.Applied
(Tezos_raw_protocol_alpha.Apply_results.Reveal_result
{| consumed_gas := Z.zero |})
| _ => Tezos_raw_protocol_alpha.Apply_results.Skipped (manager_kind operation)
end.
Fixpoint mark_skipped {kind : Type}
(baker :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(level : Tezos_raw_protocol_alpha.Alpha_context.Level.t)
(function_parameter :
Tezos_raw_protocol_alpha.Alpha_context.contents_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
: Tezos_raw_protocol_alpha.Apply_results.contents_result_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) :=
match function_parameter with
|
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
source := source; fee := fee; operation := operation |}) =>
let source := Contract.implicit_contract source in
Tezos_raw_protocol_alpha.Apply_results.Single_result
(Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result
{|
balance_updates :=
Delegate.cleanup_balance_updates
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
source),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited fee))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Fees baker
(cycle level)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
fee)) []));
operation_result := skipped_operation_result operation;
internal_operation_results := [] |})
|
Tezos_raw_protocol_alpha.Alpha_context.Cons
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
source := source; fee := fee; operation := operation |}) rest =>
let source := Contract.implicit_contract source in
Tezos_raw_protocol_alpha.Apply_results.Cons_result
(Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result
{|
balance_updates :=
Delegate.cleanup_balance_updates
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
source),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited fee))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Fees baker
(cycle level)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
fee)) []));
operation_result := skipped_operation_result operation;
internal_operation_results := [] |}) (mark_skipped baker level rest)
end.
Fixpoint precheck_manager_contents_list {A kind : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.t)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(raw_operation : Tezos_raw_protocol_alpha.Alpha_context.Operation.t A)
(contents_list :
Tezos_raw_protocol_alpha.Alpha_context.contents_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Alpha_context.context) :=
match contents_list with
|
Tezos_raw_protocol_alpha.Alpha_context.Single
((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _) as op) =>
precheck_manager_contents ctxt chain_id raw_operation op
|
Tezos_raw_protocol_alpha.Alpha_context.Cons
((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _) as op) rest
=>
op_gtgteqquestion (precheck_manager_contents ctxt chain_id raw_operation op)
(fun ctxt =>
precheck_manager_contents_list ctxt chain_id raw_operation rest)
end.
Fixpoint apply_manager_contents_list_rec {kind : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.t)
(mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
(baker : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(contents_list :
Tezos_raw_protocol_alpha.Alpha_context.contents_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(variant *
(Tezos_raw_protocol_alpha.Apply_results.contents_result_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))) :=
let level := Level.current ctxt in
match contents_list with
|
Tezos_raw_protocol_alpha.Alpha_context.Single
((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
source := source; fee := fee |}) as op) =>
let source := Contract.implicit_contract source in
op_gtgteq (apply_manager_contents ctxt mode chain_id op)
(fun function_parameter =>
let '(ctxt_result, operation_result, internal_operation_results) :=
function_parameter in
let result :=
Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result
{|
balance_updates :=
Delegate.cleanup_balance_updates
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
source),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
fee))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Fees
baker (cycle level)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
fee)) [])); operation_result := operation_result;
internal_operation_results := internal_operation_results |} in
Lwt._return
(ctxt_result,
(Tezos_raw_protocol_alpha.Apply_results.Single_result result)))
|
Tezos_raw_protocol_alpha.Alpha_context.Cons
((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
source := source; fee := fee |}) as op) rest =>
let source := Contract.implicit_contract source in
op_gtgteq (apply_manager_contents ctxt mode chain_id op)
(fun function_parameter =>
match function_parameter with
| (Failure, operation_result, internal_operation_results) =>
let result :=
Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result
{|
balance_updates :=
Delegate.cleanup_balance_updates
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
source),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
fee))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Fees
baker (cycle level)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
fee)) [])); operation_result := operation_result;
internal_operation_results := internal_operation_results |} in
Lwt._return
((* ❌ Variants not supported *)
variant,
(Tezos_raw_protocol_alpha.Apply_results.Cons_result result
(mark_skipped baker level rest)))
| (Success ctxt, operation_result, internal_operation_results) =>
let result :=
Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result
{|
balance_updates :=
Delegate.cleanup_balance_updates
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
source),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
fee))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Fees
baker (cycle level)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
fee)) [])); operation_result := operation_result;
internal_operation_results := internal_operation_results |} in
op_gtgteq
(apply_manager_contents_list_rec ctxt mode baker chain_id rest)
(fun function_parameter =>
let '(ctxt_result, results) := function_parameter in
Lwt._return
(ctxt_result,
(Tezos_raw_protocol_alpha.Apply_results.Cons_result result
results)))
end)
end.
Definition mark_backtracked {A : Type}
(results :
Tezos_raw_protocol_alpha.Apply_results.contents_result_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
: Tezos_raw_protocol_alpha.Apply_results.contents_result_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A) :=
let fix mark_contents_list {kind : Type}
(function_parameter :
Tezos_raw_protocol_alpha.Apply_results.contents_result_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
: Tezos_raw_protocol_alpha.Apply_results.contents_result_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) :=
match function_parameter with
|
Tezos_raw_protocol_alpha.Apply_results.Single_result
(Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result op) =>
Tezos_raw_protocol_alpha.Apply_results.Single_result
(Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result
{| balance_updates := balance_updates op;
operation_result :=
mark_manager_operation_result (operation_result op);
internal_operation_results :=
List.map mark_internal_operation_results
(internal_operation_results op) |})
|
Tezos_raw_protocol_alpha.Apply_results.Cons_result
(Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result op)
rest =>
Tezos_raw_protocol_alpha.Apply_results.Cons_result
(Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result
{| balance_updates := balance_updates op;
operation_result :=
mark_manager_operation_result (operation_result op);
internal_operation_results :=
List.map mark_internal_operation_results
(internal_operation_results op) |}) (mark_contents_list rest)
end
with mark_internal_operation_results
(function_parameter :
Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)
: Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result :=
let
'Tezos_raw_protocol_alpha.Apply_results.Internal_operation_result kind
result := function_parameter in
Tezos_raw_protocol_alpha.Apply_results.Internal_operation_result kind
(mark_manager_operation_result result)
with mark_manager_operation_result {kind : Type}
(function_parameter :
Tezos_raw_protocol_alpha.Apply_results.manager_operation_result kind)
: Tezos_raw_protocol_alpha.Apply_results.manager_operation_result kind :=
match function_parameter with
|
(Tezos_raw_protocol_alpha.Apply_results.Failed _ _ |
Tezos_raw_protocol_alpha.Apply_results.Skipped _ |
Tezos_raw_protocol_alpha.Apply_results.Backtracked _ _) as result =>
result
|
(Tezos_raw_protocol_alpha.Apply_results.Applied
(Tezos_raw_protocol_alpha.Apply_results.Reveal_result _)) as result =>
result
| Tezos_raw_protocol_alpha.Apply_results.Applied result =>
Tezos_raw_protocol_alpha.Apply_results.Backtracked result None
end in
mark_contents_list results.
Definition apply_manager_contents_list {A : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.t)
(mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
(baker : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(contents_list :
Tezos_raw_protocol_alpha.Alpha_context.contents_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_raw_protocol_alpha.Alpha_context.t *
(Tezos_raw_protocol_alpha.Apply_results.contents_result_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))) :=
op_gtgteq
(apply_manager_contents_list_rec ctxt mode baker chain_id contents_list)
(fun function_parameter =>
let '(ctxt_result, results) := function_parameter in
match ctxt_result with
| Failure => Lwt._return (ctxt, (mark_backtracked results))
| Success ctxt =>
op_gtgteq (Big_map.cleanup_temporary ctxt)
(fun ctxt => Lwt._return (ctxt, results))
end).
Definition apply_contents_list {A : Type}
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
(pred_block :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(baker :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(operation : Tezos_raw_protocol_alpha.Alpha_context.operation A)
(contents_list : Tezos_raw_protocol_alpha.Alpha_context.contents_list A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.context *
(Tezos_raw_protocol_alpha.Apply_results.contents_result_list A))) :=
match contents_list with
|
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Endorsement {| level := level |})
=>
let block := branch (shell operation) in
op_gtgteqquestion
(fail_unless
(Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
block pred_block)
(Tezos_protocol_environment_alpha__Environment.Error_monad.Wrong_endorsement_predecessor
pred_block block))
(fun function_parameter =>
let 'tt := function_parameter in
let current_level := level (Level.current ctxt) in
op_gtgteqquestion
(fail_unless (op_eq (succ level) current_level)
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_endorsement_level)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Baking.check_endorsement_rights ctxt chain_id operation)
(fun function_parameter =>
let '(delegate, slots, used) := function_parameter in
if used then
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_endorsement
delegate)
else
let ctxt := record_endorsement ctxt delegate in
let gap := List.length slots in
op_gtgteqquestion
(Lwt._return
(op_starquestion
(Constants.endorsement_security_deposit ctxt)
(Int64.of_int gap)))
(fun deposit =>
op_gtgteqquestion
(Delegate.freeze_deposit ctxt delegate deposit)
(fun ctxt =>
op_gtgteqquestion (Global.get_block_priority ctxt)
(fun block_priority =>
op_gtgteqquestion
(Baking.endorsing_reward ctxt block_priority gap)
(fun reward =>
op_gtgteqquestion
(Delegate.freeze_rewards ctxt delegate
reward)
(fun ctxt =>
let level :=
Level.from_raw ctxt None level in
_return
(ctxt,
(Tezos_raw_protocol_alpha.Apply_results.Single_result
(Tezos_raw_protocol_alpha.Apply_results.Endorsement_result
{|
balance_updates :=
Delegate.cleanup_balance_updates
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
(Contract.implicit_contract
delegate)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
deposit))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Deposits
delegate (cycle level)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
deposit))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Rewards
delegate
(cycle level)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
reward)) [])));
delegate := delegate;
slots := slots |})))))))))))
|
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation {|
level := level; nonce := nonce |}) =>
let level := Level.from_raw ctxt None level in
op_gtgteqquestion (Nonce.reveal ctxt level nonce)
(fun ctxt =>
let seed_nonce_revelation_tip :=
Constants.seed_nonce_revelation_tip ctxt in
op_gtgteqquestion (add_rewards ctxt seed_nonce_revelation_tip)
(fun ctxt =>
_return
(ctxt,
(Tezos_raw_protocol_alpha.Apply_results.Single_result
(Tezos_raw_protocol_alpha.Apply_results.Seed_nonce_revelation_result
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Rewards
baker (cycle level)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
seed_nonce_revelation_tip)) []))))))
|
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence {|
op1 := op1; op2 := op2 |}) =>
match ((contents (protocol_data op1)), (contents (protocol_data op2))) with
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Endorsement e1),
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Endorsement e2)) =>
let level := Level.from_raw ctxt None (level e1) in
let oldest_level := Level.last_allowed_fork_level ctxt in
op_gtgteqquestion
(fail_unless (op_lt level (Level.current ctxt))
(Tezos_protocol_environment_alpha__Environment.Error_monad.Too_early_double_endorsement_evidence
{| level := level level; current := level (Level.current ctxt) |}))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_unless (op_lteq oldest_level (level level))
(Tezos_protocol_environment_alpha__Environment.Error_monad.Outdated_double_endorsement_evidence
{| level := level level; last := oldest_level |}))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Baking.check_endorsement_rights ctxt chain_id op1)
(fun function_parameter =>
let '(delegate1, _, _) := function_parameter in
op_gtgteqquestion
(Baking.check_endorsement_rights ctxt chain_id op2)
(fun function_parameter =>
let '(delegate2, _, _) := function_parameter in
op_gtgteqquestion
(fail_unless
(Signature.Public_key_hash.equal delegate1 delegate2)
(Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_double_endorsement_evidence
{| delegate1 := delegate1; delegate2 := delegate2 |}))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Delegate.has_frozen_balance ctxt delegate1
(cycle level))
(fun valid =>
op_gtgteqquestion
(fail_unless valid
Tezos_protocol_environment_alpha__Environment.Error_monad.Unrequired_double_endorsement_evidence)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Delegate.punish ctxt delegate1
(cycle level))
(fun function_parameter =>
let '(ctxt, balance) := function_parameter
in
op_gtgteqquestion
(Lwt._return
(op_plusquestion (deposit balance)
(fees balance)))
(fun burned =>
let reward :=
match
op_divquestion burned
(* ❌ Constant of type int64 is converted to int *)
2 with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
v => v
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ => Tez.zero
end in
op_gtgteqquestion
(add_rewards ctxt reward)
(fun ctxt =>
let current_cycle :=
cycle (Level.current ctxt) in
_return
(ctxt,
(Tezos_raw_protocol_alpha.Apply_results.Single_result
(Tezos_raw_protocol_alpha.Apply_results.Double_endorsement_evidence_result
(Delegate.cleanup_balance_updates
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Deposits
delegate1
(cycle level)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
(deposit balance)))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Fees
delegate1
(cycle level)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
(fees balance)))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Rewards
delegate1
(cycle level)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
(rewards
balance)))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Rewards
baker
current_cycle),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
reward)) []))))))))))))))))))
| (_, _) =>
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_double_endorsement_evidence
end
|
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence {|
bh1 := bh1; bh2 := bh2 |}) =>
let hash1 := Block_header.hash bh1 in
let hash2 := Block_header.hash bh2 in
op_gtgteqquestion
(fail_unless
(op_andand
(Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(level (shell bh1)) (level (shell bh2)))
(not
(Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
hash1 hash2)))
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_double_baking_evidence
{| hash1 := hash1; level1 := level (shell bh1); hash2 := hash2;
level2 := level (shell bh2) |}))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Lwt._return (Raw_level.of_int32 (level (shell bh1))))
(fun raw_level =>
let oldest_level := Level.last_allowed_fork_level ctxt in
op_gtgteqquestion
(fail_unless (op_lt raw_level (level (Level.current ctxt)))
(Tezos_protocol_environment_alpha__Environment.Error_monad.Too_early_double_baking_evidence
{| level := raw_level; current := level (Level.current ctxt)
|}))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_unless (op_lteq oldest_level raw_level)
(Tezos_protocol_environment_alpha__Environment.Error_monad.Outdated_double_baking_evidence
{| level := raw_level; last := oldest_level |}))
(fun function_parameter =>
let 'tt := function_parameter in
let level := Level.from_raw ctxt None raw_level in
op_gtgteqquestion
(Roll.baking_rights_owner ctxt level
(priority (contents (protocol_data bh1))))
(fun delegate1 =>
op_gtgteqquestion
(Baking.check_signature bh1 chain_id delegate1)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Roll.baking_rights_owner ctxt level
(priority (contents (protocol_data bh2))))
(fun delegate2 =>
op_gtgteqquestion
(Baking.check_signature bh2 chain_id delegate2)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fail_unless
(Signature.Public_key.equal delegate1
delegate2)
(Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_double_baking_evidence
{|
delegate1 :=
Signature.Public_key.hash
delegate1;
delegate2 :=
Signature.Public_key.hash
delegate2 |}))
(fun function_parameter =>
let 'tt := function_parameter in
let delegate :=
Signature.Public_key.hash delegate1 in
op_gtgteqquestion
(Delegate.has_frozen_balance ctxt
delegate (cycle level))
(fun valid =>
op_gtgteqquestion
(fail_unless valid
Tezos_protocol_environment_alpha__Environment.Error_monad.Unrequired_double_baking_evidence)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Delegate.punish ctxt delegate
(cycle level))
(fun function_parameter =>
let '(ctxt, balance) :=
function_parameter in
op_gtgteqquestion
(Lwt._return
(op_plusquestion
(deposit balance)
(fees balance)))
(fun burned =>
let reward :=
match
op_divquestion
burned
(* ❌ Constant of type int64 is converted to int *)
2 with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
v => v
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ => Tez.zero
end in
op_gtgteqquestion
(add_rewards ctxt
reward)
(fun ctxt =>
let current_cycle :=
cycle
(Level.current
ctxt) in
_return
(ctxt,
(Tezos_raw_protocol_alpha.Apply_results.Single_result
(Tezos_raw_protocol_alpha.Apply_results.Double_baking_evidence_result
(Delegate.cleanup_balance_updates
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Deposits
delegate
(cycle
level)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
(deposit
balance)))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Fees
delegate
(cycle
level)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
(fees
balance)))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Rewards
delegate
(cycle
level)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
(rewards
balance)))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Rewards
baker
current_cycle),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
reward))
[]))))))))))))))))))))))
|
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Activate_account {|
id := pkh; activation_code := activation_code |}) =>
let blinded_pkh :=
Blinded_public_key_hash.of_ed25519_pkh activation_code pkh in
op_gtgteqquestion (Commitment.get_opt ctxt blinded_pkh)
(fun function_parameter =>
match function_parameter with
| None =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_activation
{| pkh := pkh |})
| Some amount =>
op_gtgteqquestion (Commitment.delete ctxt blinded_pkh)
(fun ctxt =>
let contract :=
Contract.implicit_contract
(Tezos_protocol_environment_alpha__Environment.Signature.Ed25519
pkh) in
op_gtgteqquestion (credit ctxt contract amount)
(fun ctxt =>
_return
(ctxt,
(Tezos_raw_protocol_alpha.Apply_results.Single_result
(Tezos_raw_protocol_alpha.Apply_results.Activate_account_result
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
contract),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
amount)) []))))))
end)
|
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Proposals {|
source := source; period := period; proposals := proposals |}) =>
op_gtgteqquestion (Roll.delegate_pubkey ctxt source)
(fun delegate =>
op_gtgteqquestion
(Operation.check_signature delegate chain_id operation)
(fun function_parameter =>
let 'tt := function_parameter in
let level := Level.current ctxt in
op_gtgteqquestion
(fail_unless (op_eq (voting_period level) period)
(Tezos_protocol_environment_alpha__Environment.Error_monad.Wrong_voting_period
(voting_period level) period))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Amendment.record_proposals ctxt source proposals)
(fun ctxt =>
_return
(ctxt,
(Tezos_raw_protocol_alpha.Apply_results.Single_result
Tezos_raw_protocol_alpha.Apply_results.Proposals_result))))))
|
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Ballot {|
source := source;
period := period;
proposal := proposal;
ballot := ballot
|}) =>
op_gtgteqquestion (Roll.delegate_pubkey ctxt source)
(fun delegate =>
op_gtgteqquestion
(Operation.check_signature delegate chain_id operation)
(fun function_parameter =>
let 'tt := function_parameter in
let level := Level.current ctxt in
op_gtgteqquestion
(fail_unless (op_eq (voting_period level) period)
(Tezos_protocol_environment_alpha__Environment.Error_monad.Wrong_voting_period
(voting_period level) period))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Amendment.record_ballot ctxt source proposal ballot)
(fun ctxt =>
_return
(ctxt,
(Tezos_raw_protocol_alpha.Apply_results.Single_result
Tezos_raw_protocol_alpha.Apply_results.Ballot_result))))))
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _)) as op =>
op_gtgteqquestion
(precheck_manager_contents_list ctxt chain_id operation op)
(fun ctxt =>
op_gtgteq (apply_manager_contents_list ctxt mode baker chain_id op)
(fun function_parameter =>
let '(ctxt, result) := function_parameter in
_return (ctxt, result)))
|
(Tezos_raw_protocol_alpha.Alpha_context.Cons
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _) _) as op =>
op_gtgteqquestion
(precheck_manager_contents_list ctxt chain_id operation op)
(fun ctxt =>
op_gtgteq (apply_manager_contents_list ctxt mode baker chain_id op)
(fun function_parameter =>
let '(ctxt, result) := function_parameter in
_return (ctxt, result)))
end.
Definition apply_operation {A : Type}
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
(pred_block :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(baker :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(hash :
Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(operation : Tezos_raw_protocol_alpha.Alpha_context.operation A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha__Alpha_context.context *
(Tezos_raw_protocol_alpha.Apply_results.operation_metadata A))) :=
let ctxt := Contract.init_origination_nonce ctxt hash in
op_gtgteqquestion
(apply_contents_list ctxt chain_id mode pred_block baker operation
(contents (protocol_data operation)))
(fun function_parameter =>
let '(ctxt, result) := function_parameter in
let ctxt := Gas.set_unlimited ctxt in
let ctxt := Contract.unset_origination_nonce ctxt in
_return (ctxt, {| contents := result |})).
Definition may_snapshot_roll
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha__Alpha_context.context) :=
let level := Alpha_context.Level.current ctxt in
let blocks_per_roll_snapshot := Constants.blocks_per_roll_snapshot ctxt in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.equal)
(Int32.rem (cycle_position level) blocks_per_roll_snapshot)
(Int32.pred blocks_per_roll_snapshot) then
op_gtgteqquestion (Alpha_context.Roll.snapshot_rolls ctxt)
(fun ctxt => _return ctxt)
else
_return ctxt.
Definition may_start_new_cycle
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.context *
Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates *
(list
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t))) :=
op_gtgteqquestion (Baking.dawn_of_a_new_cycle ctxt)
(fun function_parameter =>
match function_parameter with
| None => _return (ctxt, [], [])
| Some last_cycle =>
op_gtgteqquestion (Seed.cycle_end ctxt last_cycle)
(fun function_parameter =>
let '(ctxt, unrevealed) := function_parameter in
op_gtgteqquestion (Roll.cycle_end ctxt last_cycle)
(fun ctxt =>
op_gtgteqquestion
(Delegate.cycle_end ctxt last_cycle unrevealed)
(fun function_parameter =>
let '(ctxt, update_balances, deactivated) :=
function_parameter in
op_gtgteqquestion (Bootstrap.cycle_end ctxt last_cycle)
(fun ctxt => _return (ctxt, update_balances, deactivated)))))
end).
Definition begin_full_construction
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(pred_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
(protocol_data : Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.context *
Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents *
Tezos_raw_protocol_alpha.Alpha_context.public_key *
Tezos_raw_protocol_alpha.Alpha_context.Period.t)) :=
op_gtgteqquestion
(Alpha_context.Global.set_block_priority ctxt
(Block_header.priority protocol_data))
(fun ctxt =>
op_gtgteqquestion
(Baking.check_baking_rights ctxt protocol_data pred_timestamp)
(fun function_parameter =>
let '(delegate_pk, block_delay) := function_parameter in
let ctxt := Fitness.increase None ctxt in
match Level.pred ctxt (Level.current ctxt) with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some pred_level =>
op_gtgteqquestion (Baking.endorsement_rights ctxt pred_level)
(fun rights =>
let ctxt := init_endorsements ctxt rights in
_return (ctxt, protocol_data, delegate_pk, block_delay))
end)).
Definition begin_partial_construction
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Alpha_context.context) :=
let ctxt := Fitness.increase None ctxt in
match Level.pred ctxt (Level.current ctxt) with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some pred_level =>
op_gtgteqquestion (Baking.endorsement_rights ctxt pred_level)
(fun rights =>
let ctxt := init_endorsements ctxt rights in
_return ctxt)
end.
Definition begin_application
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(block_header : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
(pred_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.context *
Tezos_raw_protocol_alpha.Alpha_context.public_key *
Tezos_raw_protocol_alpha.Alpha_context.Period.t)) :=
op_gtgteqquestion
(Alpha_context.Global.set_block_priority ctxt
(priority (contents (Block_header.protocol_data block_header))))
(fun ctxt =>
let current_level := Alpha_context.Level.current ctxt in
op_gtgteqquestion (Baking.check_proof_of_work_stamp ctxt block_header)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Baking.check_fitness_gap ctxt block_header)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Baking.check_baking_rights ctxt
(contents (protocol_data block_header)) pred_timestamp)
(fun function_parameter =>
let '(delegate_pk, block_delay) := function_parameter in
op_gtgteqquestion
(Baking.check_signature block_header chain_id delegate_pk)
(fun function_parameter =>
let 'tt := function_parameter in
let has_commitment :=
match
seed_nonce_hash
(contents (protocol_data block_header)) with
| None => false
| Some _ => true
end in
op_gtgteqquestion
(fail_unless
(Tezos_protocol_environment_alpha__Environment.Compare.Bool.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
has_commitment (expected_commitment current_level))
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_commitment
{| expected := expected_commitment current_level |}))
(fun function_parameter =>
let 'tt := function_parameter in
let ctxt := Fitness.increase None ctxt in
match Level.pred ctxt (Level.current ctxt) with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some pred_level =>
op_gtgteqquestion
(Baking.endorsement_rights ctxt pred_level)
(fun rights =>
let ctxt := init_endorsements ctxt rights in
_return (ctxt, delegate_pk, block_delay))
end)))))).
Definition check_minimum_endorsements
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(protocol_data : Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
(block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
(included_endorsements :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let minimum := Baking.minimum_allowed_endorsements ctxt block_delay in
let timestamp := Timestamp.current ctxt in
fail_unless
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
included_endorsements minimum)
(Tezos_protocol_environment_alpha__Environment.Error_monad.Not_enough_endorsements_for_priority
{| required := minimum; priority := Block_header.priority protocol_data;
endorsements := included_endorsements; timestamp := timestamp |}).
Definition finalize_application
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(protocol_data : Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.context *
Tezos_raw_protocol_alpha.Apply_results.block_metadata)) :=
let included_endorsements := included_endorsements ctxt in
op_gtgteqquestion
(check_minimum_endorsements ctxt protocol_data block_delay
included_endorsements)
(fun function_parameter =>
let 'tt := function_parameter in
let deposit := Constants.block_security_deposit ctxt in
op_gtgteqquestion (add_deposit ctxt delegate deposit)
(fun ctxt =>
op_gtgteqquestion
(Baking.baking_reward ctxt (priority protocol_data)
included_endorsements)
(fun reward =>
op_gtgteqquestion (add_rewards ctxt reward)
(fun ctxt =>
op_gtgteqquestion
(Signature.Public_key_hash.Map.fold
(fun delegate =>
fun deposit =>
fun ctxt =>
op_gtgteqquestion ctxt
(fun ctxt =>
Delegate.freeze_deposit ctxt delegate deposit))
(get_deposits ctxt) (_return ctxt))
(fun ctxt =>
let fees := Alpha_context.get_fees ctxt in
op_gtgteqquestion
(Delegate.freeze_fees ctxt delegate fees)
(fun ctxt =>
let rewards := Alpha_context.get_rewards ctxt in
op_gtgteqquestion
(Delegate.freeze_rewards ctxt delegate rewards)
(fun ctxt =>
op_gtgteqquestion
match Block_header.seed_nonce_hash protocol_data
with
| None => _return ctxt
| Some nonce_hash =>
Nonce.record_hash ctxt
{| nonce_hash := nonce_hash;
delegate := delegate; rewards := rewards;
fees := fees |}
end
(fun ctxt =>
op_gtgteqquestion (may_snapshot_roll ctxt)
(fun ctxt =>
op_gtgteqquestion
(may_start_new_cycle ctxt)
(fun function_parameter =>
let
'(ctxt, balance_updates, deactivated) :=
function_parameter in
op_gtgteqquestion
(Amendment.may_start_new_voting_period
ctxt)
(fun ctxt =>
let cycle :=
cycle (Level.current ctxt) in
let balance_updates :=
cleanup_balance_updates
(op_at
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
(Contract.implicit_contract
delegate)),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
deposit))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Deposits
delegate cycle),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
deposit))
(cons
((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Rewards
delegate cycle),
(Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
reward)) [])))
balance_updates) in
let consumed_gas :=
Z.sub
(Constants.hard_gas_limit_per_block
ctxt)
(Alpha_context.Gas.block_level
ctxt) in
op_gtgteqquestion
(Alpha_context.Vote.get_current_period_kind
ctxt)
(fun voting_period_kind =>
let receipt :=
{| baker := delegate;
level :=
Level.current ctxt;
voting_period_kind :=
voting_period_kind;
nonce_hash :=
seed_nonce_hash
protocol_data;
consumed_gas :=
consumed_gas;
deactivated := deactivated;
balance_updates :=
balance_updates |} in
_return (ctxt, receipt))))))))))))).
src/proto_alpha/lib_protocol/apply_results.ml 147 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
open Data_encoding
let error_encoding =
def
"error"
~description:
"The full list of RPC errors would be too long to include.\n\
It is available at RPC `/errors` (GET).\n\
Errors specific to protocol Alpha have an id that starts with \
`proto.alpha`."
@@ splitted
~json:
(conv
(fun err ->
Data_encoding.Json.construct Error_monad.error_encoding err)
(fun json ->
Data_encoding.Json.destruct Error_monad.error_encoding json)
json)
~binary:Error_monad.error_encoding
type _ successful_manager_operation_result =
| Reveal_result : {
consumed_gas : Z.t;
}
-> Kind.reveal successful_manager_operation_result
| Transaction_result : {
storage : Script.expr option;
big_map_diff : Contract.big_map_diff option;
balance_updates : Delegate.balance_updates;
originated_contracts : Contract.t list;
consumed_gas : Z.t;
storage_size : Z.t;
paid_storage_size_diff : Z.t;
allocated_destination_contract : bool;
}
-> Kind.transaction successful_manager_operation_result
| Origination_result : {
big_map_diff : Contract.big_map_diff option;
balance_updates : Delegate.balance_updates;
originated_contracts : Contract.t list;
consumed_gas : Z.t;
storage_size : Z.t;
paid_storage_size_diff : Z.t;
}
-> Kind.origination successful_manager_operation_result
| Delegation_result : {
consumed_gas : Z.t;
}
-> Kind.delegation successful_manager_operation_result
type packed_successful_manager_operation_result =
| Successful_manager_result :
'kind successful_manager_operation_result
-> packed_successful_manager_operation_result
type 'kind manager_operation_result =
| Applied of 'kind successful_manager_operation_result
| Backtracked of
'kind successful_manager_operation_result * error list option
| Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result
| Skipped : 'kind Kind.manager -> 'kind manager_operation_result
type packed_internal_operation_result =
| Internal_operation_result :
'kind internal_operation * 'kind manager_operation_result
-> packed_internal_operation_result
module Manager_result = struct
type 'kind case =
| MCase : {
op_case : 'kind Operation.Encoding.Manager_operations.case;
encoding : 'a Data_encoding.t;
kind : 'kind Kind.manager;
iselect :
packed_internal_operation_result ->
('kind internal_operation * 'kind manager_operation_result) option;
select :
packed_successful_manager_operation_result ->
'kind successful_manager_operation_result option;
proj : 'kind successful_manager_operation_result -> 'a;
inj : 'a -> 'kind successful_manager_operation_result;
t : 'kind manager_operation_result Data_encoding.t;
}
-> 'kind case
let make ~op_case ~encoding ~kind ~iselect ~select ~proj ~inj =
let (Operation.Encoding.Manager_operations.MCase {name; _}) = op_case in
let t =
def (Format.asprintf "operation.alpha.operation_result.%s" name)
@@ union
~tag_size:`Uint8
[ case
(Tag 0)
~title:"Applied"
(merge_objs (obj1 (req "status" (constant "applied"))) encoding)
(fun o ->
match o with
| Skipped _ | Failed _ | Backtracked _ ->
None
| Applied o -> (
match select (Successful_manager_result o) with
| None ->
None
| Some o ->
Some ((), proj o) ))
(fun ((), x) -> Applied (inj x));
case
(Tag 1)
~title:"Failed"
(obj2
(req "status" (constant "failed"))
(req "errors" (list error_encoding)))
(function Failed (_, errs) -> Some ((), errs) | _ -> None)
(fun ((), errs) -> Failed (kind, errs));
case
(Tag 2)
~title:"Skipped"
(obj1 (req "status" (constant "skipped")))
(function Skipped _ -> Some () | _ -> None)
(fun () -> Skipped kind);
case
(Tag 3)
~title:"Backtracked"
(merge_objs
(obj2
(req "status" (constant "backtracked"))
(opt "errors" (list error_encoding)))
encoding)
(fun o ->
match o with
| Skipped _ | Failed _ | Applied _ ->
None
| Backtracked (o, errs) -> (
match select (Successful_manager_result o) with
| None ->
None
| Some o ->
Some (((), errs), proj o) ))
(fun (((), errs), x) -> Backtracked (inj x, errs)) ]
in
MCase {op_case; encoding; kind; iselect; select; proj; inj; t}
let reveal_case =
make
~op_case:Operation.Encoding.Manager_operations.reveal_case
~encoding:Data_encoding.(obj1 (dft "consumed_gas" z Z.zero))
~iselect:(function
| Internal_operation_result (({operation = Reveal _; _} as op), res) ->
Some (op, res)
| _ ->
None)
~select:(function
| Successful_manager_result (Reveal_result _ as op) ->
Some op
| _ ->
None)
~kind:Kind.Reveal_manager_kind
~proj:(function Reveal_result {consumed_gas} -> consumed_gas)
~inj:(fun consumed_gas -> Reveal_result {consumed_gas})
let transaction_case =
make
~op_case:Operation.Encoding.Manager_operations.transaction_case
~encoding:
(obj8
(opt "storage" Script.expr_encoding)
(opt "big_map_diff" Contract.big_map_diff_encoding)
(dft "balance_updates" Delegate.balance_updates_encoding [])
(dft "originated_contracts" (list Contract.encoding) [])
(dft "consumed_gas" z Z.zero)
(dft "storage_size" z Z.zero)
(dft "paid_storage_size_diff" z Z.zero)
(dft "allocated_destination_contract" bool false))
~iselect:(function
| Internal_operation_result
(({operation = Transaction _; _} as op), res) ->
Some (op, res)
| _ ->
None)
~select:(function
| Successful_manager_result (Transaction_result _ as op) ->
Some op
| _ ->
None)
~kind:Kind.Transaction_manager_kind
~proj:(function
| Transaction_result
{ storage;
big_map_diff;
balance_updates;
originated_contracts;
consumed_gas;
storage_size;
paid_storage_size_diff;
allocated_destination_contract } ->
( storage,
big_map_diff,
balance_updates,
originated_contracts,
consumed_gas,
storage_size,
paid_storage_size_diff,
allocated_destination_contract ))
~inj:
(fun ( storage,
big_map_diff,
balance_updates,
originated_contracts,
consumed_gas,
storage_size,
paid_storage_size_diff,
allocated_destination_contract ) ->
Transaction_result
{
storage;
big_map_diff;
balance_updates;
originated_contracts;
consumed_gas;
storage_size;
paid_storage_size_diff;
allocated_destination_contract;
})
let origination_case =
make
~op_case:Operation.Encoding.Manager_operations.origination_case
~encoding:
(obj6
(opt "big_map_diff" Contract.big_map_diff_encoding)
(dft "balance_updates" Delegate.balance_updates_encoding [])
(dft "originated_contracts" (list Contract.encoding) [])
(dft "consumed_gas" z Z.zero)
(dft "storage_size" z Z.zero)
(dft "paid_storage_size_diff" z Z.zero))
~iselect:(function
| Internal_operation_result
(({operation = Origination _; _} as op), res) ->
Some (op, res)
| _ ->
None)
~select:(function
| Successful_manager_result (Origination_result _ as op) ->
Some op
| _ ->
None)
~proj:(function
| Origination_result
{ big_map_diff;
balance_updates;
originated_contracts;
consumed_gas;
storage_size;
paid_storage_size_diff } ->
( big_map_diff,
balance_updates,
originated_contracts,
consumed_gas,
storage_size,
paid_storage_size_diff ))
~kind:Kind.Origination_manager_kind
~inj:
(fun ( big_map_diff,
balance_updates,
originated_contracts,
consumed_gas,
storage_size,
paid_storage_size_diff ) ->
Origination_result
{
big_map_diff;
balance_updates;
originated_contracts;
consumed_gas;
storage_size;
paid_storage_size_diff;
})
let delegation_case =
make
~op_case:Operation.Encoding.Manager_operations.delegation_case
~encoding:Data_encoding.(obj1 (dft "consumed_gas" z Z.zero))
~iselect:(function
| Internal_operation_result (({operation = Delegation _; _} as op), res)
->
Some (op, res)
| _ ->
None)
~select:(function
| Successful_manager_result (Delegation_result _ as op) ->
Some op
| _ ->
None)
~kind:Kind.Delegation_manager_kind
~proj:(function Delegation_result {consumed_gas} -> consumed_gas)
~inj:(fun consumed_gas -> Delegation_result {consumed_gas})
end
let internal_operation_result_encoding :
packed_internal_operation_result Data_encoding.t =
let make (type kind)
(Manager_result.MCase res_case : kind Manager_result.case) =
let (Operation.Encoding.Manager_operations.MCase op_case) =
res_case.op_case
in
case
(Tag op_case.tag)
~title:op_case.name
(merge_objs
(obj3
(req "kind" (constant op_case.name))
(req "source" Contract.encoding)
(req "nonce" uint16))
(merge_objs op_case.encoding (obj1 (req "result" res_case.t))))
(fun op ->
match res_case.iselect op with
| Some (op, res) ->
Some (((), op.source, op.nonce), (op_case.proj op.operation, res))
| None ->
None)
(fun (((), source, nonce), (op, res)) ->
let op = {source; operation = op_case.inj op; nonce} in
Internal_operation_result (op, res))
in
def "operation.alpha.internal_operation_result"
@@ union
[ make Manager_result.reveal_case;
make Manager_result.transaction_case;
make Manager_result.origination_case;
make Manager_result.delegation_case ]
type 'kind contents_result =
| Endorsement_result : {
balance_updates : Delegate.balance_updates;
delegate : Signature.Public_key_hash.t;
slots : int list;
}
-> Kind.endorsement contents_result
| Seed_nonce_revelation_result :
Delegate.balance_updates
-> Kind.seed_nonce_revelation contents_result
| Double_endorsement_evidence_result :
Delegate.balance_updates
-> Kind.double_endorsement_evidence contents_result
| Double_baking_evidence_result :
Delegate.balance_updates
-> Kind.double_baking_evidence contents_result
| Activate_account_result :
Delegate.balance_updates
-> Kind.activate_account contents_result
| Proposals_result : Kind.proposals contents_result
| Ballot_result : Kind.ballot contents_result
| Manager_operation_result : {
balance_updates : Delegate.balance_updates;
operation_result : 'kind manager_operation_result;
internal_operation_results : packed_internal_operation_result list;
}
-> 'kind Kind.manager contents_result
type packed_contents_result =
| Contents_result : 'kind contents_result -> packed_contents_result
type packed_contents_and_result =
| Contents_and_result :
'kind Operation.contents * 'kind contents_result
-> packed_contents_and_result
type ('a, 'b) eq = Eq : ('a, 'a) eq
let equal_manager_kind :
type a b. a Kind.manager -> b Kind.manager -> (a, b) eq option =
fun ka kb ->
match (ka, kb) with
| (Kind.Reveal_manager_kind, Kind.Reveal_manager_kind) ->
Some Eq
| (Kind.Reveal_manager_kind, _) ->
None
| (Kind.Transaction_manager_kind, Kind.Transaction_manager_kind) ->
Some Eq
| (Kind.Transaction_manager_kind, _) ->
None
| (Kind.Origination_manager_kind, Kind.Origination_manager_kind) ->
Some Eq
| (Kind.Origination_manager_kind, _) ->
None
| (Kind.Delegation_manager_kind, Kind.Delegation_manager_kind) ->
Some Eq
| (Kind.Delegation_manager_kind, _) ->
None
module Encoding = struct
type 'kind case =
| Case : {
op_case : 'kind Operation.Encoding.case;
encoding : 'a Data_encoding.t;
select : packed_contents_result -> 'kind contents_result option;
mselect :
packed_contents_and_result ->
('kind contents * 'kind contents_result) option;
proj : 'kind contents_result -> 'a;
inj : 'a -> 'kind contents_result;
}
-> 'kind case
let tagged_case tag name args proj inj =
let open Data_encoding in
case
tag
~title:(String.capitalize_ascii name)
(merge_objs (obj1 (req "kind" (constant name))) args)
(fun x -> match proj x with None -> None | Some x -> Some ((), x))
(fun ((), x) -> inj x)
let endorsement_case =
Case
{
op_case = Operation.Encoding.endorsement_case;
encoding =
obj3
(req "balance_updates" Delegate.balance_updates_encoding)
(req "delegate" Signature.Public_key_hash.encoding)
(req "slots" (list uint8));
select =
(function
| Contents_result (Endorsement_result _ as op) -> Some op | _ -> None);
mselect =
(function
| Contents_and_result ((Endorsement _ as op), res) ->
Some (op, res)
| _ ->
None);
proj =
(function
| Endorsement_result {balance_updates; delegate; slots} ->
(balance_updates, delegate, slots));
inj =
(fun (balance_updates, delegate, slots) ->
Endorsement_result {balance_updates; delegate; slots});
}
let seed_nonce_revelation_case =
Case
{
op_case = Operation.Encoding.seed_nonce_revelation_case;
encoding =
obj1 (req "balance_updates" Delegate.balance_updates_encoding);
select =
(function
| Contents_result (Seed_nonce_revelation_result _ as op) ->
Some op
| _ ->
None);
mselect =
(function
| Contents_and_result ((Seed_nonce_revelation _ as op), res) ->
Some (op, res)
| _ ->
None);
proj = (fun (Seed_nonce_revelation_result bus) -> bus);
inj = (fun bus -> Seed_nonce_revelation_result bus);
}
let double_endorsement_evidence_case =
Case
{
op_case = Operation.Encoding.double_endorsement_evidence_case;
encoding =
obj1 (req "balance_updates" Delegate.balance_updates_encoding);
select =
(function
| Contents_result (Double_endorsement_evidence_result _ as op) ->
Some op
| _ ->
None);
mselect =
(function
| Contents_and_result ((Double_endorsement_evidence _ as op), res) ->
Some (op, res)
| _ ->
None);
proj = (fun (Double_endorsement_evidence_result bus) -> bus);
inj = (fun bus -> Double_endorsement_evidence_result bus);
}
let double_baking_evidence_case =
Case
{
op_case = Operation.Encoding.double_baking_evidence_case;
encoding =
obj1 (req "balance_updates" Delegate.balance_updates_encoding);
select =
(function
| Contents_result (Double_baking_evidence_result _ as op) ->
Some op
| _ ->
None);
mselect =
(function
| Contents_and_result ((Double_baking_evidence _ as op), res) ->
Some (op, res)
| _ ->
None);
proj = (fun (Double_baking_evidence_result bus) -> bus);
inj = (fun bus -> Double_baking_evidence_result bus);
}
let activate_account_case =
Case
{
op_case = Operation.Encoding.activate_account_case;
encoding =
obj1 (req "balance_updates" Delegate.balance_updates_encoding);
select =
(function
| Contents_result (Activate_account_result _ as op) ->
Some op
| _ ->
None);
mselect =
(function
| Contents_and_result ((Activate_account _ as op), res) ->
Some (op, res)
| _ ->
None);
proj = (fun (Activate_account_result bus) -> bus);
inj = (fun bus -> Activate_account_result bus);
}
let proposals_case =
Case
{
op_case = Operation.Encoding.proposals_case;
encoding = Data_encoding.empty;
select =
(function
| Contents_result (Proposals_result as op) -> Some op | _ -> None);
mselect =
(function
| Contents_and_result ((Proposals _ as op), res) ->
Some (op, res)
| _ ->
None);
proj = (fun Proposals_result -> ());
inj = (fun () -> Proposals_result);
}
let ballot_case =
Case
{
op_case = Operation.Encoding.ballot_case;
encoding = Data_encoding.empty;
select =
(function
| Contents_result (Ballot_result as op) -> Some op | _ -> None);
mselect =
(function
| Contents_and_result ((Ballot _ as op), res) ->
Some (op, res)
| _ ->
None);
proj = (fun Ballot_result -> ());
inj = (fun () -> Ballot_result);
}
let make_manager_case (type kind)
(Operation.Encoding.Case op_case :
kind Kind.manager Operation.Encoding.case)
(Manager_result.MCase res_case : kind Manager_result.case) mselect =
Case
{
op_case = Operation.Encoding.Case op_case;
encoding =
obj3
(req "balance_updates" Delegate.balance_updates_encoding)
(req "operation_result" res_case.t)
(dft
"internal_operation_results"
(list internal_operation_result_encoding)
[]);
select =
(function
| Contents_result
(Manager_operation_result
({operation_result = Applied res; _} as op)) -> (
match res_case.select (Successful_manager_result res) with
| Some res ->
Some
(Manager_operation_result
{op with operation_result = Applied res})
| None ->
None )
| Contents_result
(Manager_operation_result
({operation_result = Backtracked (res, errs); _} as op)) -> (
match res_case.select (Successful_manager_result res) with
| Some res ->
Some
(Manager_operation_result
{op with operation_result = Backtracked (res, errs)})
| None ->
None )
| Contents_result
(Manager_operation_result
({operation_result = Skipped kind; _} as op)) -> (
match equal_manager_kind kind res_case.kind with
| None ->
None
| Some Eq ->
Some
(Manager_operation_result
{op with operation_result = Skipped kind}) )
| Contents_result
(Manager_operation_result
({operation_result = Failed (kind, errs); _} as op)) -> (
match equal_manager_kind kind res_case.kind with
| None ->
None
| Some Eq ->
Some
(Manager_operation_result
{op with operation_result = Failed (kind, errs)}) )
| Contents_result Ballot_result ->
None
| Contents_result (Endorsement_result _) ->
None
| Contents_result (Seed_nonce_revelation_result _) ->
None
| Contents_result (Double_endorsement_evidence_result _) ->
None
| Contents_result (Double_baking_evidence_result _) ->
None
| Contents_result (Activate_account_result _) ->
None
| Contents_result Proposals_result ->
None);
mselect;
proj =
(fun (Manager_operation_result
{ balance_updates = bus;
operation_result = r;
internal_operation_results = rs }) ->
(bus, r, rs));
inj =
(fun (bus, r, rs) ->
Manager_operation_result
{
balance_updates = bus;
operation_result = r;
internal_operation_results = rs;
});
}
let reveal_case =
make_manager_case
Operation.Encoding.reveal_case
Manager_result.reveal_case
(function
| Contents_and_result
((Manager_operation {operation = Reveal _; _} as op), res) ->
Some (op, res)
| _ ->
None)
let transaction_case =
make_manager_case
Operation.Encoding.transaction_case
Manager_result.transaction_case
(function
| Contents_and_result
((Manager_operation {operation = Transaction _; _} as op), res) ->
Some (op, res)
| _ ->
None)
let origination_case =
make_manager_case
Operation.Encoding.origination_case
Manager_result.origination_case
(function
| Contents_and_result
((Manager_operation {operation = Origination _; _} as op), res) ->
Some (op, res)
| _ ->
None)
let delegation_case =
make_manager_case
Operation.Encoding.delegation_case
Manager_result.delegation_case
(function
| Contents_and_result
((Manager_operation {operation = Delegation _; _} as op), res) ->
Some (op, res)
| _ ->
None)
end
let contents_result_encoding =
let open Encoding in
let make
(Case
{ op_case = Operation.Encoding.Case {tag; name; _};
encoding;
mselect = _;
select;
proj;
inj }) =
let proj x =
match select x with None -> None | Some x -> Some (proj x)
in
let inj x = Contents_result (inj x) in
tagged_case (Tag tag) name encoding proj inj
in
def "operation.alpha.contents_result"
@@ union
[ make endorsement_case;
make seed_nonce_revelation_case;
make double_endorsement_evidence_case;
make double_baking_evidence_case;
make activate_account_case;
make proposals_case;
make ballot_case;
make reveal_case;
make transaction_case;
make origination_case;
make delegation_case ]
let contents_and_result_encoding =
let open Encoding in
let make
(Case
{ op_case = Operation.Encoding.Case {tag; name; encoding; proj; inj; _};
mselect;
encoding = meta_encoding;
proj = meta_proj;
inj = meta_inj;
_ }) =
let proj c =
match mselect c with
| Some (op, res) ->
Some (proj op, meta_proj res)
| _ ->
None
in
let inj (op, res) = Contents_and_result (inj op, meta_inj res) in
let encoding = merge_objs encoding (obj1 (req "metadata" meta_encoding)) in
tagged_case (Tag tag) name encoding proj inj
in
def "operation.alpha.operation_contents_and_result"
@@ union
[ make endorsement_case;
make seed_nonce_revelation_case;
make double_endorsement_evidence_case;
make double_baking_evidence_case;
make activate_account_case;
make proposals_case;
make ballot_case;
make reveal_case;
make transaction_case;
make origination_case;
make delegation_case ]
type 'kind contents_result_list =
| Single_result : 'kind contents_result -> 'kind contents_result_list
| Cons_result :
'kind Kind.manager contents_result
* 'rest Kind.manager contents_result_list
-> ('kind * 'rest) Kind.manager contents_result_list
type packed_contents_result_list =
| Contents_result_list :
'kind contents_result_list
-> packed_contents_result_list
let contents_result_list_encoding =
let rec to_list = function
| Contents_result_list (Single_result o) ->
[Contents_result o]
| Contents_result_list (Cons_result (o, os)) ->
Contents_result o :: to_list (Contents_result_list os)
in
let rec of_list = function
| [] ->
Pervasives.failwith "cannot decode empty operation result"
| [Contents_result o] ->
Contents_result_list (Single_result o)
| Contents_result o :: os -> (
let (Contents_result_list os) = of_list os in
match (o, os) with
| ( Manager_operation_result _,
Single_result (Manager_operation_result _) ) ->
Contents_result_list (Cons_result (o, os))
| (Manager_operation_result _, Cons_result _) ->
Contents_result_list (Cons_result (o, os))
| _ ->
Pervasives.failwith "cannot decode ill-formed operation result" )
in
def "operation.alpha.contents_list_result"
@@ conv to_list of_list (list contents_result_encoding)
type 'kind contents_and_result_list =
| Single_and_result :
'kind Alpha_context.contents * 'kind contents_result
-> 'kind contents_and_result_list
| Cons_and_result :
'kind Kind.manager Alpha_context.contents
* 'kind Kind.manager contents_result
* 'rest Kind.manager contents_and_result_list
-> ('kind * 'rest) Kind.manager contents_and_result_list
type packed_contents_and_result_list =
| Contents_and_result_list :
'kind contents_and_result_list
-> packed_contents_and_result_list
let contents_and_result_list_encoding =
let rec to_list = function
| Contents_and_result_list (Single_and_result (op, res)) ->
[Contents_and_result (op, res)]
| Contents_and_result_list (Cons_and_result (op, res, rest)) ->
Contents_and_result (op, res)
:: to_list (Contents_and_result_list rest)
in
let rec of_list = function
| [] ->
Pervasives.failwith "cannot decode empty combined operation result"
| [Contents_and_result (op, res)] ->
Contents_and_result_list (Single_and_result (op, res))
| Contents_and_result (op, res) :: rest -> (
let (Contents_and_result_list rest) = of_list rest in
match (op, rest) with
| (Manager_operation _, Single_and_result (Manager_operation _, _)) ->
Contents_and_result_list (Cons_and_result (op, res, rest))
| (Manager_operation _, Cons_and_result (_, _, _)) ->
Contents_and_result_list (Cons_and_result (op, res, rest))
| _ ->
Pervasives.failwith
"cannot decode ill-formed combined operation result" )
in
conv to_list of_list (Variable.list contents_and_result_encoding)
type 'kind operation_metadata = {contents : 'kind contents_result_list}
type packed_operation_metadata =
| Operation_metadata : 'kind operation_metadata -> packed_operation_metadata
| No_operation_metadata : packed_operation_metadata
let operation_metadata_encoding =
def "operation.alpha.result"
@@ union
[ case
(Tag 0)
~title:"Operation_metadata"
contents_result_list_encoding
(function
| Operation_metadata {contents} ->
Some (Contents_result_list contents)
| _ ->
None)
(fun (Contents_result_list contents) ->
Operation_metadata {contents});
case
(Tag 1)
~title:"No_operation_metadata"
empty
(function No_operation_metadata -> Some () | _ -> None)
(fun () -> No_operation_metadata) ]
let kind_equal :
type kind kind2.
kind contents -> kind2 contents_result -> (kind, kind2) eq option =
fun op res ->
match (op, res) with
| (Endorsement _, Endorsement_result _) ->
Some Eq
| (Endorsement _, _) ->
None
| (Seed_nonce_revelation _, Seed_nonce_revelation_result _) ->
Some Eq
| (Seed_nonce_revelation _, _) ->
None
| (Double_endorsement_evidence _, Double_endorsement_evidence_result _) ->
Some Eq
| (Double_endorsement_evidence _, _) ->
None
| (Double_baking_evidence _, Double_baking_evidence_result _) ->
Some Eq
| (Double_baking_evidence _, _) ->
None
| (Activate_account _, Activate_account_result _) ->
Some Eq
| (Activate_account _, _) ->
None
| (Proposals _, Proposals_result) ->
Some Eq
| (Proposals _, _) ->
None
| (Ballot _, Ballot_result) ->
Some Eq
| (Ballot _, _) ->
None
| ( Manager_operation {operation = Reveal _; _},
Manager_operation_result {operation_result = Applied (Reveal_result _); _}
) ->
Some Eq
| ( Manager_operation {operation = Reveal _; _},
Manager_operation_result
{operation_result = Backtracked (Reveal_result _, _); _} ) ->
Some Eq
| ( Manager_operation {operation = Reveal _; _},
Manager_operation_result
{ operation_result = Failed (Alpha_context.Kind.Reveal_manager_kind, _);
_ } ) ->
Some Eq
| ( Manager_operation {operation = Reveal _; _},
Manager_operation_result
{operation_result = Skipped Alpha_context.Kind.Reveal_manager_kind; _}
) ->
Some Eq
| (Manager_operation {operation = Reveal _; _}, _) ->
None
| ( Manager_operation {operation = Transaction _; _},
Manager_operation_result
{operation_result = Applied (Transaction_result _); _} ) ->
Some Eq
| ( Manager_operation {operation = Transaction _; _},
Manager_operation_result
{operation_result = Backtracked (Transaction_result _, _); _} ) ->
Some Eq
| ( Manager_operation {operation = Transaction _; _},
Manager_operation_result
{ operation_result =
Failed (Alpha_context.Kind.Transaction_manager_kind, _);
_ } ) ->
Some Eq
| ( Manager_operation {operation = Transaction _; _},
Manager_operation_result
{ operation_result = Skipped Alpha_context.Kind.Transaction_manager_kind;
_ } ) ->
Some Eq
| (Manager_operation {operation = Transaction _; _}, _) ->
None
| ( Manager_operation {operation = Origination _; _},
Manager_operation_result
{operation_result = Applied (Origination_result _); _} ) ->
Some Eq
| ( Manager_operation {operation = Origination _; _},
Manager_operation_result
{operation_result = Backtracked (Origination_result _, _); _} ) ->
Some Eq
| ( Manager_operation {operation = Origination _; _},
Manager_operation_result
{ operation_result =
Failed (Alpha_context.Kind.Origination_manager_kind, _);
_ } ) ->
Some Eq
| ( Manager_operation {operation = Origination _; _},
Manager_operation_result
{ operation_result = Skipped Alpha_context.Kind.Origination_manager_kind;
_ } ) ->
Some Eq
| (Manager_operation {operation = Origination _; _}, _) ->
None
| ( Manager_operation {operation = Delegation _; _},
Manager_operation_result
{operation_result = Applied (Delegation_result _); _} ) ->
Some Eq
| ( Manager_operation {operation = Delegation _; _},
Manager_operation_result
{operation_result = Backtracked (Delegation_result _, _); _} ) ->
Some Eq
| ( Manager_operation {operation = Delegation _; _},
Manager_operation_result
{ operation_result =
Failed (Alpha_context.Kind.Delegation_manager_kind, _);
_ } ) ->
Some Eq
| ( Manager_operation {operation = Delegation _; _},
Manager_operation_result
{ operation_result = Skipped Alpha_context.Kind.Delegation_manager_kind;
_ } ) ->
Some Eq
| (Manager_operation {operation = Delegation _; _}, _) ->
None
let rec kind_equal_list :
type kind kind2.
kind contents_list -> kind2 contents_result_list -> (kind, kind2) eq option
=
fun contents res ->
match (contents, res) with
| (Single op, Single_result res) -> (
match kind_equal op res with None -> None | Some Eq -> Some Eq )
| (Cons (op, ops), Cons_result (res, ress)) -> (
match kind_equal op res with
| None ->
None
| Some Eq -> (
match kind_equal_list ops ress with None -> None | Some Eq -> Some Eq ) )
| _ ->
None
let rec pack_contents_list :
type kind.
kind contents_list ->
kind contents_result_list ->
kind contents_and_result_list =
fun contents res ->
match (contents, res) with
| (Single op, Single_result res) ->
Single_and_result (op, res)
| (Cons (op, ops), Cons_result (res, ress)) ->
Cons_and_result (op, res, pack_contents_list ops ress)
| ( Single (Manager_operation _),
Cons_result (Manager_operation_result _, Single_result _) ) ->
.
| ( Cons (_, _),
Single_result (Manager_operation_result {operation_result = Failed _; _})
) ->
.
| ( Cons (_, _),
Single_result
(Manager_operation_result {operation_result = Skipped _; _}) ) ->
.
| ( Cons (_, _),
Single_result
(Manager_operation_result {operation_result = Applied _; _}) ) ->
.
| ( Cons (_, _),
Single_result
(Manager_operation_result {operation_result = Backtracked _; _}) ) ->
.
| (Single _, Cons_result _) ->
.
let rec unpack_contents_list :
type kind.
kind contents_and_result_list ->
kind contents_list * kind contents_result_list = function
| Single_and_result (op, res) ->
(Single op, Single_result res)
| Cons_and_result (op, res, rest) ->
let (ops, ress) = unpack_contents_list rest in
(Cons (op, ops), Cons_result (res, ress))
let rec to_list = function
| Contents_result_list (Single_result o) ->
[Contents_result o]
| Contents_result_list (Cons_result (o, os)) ->
Contents_result o :: to_list (Contents_result_list os)
let rec of_list = function
| [] ->
assert false
| [Contents_result o] ->
Contents_result_list (Single_result o)
| Contents_result o :: os -> (
let (Contents_result_list os) = of_list os in
match (o, os) with
| (Manager_operation_result _, Single_result (Manager_operation_result _))
->
Contents_result_list (Cons_result (o, os))
| (Manager_operation_result _, Cons_result _) ->
Contents_result_list (Cons_result (o, os))
| _ ->
Pervasives.failwith
"Operation result list of length > 1 should only contains manager \
operations result." )
let operation_data_and_metadata_encoding =
def "operation.alpha.operation_with_metadata"
@@ union
[ case
(Tag 0)
~title:"Operation_with_metadata"
(obj2
(req "contents" (dynamic_size contents_and_result_list_encoding))
(opt "signature" Signature.encoding))
(function
| (Operation_data _, No_operation_metadata) ->
None
| (Operation_data op, Operation_metadata res) -> (
match kind_equal_list op.contents res.contents with
| None ->
Pervasives.failwith
"cannot decode inconsistent combined operation result"
| Some Eq ->
Some
( Contents_and_result_list
(pack_contents_list op.contents res.contents),
op.signature ) ))
(fun (Contents_and_result_list contents, signature) ->
let (op_contents, res_contents) = unpack_contents_list contents in
( Operation_data {contents = op_contents; signature},
Operation_metadata {contents = res_contents} ));
case
(Tag 1)
~title:"Operation_without_metadata"
(obj2
(req "contents" (dynamic_size Operation.contents_list_encoding))
(opt "signature" Signature.encoding))
(function
| (Operation_data op, No_operation_metadata) ->
Some (Contents_list op.contents, op.signature)
| (Operation_data _, Operation_metadata _) ->
None)
(fun (Contents_list contents, signature) ->
(Operation_data {contents; signature}, No_operation_metadata)) ]
type block_metadata = {
baker : Signature.Public_key_hash.t;
level : Level.t;
voting_period_kind : Voting_period.kind;
nonce_hash : Nonce_hash.t option;
consumed_gas : Z.t;
deactivated : Signature.Public_key_hash.t list;
balance_updates : Delegate.balance_updates;
}
let block_metadata_encoding =
let open Data_encoding in
def "block_header.alpha.metadata"
@@ conv
(fun { baker;
level;
voting_period_kind;
nonce_hash;
consumed_gas;
deactivated;
balance_updates } ->
( baker,
level,
voting_period_kind,
nonce_hash,
consumed_gas,
deactivated,
balance_updates ))
(fun ( baker,
level,
voting_period_kind,
nonce_hash,
consumed_gas,
deactivated,
balance_updates ) ->
{
baker;
level;
voting_period_kind;
nonce_hash;
consumed_gas;
deactivated;
balance_updates;
})
(obj7
(req "baker" Signature.Public_key_hash.encoding)
(req "level" Level.encoding)
(req "voting_period_kind" Voting_period.kind_encoding)
(req "nonce_hash" (option Nonce_hash.encoding))
(req "consumed_gas" (check_size 10 n))
(req "deactivated" (list Signature.Public_key_hash.encoding))
(req "balance_updates" Delegate.balance_updates_encoding))
src/proto_alpha/lib_protocol/apply_results.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Import Data_encoding.
Definition error_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
Tezos_protocol_environment_alpha__Environment.Error_monad.error :=
op_atat
(let arg :=
def "error" % string
(* ❌ expected an argument *)
expected_argument
(Some
"The full list of RPC errors would be too long to include.
It is available at RPC `/errors` (GET).
Errors specific to protocol Alpha have an id that starts with `proto.alpha`."
% string) in
fun eta => arg None eta)
(splitted
(conv
(fun err => Data_encoding.Json.construct Error_monad.error_encoding err)
(fun json => Data_encoding.Json.destruct Error_monad.error_encoding json)
None json) Error_monad.error_encoding).
Inductive successful_manager_operation_result : forall (_ : Type), Type :=
| Reveal_result : Tezos_protocol_environment_alpha__Environment.Z.t ->
successful_manager_operation_result
Tezos_raw_protocol_alpha.Alpha_context.Kind.reveal
| Transaction_result :
(option Tezos_raw_protocol_alpha.Alpha_context.Script.expr) ->
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff) ->
Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
(list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t -> bool ->
successful_manager_operation_result
Tezos_raw_protocol_alpha.Alpha_context.Kind.transaction
| Origination_result :
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff) ->
Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
(list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
successful_manager_operation_result
Tezos_raw_protocol_alpha.Alpha_context.Kind.origination
| Delegation_result : Tezos_protocol_environment_alpha__Environment.Z.t ->
successful_manager_operation_result
Tezos_raw_protocol_alpha.Alpha_context.Kind.delegation.
Inductive packed_successful_manager_operation_result : Type :=
| Successful_manager_result : forall {kind : Type},
(successful_manager_operation_result kind) ->
packed_successful_manager_operation_result.
Inductive manager_operation_result (kind : Type) : Type :=
| Applied : (successful_manager_operation_result kind) ->
manager_operation_result kind
| Backtracked : (successful_manager_operation_result kind) ->
(option (list Tezos_protocol_environment_alpha__Environment.Error_monad.error))
-> manager_operation_result kind
| Failed : (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) ->
(list Tezos_protocol_environment_alpha__Environment.Error_monad.error) ->
manager_operation_result kind
| Skipped : (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) ->
manager_operation_result kind.
Arguments Applied {_}.
Arguments Backtracked {_}.
Arguments Failed {_}.
Arguments Skipped {_}.
Inductive packed_internal_operation_result : Type :=
| Internal_operation_result : forall {kind : Type},
(Tezos_raw_protocol_alpha.Alpha_context.internal_operation kind) ->
(manager_operation_result kind) -> packed_internal_operation_result.
Module Manager_result.
Inductive case (kind : Type) : Type :=
| MCase : forall {a : Type},
(Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Manager_operations.case
kind) -> (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a)
-> (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) ->
(packed_internal_operation_result ->
option
((Tezos_raw_protocol_alpha.Alpha_context.internal_operation kind) *
(manager_operation_result kind))) ->
(packed_successful_manager_operation_result ->
option (successful_manager_operation_result kind)) ->
((successful_manager_operation_result kind) -> a) ->
(a -> successful_manager_operation_result kind) ->
(Tezos_protocol_environment_alpha__Environment.Data_encoding.t
(manager_operation_result kind)) -> case kind.
Arguments MCase {_}.
Definition make {A B : Type}
(op_case :
Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Manager_operations.case
A)
(encoding :
Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding B)
(kind : Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A)
(iselect :
packed_internal_operation_result ->
option
((Tezos_raw_protocol_alpha.Alpha_context.internal_operation A) *
(manager_operation_result A)))
(select :
packed_successful_manager_operation_result ->
option (successful_manager_operation_result A))
(proj : (successful_manager_operation_result A) -> B)
(inj : B -> successful_manager_operation_result A) : case A :=
let
'Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Manager_operations.MCase
{| name := name |} := op_case in
let t :=
op_atat
(let arg :=
def
(Format.asprintf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"operation.alpha.operation_result." % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format))
"operation.alpha.operation_result.%s" % string) name) in
fun eta => arg None None eta)
(union
(Some
(* ❌ Variants not supported *)
variant)
(cons
(case "Applied" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
(merge_objs
(obj1
(req None None "status" % string (constant "applied" % string)))
encoding)
(fun o =>
match o with
| Skipped _ | Failed _ _ | Backtracked _ _ => None
| Applied o =>
match select (Successful_manager_result o) with
| None => None
| Some o => Some (tt, (proj o))
end
end)
(fun function_parameter =>
let '(tt, x) := function_parameter in
Applied (inj x)))
(cons
(case "Failed" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag
1)
(obj2
(req None None "status" % string (constant "failed" % string))
(req None None "errors" % string (list None error_encoding)))
(fun function_parameter =>
match function_parameter with
| Failed _ errs => Some (tt, errs)
| _ => None
end)
(fun function_parameter =>
let '(tt, errs) := function_parameter in
Failed kind errs))
(cons
(case "Skipped" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag
2)
(obj1
(req None None "status" % string
(constant "skipped" % string)))
(fun function_parameter =>
match function_parameter with
| Skipped _ => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Skipped kind))
(cons
(case "Backtracked" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag
3)
(merge_objs
(obj2
(req None None "status" % string
(constant "backtracked" % string))
(opt None None "errors" % string
(list None error_encoding))) encoding)
(fun o =>
match o with
| Skipped _ | Failed _ _ | Applied _ => None
| Backtracked o errs =>
match select (Successful_manager_result o) with
| None => None
| Some o => Some ((tt, errs), (proj o))
end
end)
(fun function_parameter =>
let '((tt, errs), x) := function_parameter in
Backtracked (inj x) errs)) []))))) in
MCase
{| op_case := op_case; encoding := encoding; kind := kind;
iselect := iselect; select := select; proj := proj; inj := inj; t := t
|}.
Definition reveal_case
: case Tezos_raw_protocol_alpha.Alpha_context.Kind.reveal :=
make Operation.Encoding.Manager_operations.reveal_case
(obj1 (dft None None "consumed_gas" % string z Z.zero))
Tezos_raw_protocol_alpha.Alpha_context.Kind.Reveal_manager_kind
(fun function_parameter =>
match function_parameter with
|
Internal_operation_result
({| operation := Tezos_raw_protocol_alpha.Alpha_context.Reveal _ |}
as op) res => Some (op, res)
| _ => None
end)
(fun function_parameter =>
match function_parameter with
| Successful_manager_result ((Reveal_result _) as op) => Some op
| _ => None
end)
(fun function_parameter =>
let 'Reveal_result {| consumed_gas := consumed_gas |} :=
function_parameter in
consumed_gas)
(fun consumed_gas => Reveal_result {| consumed_gas := consumed_gas |}).
Definition transaction_case
: case Tezos_raw_protocol_alpha.Alpha_context.Kind.transaction :=
make Operation.Encoding.Manager_operations.transaction_case
(obj8 (opt None None "storage" % string Script.expr_encoding)
(opt None None "big_map_diff" % string Contract.big_map_diff_encoding)
(dft None None "balance_updates" % string
Delegate.balance_updates_encoding [])
(dft None None "originated_contracts" % string
(list None Contract.encoding) [])
(dft None None "consumed_gas" % string z Z.zero)
(dft None None "storage_size" % string z Z.zero)
(dft None None "paid_storage_size_diff" % string z Z.zero)
(dft None None "allocated_destination_contract" % string bool false))
Tezos_raw_protocol_alpha.Alpha_context.Kind.Transaction_manager_kind
(fun function_parameter =>
match function_parameter with
|
Internal_operation_result
({|
operation := Tezos_raw_protocol_alpha.Alpha_context.Transaction _
|} as op) res => Some (op, res)
| _ => None
end)
(fun function_parameter =>
match function_parameter with
| Successful_manager_result ((Transaction_result _) as op) => Some op
| _ => None
end)
(fun function_parameter =>
let
'Transaction_result {|
storage := storage;
big_map_diff := big_map_diff;
balance_updates := balance_updates;
originated_contracts := originated_contracts;
consumed_gas := consumed_gas;
storage_size := storage_size;
paid_storage_size_diff := paid_storage_size_diff;
allocated_destination_contract := allocated_destination_contract
|} := function_parameter in
(storage, big_map_diff, balance_updates, originated_contracts,
consumed_gas, storage_size, paid_storage_size_diff,
allocated_destination_contract))
(fun function_parameter =>
let
'(storage, big_map_diff, balance_updates, originated_contracts,
consumed_gas, storage_size, paid_storage_size_diff,
allocated_destination_contract) := function_parameter in
Transaction_result
{| storage := storage; big_map_diff := big_map_diff;
balance_updates := balance_updates;
originated_contracts := originated_contracts;
consumed_gas := consumed_gas; storage_size := storage_size;
paid_storage_size_diff := paid_storage_size_diff;
allocated_destination_contract := allocated_destination_contract |}).
Definition origination_case
: case Tezos_raw_protocol_alpha.Alpha_context.Kind.origination :=
make Operation.Encoding.Manager_operations.origination_case
(obj6
(opt None None "big_map_diff" % string Contract.big_map_diff_encoding)
(dft None None "balance_updates" % string
Delegate.balance_updates_encoding [])
(dft None None "originated_contracts" % string
(list None Contract.encoding) [])
(dft None None "consumed_gas" % string z Z.zero)
(dft None None "storage_size" % string z Z.zero)
(dft None None "paid_storage_size_diff" % string z Z.zero))
Tezos_raw_protocol_alpha.Alpha_context.Kind.Origination_manager_kind
(fun function_parameter =>
match function_parameter with
|
Internal_operation_result
({|
operation := Tezos_raw_protocol_alpha.Alpha_context.Origination _
|} as op) res => Some (op, res)
| _ => None
end)
(fun function_parameter =>
match function_parameter with
| Successful_manager_result ((Origination_result _) as op) => Some op
| _ => None
end)
(fun function_parameter =>
let
'Origination_result {|
big_map_diff := big_map_diff;
balance_updates := balance_updates;
originated_contracts := originated_contracts;
consumed_gas := consumed_gas;
storage_size := storage_size;
paid_storage_size_diff := paid_storage_size_diff
|} := function_parameter in
(big_map_diff, balance_updates, originated_contracts, consumed_gas,
storage_size, paid_storage_size_diff))
(fun function_parameter =>
let
'(big_map_diff, balance_updates, originated_contracts, consumed_gas,
storage_size, paid_storage_size_diff) := function_parameter in
Origination_result
{| big_map_diff := big_map_diff; balance_updates := balance_updates;
originated_contracts := originated_contracts;
consumed_gas := consumed_gas; storage_size := storage_size;
paid_storage_size_diff := paid_storage_size_diff |}).
Definition delegation_case
: case Tezos_raw_protocol_alpha.Alpha_context.Kind.delegation :=
make Operation.Encoding.Manager_operations.delegation_case
(obj1 (dft None None "consumed_gas" % string z Z.zero))
Tezos_raw_protocol_alpha.Alpha_context.Kind.Delegation_manager_kind
(fun function_parameter =>
match function_parameter with
|
Internal_operation_result
({|
operation := Tezos_raw_protocol_alpha.Alpha_context.Delegation _
|} as op) res => Some (op, res)
| _ => None
end)
(fun function_parameter =>
match function_parameter with
| Successful_manager_result ((Delegation_result _) as op) => Some op
| _ => None
end)
(fun function_parameter =>
let 'Delegation_result {| consumed_gas := consumed_gas |} :=
function_parameter in
consumed_gas)
(fun consumed_gas => Delegation_result {| consumed_gas := consumed_gas |}).
End Manager_result.
Definition internal_operation_result_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.t
packed_internal_operation_result :=
let make {A : Type} (function_parameter : Manager_result.case A)
: Tezos_protocol_environment_alpha__Environment.Data_encoding.case
packed_internal_operation_result :=
let 'Manager_result.MCase res_case := function_parameter in
let
'Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Manager_operations.MCase
op_case := op_case res_case in
case (name op_case) None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag
(tag op_case))
(merge_objs
(obj3 (req None None "kind" % string (constant (name op_case)))
(req None None "source" % string Contract.encoding)
(req None None "nonce" % string uint16))
(merge_objs (encoding op_case)
(obj1 (req None None "result" % string (t res_case)))))
(fun op =>
match (iselect res_case) op with
| Some (op, res) =>
Some
((tt, (source op), (nonce op)),
(((proj op_case) (operation op)), res))
| None => None
end)
(fun function_parameter =>
let '((tt, source, nonce), (op, res)) := function_parameter in
let op :=
{| source := source; operation := (inj op_case) op; nonce := nonce |}
in
Internal_operation_result op res) in
op_atat
(let arg := def "operation.alpha.internal_operation_result" % string in
fun eta => arg None None eta)
(union None
(cons (make Manager_result.reveal_case)
(cons (make Manager_result.transaction_case)
(cons (make Manager_result.origination_case)
(cons (make Manager_result.delegation_case) []))))).
Inductive contents_result : forall (kind : Type), Type :=
| Endorsement_result :
Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
(list Z) ->
contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement
| Seed_nonce_revelation_result :
Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
contents_result
Tezos_raw_protocol_alpha.Alpha_context.Kind.seed_nonce_revelation
| Double_endorsement_evidence_result :
Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
contents_result
Tezos_raw_protocol_alpha.Alpha_context.Kind.double_endorsement_evidence
| Double_baking_evidence_result :
Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
contents_result
Tezos_raw_protocol_alpha.Alpha_context.Kind.double_baking_evidence
| Activate_account_result :
Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.activate_account
| Proposals_result :
contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.proposals
| Ballot_result :
contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.ballot
| Manager_operation_result : forall {kind : Type},
Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
(manager_operation_result kind) -> (list packed_internal_operation_result) ->
contents_result (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind).
Inductive packed_contents_result : Type :=
| Contents_result : forall {kind : Type}, (contents_result kind) ->
packed_contents_result.
Inductive packed_contents_and_result : Type :=
| Contents_and_result : forall {kind : Type},
(Tezos_raw_protocol_alpha.Alpha_context.Operation.contents kind) ->
(contents_result kind) -> packed_contents_and_result.
Inductive eq (a : Type) : forall (b : Type), Type :=
| Eq : eq a a.
Arguments Eq {_}.
Definition equal_manager_kind {a b : Type}
(ka : Tezos_raw_protocol_alpha.Alpha_context.Kind.manager a)
(kb : Tezos_raw_protocol_alpha.Alpha_context.Kind.manager b)
: option (eq a b) :=
match (ka, kb) with
|
(Tezos_raw_protocol_alpha.Alpha_context.Kind.Reveal_manager_kind,
Tezos_raw_protocol_alpha.Alpha_context.Kind.Reveal_manager_kind) =>
Some Eq
| (Tezos_raw_protocol_alpha.Alpha_context.Kind.Reveal_manager_kind, _) => None
|
(Tezos_raw_protocol_alpha.Alpha_context.Kind.Transaction_manager_kind,
Tezos_raw_protocol_alpha.Alpha_context.Kind.Transaction_manager_kind) =>
Some Eq
| (Tezos_raw_protocol_alpha.Alpha_context.Kind.Transaction_manager_kind, _) =>
None
|
(Tezos_raw_protocol_alpha.Alpha_context.Kind.Origination_manager_kind,
Tezos_raw_protocol_alpha.Alpha_context.Kind.Origination_manager_kind) =>
Some Eq
| (Tezos_raw_protocol_alpha.Alpha_context.Kind.Origination_manager_kind, _) =>
None
|
(Tezos_raw_protocol_alpha.Alpha_context.Kind.Delegation_manager_kind,
Tezos_raw_protocol_alpha.Alpha_context.Kind.Delegation_manager_kind) =>
Some Eq
| (Tezos_raw_protocol_alpha.Alpha_context.Kind.Delegation_manager_kind, _) =>
None
end.
Module Encoding.
Inductive case (kind : Type) : Type :=
| Case : forall {a : Type},
(Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.case kind) ->
(Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
(packed_contents_result -> option (contents_result kind)) ->
(packed_contents_and_result ->
option
((Tezos_raw_protocol_alpha.Alpha_context.contents kind) *
(contents_result kind))) -> ((contents_result kind) -> a) ->
(a -> contents_result kind) -> case kind.
Arguments Case {_}.
Definition tagged_case {A B : Type}
(tag : Tezos_protocol_environment_alpha__Environment.Data_encoding.case_tag)
(name : string)
(args :
Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding A)
(proj : B -> option A) (inj : A -> B)
: Tezos_protocol_environment_alpha__Environment.Data_encoding.case B :=
case (String.capitalize_ascii name) None tag
(merge_objs (obj1 (req None None "kind" % string (constant name))) args)
(fun x =>
match proj x with
| None => None
| Some x => Some (tt, x)
end)
(fun function_parameter =>
let '(tt, x) := function_parameter in
inj x).
Definition endorsement_case
: case Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement :=
Case
{| op_case := Operation.Encoding.endorsement_case;
encoding :=
obj3
(req None None "balance_updates" % string
Delegate.balance_updates_encoding)
(req None None "delegate" % string
Signature.Public_key_hash.encoding)
(req None None "slots" % string (list None uint8));
select :=
fun function_parameter =>
match function_parameter with
| Contents_result ((Endorsement_result _) as op) => Some op
| _ => None
end;
mselect :=
fun function_parameter =>
match function_parameter with
|
Contents_and_result
((Tezos_raw_protocol_alpha.Alpha_context.Endorsement _) as op)
res => Some (op, res)
| _ => None
end;
proj :=
fun function_parameter =>
let
'Endorsement_result {|
balance_updates := balance_updates;
delegate := delegate;
slots := slots
|} := function_parameter in
(balance_updates, delegate, slots);
inj :=
fun function_parameter =>
let '(balance_updates, delegate, slots) := function_parameter in
Endorsement_result
{| balance_updates := balance_updates; delegate := delegate;
slots := slots |} |}.
Definition seed_nonce_revelation_case
: case Tezos_raw_protocol_alpha.Alpha_context.Kind.seed_nonce_revelation :=
Case
{| op_case := Operation.Encoding.seed_nonce_revelation_case;
encoding :=
obj1
(req None None "balance_updates" % string
Delegate.balance_updates_encoding);
select :=
fun function_parameter =>
match function_parameter with
| Contents_result ((Seed_nonce_revelation_result _) as op) =>
Some op
| _ => None
end;
mselect :=
fun function_parameter =>
match function_parameter with
|
Contents_and_result
((Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation _)
as op) res => Some (op, res)
| _ => None
end;
proj :=
fun function_parameter =>
let 'Seed_nonce_revelation_result bus := function_parameter in
bus; inj := fun bus => Seed_nonce_revelation_result bus |}.
Definition double_endorsement_evidence_case
: case
Tezos_raw_protocol_alpha.Alpha_context.Kind.double_endorsement_evidence :=
Case
{| op_case := Operation.Encoding.double_endorsement_evidence_case;
encoding :=
obj1
(req None None "balance_updates" % string
Delegate.balance_updates_encoding);
select :=
fun function_parameter =>
match function_parameter with
| Contents_result ((Double_endorsement_evidence_result _) as op) =>
Some op
| _ => None
end;
mselect :=
fun function_parameter =>
match function_parameter with
|
Contents_and_result
((Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence
_) as op) res => Some (op, res)
| _ => None
end;
proj :=
fun function_parameter =>
let 'Double_endorsement_evidence_result bus := function_parameter in
bus; inj := fun bus => Double_endorsement_evidence_result bus |}.
Definition double_baking_evidence_case
: case Tezos_raw_protocol_alpha.Alpha_context.Kind.double_baking_evidence :=
Case
{| op_case := Operation.Encoding.double_baking_evidence_case;
encoding :=
obj1
(req None None "balance_updates" % string
Delegate.balance_updates_encoding);
select :=
fun function_parameter =>
match function_parameter with
| Contents_result ((Double_baking_evidence_result _) as op) =>
Some op
| _ => None
end;
mselect :=
fun function_parameter =>
match function_parameter with
|
Contents_and_result
((Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence
_) as op) res => Some (op, res)
| _ => None
end;
proj :=
fun function_parameter =>
let 'Double_baking_evidence_result bus := function_parameter in
bus; inj := fun bus => Double_baking_evidence_result bus |}.
Definition activate_account_case
: case Tezos_raw_protocol_alpha.Alpha_context.Kind.activate_account :=
Case
{| op_case := Operation.Encoding.activate_account_case;
encoding :=
obj1
(req None None "balance_updates" % string
Delegate.balance_updates_encoding);
select :=
fun function_parameter =>
match function_parameter with
| Contents_result ((Activate_account_result _) as op) => Some op
| _ => None
end;
mselect :=
fun function_parameter =>
match function_parameter with
|
Contents_and_result
((Tezos_raw_protocol_alpha.Alpha_context.Activate_account _) as
op) res => Some (op, res)
| _ => None
end;
proj :=
fun function_parameter =>
let 'Activate_account_result bus := function_parameter in
bus; inj := fun bus => Activate_account_result bus |}.
Definition proposals_case
: case Tezos_raw_protocol_alpha__Alpha_context.Kind.proposals :=
Case
{| op_case := Operation.Encoding.proposals_case;
encoding := Data_encoding.empty;
select :=
fun function_parameter =>
match function_parameter with
| Contents_result (Proposals_result as op) => Some op
| _ => None
end;
mselect :=
fun function_parameter =>
match function_parameter with
|
Contents_and_result
((Tezos_raw_protocol_alpha.Alpha_context.Proposals _) as op) res
=> Some (op, res)
| _ => None
end;
proj :=
fun function_parameter =>
let 'Proposals_result := function_parameter in
tt;
inj :=
fun function_parameter =>
let 'tt := function_parameter in
Proposals_result |}.
Definition ballot_case
: case Tezos_raw_protocol_alpha__Alpha_context.Kind.ballot :=
Case
{| op_case := Operation.Encoding.ballot_case;
encoding := Data_encoding.empty;
select :=
fun function_parameter =>
match function_parameter with
| Contents_result (Ballot_result as op) => Some op
| _ => None
end;
mselect :=
fun function_parameter =>
match function_parameter with
|
Contents_and_result
((Tezos_raw_protocol_alpha.Alpha_context.Ballot _) as op) res =>
Some (op, res)
| _ => None
end;
proj :=
fun function_parameter =>
let 'Ballot_result := function_parameter in
tt;
inj :=
fun function_parameter =>
let 'tt := function_parameter in
Ballot_result |}.
Definition make_manager_case {A : Type}
(function_parameter :
Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.case
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
: (Manager_result.case A) ->
(packed_contents_and_result ->
option
((Tezos_raw_protocol_alpha.Alpha_context.contents
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A)) *
(contents_result
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A)))) ->
case (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A) :=
let
'Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Case op_case :=
function_parameter in
fun function_parameter =>
let 'Manager_result.MCase res_case := function_parameter in
fun mselect =>
Case
{|
op_case :=
Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Case
op_case;
encoding :=
obj3
(req None None "balance_updates" % string
Delegate.balance_updates_encoding)
(req None None "operation_result" % string (t res_case))
(dft None None "internal_operation_results" % string
(list None internal_operation_result_encoding) []);
select :=
fun function_parameter =>
match function_parameter with
|
Contents_result
(Manager_operation_result
({| operation_result := Applied res |} as op)) =>
match (select res_case) (Successful_manager_result res) with
| Some res =>
Some
(Manager_operation_result
(* ❌ Record substitution not handled *)
record_substitution)
| None => None
end
|
Contents_result
(Manager_operation_result
({| operation_result := Backtracked res errs |} as op)) =>
match (select res_case) (Successful_manager_result res) with
| Some res =>
Some
(Manager_operation_result
(* ❌ Record substitution not handled *)
record_substitution)
| None => None
end
|
Contents_result
(Manager_operation_result
({| operation_result := Skipped kind |} as op)) =>
match equal_manager_kind kind (kind res_case) with
| None => None
| Some Eq =>
Some
(Manager_operation_result
(* ❌ Record substitution not handled *)
record_substitution)
end
|
Contents_result
(Manager_operation_result
({| operation_result := Failed kind errs |} as op)) =>
match equal_manager_kind kind (kind res_case) with
| None => None
| Some Eq =>
Some
(Manager_operation_result
(* ❌ Record substitution not handled *)
record_substitution)
end
| Contents_result Ballot_result => None
| Contents_result (Endorsement_result _) => None
| Contents_result (Seed_nonce_revelation_result _) => None
| Contents_result (Double_endorsement_evidence_result _) => None
| Contents_result (Double_baking_evidence_result _) => None
| Contents_result (Activate_account_result _) => None
| Contents_result Proposals_result => None
end; mselect := mselect;
proj :=
fun function_parameter =>
let
'Manager_operation_result {|
balance_updates := bus;
operation_result := r;
internal_operation_results := rs
|} := function_parameter in
(bus, r, rs);
inj :=
fun function_parameter =>
let '(bus, r, rs) := function_parameter in
Manager_operation_result
{| balance_updates := bus; operation_result := r;
internal_operation_results := rs |} |}.
Definition reveal_case
: case
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager
Tezos_raw_protocol_alpha.Alpha_context.Kind.reveal) :=
make_manager_case Operation.Encoding.reveal_case Manager_result.reveal_case
(fun function_parameter =>
match function_parameter with
|
Contents_and_result
((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Reveal _
|}) as op) res => Some (op, res)
| _ => None
end).
Definition transaction_case
: case
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager
Tezos_raw_protocol_alpha.Alpha_context.Kind.transaction) :=
make_manager_case Operation.Encoding.transaction_case
Manager_result.transaction_case
(fun function_parameter =>
match function_parameter with
|
Contents_and_result
((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Transaction _
|}) as op) res => Some (op, res)
| _ => None
end).
Definition origination_case
: case
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager
Tezos_raw_protocol_alpha.Alpha_context.Kind.origination) :=
make_manager_case Operation.Encoding.origination_case
Manager_result.origination_case
(fun function_parameter =>
match function_parameter with
|
Contents_and_result
((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Origination _
|}) as op) res => Some (op, res)
| _ => None
end).
Definition delegation_case
: case
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager
Tezos_raw_protocol_alpha.Alpha_context.Kind.delegation) :=
make_manager_case Operation.Encoding.delegation_case
Manager_result.delegation_case
(fun function_parameter =>
match function_parameter with
|
Contents_and_result
((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Delegation _
|}) as op) res => Some (op, res)
| _ => None
end).
End Encoding.
Definition contents_result_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_contents_result :=
let make {A : Type} (function_parameter : Encoding.case A)
: Tezos_protocol_environment_alpha__Environment.Data_encoding.case
packed_contents_result :=
let
'Encoding.Case {|
op_case :=
Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Case {|
tag := tag; name := name |};
encoding := encoding;
select := select;
mselect := _;
proj := proj;
inj := inj
|} := function_parameter in
let proj (x : packed_contents_result) : option op_dollarCase_'a :=
match select x with
| None => None
| Some x => Some (proj x)
end in
let inj (x : op_dollarCase_'a) : packed_contents_result :=
Contents_result (inj x) in
tagged_case
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag tag) name
encoding proj inj in
op_atat
(let arg := def "operation.alpha.contents_result" % string in
fun eta => arg None None eta)
(union None
(cons (make endorsement_case)
(cons (make seed_nonce_revelation_case)
(cons (make double_endorsement_evidence_case)
(cons (make double_baking_evidence_case)
(cons (make activate_account_case)
(cons (make proposals_case)
(cons (make ballot_case)
(cons (make reveal_case)
(cons (make transaction_case)
(cons (make origination_case)
(cons (make delegation_case) [])))))))))))).
Definition contents_and_result_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_contents_and_result :=
let make {A : Type} (function_parameter : Encoding.case A)
: Tezos_protocol_environment_alpha__Environment.Data_encoding.case
packed_contents_and_result :=
let
'Encoding.Case {|
op_case :=
Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Case {|
tag := tag;
name := name;
encoding := encoding;
proj := proj;
inj := inj
|};
encoding := meta_encoding;
mselect := mselect;
proj := meta_proj;
inj := meta_inj
|} := function_parameter in
let proj (c : packed_contents_and_result)
: option (op_dollarCase_'a1 * op_dollarCase_'a) :=
match mselect c with
| Some (op, res) => Some ((proj op), (meta_proj res))
| _ => None
end in
let inj (function_parameter : op_dollarCase_'a1 * op_dollarCase_'a)
: packed_contents_and_result :=
let '(op, res) := function_parameter in
Contents_and_result (inj op) (meta_inj res) in
let encoding :=
merge_objs encoding
(obj1 (req None None "metadata" % string meta_encoding)) in
tagged_case
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag tag) name
encoding proj inj in
op_atat
(let arg := def "operation.alpha.operation_contents_and_result" % string in
fun eta => arg None None eta)
(union None
(cons (make endorsement_case)
(cons (make seed_nonce_revelation_case)
(cons (make double_endorsement_evidence_case)
(cons (make double_baking_evidence_case)
(cons (make activate_account_case)
(cons (make proposals_case)
(cons (make ballot_case)
(cons (make reveal_case)
(cons (make transaction_case)
(cons (make origination_case)
(cons (make delegation_case) [])))))))))))).
Inductive contents_result_list : forall (kind : Type), Type :=
| Single_result : forall {kind : Type}, (contents_result kind) ->
contents_result_list kind
| Cons_result : forall {kind rest : Type},
(contents_result (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
->
(contents_result_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager rest)) ->
contents_result_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager (kind * rest)).
Inductive packed_contents_result_list : Type :=
| Contents_result_list : forall {kind : Type}, (contents_result_list kind) ->
packed_contents_result_list.
Definition contents_result_list_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_contents_result_list :=
let fix to_list (function_parameter : packed_contents_result_list)
: list packed_contents_result :=
match function_parameter with
| Contents_result_list (Single_result o) => cons (Contents_result o) []
| Contents_result_list (Cons_result o os) =>
cons (Contents_result o) (to_list (Contents_result_list os))
end in
let fix of_list (function_parameter : list packed_contents_result)
: packed_contents_result_list :=
match function_parameter with
| [] => Pervasives.failwith "cannot decode empty operation result" % string
| cons (Contents_result o) [] => Contents_result_list (Single_result o)
| cons (Contents_result o) os =>
let 'Contents_result_list os := of_list os in
match (o, os) with
| (Manager_operation_result _, Single_result (Manager_operation_result _))
=> Contents_result_list (Cons_result o os)
| (Manager_operation_result _, Cons_result _ _) =>
Contents_result_list (Cons_result o os)
| _ =>
Pervasives.failwith "cannot decode ill-formed operation result" % string
end
end in
op_atat
(let arg := def "operation.alpha.contents_list_result" % string in
fun eta => arg None None eta)
(conv to_list of_list None (list None contents_result_encoding)).
Inductive contents_and_result_list : forall (kind : Type), Type :=
| Single_and_result : forall {kind : Type},
(Tezos_raw_protocol_alpha.Alpha_context.contents kind) ->
(contents_result kind) -> contents_and_result_list kind
| Cons_and_result : forall {kind rest : Type},
(Tezos_raw_protocol_alpha.Alpha_context.contents
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind)) ->
(contents_result (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
->
(contents_and_result_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager rest)) ->
contents_and_result_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager (kind * rest)).
Inductive packed_contents_and_result_list : Type :=
| Contents_and_result_list : forall {kind : Type},
(contents_and_result_list kind) -> packed_contents_and_result_list.
Definition contents_and_result_list_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_contents_and_result_list :=
let fix to_list (function_parameter : packed_contents_and_result_list)
: list packed_contents_and_result :=
match function_parameter with
| Contents_and_result_list (Single_and_result op res) =>
cons (Contents_and_result op res) []
| Contents_and_result_list (Cons_and_result op res rest) =>
cons (Contents_and_result op res)
(to_list (Contents_and_result_list rest))
end in
let fix of_list (function_parameter : list packed_contents_and_result)
: packed_contents_and_result_list :=
match function_parameter with
| [] =>
Pervasives.failwith
"cannot decode empty combined operation result" % string
| cons (Contents_and_result op res) [] =>
Contents_and_result_list (Single_and_result op res)
| cons (Contents_and_result op res) rest =>
let 'Contents_and_result_list rest := of_list rest in
match (op, rest) with
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _,
Single_and_result
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _) _) =>
Contents_and_result_list (Cons_and_result op res rest)
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _,
Cons_and_result _ _ _) =>
Contents_and_result_list (Cons_and_result op res rest)
| _ =>
Pervasives.failwith
"cannot decode ill-formed combined operation result" % string
end
end in
conv to_list of_list None (Variable.list None contents_and_result_encoding).
Record operation_metadata {kind : Type} := {
contents : contents_result_list kind }.
Arguments operation_metadata : clear implicits.
Inductive packed_operation_metadata : Type :=
| Operation_metadata : forall {kind : Type}, (operation_metadata kind) ->
packed_operation_metadata
| No_operation_metadata : packed_operation_metadata.
Definition operation_metadata_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_operation_metadata :=
op_atat
(let arg := def "operation.alpha.result" % string in
fun eta => arg None None eta)
(union None
(cons
(case "Operation_metadata" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
contents_result_list_encoding
(fun function_parameter =>
match function_parameter with
| Operation_metadata {| contents := contents |} =>
Some (Contents_result_list contents)
| _ => None
end)
(fun function_parameter =>
let 'Contents_result_list contents := function_parameter in
Operation_metadata {| contents := contents |}))
(cons
(case "No_operation_metadata" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
empty
(fun function_parameter =>
match function_parameter with
| No_operation_metadata => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
No_operation_metadata)) []))).
Definition kind_equal {kind kind2 : Type}
(op : Tezos_raw_protocol_alpha.Alpha_context.contents kind)
(res : contents_result kind2) : option (eq kind kind2) :=
match (op, res) with
| (Tezos_raw_protocol_alpha.Alpha_context.Endorsement _, Endorsement_result _)
=> Some Eq
| (Tezos_raw_protocol_alpha.Alpha_context.Endorsement _, _) => None
|
(Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation _,
Seed_nonce_revelation_result _) => Some Eq
| (Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation _, _) => None
|
(Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence _,
Double_endorsement_evidence_result _) => Some Eq
| (Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence _, _) =>
None
|
(Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence _,
Double_baking_evidence_result _) => Some Eq
| (Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence _, _) => None
|
(Tezos_raw_protocol_alpha.Alpha_context.Activate_account _,
Activate_account_result _) => Some Eq
| (Tezos_raw_protocol_alpha.Alpha_context.Activate_account _, _) => None
| (Tezos_raw_protocol_alpha.Alpha_context.Proposals _, Proposals_result) =>
Some Eq
| (Tezos_raw_protocol_alpha.Alpha_context.Proposals _, _) => None
| (Tezos_raw_protocol_alpha.Alpha_context.Ballot _, Ballot_result) => Some Eq
| (Tezos_raw_protocol_alpha.Alpha_context.Ballot _, _) => None
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Reveal _ |},
Manager_operation_result {|
operation_result := Applied (Reveal_result _) |}) => Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Reveal _ |},
Manager_operation_result {|
operation_result := Backtracked (Reveal_result _) _ |}) => Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Reveal _ |},
Manager_operation_result {|
operation_result :=
Failed Tezos_raw_protocol_alpha.Alpha_context.Kind.Reveal_manager_kind
_
|}) => Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Reveal _ |},
Manager_operation_result {|
operation_result :=
Skipped
Tezos_raw_protocol_alpha.Alpha_context.Kind.Reveal_manager_kind
|}) => Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Reveal _ |}, _) =>
None
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Transaction _ |},
Manager_operation_result {|
operation_result := Applied (Transaction_result _) |}) => Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Transaction _ |},
Manager_operation_result {|
operation_result := Backtracked (Transaction_result _) _ |}) =>
Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Transaction _ |},
Manager_operation_result {|
operation_result :=
Failed
Tezos_raw_protocol_alpha.Alpha_context.Kind.Transaction_manager_kind
_
|}) => Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Transaction _ |},
Manager_operation_result {|
operation_result :=
Skipped
Tezos_raw_protocol_alpha.Alpha_context.Kind.Transaction_manager_kind
|}) => Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Transaction _ |},
_) => None
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Origination _ |},
Manager_operation_result {|
operation_result := Applied (Origination_result _) |}) => Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Origination _ |},
Manager_operation_result {|
operation_result := Backtracked (Origination_result _) _ |}) =>
Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Origination _ |},
Manager_operation_result {|
operation_result :=
Failed
Tezos_raw_protocol_alpha.Alpha_context.Kind.Origination_manager_kind
_
|}) => Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Origination _ |},
Manager_operation_result {|
operation_result :=
Skipped
Tezos_raw_protocol_alpha.Alpha_context.Kind.Origination_manager_kind
|}) => Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Origination _ |},
_) => None
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Delegation _ |},
Manager_operation_result {|
operation_result := Applied (Delegation_result _) |}) => Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Delegation _ |},
Manager_operation_result {|
operation_result := Backtracked (Delegation_result _) _ |}) =>
Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Delegation _ |},
Manager_operation_result {|
operation_result :=
Failed
Tezos_raw_protocol_alpha.Alpha_context.Kind.Delegation_manager_kind
_
|}) => Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Delegation _ |},
Manager_operation_result {|
operation_result :=
Skipped
Tezos_raw_protocol_alpha.Alpha_context.Kind.Delegation_manager_kind
|}) => Some Eq
|
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
operation := Tezos_raw_protocol_alpha.Alpha_context.Delegation _ |}, _)
=> None
end.
Fixpoint kind_equal_list {kind kind2 : Type}
(contents : Tezos_raw_protocol_alpha.Alpha_context.contents_list kind)
(res : contents_result_list kind2) : option (eq kind kind2) :=
match (contents, res) with
| (Tezos_raw_protocol_alpha.Alpha_context.Single op, Single_result res) =>
match kind_equal op res with
| None => None
| Some Eq => Some Eq
end
| (Tezos_raw_protocol_alpha.Alpha_context.Cons op ops, Cons_result res ress)
=>
match kind_equal op res with
| None => None
| Some Eq =>
match kind_equal_list ops ress with
| None => None
| Some Eq => Some Eq
end
end
| _ => None
end.
Fixpoint pack_contents_list {kind : Type}
(contents : Tezos_raw_protocol_alpha.Alpha_context.contents_list kind)
(res : contents_result_list kind) : contents_and_result_list kind :=
match (contents, res) with
| (Tezos_raw_protocol_alpha.Alpha_context.Single op, Single_result res) =>
Single_and_result op res
| (Tezos_raw_protocol_alpha.Alpha_context.Cons op ops, Cons_result res ress)
=> Cons_and_result op res (pack_contents_list ops ress)
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _),
Cons_result (Manager_operation_result _) (Single_result _)) =>
(* ❌ Unreachable expressions are not supported *)
unreachable
|
(Tezos_raw_protocol_alpha.Alpha_context.Cons _ _,
Single_result
(Manager_operation_result {| operation_result := Failed _ _ |})) =>
(* ❌ Unreachable expressions are not supported *)
unreachable
|
(Tezos_raw_protocol_alpha.Alpha_context.Cons _ _,
Single_result
(Manager_operation_result {| operation_result := Skipped _ |})) =>
(* ❌ Unreachable expressions are not supported *)
unreachable
|
(Tezos_raw_protocol_alpha.Alpha_context.Cons _ _,
Single_result
(Manager_operation_result {| operation_result := Applied _ |})) =>
(* ❌ Unreachable expressions are not supported *)
unreachable
|
(Tezos_raw_protocol_alpha.Alpha_context.Cons _ _,
Single_result
(Manager_operation_result {| operation_result := Backtracked _ _ |})) =>
(* ❌ Unreachable expressions are not supported *)
unreachable
| (Tezos_raw_protocol_alpha.Alpha_context.Single _, Cons_result _ _) =>
(* ❌ Unreachable expressions are not supported *)
unreachable
end.
Fixpoint unpack_contents_list {kind : Type}
(function_parameter : contents_and_result_list kind)
: (Tezos_raw_protocol_alpha.Alpha_context.contents_list kind) *
(contents_result_list kind) :=
match function_parameter with
| Single_and_result op res =>
((Tezos_raw_protocol_alpha.Alpha_context.Single op), (Single_result res))
| Cons_and_result op res rest =>
let '(ops, ress) := unpack_contents_list rest in
((Tezos_raw_protocol_alpha.Alpha_context.Cons op ops),
(Cons_result res ress))
end.
Fixpoint to_list (function_parameter : packed_contents_result_list)
: list packed_contents_result :=
match function_parameter with
| Contents_result_list (Single_result o) => cons (Contents_result o) []
| Contents_result_list (Cons_result o os) =>
cons (Contents_result o) (to_list (Contents_result_list os))
end.
Fixpoint of_list (function_parameter : list packed_contents_result)
: packed_contents_result_list :=
match function_parameter with
| [] =>
(* ❌ Assert instruction is not handled. *)
assert false
| cons (Contents_result o) [] => Contents_result_list (Single_result o)
| cons (Contents_result o) os =>
let 'Contents_result_list os := of_list os in
match (o, os) with
| (Manager_operation_result _, Single_result (Manager_operation_result _))
=> Contents_result_list (Cons_result o os)
| (Manager_operation_result _, Cons_result _ _) =>
Contents_result_list (Cons_result o os)
| _ =>
Pervasives.failwith
"Operation result list of length > 1 should only contains manager operations result."
% string
end
end.
Definition operation_data_and_metadata_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(Tezos_raw_protocol_alpha.Alpha_context.packed_protocol_data *
packed_operation_metadata) :=
op_atat
(let arg := def "operation.alpha.operation_with_metadata" % string in
fun eta => arg None None eta)
(union None
(cons
(case "Operation_with_metadata" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
(obj2
(req None None "contents" % string
(dynamic_size None contents_and_result_list_encoding))
(opt None None "signature" % string Signature.encoding))
(fun function_parameter =>
match function_parameter with
|
(Tezos_raw_protocol_alpha.Alpha_context.Operation_data _,
No_operation_metadata) => None
|
(Tezos_raw_protocol_alpha.Alpha_context.Operation_data op,
Operation_metadata res) =>
match kind_equal_list (contents op) (contents res) with
| None =>
Pervasives.failwith
"cannot decode inconsistent combined operation result" %
string
| Some Eq =>
Some
((Contents_and_result_list
(pack_contents_list (contents op) (contents res))),
(signature op))
end
end)
(fun function_parameter =>
let '(Contents_and_result_list contents, signature) :=
function_parameter in
let '(op_contents, res_contents) := unpack_contents_list contents in
((Tezos_raw_protocol_alpha.Alpha_context.Operation_data
{| contents := op_contents; signature := signature |}),
(Operation_metadata {| contents := res_contents |}))))
(cons
(case "Operation_without_metadata" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
(obj2
(req None None "contents" % string
(dynamic_size None Operation.contents_list_encoding))
(opt None None "signature" % string Signature.encoding))
(fun function_parameter =>
match function_parameter with
|
(Tezos_raw_protocol_alpha.Alpha_context.Operation_data op,
No_operation_metadata) =>
Some
((Tezos_raw_protocol_alpha.Alpha_context.Contents_list
(contents op)), (signature op))
|
(Tezos_raw_protocol_alpha.Alpha_context.Operation_data _,
Operation_metadata _) => None
end)
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Alpha_context.Contents_list contents,
signature) := function_parameter in
((Tezos_raw_protocol_alpha.Alpha_context.Operation_data
{| contents := contents; signature := signature |}),
No_operation_metadata))) []))).
Record block_metadata := {
baker :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
level : Tezos_raw_protocol_alpha.Alpha_context.Level.t;
voting_period_kind : Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind;
nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t;
consumed_gas : Tezos_protocol_environment_alpha__Environment.Z.t;
deactivated :
list
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
balance_updates :
Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates }.
Definition block_metadata_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
block_metadata :=
op_atat
(let arg := def "block_header.alpha.metadata" % string in
fun eta => arg None None eta)
(conv
(fun function_parameter =>
let '{|
baker := baker;
level := level;
voting_period_kind := voting_period_kind;
nonce_hash := nonce_hash;
consumed_gas := consumed_gas;
deactivated := deactivated;
balance_updates := balance_updates
|} := function_parameter in
(baker, level, voting_period_kind, nonce_hash, consumed_gas,
deactivated, balance_updates))
(fun function_parameter =>
let
'(baker, level, voting_period_kind, nonce_hash, consumed_gas,
deactivated, balance_updates) := function_parameter in
{| baker := baker; level := level;
voting_period_kind := voting_period_kind; nonce_hash := nonce_hash;
consumed_gas := consumed_gas; deactivated := deactivated;
balance_updates := balance_updates |}) None
(obj7 (req None None "baker" % string Signature.Public_key_hash.encoding)
(req None None "level" % string Level.encoding)
(req None None "voting_period_kind" % string Voting_period.kind_encoding)
(req None None "nonce_hash" % string (option Nonce_hash.encoding))
(req None None "consumed_gas" % string (check_size 10 n))
(req None None "deactivated" % string
(list None Signature.Public_key_hash.encoding))
(req None None "balance_updates" % string
Delegate.balance_updates_encoding))).
src/proto_alpha/lib_protocol/baking.ml 113 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
open Misc
type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)
type error += Timestamp_too_early of Timestamp.t * Timestamp.t
(* `Permanent *)
type error += Unexpected_endorsement (* `Permanent *)
type error +=
| Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t
(* `Permanent *)
type error += Invalid_signature (* `Permanent *)
type error += Invalid_stamp (* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"baking.timestamp_too_early"
~title:"Block forged too early"
~description:
"The block timestamp is before the first slot for this baker at this \
level"
~pp:(fun ppf (r, p) ->
Format.fprintf
ppf
"Block forged too early (%a is before %a)"
Time.pp_hum
p
Time.pp_hum
r)
Data_encoding.(
obj2 (req "minimum" Time.encoding) (req "provided" Time.encoding))
(function Timestamp_too_early (r, p) -> Some (r, p) | _ -> None)
(fun (r, p) -> Timestamp_too_early (r, p)) ;
register_error_kind
`Permanent
~id:"baking.invalid_fitness_gap"
~title:"Invalid fitness gap"
~description:"The gap of fitness is out of bounds"
~pp:(fun ppf (m, g) ->
Format.fprintf ppf "The gap of fitness %Ld is not between 0 and %Ld" g m)
Data_encoding.(obj2 (req "maximum" int64) (req "provided" int64))
(function Invalid_fitness_gap (m, g) -> Some (m, g) | _ -> None)
(fun (m, g) -> Invalid_fitness_gap (m, g)) ;
register_error_kind
`Permanent
~id:"baking.invalid_block_signature"
~title:"Invalid block signature"
~description:"A block was not signed with the expected private key."
~pp:(fun ppf (block, pkh) ->
Format.fprintf
ppf
"Invalid signature for block %a. Expected: %a."
Block_hash.pp_short
block
Signature.Public_key_hash.pp_short
pkh)
Data_encoding.(
obj2
(req "block" Block_hash.encoding)
(req "expected" Signature.Public_key_hash.encoding))
(function
| Invalid_block_signature (block, pkh) -> Some (block, pkh) | _ -> None)
(fun (block, pkh) -> Invalid_block_signature (block, pkh)) ;
register_error_kind
`Permanent
~id:"baking.invalid_signature"
~title:"Invalid block signature"
~description:"The block's signature is invalid"
~pp:(fun ppf () -> Format.fprintf ppf "Invalid block signature")
Data_encoding.empty
(function Invalid_signature -> Some () | _ -> None)
(fun () -> Invalid_signature) ;
register_error_kind
`Permanent
~id:"baking.insufficient_proof_of_work"
~title:"Insufficient block proof-of-work stamp"
~description:"The block's proof-of-work stamp is insufficient"
~pp:(fun ppf () -> Format.fprintf ppf "Insufficient proof-of-work stamp")
Data_encoding.empty
(function Invalid_stamp -> Some () | _ -> None)
(fun () -> Invalid_stamp) ;
register_error_kind
`Permanent
~id:"baking.unexpected_endorsement"
~title:"Endorsement from unexpected delegate"
~description:
"The operation is signed by a delegate without endorsement rights."
~pp:(fun ppf () ->
Format.fprintf
ppf
"The endorsement is signed by a delegate without endorsement rights.")
Data_encoding.unit
(function Unexpected_endorsement -> Some () | _ -> None)
(fun () -> Unexpected_endorsement)
let minimal_time c priority pred_timestamp =
let priority = Int32.of_int priority in
let rec cumsum_time_between_blocks acc durations p =
if Compare.Int32.( <= ) p 0l then ok acc
else
match durations with
| [] ->
cumsum_time_between_blocks acc [Period.one_minute] p
| [last] ->
Period.mult p last >>? fun period -> Timestamp.(acc +? period)
| first :: durations ->
Timestamp.(acc +? first)
>>? fun acc ->
let p = Int32.pred p in
cumsum_time_between_blocks acc durations p
in
Lwt.return
(cumsum_time_between_blocks
pred_timestamp
(Constants.time_between_blocks c)
(Int32.succ priority))
let earlier_predecessor_timestamp ctxt level =
let current = Level.current ctxt in
let current_timestamp = Timestamp.current ctxt in
let gap = Level.diff level current in
let step = List.hd (Constants.time_between_blocks ctxt) in
if Compare.Int32.(gap < 1l) then
failwith "Baking.earlier_block_timestamp: past block."
else
Lwt.return (Period.mult (Int32.pred gap) step)
>>=? fun delay ->
Lwt.return Timestamp.(current_timestamp +? delay)
>>=? fun result -> return result
let check_timestamp c priority pred_timestamp =
minimal_time c priority pred_timestamp
>>=? fun minimal_time ->
let timestamp = Alpha_context.Timestamp.current c in
Lwt.return
(record_trace
(Timestamp_too_early (minimal_time, timestamp))
Timestamp.(timestamp -? minimal_time))
let check_baking_rights c {Block_header.priority; _} pred_timestamp =
let level = Level.current c in
Roll.baking_rights_owner c level ~priority
>>=? fun delegate ->
check_timestamp c priority pred_timestamp
>>=? fun block_delay -> return (delegate, block_delay)
type error += Incorrect_priority (* `Permanent *)
type error += Incorrect_number_of_endorsements (* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"incorrect_priority"
~title:"Incorrect priority"
~description:"Block priority must be non-negative."
~pp:(fun ppf () ->
Format.fprintf ppf "The block priority must be non-negative.")
Data_encoding.unit
(function Incorrect_priority -> Some () | _ -> None)
(fun () -> Incorrect_priority)
let () =
let description =
"The number of endorsements must be non-negative and at most the \
endosers_per_block constant."
in
register_error_kind
`Permanent
~id:"incorrect_number_of_endorsements"
~title:"Incorrect number of endorsements"
~description
~pp:(fun ppf () -> Format.fprintf ppf "%s" description)
Data_encoding.unit
(function Incorrect_number_of_endorsements -> Some () | _ -> None)
(fun () -> Incorrect_number_of_endorsements)
let baking_reward ctxt ~block_priority:prio ~included_endorsements:num_endo =
fail_unless Compare.Int.(prio >= 0) Incorrect_priority
>>=? fun () ->
let max_endorsements = Constants.endorsers_per_block ctxt in
fail_unless
Compare.Int.(num_endo >= 0 && num_endo <= max_endorsements)
Incorrect_number_of_endorsements
>>=? fun () ->
let prio_factor_denominator = Int64.(succ (of_int prio)) in
let endo_factor_numerator =
Int64.of_int (8 + (2 * num_endo / max_endorsements))
in
let endo_factor_denominator = 10L in
Lwt.return
Tez.(
Constants.block_reward ctxt *? endo_factor_numerator
>>? fun val1 ->
val1 /? endo_factor_denominator
>>? fun val2 -> val2 /? prio_factor_denominator)
let endorsing_reward ctxt ~block_priority:prio n =
if Compare.Int.(prio >= 0) then
Lwt.return
Tez.(Constants.endorsement_reward ctxt /? Int64.(succ (of_int prio)))
>>=? fun tez -> Lwt.return Tez.(tez *? Int64.of_int n)
else fail Incorrect_priority
let baking_priorities c level =
let rec f priority =
Roll.baking_rights_owner c level ~priority
>>=? fun delegate -> return (LCons (delegate, fun () -> f (succ priority)))
in
f 0
let endorsement_rights c level =
fold_left_s
(fun acc slot ->
Roll.endorsement_rights_owner c level ~slot
>>=? fun pk ->
let pkh = Signature.Public_key.hash pk in
let right =
match Signature.Public_key_hash.Map.find_opt pkh acc with
| None ->
(pk, [slot], false)
| Some (pk, slots, used) ->
(pk, slot :: slots, used)
in
return (Signature.Public_key_hash.Map.add pkh right acc))
Signature.Public_key_hash.Map.empty
(0 --> (Constants.endorsers_per_block c - 1))
let check_endorsement_rights ctxt chain_id (op : Kind.endorsement Operation.t)
=
let current_level = Level.current ctxt in
let (Single (Endorsement {level; _})) = op.protocol_data.contents in
( if Raw_level.(succ level = current_level.level) then
return (Alpha_context.allowed_endorsements ctxt)
else endorsement_rights ctxt (Level.from_raw ctxt level) )
>>=? fun endorsements ->
match
Signature.Public_key_hash.Map.fold (* no find_first *)
(fun pkh (pk, slots, used) acc ->
match Operation.check_signature_sync pk chain_id op with
| Error _ ->
acc
| Ok () ->
Some (pkh, slots, used))
endorsements
None
with
| None ->
fail Unexpected_endorsement
| Some v ->
return v
let select_delegate delegate delegate_list max_priority =
let rec loop acc l n =
if Compare.Int.(n >= max_priority) then return (List.rev acc)
else
let (LCons (pk, t)) = l in
let acc =
if
Signature.Public_key_hash.equal
delegate
(Signature.Public_key.hash pk)
then n :: acc
else acc
in
t () >>=? fun t -> loop acc t (succ n)
in
loop [] delegate_list 0
let first_baking_priorities ctxt ?(max_priority = 32) delegate level =
baking_priorities ctxt level
>>=? fun delegate_list -> select_delegate delegate delegate_list max_priority
let check_hash hash stamp_threshold =
let bytes = Block_hash.to_bytes hash in
let word = MBytes.get_int64 bytes 0 in
Compare.Uint64.(word <= stamp_threshold)
let check_header_proof_of_work_stamp shell contents stamp_threshold =
let hash =
Block_header.hash
{shell; protocol_data = {contents; signature = Signature.zero}}
in
check_hash hash stamp_threshold
let check_proof_of_work_stamp ctxt block =
let proof_of_work_threshold = Constants.proof_of_work_threshold ctxt in
if
check_header_proof_of_work_stamp
block.Block_header.shell
block.protocol_data.contents
proof_of_work_threshold
then return_unit
else fail Invalid_stamp
let check_signature block chain_id key =
let check_signature key
{Block_header.shell; protocol_data = {contents; signature}} =
let unsigned_header =
Data_encoding.Binary.to_bytes_exn
Block_header.unsigned_encoding
(shell, contents)
in
Signature.check
~watermark:(Block_header chain_id)
key
signature
unsigned_header
in
if check_signature key block then return_unit
else
fail
(Invalid_block_signature
(Block_header.hash block, Signature.Public_key.hash key))
let max_fitness_gap _ctxt = 1L
let check_fitness_gap ctxt (block : Block_header.t) =
let current_fitness = Fitness.current ctxt in
Lwt.return (Fitness.to_int64 block.shell.fitness)
>>=? fun announced_fitness ->
let gap = Int64.sub announced_fitness current_fitness in
if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then
fail (Invalid_fitness_gap (max_fitness_gap ctxt, gap))
else return_unit
let last_of_a_cycle ctxt l =
Compare.Int32.(
Int32.succ l.Level.cycle_position = Constants.blocks_per_cycle ctxt)
let dawn_of_a_new_cycle ctxt =
let level = Level.current ctxt in
if last_of_a_cycle ctxt level then return_some level.cycle else return_none
let minimum_allowed_endorsements ctxt ~block_delay =
let minimum = Constants.initial_endorsers ctxt in
let delay_per_missing_endorsement =
Int64.to_int
(Period.to_seconds (Constants.delay_per_missing_endorsement ctxt))
in
let reduced_time_constraint =
let delay = Int64.to_int (Period.to_seconds block_delay) in
if Compare.Int.(delay_per_missing_endorsement = 0) then delay
else delay / delay_per_missing_endorsement
in
Compare.Int.max 0 (minimum - reduced_time_constraint)
let minimal_valid_time ctxt ~priority ~endorsing_power =
let predecessor_timestamp = Timestamp.current ctxt in
minimal_time ctxt priority predecessor_timestamp
>>=? fun minimal_time ->
let minimal_required_endorsements = Constants.initial_endorsers ctxt in
let delay_per_missing_endorsement =
Constants.delay_per_missing_endorsement ctxt
in
let missing_endorsements =
Compare.Int.max 0 (minimal_required_endorsements - endorsing_power)
in
match
Period.mult
(Int32.of_int missing_endorsements)
delay_per_missing_endorsement
with
| Ok delay ->
return (Time.add minimal_time (Period.to_seconds delay))
| Error _ as err ->
Lwt.return err
src/proto_alpha/lib_protocol/baking.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Import Misc.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition minimal_time
(c : Tezos_raw_protocol_alpha__Alpha_context.context) (priority : Z)
(pred_timestamp : Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time) :=
let priority := Int32.of_int priority in
let fix cumsum_time_between_blocks
(acc : Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time) (durations :
list Tezos_raw_protocol_alpha.Alpha_context.Period.period) (p :
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
p
(* ❌ Constant of type int32 is converted to int *)
0 then
ok acc
else
match durations with
| [] => cumsum_time_between_blocks acc (cons Period.one_minute []) p
| cons last [] =>
op_gtgtquestion (Period.mult p last)
(fun period => op_plusquestion acc period)
| cons first durations =>
op_gtgtquestion (op_plusquestion acc first)
(fun acc =>
let p := Int32.pred p in
cumsum_time_between_blocks acc durations p)
end in
Lwt._return
(cumsum_time_between_blocks pred_timestamp (Constants.time_between_blocks c)
(Int32.succ priority)).
Definition earlier_predecessor_timestamp
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(level : Tezos_raw_protocol_alpha.Alpha_context.Level.level)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time) :=
let current := Level.current ctxt in
let current_timestamp := Timestamp.current ctxt in
let gap := Level.diff level current in
let step := List.hd (Constants.time_between_blocks ctxt) in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
gap
(* ❌ Constant of type int32 is converted to int *)
1 then
failwith "Baking.earlier_block_timestamp: past block." % string
else
op_gtgteqquestion (Lwt._return (Period.mult (Int32.pred gap) step))
(fun delay =>
op_gtgteqquestion
(Lwt._return (op_plusquestion current_timestamp delay))
(fun result => _return result)).
Definition check_timestamp
(c : Tezos_raw_protocol_alpha__Alpha_context.context) (priority : Z)
(pred_timestamp : Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha__Alpha_context.Period.t) :=
op_gtgteqquestion (minimal_time c priority pred_timestamp)
(fun minimal_time =>
let timestamp := Alpha_context.Timestamp.current c in
Lwt._return
(record_trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Timestamp_too_early
minimal_time timestamp) (op_minusquestion timestamp minimal_time))).
Definition check_baking_rights
(c : Tezos_raw_protocol_alpha__Alpha_context.context)
(function_parameter :
Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
: Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha__Alpha_context.public_key *
Tezos_raw_protocol_alpha__Alpha_context.Period.t)) :=
let '{| Block_header.priority := priority |} := function_parameter in
fun pred_timestamp =>
let level := Level.current c in
op_gtgteqquestion (Roll.baking_rights_owner c level priority)
(fun delegate =>
op_gtgteqquestion (check_timestamp c priority pred_timestamp)
(fun block_delay => _return (delegate, block_delay))).
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition baking_reward
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(prio :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(num_endo :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Alpha_context.Tez.tez) :=
op_gtgteqquestion
(fail_unless
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
prio 0)
Tezos_protocol_environment_alpha__Environment.Error_monad.Incorrect_priority)
(fun function_parameter =>
let 'tt := function_parameter in
let max_endorsements := Constants.endorsers_per_block ctxt in
op_gtgteqquestion
(fail_unless
(op_andand
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
num_endo 0)
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
num_endo max_endorsements))
Tezos_protocol_environment_alpha__Environment.Error_monad.Incorrect_number_of_endorsements)
(fun function_parameter =>
let 'tt := function_parameter in
let prio_factor_denominator := succ (of_int prio) in
let endo_factor_numerator :=
Int64.of_int
(op_plus 8 (op_div (op_star 2 num_endo) max_endorsements)) in
let endo_factor_denominator :=
(* ❌ Constant of type int64 is converted to int *)
10 in
Lwt._return
(op_gtgtquestion
(op_starquestion (Constants.block_reward ctxt)
endo_factor_numerator)
(fun val1 =>
op_gtgtquestion (op_divquestion val1 endo_factor_denominator)
(fun val2 => op_divquestion val2 prio_factor_denominator))))).
Definition endorsing_reward
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(prio :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(n : Z)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Alpha_context.Tez.tez) :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
prio 0 then
op_gtgteqquestion
(Lwt._return
(op_divquestion (Constants.endorsement_reward ctxt) (succ (of_int prio))))
(fun tez => Lwt._return (op_starquestion tez (Int64.of_int n)))
else
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Incorrect_priority.
Definition baking_priorities
(c : Tezos_raw_protocol_alpha__Alpha_context.context)
(level : Tezos_raw_protocol_alpha__Alpha_context.Level.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Misc.lazy_list_t
Tezos_raw_protocol_alpha__Alpha_context.public_key)) :=
let fix f (priority : Z)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Misc.lazy_list_t
Tezos_raw_protocol_alpha__Alpha_context.public_key)) :=
op_gtgteqquestion (Roll.baking_rights_owner c level priority)
(fun delegate =>
_return
(Tezos_raw_protocol_alpha.Misc.LCons delegate
(fun function_parameter =>
let 'tt := function_parameter in
f (succ priority)))) in
f 0.
Definition endorsement_rights
(c : Tezos_raw_protocol_alpha__Alpha_context.context)
(level : Tezos_raw_protocol_alpha__Alpha_context.Level.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
(Tezos_raw_protocol_alpha__Alpha_context.public_key * (list Z) * bool))) :=
fold_left_s
(fun acc =>
fun slot =>
op_gtgteqquestion (Roll.endorsement_rights_owner c level slot)
(fun pk =>
let pkh := Signature.Public_key.hash pk in
let right :=
match Signature.Public_key_hash.Map.find_opt pkh acc with
| None => (pk, (cons slot []), false)
| Some (pk, slots, used) => (pk, (cons slot slots), used)
end in
_return (Signature.Public_key_hash.Map.add pkh right acc)))
Signature.Public_key_hash.Map.empty
(op_minusminusgt 0 (op_minus (Constants.endorsers_per_block c) 1)).
Definition check_endorsement_rights
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(op :
Tezos_raw_protocol_alpha.Alpha_context.Operation.t
Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.key
* (list Z) * bool)) :=
let current_level := Level.current ctxt in
let
'Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Endorsement {| level := level |}) :=
contents (protocol_data op) in
op_gtgteqquestion
(if op_eq (succ level) (level current_level) then
_return (Alpha_context.allowed_endorsements ctxt)
else
endorsement_rights ctxt (Level.from_raw ctxt None level))
(fun endorsements =>
match
Signature.Public_key_hash.Map.fold
(fun pkh =>
fun function_parameter =>
let '(pk, slots, used) := function_parameter in
fun acc =>
match Operation.check_signature_sync pk chain_id op with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ => acc
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok tt
=> Some (pkh, slots, used)
end) endorsements None with
| None =>
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_endorsement
| Some v => _return v
end).
Definition select_delegate
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(delegate_list :
Tezos_raw_protocol_alpha.Misc.lazy_list_t
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
(max_priority :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))) :=
let fix loop
(acc :
list
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(l :
Tezos_raw_protocol_alpha.Misc.lazy_list_t
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t) (n :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))) :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
n max_priority then
_return (List.rev acc)
else
let 'Tezos_raw_protocol_alpha.Misc.LCons pk t := l in
let acc :=
if
Signature.Public_key_hash.equal delegate
(Signature.Public_key.hash pk) then
cons n acc
else
acc in
op_gtgteqquestion (t tt) (fun t => loop acc t (succ n)) in
loop [] delegate_list 0.
Definition first_baking_priorities
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(op_staroptstar :
option
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
Tezos_raw_protocol_alpha__Alpha_context.Level.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))) :=
let max_priority :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 32
end in
fun delegate =>
fun level =>
op_gtgteqquestion (baking_priorities ctxt level)
(fun delegate_list =>
select_delegate delegate delegate_list max_priority).
Definition check_hash
(hash :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(stamp_threshold :
Tezos_protocol_environment_alpha__Environment.Compare.Uint64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: bool :=
let bytes :=
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.to_bytes)
hash in
let word := MBytes.get_int64 string 0 in
Tezos_protocol_environment_alpha__Environment.Compare.Uint64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
word stamp_threshold.
Definition check_header_proof_of_work_stamp
(shell :
Tezos_protocol_environment_alpha__Environment.Block_header.shell_header)
(contents : Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
(stamp_threshold :
Tezos_protocol_environment_alpha__Environment.Compare.Uint64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: bool :=
let hash :=
Block_header.hash
{| shell := shell;
protocol_data := {| contents := contents; signature := Signature.zero |}
|} in
check_hash hash stamp_threshold.
Definition check_proof_of_work_stamp
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(block : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let proof_of_work_threshold := Constants.proof_of_work_threshold ctxt in
if
check_header_proof_of_work_stamp (Block_header.shell block)
(contents (protocol_data block)) proof_of_work_threshold then
return_unit
else
fail Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_stamp.
Definition check_signature
(block : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(key : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let check_signature
(key : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
(function_parameter : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
: bool :=
let '{|
Block_header.shell := shell;
Block_header.protocol_data := {|
contents := contents; signature := signature |}
|} := function_parameter in
let unsigned_header :=
Data_encoding.Binary.to_bytes_exn Block_header.unsigned_encoding
(shell, contents) in
Signature.check
(Some
(Tezos_protocol_environment_alpha__Environment.Signature.Block_header
chain_id)) key signature unsigned_header in
if check_signature key block then
return_unit
else
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_block_signature
(Block_header.hash block) (Signature.Public_key.hash key)).
Definition max_fitness_gap {A : Type} (_ctxt : A) : int64 :=
(* ❌ Constant of type int64 is converted to int *)
1.
Definition check_fitness_gap
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(block : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let current_fitness := Fitness.current ctxt in
op_gtgteqquestion (Lwt._return (Fitness.to_int64 (fitness (shell block))))
(fun announced_fitness =>
let gap := Int64.sub announced_fitness current_fitness in
if
op_pipepipe
(Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
gap
(* ❌ Constant of type int64 is converted to int *)
0)
(Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
(max_fitness_gap ctxt) gap) then
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_fitness_gap
(max_fitness_gap ctxt) gap)
else
return_unit).
Definition last_of_a_cycle
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(l : Tezos_raw_protocol_alpha.Alpha_context.Level.t) : bool :=
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(Int32.succ (Level.cycle_position l)) (Constants.blocks_per_cycle ctxt).
Definition dawn_of_a_new_cycle
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option Tezos_raw_protocol_alpha__Alpha_context.Cycle.t)) :=
let level := Level.current ctxt in
if last_of_a_cycle ctxt level then
return_some (cycle level)
else
return_none.
Definition minimum_allowed_endorsements
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.period)
: Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
let minimum := Constants.initial_endorsers ctxt in
let delay_per_missing_endorsement :=
Int64.to_int
(Period.to_seconds (Constants.delay_per_missing_endorsement ctxt)) in
let reduced_time_constraint :=
let delay := Int64.to_int (Period.to_seconds block_delay) in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
delay_per_missing_endorsement 0 then
delay
else
op_div delay delay_per_missing_endorsement in
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
0 (op_minus minimum reduced_time_constraint).
Definition minimal_valid_time
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (priority : Z)
(endorsing_power : Z)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Time.t) :=
let predecessor_timestamp := Timestamp.current ctxt in
op_gtgteqquestion (minimal_time ctxt priority predecessor_timestamp)
(fun minimal_time =>
let minimal_required_endorsements := Constants.initial_endorsers ctxt in
let delay_per_missing_endorsement :=
Constants.delay_per_missing_endorsement ctxt in
let missing_endorsements :=
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
0 (op_minus minimal_required_endorsements endorsing_power) in
match
Period.mult (Int32.of_int missing_endorsements)
delay_per_missing_endorsement with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok delay =>
_return (Time.add minimal_time (Period.to_seconds delay))
|
(Tezos_protocol_environment_alpha__Environment.Pervasives.Error _) as
err => Lwt._return err
end).
src/proto_alpha/lib_protocol/blinded_public_key_hash.ml 8 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module H =
Blake2B.Make
(Base58)
(struct
let name = "Blinded public key hash"
let title = "A blinded public key hash"
let b58check_prefix = "\001\002\049\223"
let size = Some Ed25519.Public_key_hash.size
end)
include H
let () = Base58.check_encoded_prefix b58check_encoding "btz1" 37
let of_ed25519_pkh activation_code pkh =
hash_bytes ~key:activation_code [Ed25519.Public_key_hash.to_bytes pkh]
type activation_code = MBytes.t
let activation_code_size = Ed25519.Public_key_hash.size
let activation_code_encoding = Data_encoding.Fixed.bytes activation_code_size
let activation_code_of_hex h =
if Compare.Int.(String.length h <> activation_code_size * 2) then
invalid_arg "Blinded_public_key_hash.activation_code_of_hex" ;
MBytes.of_hex (`Hex h)
module Index = H
src/proto_alpha/lib_protocol/blinded_public_key_hash.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Structure item `include` not handled. *)
include
Definition of_ed25519_pkh
(activation_code : Tezos_protocol_environment_alpha__Environment.MBytes.t)
(pkh : Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.t)
: t :=
hash_bytes (Some activation_code)
(cons (Ed25519.Public_key_hash.to_bytes pkh) []).
Definition activation_code :=
Tezos_protocol_environment_alpha__Environment.MBytes.t.
Definition activation_code_size : Z := Ed25519.Public_key_hash.size.
Definition activation_code_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
Tezos_protocol_environment_alpha__Environment.MBytes.t :=
Data_encoding.Fixed.bytes activation_code_size.
Definition activation_code_of_hex (h : string)
: Tezos_protocol_environment_alpha__Environment.MBytes.t :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt)
(String.length h) (op_star activation_code_size 2) then
invalid_arg "Blinded_public_key_hash.activation_code_of_hex" % string
else
tt in
MBytes.of_hex
(* ❌ Variants not supported *)
variant.
(* ❌ This kind of module is not handled. *)
unhandled_module
src/proto_alpha/lib_protocol/block_header_repr.ml 9 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Block header *)
type t = {shell : Block_header.shell_header; protocol_data : protocol_data}
and protocol_data = {contents : contents; signature : Signature.t}
and contents = {
priority : int;
seed_nonce_hash : Nonce_hash.t option;
proof_of_work_nonce : MBytes.t;
}
type block_header = t
type raw = Block_header.t
type shell_header = Block_header.shell_header
let raw_encoding = Block_header.encoding
let shell_header_encoding = Block_header.shell_header_encoding
let contents_encoding =
let open Data_encoding in
def "block_header.alpha.unsigned_contents"
@@ conv
(fun {priority; seed_nonce_hash; proof_of_work_nonce} ->
(priority, proof_of_work_nonce, seed_nonce_hash))
(fun (priority, proof_of_work_nonce, seed_nonce_hash) ->
{priority; seed_nonce_hash; proof_of_work_nonce})
(obj3
(req "priority" uint16)
(req
"proof_of_work_nonce"
(Fixed.bytes Constants_repr.proof_of_work_nonce_size))
(opt "seed_nonce_hash" Nonce_hash.encoding))
let protocol_data_encoding =
let open Data_encoding in
def "block_header.alpha.signed_contents"
@@ conv
(fun {contents; signature} -> (contents, signature))
(fun (contents, signature) -> {contents; signature})
(merge_objs
contents_encoding
(obj1 (req "signature" Signature.encoding)))
let raw {shell; protocol_data} =
let protocol_data =
Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data
in
{Block_header.shell; protocol_data}
let unsigned_encoding =
let open Data_encoding in
merge_objs Block_header.shell_header_encoding contents_encoding
let encoding =
let open Data_encoding in
def "block_header.alpha.full_header"
@@ conv
(fun {shell; protocol_data} -> (shell, protocol_data))
(fun (shell, protocol_data) -> {shell; protocol_data})
(merge_objs Block_header.shell_header_encoding protocol_data_encoding)
(** Constants *)
let max_header_length =
let fake_shell =
{
Block_header.level = 0l;
proto_level = 0;
predecessor = Block_hash.zero;
timestamp = Time.of_seconds 0L;
validation_passes = 0;
operations_hash = Operation_list_list_hash.zero;
fitness = Fitness_repr.from_int64 0L;
context = Context_hash.zero;
}
and fake_contents =
{
priority = 0;
proof_of_work_nonce =
MBytes.create Constants_repr.proof_of_work_nonce_size;
seed_nonce_hash = Some Nonce_hash.zero;
}
in
Data_encoding.Binary.length
encoding
{
shell = fake_shell;
protocol_data = {contents = fake_contents; signature = Signature.zero};
}
(** Header parsing entry point *)
let hash_raw = Block_header.hash
let hash {shell; protocol_data} =
Block_header.hash
{
shell;
protocol_data =
Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data;
}
src/proto_alpha/lib_protocol/block_header_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
.
Definition block_header := t.
Definition raw := Tezos_protocol_environment_alpha__Environment.Block_header.t.
Definition shell_header :=
Tezos_protocol_environment_alpha__Environment.Block_header.shell_header.
Definition raw_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.t
Tezos_protocol_environment_alpha__Environment.Block_header.t :=
Block_header.encoding.
Definition shell_header_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.t
Tezos_protocol_environment_alpha__Environment.Block_header.shell_header :=
Block_header.shell_header_encoding.
Definition contents_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
contents :=
op_atat
(let arg := def "block_header.alpha.unsigned_contents" % string in
fun eta => arg None None eta)
(conv
(fun function_parameter =>
let '{|
priority := priority;
seed_nonce_hash := seed_nonce_hash;
proof_of_work_nonce := proof_of_work_nonce
|} := function_parameter in
(priority, proof_of_work_nonce, seed_nonce_hash))
(fun function_parameter =>
let '(priority, proof_of_work_nonce, seed_nonce_hash) :=
function_parameter in
{| priority := priority; seed_nonce_hash := seed_nonce_hash;
proof_of_work_nonce := proof_of_work_nonce |}) None
(obj3 (req None None "priority" % string uint16)
(req None None "proof_of_work_nonce" % string
(Fixed.bytes Constants_repr.proof_of_work_nonce_size))
(opt None None "seed_nonce_hash" % string Nonce_hash.encoding))).
Definition protocol_data_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
protocol_data :=
op_atat
(let arg := def "block_header.alpha.signed_contents" % string in
fun eta => arg None None eta)
(conv
(fun function_parameter =>
let '{| contents := contents; signature := signature |} :=
function_parameter in
(contents, signature))
(fun function_parameter =>
let '(contents, signature) := function_parameter in
{| contents := contents; signature := signature |}) None
(merge_objs contents_encoding
(obj1 (req None None "signature" % string Signature.encoding)))).
Definition raw (function_parameter : t)
: Tezos_protocol_environment_alpha__Environment.Block_header.t :=
let '{| shell := shell; protocol_data := protocol_data |} :=
function_parameter in
let protocol_data :=
Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data in
{| Block_header.shell := shell; Block_header.protocol_data := protocol_data |}.
Definition unsigned_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(Tezos_protocol_environment_alpha__Environment.Block_header.shell_header *
contents) :=
merge_objs Block_header.shell_header_encoding contents_encoding.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
op_atat
(let arg := def "block_header.alpha.full_header" % string in
fun eta => arg None None eta)
(conv
(fun function_parameter =>
let '{| shell := shell; protocol_data := protocol_data |} :=
function_parameter in
(shell, protocol_data))
(fun function_parameter =>
let '(shell, protocol_data) := function_parameter in
{| shell := shell; protocol_data := protocol_data |}) None
(merge_objs Block_header.shell_header_encoding protocol_data_encoding)).
Definition max_header_length : Z :=
let fake_shell
: Tezos_protocol_environment_alpha__Environment.Block_header.shell_header :=
{|
Block_header.level :=
(* ❌ Constant of type int32 is converted to int *)
0; Block_header.proto_level := 0;
Block_header.predecessor :=
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero);
Block_header.timestamp :=
Time.of_seconds
(* ❌ Constant of type int64 is converted to int *)
0; Block_header.validation_passes := 0;
Block_header.operations_hash :=
Tezos_protocol_environment_alpha__Environment.Operation_list_list_hash.(Tezos_protocol_environment_alpha__Environment.MERKLE_TREE.S.zero);
Block_header.fitness :=
Fitness_repr.from_int64
(* ❌ Constant of type int64 is converted to int *)
0;
Block_header.context :=
Tezos_protocol_environment_alpha__Environment.Context_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
|}
with fake_contents : contents :=
{| priority := 0; seed_nonce_hash := Some Nonce_hash.zero;
proof_of_work_nonce :=
MBytes.create Constants_repr.proof_of_work_nonce_size |} in
Data_encoding.Binary.length encoding
{| shell := fake_shell;
protocol_data :=
{| contents := fake_contents; signature := Signature.zero |} |}.
Definition hash_raw
: Tezos_protocol_environment_alpha__Environment.Block_header.t ->
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
Block_header.hash.
Definition hash (function_parameter : t)
: Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
let '{| shell := shell; protocol_data := protocol_data |} :=
function_parameter in
Block_header.hash
{| shell := shell;
protocol_data :=
Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data
|}.
src/proto_alpha/lib_protocol/bootstrap_storage.ml 24 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Misc
let init_account ctxt
({public_key_hash; public_key; amount} : Parameters_repr.bootstrap_account)
=
let contract = Contract_repr.implicit_contract public_key_hash in
Contract_storage.credit ctxt contract amount
>>=? fun ctxt ->
match public_key with
| Some public_key ->
Contract_storage.reveal_manager_key ctxt public_key_hash public_key
>>=? fun ctxt ->
Delegate_storage.set ctxt contract (Some public_key_hash)
>>=? fun ctxt -> return ctxt
| None ->
return ctxt
let init_contract ~typecheck ctxt
({delegate; amount; script} : Parameters_repr.bootstrap_contract) =
Contract_storage.fresh_contract_from_current_nonce ctxt
>>=? fun (ctxt, contract) ->
typecheck ctxt script
>>=? fun (script, ctxt) ->
Contract_storage.originate
ctxt
contract
~balance:amount
~prepaid_bootstrap_storage:true
~script
~delegate:(Some delegate)
>>=? fun ctxt -> return ctxt
let init ctxt ~typecheck ?ramp_up_cycles ?no_reward_cycles accounts contracts =
let nonce =
Operation_hash.hash_bytes [MBytes.of_string "Un festival de GADT."]
in
let ctxt = Raw_context.init_origination_nonce ctxt nonce in
fold_left_s init_account ctxt accounts
>>=? fun ctxt ->
fold_left_s (init_contract ~typecheck) ctxt contracts
>>=? fun ctxt ->
( match no_reward_cycles with
| None ->
return ctxt
| Some cycles ->
(* Store pending ramp ups. *)
let constants = Raw_context.constants ctxt in
(* Start without reward *)
Raw_context.patch_constants ctxt (fun c ->
{
c with
block_reward = Tez_repr.zero;
endorsement_reward = Tez_repr.zero;
})
>>= fun ctxt ->
(* Store the final reward. *)
Storage.Ramp_up.Rewards.init
ctxt
(Cycle_repr.of_int32_exn (Int32.of_int cycles))
(constants.block_reward, constants.endorsement_reward) )
>>=? fun ctxt ->
match ramp_up_cycles with
| None ->
return ctxt
| Some cycles ->
(* Store pending ramp ups. *)
let constants = Raw_context.constants ctxt in
Lwt.return
Tez_repr.(constants.block_security_deposit /? Int64.of_int cycles)
>>=? fun block_step ->
Lwt.return
Tez_repr.(
constants.endorsement_security_deposit /? Int64.of_int cycles)
>>=? fun endorsement_step ->
(* Start without security_deposit *)
Raw_context.patch_constants ctxt (fun c ->
{
c with
block_security_deposit = Tez_repr.zero;
endorsement_security_deposit = Tez_repr.zero;
})
>>= fun ctxt ->
fold_left_s
(fun ctxt cycle ->
Lwt.return Tez_repr.(block_step *? Int64.of_int cycle)
>>=? fun block_security_deposit ->
Lwt.return Tez_repr.(endorsement_step *? Int64.of_int cycle)
>>=? fun endorsement_security_deposit ->
let cycle = Cycle_repr.of_int32_exn (Int32.of_int cycle) in
Storage.Ramp_up.Security_deposits.init
ctxt
cycle
(block_security_deposit, endorsement_security_deposit))
ctxt
(1 --> (cycles - 1))
>>=? fun ctxt ->
(* Store the final security deposits. *)
Storage.Ramp_up.Security_deposits.init
ctxt
(Cycle_repr.of_int32_exn (Int32.of_int cycles))
( constants.block_security_deposit,
constants.endorsement_security_deposit )
>>=? fun ctxt -> return ctxt
let cycle_end ctxt last_cycle =
let next_cycle = Cycle_repr.succ last_cycle in
Storage.Ramp_up.Rewards.get_option ctxt next_cycle
>>=? (function
| None ->
return ctxt
| Some (block_reward, endorsement_reward) ->
Storage.Ramp_up.Rewards.delete ctxt next_cycle
>>=? fun ctxt ->
Raw_context.patch_constants ctxt (fun c ->
{c with block_reward; endorsement_reward})
>>= fun ctxt -> return ctxt)
>>=? fun ctxt ->
Storage.Ramp_up.Security_deposits.get_option ctxt next_cycle
>>=? function
| None ->
return ctxt
| Some (block_security_deposit, endorsement_security_deposit) ->
Storage.Ramp_up.Security_deposits.delete ctxt next_cycle
>>=? fun ctxt ->
Raw_context.patch_constants ctxt (fun c ->
{c with block_security_deposit; endorsement_security_deposit})
>>= fun ctxt -> return ctxt
src/proto_alpha/lib_protocol/bootstrap_storage.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Misc.
Definition init_account
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(function_parameter :
Tezos_raw_protocol_alpha.Parameters_repr.bootstrap_account)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let '{|
public_key_hash := public_key_hash;
public_key := public_key;
amount := amount
|} := function_parameter in
let contract := Contract_repr.implicit_contract public_key_hash in
op_gtgteqquestion (Contract_storage.credit ctxt contract amount)
(fun ctxt =>
match public_key with
| Some public_key =>
op_gtgteqquestion
(Contract_storage.reveal_manager_key ctxt public_key_hash public_key)
(fun ctxt =>
op_gtgteqquestion
(Delegate_storage.set ctxt contract (Some public_key_hash))
(fun ctxt => _return ctxt))
| None => _return ctxt
end).
Definition init_contract
(typecheck :
Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_raw_protocol_alpha.Script_repr.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_raw_protocol_alpha.Script_repr.t *
(option Tezos_raw_protocol_alpha.Contract_storage.big_map_diff)) *
Tezos_raw_protocol_alpha.Raw_context.t)))
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(function_parameter :
Tezos_raw_protocol_alpha.Parameters_repr.bootstrap_contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let '{| delegate := delegate; amount := amount; script := script |} :=
function_parameter in
op_gtgteqquestion (Contract_storage.fresh_contract_from_current_nonce ctxt)
(fun function_parameter =>
let '(ctxt, contract) := function_parameter in
op_gtgteqquestion (typecheck ctxt script)
(fun function_parameter =>
let '(script, ctxt) := function_parameter in
op_gtgteqquestion
(Contract_storage.originate ctxt (Some true) contract amount script
(Some delegate)) (fun ctxt => _return ctxt))).
Definition init
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(typecheck :
Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_raw_protocol_alpha.Script_repr.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_raw_protocol_alpha.Script_repr.t *
(option Tezos_raw_protocol_alpha.Contract_storage.big_map_diff)) *
Tezos_raw_protocol_alpha.Raw_context.t)))
(ramp_up_cycles : option Z) (no_reward_cycles : option Z)
(accounts : list Tezos_raw_protocol_alpha.Parameters_repr.bootstrap_account)
(contracts : list Tezos_raw_protocol_alpha.Parameters_repr.bootstrap_contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let nonce :=
Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.hash_bytes)
None (cons (MBytes.of_string "Un festival de GADT." % string) []) in
let ctxt := Raw_context.init_origination_nonce ctxt nonce in
op_gtgteqquestion (fold_left_s init_account ctxt accounts)
(fun ctxt =>
op_gtgteqquestion (fold_left_s (init_contract typecheck) ctxt contracts)
(fun ctxt =>
op_gtgteqquestion
match no_reward_cycles with
| None => _return ctxt
| Some cycles =>
let constants := Raw_context.constants ctxt in
op_gtgteq
(Raw_context.patch_constants ctxt
(fun c =>
(* ❌ Record substitution not handled *)
record_substitution))
(fun ctxt =>
Storage.Ramp_up.Rewards.init ctxt
(Cycle_repr.of_int32_exn (Int32.of_int cycles))
((block_reward constants), (endorsement_reward constants)))
end
(fun ctxt =>
match ramp_up_cycles with
| None => _return ctxt
| Some cycles =>
let constants := Raw_context.constants ctxt in
op_gtgteqquestion
(Lwt._return
(op_divquestion (block_security_deposit constants)
(Int64.of_int cycles)))
(fun block_step =>
op_gtgteqquestion
(Lwt._return
(op_divquestion (endorsement_security_deposit constants)
(Int64.of_int cycles)))
(fun endorsement_step =>
op_gtgteq
(Raw_context.patch_constants ctxt
(fun c =>
(* ❌ Record substitution not handled *)
record_substitution))
(fun ctxt =>
op_gtgteqquestion
(fold_left_s
(fun ctxt =>
fun cycle =>
op_gtgteqquestion
(Lwt._return
(op_starquestion block_step
(Int64.of_int cycle)))
(fun block_security_deposit =>
op_gtgteqquestion
(Lwt._return
(op_starquestion endorsement_step
(Int64.of_int cycle)))
(fun endorsement_security_deposit =>
let cycle :=
Cycle_repr.of_int32_exn
(Int32.of_int cycle) in
Storage.Ramp_up.Security_deposits.init
ctxt cycle
(block_security_deposit,
endorsement_security_deposit))))
ctxt (op_minusminusgt 1 (op_minus cycles 1)))
(fun ctxt =>
op_gtgteqquestion
(Storage.Ramp_up.Security_deposits.init ctxt
(Cycle_repr.of_int32_exn
(Int32.of_int cycles))
((block_security_deposit constants),
(endorsement_security_deposit constants)))
(fun ctxt => _return ctxt)))))
end))).
Definition cycle_end
(ctxt : Tezos_raw_protocol_alpha.Storage.Ramp_up.Rewards.context)
(last_cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Ramp_up.Rewards.context) :=
let next_cycle := Cycle_repr.succ last_cycle in
op_gtgteqquestion
(op_gtgteqquestion (Storage.Ramp_up.Rewards.get_option ctxt next_cycle)
(fun function_parameter =>
match function_parameter with
| None => _return ctxt
| Some (block_reward, endorsement_reward) =>
op_gtgteqquestion (Storage.Ramp_up.Rewards.delete ctxt next_cycle)
(fun ctxt =>
op_gtgteq
(Raw_context.patch_constants ctxt
(fun c =>
(* ❌ Record substitution not handled *)
record_substitution)) (fun ctxt => _return ctxt))
end))
(fun ctxt =>
op_gtgteqquestion
(Storage.Ramp_up.Security_deposits.get_option ctxt next_cycle)
(fun function_parameter =>
match function_parameter with
| None => _return ctxt
| Some (block_security_deposit, endorsement_security_deposit) =>
op_gtgteqquestion
(Storage.Ramp_up.Security_deposits.delete ctxt next_cycle)
(fun ctxt =>
op_gtgteq
(Raw_context.patch_constants ctxt
(fun c =>
(* ❌ Record substitution not handled *)
record_substitution)) (fun ctxt => _return ctxt))
end)).
src/proto_alpha/lib_protocol/commitment_repr.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {
blinded_public_key_hash : Blinded_public_key_hash.t;
amount : Tez_repr.t;
}
let encoding =
let open Data_encoding in
conv
(fun {blinded_public_key_hash; amount} ->
(blinded_public_key_hash, amount))
(fun (blinded_public_key_hash, amount) ->
{blinded_public_key_hash; amount})
(tup2 Blinded_public_key_hash.encoding Tez_repr.encoding)
src/proto_alpha/lib_protocol/commitment_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record t := {
blinded_public_key_hash : Tezos_raw_protocol_alpha.Blinded_public_key_hash.t;
amount : Tezos_raw_protocol_alpha.Tez_repr.t }.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
conv
(fun function_parameter =>
let '{|
blinded_public_key_hash := blinded_public_key_hash;
amount := amount
|} := function_parameter in
(blinded_public_key_hash, amount))
(fun function_parameter =>
let '(blinded_public_key_hash, amount) := function_parameter in
{| blinded_public_key_hash := blinded_public_key_hash; amount := amount |})
None (tup2 Blinded_public_key_hash.encoding Tez_repr.encoding).
src/proto_alpha/lib_protocol/commitment_storage.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let get_opt = Storage.Commitments.get_option
let delete = Storage.Commitments.delete
let init ctxt commitments =
let init_commitment ctxt Commitment_repr.{blinded_public_key_hash; amount} =
Storage.Commitments.init ctxt blinded_public_key_hash amount
in
fold_left_s init_commitment ctxt commitments >>=? fun ctxt -> return ctxt
src/proto_alpha/lib_protocol/commitment_storage.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition get_opt
: Tezos_raw_protocol_alpha.Storage.Commitments.context ->
Tezos_raw_protocol_alpha.Storage.Commitments.key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option Tezos_raw_protocol_alpha.Storage.Commitments.value)) :=
Storage.Commitments.get_option.
Definition delete
: Tezos_raw_protocol_alpha.Storage.Commitments.context ->
Tezos_raw_protocol_alpha.Storage.Commitments.key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) := Storage.Commitments.delete.
Definition init
(ctxt : Tezos_raw_protocol_alpha.Storage.Commitments.context)
(commitments : list Tezos_raw_protocol_alpha.Commitment_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Commitments.context) :=
let init_commitment
(ctxt : Tezos_raw_protocol_alpha.Storage.Commitments.context)
(function_parameter : Tezos_raw_protocol_alpha.Commitment_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let '{|
blinded_public_key_hash := blinded_public_key_hash;
amount := amount
|} := function_parameter in
Storage.Commitments.init ctxt blinded_public_key_hash amount in
op_gtgteqquestion (fold_left_s init_commitment ctxt commitments)
(fun ctxt => _return ctxt).
src/proto_alpha/lib_protocol/constants_repr.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let version_number_004 = "\000"
let version_number = "\001"
let proof_of_work_nonce_size = 8
let nonce_length = 32
let max_revelations_per_block = 32
let max_proposals_per_delegate = 20
let max_operation_data_length = 16 * 1024 (* 16kB *)
type fixed = {
proof_of_work_nonce_size : int;
nonce_length : int;
max_revelations_per_block : int;
max_operation_data_length : int;
max_proposals_per_delegate : int;
}
let fixed_encoding =
let open Data_encoding in
conv
(fun c ->
( c.proof_of_work_nonce_size,
c.nonce_length,
c.max_revelations_per_block,
c.max_operation_data_length,
c.max_proposals_per_delegate ))
(fun ( proof_of_work_nonce_size,
nonce_length,
max_revelations_per_block,
max_operation_data_length,
max_proposals_per_delegate ) ->
{
proof_of_work_nonce_size;
nonce_length;
max_revelations_per_block;
max_operation_data_length;
max_proposals_per_delegate;
})
(obj5
(req "proof_of_work_nonce_size" uint8)
(req "nonce_length" uint8)
(req "max_revelations_per_block" uint8)
(req "max_operation_data_length" int31)
(req "max_proposals_per_delegate" uint8))
let fixed =
{
proof_of_work_nonce_size;
nonce_length;
max_revelations_per_block;
max_operation_data_length;
max_proposals_per_delegate;
}
type parametric = {
preserved_cycles : int;
blocks_per_cycle : int32;
blocks_per_commitment : int32;
blocks_per_roll_snapshot : int32;
blocks_per_voting_period : int32;
time_between_blocks : Period_repr.t list;
endorsers_per_block : int;
hard_gas_limit_per_operation : Z.t;
hard_gas_limit_per_block : Z.t;
proof_of_work_threshold : int64;
tokens_per_roll : Tez_repr.t;
michelson_maximum_type_size : int;
seed_nonce_revelation_tip : Tez_repr.t;
origination_size : int;
block_security_deposit : Tez_repr.t;
endorsement_security_deposit : Tez_repr.t;
block_reward : Tez_repr.t;
endorsement_reward : Tez_repr.t;
cost_per_byte : Tez_repr.t;
hard_storage_limit_per_operation : Z.t;
test_chain_duration : int64;
(* in seconds *)
quorum_min : int32;
quorum_max : int32;
min_proposal_quorum : int32;
initial_endorsers : int;
delay_per_missing_endorsement : Period_repr.t;
}
let parametric_encoding =
let open Data_encoding in
conv
(fun c ->
( ( c.preserved_cycles,
c.blocks_per_cycle,
c.blocks_per_commitment,
c.blocks_per_roll_snapshot,
c.blocks_per_voting_period,
c.time_between_blocks,
c.endorsers_per_block,
c.hard_gas_limit_per_operation,
c.hard_gas_limit_per_block ),
( ( c.proof_of_work_threshold,
c.tokens_per_roll,
c.michelson_maximum_type_size,
c.seed_nonce_revelation_tip,
c.origination_size,
c.block_security_deposit,
c.endorsement_security_deposit,
c.block_reward ),
( c.endorsement_reward,
c.cost_per_byte,
c.hard_storage_limit_per_operation,
c.test_chain_duration,
c.quorum_min,
c.quorum_max,
c.min_proposal_quorum,
c.initial_endorsers,
c.delay_per_missing_endorsement ) ) ))
(fun ( ( preserved_cycles,
blocks_per_cycle,
blocks_per_commitment,
blocks_per_roll_snapshot,
blocks_per_voting_period,
time_between_blocks,
endorsers_per_block,
hard_gas_limit_per_operation,
hard_gas_limit_per_block ),
( ( proof_of_work_threshold,
tokens_per_roll,
michelson_maximum_type_size,
seed_nonce_revelation_tip,
origination_size,
block_security_deposit,
endorsement_security_deposit,
block_reward ),
( endorsement_reward,
cost_per_byte,
hard_storage_limit_per_operation,
test_chain_duration,
quorum_min,
quorum_max,
min_proposal_quorum,
initial_endorsers,
delay_per_missing_endorsement ) ) ) ->
{
preserved_cycles;
blocks_per_cycle;
blocks_per_commitment;
blocks_per_roll_snapshot;
blocks_per_voting_period;
time_between_blocks;
endorsers_per_block;
hard_gas_limit_per_operation;
hard_gas_limit_per_block;
proof_of_work_threshold;
tokens_per_roll;
michelson_maximum_type_size;
seed_nonce_revelation_tip;
origination_size;
block_security_deposit;
endorsement_security_deposit;
block_reward;
endorsement_reward;
cost_per_byte;
hard_storage_limit_per_operation;
test_chain_duration;
quorum_min;
quorum_max;
min_proposal_quorum;
initial_endorsers;
delay_per_missing_endorsement;
})
(merge_objs
(obj9
(req "preserved_cycles" uint8)
(req "blocks_per_cycle" int32)
(req "blocks_per_commitment" int32)
(req "blocks_per_roll_snapshot" int32)
(req "blocks_per_voting_period" int32)
(req "time_between_blocks" (list Period_repr.encoding))
(req "endorsers_per_block" uint16)
(req "hard_gas_limit_per_operation" z)
(req "hard_gas_limit_per_block" z))
(merge_objs
(obj8
(req "proof_of_work_threshold" int64)
(req "tokens_per_roll" Tez_repr.encoding)
(req "michelson_maximum_type_size" uint16)
(req "seed_nonce_revelation_tip" Tez_repr.encoding)
(req "origination_size" int31)
(req "block_security_deposit" Tez_repr.encoding)
(req "endorsement_security_deposit" Tez_repr.encoding)
(req "block_reward" Tez_repr.encoding))
(obj9
(req "endorsement_reward" Tez_repr.encoding)
(req "cost_per_byte" Tez_repr.encoding)
(req "hard_storage_limit_per_operation" z)
(req "test_chain_duration" int64)
(req "quorum_min" int32)
(req "quorum_max" int32)
(req "min_proposal_quorum" int32)
(req "initial_endorsers" uint16)
(req "delay_per_missing_endorsement" Period_repr.encoding))))
type t = {fixed : fixed; parametric : parametric}
let encoding =
let open Data_encoding in
conv
(fun {fixed; parametric} -> (fixed, parametric))
(fun (fixed, parametric) -> {fixed; parametric})
(merge_objs fixed_encoding parametric_encoding)
src/proto_alpha/lib_protocol/constants_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition version_number_004 : string := " " % string.
Definition version_number : string := "" % string.
Definition proof_of_work_nonce_size : Z := 8.
Definition nonce_length : Z := 32.
Definition max_revelations_per_block : Z := 32.
Definition max_proposals_per_delegate : Z := 20.
Definition max_operation_data_length : Z := op_star 16 1024.
Record fixed := {
proof_of_work_nonce_size : Z;
nonce_length : Z;
max_revelations_per_block : Z;
max_operation_data_length : Z;
max_proposals_per_delegate : Z }.
Definition fixed_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding fixed :=
conv
(fun c =>
((proof_of_work_nonce_size c), (nonce_length c),
(max_revelations_per_block c), (max_operation_data_length c),
(max_proposals_per_delegate c)))
(fun function_parameter =>
let
'(proof_of_work_nonce_size, nonce_length, max_revelations_per_block,
max_operation_data_length, max_proposals_per_delegate) :=
function_parameter in
{| proof_of_work_nonce_size := proof_of_work_nonce_size;
nonce_length := nonce_length;
max_revelations_per_block := max_revelations_per_block;
max_operation_data_length := max_operation_data_length;
max_proposals_per_delegate := max_proposals_per_delegate |}) None
(obj5 (req None None "proof_of_work_nonce_size" % string uint8)
(req None None "nonce_length" % string uint8)
(req None None "max_revelations_per_block" % string uint8)
(req None None "max_operation_data_length" % string int31)
(req None None "max_proposals_per_delegate" % string uint8)).
Definition fixed : fixed :=
{| proof_of_work_nonce_size := proof_of_work_nonce_size;
nonce_length := nonce_length;
max_revelations_per_block := max_revelations_per_block;
max_operation_data_length := max_operation_data_length;
max_proposals_per_delegate := max_proposals_per_delegate |}.
Record parametric := {
preserved_cycles : Z;
blocks_per_cycle : int32;
blocks_per_commitment : int32;
blocks_per_roll_snapshot : int32;
blocks_per_voting_period : int32;
time_between_blocks : list Tezos_raw_protocol_alpha.Period_repr.t;
endorsers_per_block : Z;
hard_gas_limit_per_operation :
Tezos_protocol_environment_alpha__Environment.Z.t;
hard_gas_limit_per_block : Tezos_protocol_environment_alpha__Environment.Z.t;
proof_of_work_threshold : int64;
tokens_per_roll : Tezos_raw_protocol_alpha.Tez_repr.t;
michelson_maximum_type_size : Z;
seed_nonce_revelation_tip : Tezos_raw_protocol_alpha.Tez_repr.t;
origination_size : Z;
block_security_deposit : Tezos_raw_protocol_alpha.Tez_repr.t;
endorsement_security_deposit : Tezos_raw_protocol_alpha.Tez_repr.t;
block_reward : Tezos_raw_protocol_alpha.Tez_repr.t;
endorsement_reward : Tezos_raw_protocol_alpha.Tez_repr.t;
cost_per_byte : Tezos_raw_protocol_alpha.Tez_repr.t;
hard_storage_limit_per_operation :
Tezos_protocol_environment_alpha__Environment.Z.t;
test_chain_duration : int64;
quorum_min : int32;
quorum_max : int32;
min_proposal_quorum : int32;
initial_endorsers : Z;
delay_per_missing_endorsement : Tezos_raw_protocol_alpha.Period_repr.t }.
Definition parametric_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
parametric :=
conv
(fun c =>
(((preserved_cycles c), (blocks_per_cycle c), (blocks_per_commitment c),
(blocks_per_roll_snapshot c), (blocks_per_voting_period c),
(time_between_blocks c), (endorsers_per_block c),
(hard_gas_limit_per_operation c), (hard_gas_limit_per_block c)),
(((proof_of_work_threshold c), (tokens_per_roll c),
(michelson_maximum_type_size c), (seed_nonce_revelation_tip c),
(origination_size c), (block_security_deposit c),
(endorsement_security_deposit c), (block_reward c)),
((endorsement_reward c), (cost_per_byte c),
(hard_storage_limit_per_operation c), (test_chain_duration c),
(quorum_min c), (quorum_max c), (min_proposal_quorum c),
(initial_endorsers c), (delay_per_missing_endorsement c)))))
(fun function_parameter =>
let
'((preserved_cycles, blocks_per_cycle, blocks_per_commitment,
blocks_per_roll_snapshot, blocks_per_voting_period,
time_between_blocks, endorsers_per_block,
hard_gas_limit_per_operation, hard_gas_limit_per_block),
((proof_of_work_threshold, tokens_per_roll,
michelson_maximum_type_size, seed_nonce_revelation_tip,
origination_size, block_security_deposit,
endorsement_security_deposit, block_reward),
(endorsement_reward, cost_per_byte,
hard_storage_limit_per_operation, test_chain_duration, quorum_min,
quorum_max, min_proposal_quorum, initial_endorsers,
delay_per_missing_endorsement))) := function_parameter in
{| preserved_cycles := preserved_cycles;
blocks_per_cycle := blocks_per_cycle;
blocks_per_commitment := blocks_per_commitment;
blocks_per_roll_snapshot := blocks_per_roll_snapshot;
blocks_per_voting_period := blocks_per_voting_period;
time_between_blocks := time_between_blocks;
endorsers_per_block := endorsers_per_block;
hard_gas_limit_per_operation := hard_gas_limit_per_operation;
hard_gas_limit_per_block := hard_gas_limit_per_block;
proof_of_work_threshold := proof_of_work_threshold;
tokens_per_roll := tokens_per_roll;
michelson_maximum_type_size := michelson_maximum_type_size;
seed_nonce_revelation_tip := seed_nonce_revelation_tip;
origination_size := origination_size;
block_security_deposit := block_security_deposit;
endorsement_security_deposit := endorsement_security_deposit;
block_reward := block_reward; endorsement_reward := endorsement_reward;
cost_per_byte := cost_per_byte;
hard_storage_limit_per_operation := hard_storage_limit_per_operation;
test_chain_duration := test_chain_duration; quorum_min := quorum_min;
quorum_max := quorum_max; min_proposal_quorum := min_proposal_quorum;
initial_endorsers := initial_endorsers;
delay_per_missing_endorsement := delay_per_missing_endorsement |}) None
(merge_objs
(obj9 (req None None "preserved_cycles" % string uint8)
(req None None "blocks_per_cycle" % string int32)
(req None None "blocks_per_commitment" % string int32)
(req None None "blocks_per_roll_snapshot" % string int32)
(req None None "blocks_per_voting_period" % string int32)
(req None None "time_between_blocks" % string
(list None Period_repr.encoding))
(req None None "endorsers_per_block" % string uint16)
(req None None "hard_gas_limit_per_operation" % string z)
(req None None "hard_gas_limit_per_block" % string z))
(merge_objs
(obj8 (req None None "proof_of_work_threshold" % string int64)
(req None None "tokens_per_roll" % string Tez_repr.encoding)
(req None None "michelson_maximum_type_size" % string uint16)
(req None None "seed_nonce_revelation_tip" % string Tez_repr.encoding)
(req None None "origination_size" % string int31)
(req None None "block_security_deposit" % string Tez_repr.encoding)
(req None None "endorsement_security_deposit" % string
Tez_repr.encoding)
(req None None "block_reward" % string Tez_repr.encoding))
(obj9 (req None None "endorsement_reward" % string Tez_repr.encoding)
(req None None "cost_per_byte" % string Tez_repr.encoding)
(req None None "hard_storage_limit_per_operation" % string z)
(req None None "test_chain_duration" % string int64)
(req None None "quorum_min" % string int32)
(req None None "quorum_max" % string int32)
(req None None "min_proposal_quorum" % string int32)
(req None None "initial_endorsers" % string uint16)
(req None None "delay_per_missing_endorsement" % string
Period_repr.encoding)))).
Record t := {
fixed : fixed;
parametric : parametric }.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
conv
(fun function_parameter =>
let '{| fixed := fixed; parametric := parametric |} := function_parameter
in
(fixed, parametric))
(fun function_parameter =>
let '(fixed, parametric) := function_parameter in
{| fixed := fixed; parametric := parametric |}) None
(merge_objs fixed_encoding parametric_encoding).
src/proto_alpha/lib_protocol/constants_services.ml 35 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
let custom_root =
( RPC_path.(open_root / "context" / "constants")
: RPC_context.t RPC_path.context )
module S = struct
open Data_encoding
let errors =
RPC_service.get_service
~description:"Schema for all the RPC errors from this protocol version"
~query:RPC_query.empty
~output:json_schema
RPC_path.(custom_root / "errors")
let all =
RPC_service.get_service
~description:"All constants"
~query:RPC_query.empty
~output:Alpha_context.Constants.encoding
custom_root
end
let register () =
let open Services_registration in
register0_noctxt S.errors (fun () () ->
return Data_encoding.Json.(schema error_encoding)) ;
register0 S.all (fun ctxt () () ->
let open Constants in
return {fixed; parametric = parametric ctxt})
let errors ctxt block = RPC_context.make_call0 S.errors ctxt block () ()
let all ctxt block = RPC_context.make_call0 S.all ctxt block () ()
src/proto_alpha/lib_protocol/constants_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Definition custom_root
: Tezos_protocol_environment_alpha__Environment.RPC_path.context
Tezos_protocol_environment_alpha__Environment.RPC_context.t :=
op_div (op_div open_root "context" % string) "constants" % string.
Module S.
Import Data_encoding.
Definition errors
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t unit unit
Tezos_protocol_environment_alpha__Environment.Data_encoding.json_schema :=
RPC_service.get_service
(Some "Schema for all the RPC errors from this protocol version" % string)
RPC_query.empty json_schema (op_div custom_root "errors" % string).
Definition all
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t unit unit
Tezos_raw_protocol_alpha.Alpha_context.Constants.t :=
RPC_service.get_service (Some "All constants" % string) RPC_query.empty
Alpha_context.Constants.encoding custom_root.
End S.
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0_noctxt S.errors
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
_return (schema None error_encoding)) in
register0 S.all
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
_return {| fixed := fixed; parametric := parametric ctxt |}).
Definition errors {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_environment_alpha__Environment.Data_encoding.json_schema) :=
RPC_context.make_call0 S.errors ctxt block tt tt.
Definition all {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Constants.t) :=
RPC_context.make_call0 S.all ctxt block tt tt.
src/proto_alpha/lib_protocol/constants_storage.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) let preserved_cycles c = let constants = Raw_context.constants c in constants.preserved_cycles let blocks_per_cycle c = let constants = Raw_context.constants c in constants.blocks_per_cycle let blocks_per_commitment c = let constants = Raw_context.constants c in constants.blocks_per_commitment let blocks_per_roll_snapshot c = let constants = Raw_context.constants c in constants.blocks_per_roll_snapshot let blocks_per_voting_period c = let constants = Raw_context.constants c in constants.blocks_per_voting_period let time_between_blocks c = let constants = Raw_context.constants c in constants.time_between_blocks let endorsers_per_block c = let constants = Raw_context.constants c in constants.endorsers_per_block let initial_endorsers c = let constants = Raw_context.constants c in constants.initial_endorsers let delay_per_missing_endorsement c = let constants = Raw_context.constants c in constants.delay_per_missing_endorsement let hard_gas_limit_per_operation c = let constants = Raw_context.constants c in constants.hard_gas_limit_per_operation let hard_gas_limit_per_block c = let constants = Raw_context.constants c in constants.hard_gas_limit_per_block let cost_per_byte c = let constants = Raw_context.constants c in constants.cost_per_byte let hard_storage_limit_per_operation c = let constants = Raw_context.constants c in constants.hard_storage_limit_per_operation let proof_of_work_threshold c = let constants = Raw_context.constants c in constants.proof_of_work_threshold let tokens_per_roll c = let constants = Raw_context.constants c in constants.tokens_per_roll let michelson_maximum_type_size c = let constants = Raw_context.constants c in constants.michelson_maximum_type_size let seed_nonce_revelation_tip c = let constants = Raw_context.constants c in constants.seed_nonce_revelation_tip let origination_size c = let constants = Raw_context.constants c in constants.origination_size let block_security_deposit c = let constants = Raw_context.constants c in constants.block_security_deposit let endorsement_security_deposit c = let constants = Raw_context.constants c in constants.endorsement_security_deposit let block_reward c = let constants = Raw_context.constants c in constants.block_reward let endorsement_reward c = let constants = Raw_context.constants c in constants.endorsement_reward let test_chain_duration c = let constants = Raw_context.constants c in constants.test_chain_duration let quorum_min c = let constants = Raw_context.constants c in constants.quorum_min let quorum_max c = let constants = Raw_context.constants c in constants.quorum_max let min_proposal_quorum c = let constants = Raw_context.constants c in constants.min_proposal_quorum let parametric c = Raw_context.constants c
src/proto_alpha/lib_protocol/constants_storage.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. Definition preserved_cycles (c : Tezos_raw_protocol_alpha.Raw_context.context) : Z := let constants := Raw_context.constants c in preserved_cycles constants. Definition blocks_per_cycle (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 := let constants := Raw_context.constants c in blocks_per_cycle constants. Definition blocks_per_commitment (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 := let constants := Raw_context.constants c in blocks_per_commitment constants. Definition blocks_per_roll_snapshot (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 := let constants := Raw_context.constants c in blocks_per_roll_snapshot constants. Definition blocks_per_voting_period (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 := let constants := Raw_context.constants c in blocks_per_voting_period constants. Definition time_between_blocks (c : Tezos_raw_protocol_alpha.Raw_context.context) : list Tezos_raw_protocol_alpha.Period_repr.t := let constants := Raw_context.constants c in time_between_blocks constants. Definition endorsers_per_block (c : Tezos_raw_protocol_alpha.Raw_context.context) : Z := let constants := Raw_context.constants c in endorsers_per_block constants. Definition initial_endorsers (c : Tezos_raw_protocol_alpha.Raw_context.context) : Z := let constants := Raw_context.constants c in initial_endorsers constants. Definition delay_per_missing_endorsement (c : Tezos_raw_protocol_alpha.Raw_context.context) : Tezos_raw_protocol_alpha.Period_repr.t := let constants := Raw_context.constants c in delay_per_missing_endorsement constants. Definition hard_gas_limit_per_operation (c : Tezos_raw_protocol_alpha.Raw_context.context) : Tezos_protocol_environment_alpha__Environment.Z.t := let constants := Raw_context.constants c in hard_gas_limit_per_operation constants. Definition hard_gas_limit_per_block (c : Tezos_raw_protocol_alpha.Raw_context.context) : Tezos_protocol_environment_alpha__Environment.Z.t := let constants := Raw_context.constants c in hard_gas_limit_per_block constants. Definition cost_per_byte (c : Tezos_raw_protocol_alpha.Raw_context.context) : Tezos_raw_protocol_alpha.Tez_repr.t := let constants := Raw_context.constants c in cost_per_byte constants. Definition hard_storage_limit_per_operation (c : Tezos_raw_protocol_alpha.Raw_context.context) : Tezos_protocol_environment_alpha__Environment.Z.t := let constants := Raw_context.constants c in hard_storage_limit_per_operation constants. Definition proof_of_work_threshold (c : Tezos_raw_protocol_alpha.Raw_context.context) : int64 := let constants := Raw_context.constants c in proof_of_work_threshold constants. Definition tokens_per_roll (c : Tezos_raw_protocol_alpha.Raw_context.context) : Tezos_raw_protocol_alpha.Tez_repr.t := let constants := Raw_context.constants c in tokens_per_roll constants. Definition michelson_maximum_type_size (c : Tezos_raw_protocol_alpha.Raw_context.context) : Z := let constants := Raw_context.constants c in michelson_maximum_type_size constants. Definition seed_nonce_revelation_tip (c : Tezos_raw_protocol_alpha.Raw_context.context) : Tezos_raw_protocol_alpha.Tez_repr.t := let constants := Raw_context.constants c in seed_nonce_revelation_tip constants. Definition origination_size (c : Tezos_raw_protocol_alpha.Raw_context.context) : Z := let constants := Raw_context.constants c in origination_size constants. Definition block_security_deposit (c : Tezos_raw_protocol_alpha.Raw_context.context) : Tezos_raw_protocol_alpha.Tez_repr.t := let constants := Raw_context.constants c in block_security_deposit constants. Definition endorsement_security_deposit (c : Tezos_raw_protocol_alpha.Raw_context.context) : Tezos_raw_protocol_alpha.Tez_repr.t := let constants := Raw_context.constants c in endorsement_security_deposit constants. Definition block_reward (c : Tezos_raw_protocol_alpha.Raw_context.context) : Tezos_raw_protocol_alpha.Tez_repr.t := let constants := Raw_context.constants c in block_reward constants. Definition endorsement_reward (c : Tezos_raw_protocol_alpha.Raw_context.context) : Tezos_raw_protocol_alpha.Tez_repr.t := let constants := Raw_context.constants c in endorsement_reward constants. Definition test_chain_duration (c : Tezos_raw_protocol_alpha.Raw_context.context) : int64 := let constants := Raw_context.constants c in test_chain_duration constants. Definition quorum_min (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 := let constants := Raw_context.constants c in quorum_min constants. Definition quorum_max (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 := let constants := Raw_context.constants c in quorum_max constants. Definition min_proposal_quorum (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 := let constants := Raw_context.constants c in min_proposal_quorum constants. Definition parametric (c : Tezos_raw_protocol_alpha.Raw_context.context) : Tezos_raw_protocol_alpha.Constants_repr.parametric := Raw_context.constants c.
src/proto_alpha/lib_protocol/contract_hash.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* 20 *)
let contract_hash = "\002\090\121" (* KT1(36) *)
include Blake2B.Make
(Base58)
(struct
let name = "Contract_hash"
let title = "A contract ID"
let b58check_prefix = contract_hash
let size = Some 20
end)
let () = Base58.check_encoded_prefix b58check_encoding "KT1" 36
src/proto_alpha/lib_protocol/contract_hash.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. Definition contract_hash : string := "Zy" % string. (* ❌ Structure item `include` not handled. *) include
src/proto_alpha/lib_protocol/contract_repr.ml 38 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t =
| Implicit of Signature.Public_key_hash.t
| Originated of Contract_hash.t
include Compare.Make (struct
type nonrec t = t
let compare l1 l2 =
match (l1, l2) with
| (Implicit pkh1, Implicit pkh2) ->
Signature.Public_key_hash.compare pkh1 pkh2
| (Originated h1, Originated h2) ->
Contract_hash.compare h1 h2
| (Implicit _, Originated _) ->
-1
| (Originated _, Implicit _) ->
1
end)
type contract = t
type error += Invalid_contract_notation of string (* `Permanent *)
let to_b58check = function
| Implicit pbk ->
Signature.Public_key_hash.to_b58check pbk
| Originated h ->
Contract_hash.to_b58check h
let of_b58check s =
match Base58.decode s with
| Some (Ed25519.Public_key_hash.Data h) ->
ok (Implicit (Signature.Ed25519 h))
| Some (Secp256k1.Public_key_hash.Data h) ->
ok (Implicit (Signature.Secp256k1 h))
| Some (P256.Public_key_hash.Data h) ->
ok (Implicit (Signature.P256 h))
| Some (Contract_hash.Data h) ->
ok (Originated h)
| _ ->
error (Invalid_contract_notation s)
let pp ppf = function
| Implicit pbk ->
Signature.Public_key_hash.pp ppf pbk
| Originated h ->
Contract_hash.pp ppf h
let pp_short ppf = function
| Implicit pbk ->
Signature.Public_key_hash.pp_short ppf pbk
| Originated h ->
Contract_hash.pp_short ppf h
let encoding =
let open Data_encoding in
def
"contract_id"
~title:"A contract handle"
~description:
"A contract notation as given to an RPC or inside scripts. Can be a \
base58 implicit contract hash or a base58 originated contract hash."
@@ splitted
~binary:
(union
~tag_size:`Uint8
[ case
(Tag 0)
~title:"Implicit"
Signature.Public_key_hash.encoding
(function Implicit k -> Some k | _ -> None)
(fun k -> Implicit k);
case
(Tag 1)
(Fixed.add_padding Contract_hash.encoding 1)
~title:"Originated"
(function Originated k -> Some k | _ -> None)
(fun k -> Originated k) ])
~json:
(conv
to_b58check
(fun s ->
match of_b58check s with
| Ok s ->
s
| Error _ ->
Json.cannot_destruct "Invalid contract notation.")
string)
let () =
let open Data_encoding in
register_error_kind
`Permanent
~id:"contract.invalid_contract_notation"
~title:"Invalid contract notation"
~pp:(fun ppf x -> Format.fprintf ppf "Invalid contract notation %S" x)
~description:
"A malformed contract notation was given to an RPC or in a script."
(obj1 (req "notation" string))
(function Invalid_contract_notation loc -> Some loc | _ -> None)
(fun loc -> Invalid_contract_notation loc)
let implicit_contract id = Implicit id
let is_implicit = function Implicit m -> Some m | Originated _ -> None
let is_originated = function Implicit _ -> None | Originated h -> Some h
type origination_nonce = {
operation_hash : Operation_hash.t;
origination_index : int32;
}
let origination_nonce_encoding =
let open Data_encoding in
conv
(fun {operation_hash; origination_index} ->
(operation_hash, origination_index))
(fun (operation_hash, origination_index) ->
{operation_hash; origination_index})
@@ obj2 (req "operation" Operation_hash.encoding) (dft "index" int32 0l)
let originated_contract nonce =
let data =
Data_encoding.Binary.to_bytes_exn origination_nonce_encoding nonce
in
Originated (Contract_hash.hash_bytes [data])
let originated_contracts
~since:{origination_index = first; operation_hash = first_hash}
~until:( {origination_index = last; operation_hash = last_hash} as
origination_nonce ) =
assert (Operation_hash.equal first_hash last_hash) ;
let rec contracts acc origination_index =
if Compare.Int32.(origination_index < first) then acc
else
let origination_nonce = {origination_nonce with origination_index} in
let acc = originated_contract origination_nonce :: acc in
contracts acc (Int32.pred origination_index)
in
contracts [] (Int32.pred last)
let initial_origination_nonce operation_hash =
{operation_hash; origination_index = 0l}
let incr_origination_nonce nonce =
let origination_index = Int32.succ nonce.origination_index in
{nonce with origination_index}
let rpc_arg =
let construct = to_b58check in
let destruct hash =
match of_b58check hash with
| Error _ ->
Error "Cannot parse contract id"
| Ok contract ->
Ok contract
in
RPC_arg.make
~descr:"A contract identifier encoded in b58check."
~name:"contract_id"
~construct
~destruct
()
module Index = struct
type t = contract
let path_length = 7
let to_path c l =
let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
let (`Hex key) = MBytes.to_hex raw_key in
let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
String.sub index_key 0 2 :: String.sub index_key 2 2
:: String.sub index_key 4 2 :: String.sub index_key 6 2
:: String.sub index_key 8 2 :: String.sub index_key 10 2 :: key :: l
let of_path = function
| []
| [_]
| [_; _]
| [_; _; _]
| [_; _; _; _]
| [_; _; _; _; _]
| [_; _; _; _; _; _]
| _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ ->
None
| [index1; index2; index3; index4; index5; index6; key] ->
let raw_key = MBytes.of_hex (`Hex key) in
let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
assert (Compare.String.(String.sub index_key 0 2 = index1)) ;
assert (Compare.String.(String.sub index_key 2 2 = index2)) ;
assert (Compare.String.(String.sub index_key 4 2 = index3)) ;
assert (Compare.String.(String.sub index_key 6 2 = index4)) ;
assert (Compare.String.(String.sub index_key 8 2 = index5)) ;
assert (Compare.String.(String.sub index_key 10 2 = index6)) ;
Data_encoding.Binary.of_bytes encoding raw_key
let rpc_arg = rpc_arg
let encoding = encoding
let compare = compare
end
src/proto_alpha/lib_protocol/contract_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive t : Type :=
| Implicit :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t -> t
| Originated : Tezos_raw_protocol_alpha.Contract_hash.t -> t.
(* ❌ Structure item `include` not handled. *)
include
Definition contract := t.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition to_b58check (function_parameter : t) : string :=
match function_parameter with
| Implicit pbk => Signature.Public_key_hash.to_b58check pbk
| Originated h => Contract_hash.to_b58check h
end.
Definition of_b58check (s : string)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t :=
match Base58.decode s with
| Some (Tezos_protocol_environment_alpha__Environment.Base58.Data h) =>
ok
(Implicit
(Tezos_protocol_environment_alpha__Environment.Signature.Ed25519 h))
| Some (Tezos_protocol_environment_alpha__Environment.Base58.Data h) =>
ok
(Implicit
(Tezos_protocol_environment_alpha__Environment.Signature.Secp256k1 h))
| Some (Tezos_protocol_environment_alpha__Environment.Base58.Data h) =>
ok
(Implicit (Tezos_protocol_environment_alpha__Environment.Signature.P256 h))
| Some (Tezos_protocol_environment_alpha__Environment.Base58.Data h) =>
ok (Originated h)
| _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract_notation
s)
end.
Definition pp
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
(function_parameter : t) : unit :=
match function_parameter with
| Implicit pbk => Signature.Public_key_hash.pp ppf pbk
| Originated h => Contract_hash.pp ppf h
end.
Definition pp_short
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
(function_parameter : t) : unit :=
match function_parameter with
| Implicit pbk => Signature.Public_key_hash.pp_short ppf pbk
| Originated h => Contract_hash.pp_short ppf h
end.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
op_atat
(def "contract_id" % string (Some "A contract handle" % string)
(Some
"A contract notation as given to an RPC or inside scripts. Can be a base58 implicit contract hash or a base58 originated contract hash."
% string))
(splitted
(conv to_b58check
(fun s =>
match of_b58check s with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok s => s
| Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ =>
Json.cannot_destruct
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"Invalid contract notation." % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
"Invalid contract notation." % string)
end) None string)
(union
(Some
(* ❌ Variants not supported *)
variant)
(cons
(case "Implicit" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
Signature.Public_key_hash.encoding
(fun function_parameter =>
match function_parameter with
| Implicit k => Some k
| _ => None
end) (fun k => Implicit k))
(cons
(case "Originated" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
(Fixed.add_padding Contract_hash.encoding 1)
(fun function_parameter =>
match function_parameter with
| Originated k => Some k
| _ => None
end) (fun k => Originated k)) [])))).
Definition implicit_contract
(id :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: t := Implicit id.
Definition is_implicit (function_parameter : t)
: option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t :=
match function_parameter with
| Implicit m => Some m
| Originated _ => None
end.
Definition is_originated (function_parameter : t)
: option Tezos_raw_protocol_alpha.Contract_hash.t :=
match function_parameter with
| Implicit _ => None
| Originated h => Some h
end.
Record origination_nonce := {
operation_hash :
Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t);
origination_index : int32 }.
Definition origination_nonce_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
origination_nonce :=
op_atat
(let arg :=
conv
(fun function_parameter =>
let '{|
operation_hash := operation_hash;
origination_index := origination_index
|} := function_parameter in
(operation_hash, origination_index))
(fun function_parameter =>
let '(operation_hash, origination_index) := function_parameter in
{| operation_hash := operation_hash;
origination_index := origination_index |}) in
fun eta => arg None eta)
(obj2
(req None None "operation" % string
Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding))
(dft None None "index" % string int32
(* ❌ Constant of type int32 is converted to int *)
0)).
Definition originated_contract (nonce : origination_nonce) : t :=
let data := Data_encoding.Binary.to_bytes_exn origination_nonce_encoding nonce
in
Originated (Contract_hash.hash_bytes None (cons data [])).
Definition originated_contracts (function_parameter : origination_nonce)
: origination_nonce -> list t :=
let '{| operation_hash := first_hash; origination_index := first |} :=
function_parameter in
fun function_parameter =>
let
'{| operation_hash := last_hash; origination_index := last |} as
origination_nonce := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
first_hash last_hash) in
let fix contracts
(acc : list t) (origination_index :
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: list t :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
origination_index first then
acc
else
let origination_nonce :=
(* ❌ Record substitution not handled *)
record_substitution in
let acc := cons (originated_contract origination_nonce) acc in
contracts acc (Int32.pred origination_index) in
contracts [] (Int32.pred last).
Definition initial_origination_nonce
(operation_hash :
Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
: origination_nonce :=
{| operation_hash := operation_hash;
origination_index :=
(* ❌ Constant of type int32 is converted to int *)
0 |}.
Definition incr_origination_nonce (nonce : origination_nonce)
: origination_nonce :=
let origination_index := Int32.succ (origination_index nonce) in
(* ❌ Record substitution not handled *)
record_substitution.
Definition rpc_arg
: Tezos_protocol_environment_alpha__Environment.RPC_arg.arg t :=
let construct := to_b58check in
let destruct (hash : string)
: Tezos_protocol_environment_alpha__Environment.Pervasives.result t string :=
match of_b58check hash with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ =>
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
"Cannot parse contract id" % string
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok contract =>
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok contract
end in
RPC_arg.make (Some "A contract identifier encoded in b58check." % string)
"contract_id" % string destruct construct tt.
Module Index.
Definition t := contract.
Definition path_length : Z := 7.
Definition to_path (c : t) (l : list string) : list string :=
let raw_key := Data_encoding.Binary.to_bytes_exn encoding c in
let 'Hex key := MBytes.to_hex raw_key in
let 'Hex index_key := MBytes.to_hex (Raw_hashes.blake2b raw_key) in
cons (String.sub index_key 0 2)
(cons (String.sub index_key 2 2)
(cons (String.sub index_key 4 2)
(cons (String.sub index_key 6 2)
(cons (String.sub index_key 8 2)
(cons (String.sub index_key 10 2) (cons key l)))))).
Definition of_path
(function_parameter :
list
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: option t :=
match function_parameter with
|
[] | cons _ [] | cons _ (cons _ []) | cons _ (cons _ (cons _ [])) |
cons _ (cons _ (cons _ (cons _ []))) |
cons _ (cons _ (cons _ (cons _ (cons _ [])))) |
cons _ (cons _ (cons _ (cons _ (cons _ (cons _ []))))) |
cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ _)))))))
=> None
|
cons index1
(cons index2
(cons index3 (cons index4 (cons index5 (cons index6 (cons key []))))))
=>
let raw_key :=
MBytes.of_hex
(* ❌ Variants not supported *)
variant in
let 'Hex index_key := MBytes.to_hex (Raw_hashes.blake2b raw_key) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.sub index_key 0 2) index1) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.sub index_key 2 2) index2) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.sub index_key 4 2) index3) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.sub index_key 6 2) index4) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.sub index_key 8 2) index5) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.sub index_key 10 2) index6) in
Data_encoding.Binary.of_bytes encoding raw_key
end.
Definition rpc_arg
: Tezos_protocol_environment_alpha__Environment.RPC_arg.arg t := rpc_arg.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
encoding.
Definition compare : t -> t -> Z := compare.
End Index.
src/proto_alpha/lib_protocol/contract_services.ml 332 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
let custom_root =
( RPC_path.(open_root / "context" / "contracts")
: RPC_context.t RPC_path.context )
let big_map_root =
( RPC_path.(open_root / "context" / "big_maps")
: RPC_context.t RPC_path.context )
type info = {
balance : Tez.t;
delegate : public_key_hash option;
counter : counter option;
script : Script.t option;
}
let info_encoding =
let open Data_encoding in
conv
(fun {balance; delegate; script; counter} ->
(balance, delegate, script, counter))
(fun (balance, delegate, script, counter) ->
{balance; delegate; script; counter})
@@ obj4
(req "balance" Tez.encoding)
(opt "delegate" Signature.Public_key_hash.encoding)
(opt "script" Script.encoding)
(opt "counter" n)
module S = struct
open Data_encoding
let balance =
RPC_service.get_service
~description:"Access the balance of a contract."
~query:RPC_query.empty
~output:Tez.encoding
RPC_path.(custom_root /: Contract.rpc_arg / "balance")
let manager_key =
RPC_service.get_service
~description:"Access the manager of a contract."
~query:RPC_query.empty
~output:(option Signature.Public_key.encoding)
RPC_path.(custom_root /: Contract.rpc_arg / "manager_key")
let delegate =
RPC_service.get_service
~description:"Access the delegate of a contract, if any."
~query:RPC_query.empty
~output:Signature.Public_key_hash.encoding
RPC_path.(custom_root /: Contract.rpc_arg / "delegate")
let counter =
RPC_service.get_service
~description:"Access the counter of a contract, if any."
~query:RPC_query.empty
~output:z
RPC_path.(custom_root /: Contract.rpc_arg / "counter")
let script =
RPC_service.get_service
~description:"Access the code and data of the contract."
~query:RPC_query.empty
~output:Script.encoding
RPC_path.(custom_root /: Contract.rpc_arg / "script")
let storage =
RPC_service.get_service
~description:"Access the data of the contract."
~query:RPC_query.empty
~output:Script.expr_encoding
RPC_path.(custom_root /: Contract.rpc_arg / "storage")
let entrypoint_type =
RPC_service.get_service
~description:"Return the type of the given entrypoint of the contract"
~query:RPC_query.empty
~output:Script.expr_encoding
RPC_path.(
custom_root /: Contract.rpc_arg / "entrypoints" /: RPC_arg.string)
let list_entrypoints =
RPC_service.get_service
~description:"Return the list of entrypoints of the contract"
~query:RPC_query.empty
~output:
(obj2
(dft
"unreachable"
(Data_encoding.list
(obj1
(req
"path"
(Data_encoding.list
Michelson_v1_primitives.prim_encoding))))
[])
(req "entrypoints" (assoc Script.expr_encoding)))
RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints")
let contract_big_map_get_opt =
RPC_service.post_service
~description:
"Access the value associated with a key in a big map of the contract \
(deprecated)."
~query:RPC_query.empty
~input:
(obj2
(req "key" Script.expr_encoding)
(req "type" Script.expr_encoding))
~output:(option Script.expr_encoding)
RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get")
let big_map_get =
RPC_service.get_service
~description:"Access the value associated with a key in a big map."
~query:RPC_query.empty
~output:Script.expr_encoding
RPC_path.(big_map_root /: Big_map.rpc_arg /: Script_expr_hash.rpc_arg)
let info =
RPC_service.get_service
~description:"Access the complete status of a contract."
~query:RPC_query.empty
~output:info_encoding
RPC_path.(custom_root /: Contract.rpc_arg)
let list =
RPC_service.get_service
~description:
"All existing contracts (including non-empty default contracts)."
~query:RPC_query.empty
~output:(list Contract.encoding)
custom_root
end
let register () =
let open Services_registration in
register0 S.list (fun ctxt () () -> Contract.list ctxt >>= return) ;
let register_field s f =
register1 s (fun ctxt contract () () ->
Contract.exists ctxt contract
>>=? function true -> f ctxt contract | false -> raise Not_found)
in
let register_opt_field s f =
register_field s (fun ctxt a1 ->
f ctxt a1 >>=? function None -> raise Not_found | Some v -> return v)
in
let do_big_map_get ctxt id key =
let open Script_ir_translator in
let ctxt = Gas.set_unlimited ctxt in
Big_map.exists ctxt id
>>=? fun (ctxt, types) ->
match types with
| None ->
raise Not_found
| Some (_, value_type) -> (
Lwt.return
(parse_ty
ctxt
~legacy:true
~allow_big_map:false
~allow_operation:false
~allow_contract:true
(Micheline.root value_type))
>>=? fun (Ex_ty value_type, ctxt) ->
Big_map.get_opt ctxt id key
>>=? fun (_ctxt, value) ->
match value with
| None ->
raise Not_found
| Some value ->
parse_data ctxt ~legacy:true value_type (Micheline.root value)
>>=? fun (value, ctxt) ->
unparse_data ctxt Readable value_type value
>>=? fun (value, _ctxt) -> return (Micheline.strip_locations value)
)
in
register_field S.balance Contract.get_balance ;
register1 S.manager_key (fun ctxt contract () () ->
match Contract.is_implicit contract with
| None ->
raise Not_found
| Some mgr -> (
Contract.is_manager_key_revealed ctxt mgr
>>=? function
| false ->
return_none
| true ->
Contract.get_manager_key ctxt mgr >>=? return_some )) ;
register_opt_field S.delegate Delegate.get ;
register1 S.counter (fun ctxt contract () () ->
match Contract.is_implicit contract with
| None ->
raise Not_found
| Some mgr ->
Contract.get_counter ctxt mgr) ;
register_opt_field S.script (fun c v ->
Contract.get_script c v >>=? fun (_, v) -> return v) ;
register_opt_field S.storage (fun ctxt contract ->
Contract.get_script ctxt contract
>>=? fun (ctxt, script) ->
match script with
| None ->
return_none
| Some script ->
let ctxt = Gas.set_unlimited ctxt in
let open Script_ir_translator in
parse_script ctxt ~legacy:true script
>>=? fun (Ex_script script, ctxt) ->
unparse_script ctxt Readable script
>>=? fun (script, ctxt) ->
Script.force_decode ctxt script.storage
>>=? fun (storage, _ctxt) -> return_some storage) ;
register2 S.entrypoint_type (fun ctxt v entrypoint () () ->
Contract.get_script_code ctxt v
>>=? fun (_, expr) ->
match expr with
| None ->
raise Not_found
| Some expr -> (
let ctxt = Gas.set_unlimited ctxt in
let legacy = true in
let open Script_ir_translator in
Script.force_decode ctxt expr
>>=? fun (expr, _) ->
Lwt.return
( parse_toplevel ~legacy expr
>>? fun (arg_type, _, _, root_name) ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:true
arg_type
>>? fun (Ex_ty arg_type, _) ->
Script_ir_translator.find_entrypoint ~root_name arg_type entrypoint
)
>>= function
| Ok (_f, Ex_ty ty) ->
unparse_ty ctxt ty
>>=? fun (ty_node, _) ->
return (Micheline.strip_locations ty_node)
| Error _ ->
raise Not_found )) ;
register1 S.list_entrypoints (fun ctxt v () () ->
Contract.get_script_code ctxt v
>>=? fun (_, expr) ->
match expr with
| None ->
raise Not_found
| Some expr ->
let ctxt = Gas.set_unlimited ctxt in
let legacy = true in
let open Script_ir_translator in
Script.force_decode ctxt expr
>>=? fun (expr, _) ->
Lwt.return
( parse_toplevel ~legacy expr
>>? fun (arg_type, _, _, root_name) ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:true
arg_type
>>? fun (Ex_ty arg_type, _) ->
Script_ir_translator.list_entrypoints ~root_name arg_type ctxt )
>>=? fun (unreachable_entrypoint, map) ->
return
( unreachable_entrypoint,
Entrypoints_map.fold
(fun entry (_, ty) acc ->
(entry, Micheline.strip_locations ty) :: acc)
map
[] )) ;
register1 S.contract_big_map_get_opt (fun ctxt contract () (key, key_type) ->
Contract.get_script ctxt contract
>>=? fun (ctxt, script) ->
Lwt.return
(Script_ir_translator.parse_packable_ty
ctxt
~legacy:true
(Micheline.root key_type))
>>=? fun (Ex_ty key_type, ctxt) ->
Script_ir_translator.parse_data
ctxt
~legacy:true
key_type
(Micheline.root key)
>>=? fun (key, ctxt) ->
Script_ir_translator.hash_data ctxt key_type key
>>=? fun (key, ctxt) ->
match script with
| None ->
raise Not_found
| Some script ->
let ctxt = Gas.set_unlimited ctxt in
let open Script_ir_translator in
parse_script ctxt ~legacy:true script
>>=? fun (Ex_script script, ctxt) ->
Script_ir_translator.collect_big_maps
ctxt
script.storage_type
script.storage
>>=? fun (ids, _ctxt) ->
let ids = Script_ir_translator.list_of_big_map_ids ids in
let rec find = function
| [] ->
return_none
| (id : Z.t) :: ids -> (
try do_big_map_get ctxt id key >>=? return_some
with Not_found -> find ids )
in
find ids) ;
register2 S.big_map_get (fun ctxt id key () () -> do_big_map_get ctxt id key) ;
register_field S.info (fun ctxt contract ->
Contract.get_balance ctxt contract
>>=? fun balance ->
Delegate.get ctxt contract
>>=? fun delegate ->
( match Contract.is_implicit contract with
| Some manager ->
Contract.get_counter ctxt manager
>>=? fun counter -> return_some counter
| None ->
return None )
>>=? fun counter ->
Contract.get_script ctxt contract
>>=? fun (ctxt, script) ->
( match script with
| None ->
return (None, ctxt)
| Some script ->
let ctxt = Gas.set_unlimited ctxt in
let open Script_ir_translator in
parse_script ctxt ~legacy:true script
>>=? fun (Ex_script script, ctxt) ->
unparse_script ctxt Readable script
>>=? fun (script, ctxt) -> return (Some script, ctxt) )
>>=? fun (script, _ctxt) -> return {balance; delegate; script; counter})
let list ctxt block = RPC_context.make_call0 S.list ctxt block () ()
let info ctxt block contract =
RPC_context.make_call1 S.info ctxt block contract () ()
let balance ctxt block contract =
RPC_context.make_call1 S.balance ctxt block contract () ()
let manager_key ctxt block mgr =
RPC_context.make_call1
S.manager_key
ctxt
block
(Contract.implicit_contract mgr)
()
()
let delegate ctxt block contract =
RPC_context.make_call1 S.delegate ctxt block contract () ()
let delegate_opt ctxt block contract =
RPC_context.make_opt_call1 S.delegate ctxt block contract () ()
let counter ctxt block mgr =
RPC_context.make_call1
S.counter
ctxt
block
(Contract.implicit_contract mgr)
()
()
let script ctxt block contract =
RPC_context.make_call1 S.script ctxt block contract () ()
let script_opt ctxt block contract =
RPC_context.make_opt_call1 S.script ctxt block contract () ()
let storage ctxt block contract =
RPC_context.make_call1 S.storage ctxt block contract () ()
let entrypoint_type ctxt block contract entrypoint =
RPC_context.make_call2 S.entrypoint_type ctxt block contract entrypoint () ()
let list_entrypoints ctxt block contract =
RPC_context.make_call1 S.list_entrypoints ctxt block contract () ()
let storage_opt ctxt block contract =
RPC_context.make_opt_call1 S.storage ctxt block contract () ()
let big_map_get ctxt block id key =
RPC_context.make_call2 S.big_map_get ctxt block id key () ()
let contract_big_map_get_opt ctxt block contract key =
RPC_context.make_call1 S.contract_big_map_get_opt ctxt block contract () key
src/proto_alpha/lib_protocol/contract_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Definition custom_root
: Tezos_protocol_environment_alpha__Environment.RPC_path.context
Tezos_protocol_environment_alpha__Environment.RPC_context.t :=
op_div (op_div open_root "context" % string) "contracts" % string.
Definition big_map_root
: Tezos_protocol_environment_alpha__Environment.RPC_path.context
Tezos_protocol_environment_alpha__Environment.RPC_context.t :=
op_div (op_div open_root "context" % string) "big_maps" % string.
Record info := {
balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
delegate : option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash;
counter : option Tezos_raw_protocol_alpha.Alpha_context.counter;
script : option Tezos_raw_protocol_alpha.Alpha_context.Script.t }.
Definition info_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding info :=
op_atat
(let arg :=
conv
(fun function_parameter =>
let '{|
balance := balance;
delegate := delegate;
counter := counter;
script := script
|} := function_parameter in
(balance, delegate, script, counter))
(fun function_parameter =>
let '(balance, delegate, script, counter) := function_parameter in
{| balance := balance; delegate := delegate; counter := counter;
script := script |}) in
fun eta => arg None eta)
(obj4 (req None None "balance" % string Tez.encoding)
(opt None None "delegate" % string Signature.Public_key_hash.encoding)
(opt None None "script" % string Script.encoding)
(opt None None "counter" % string n)).
Module S.
Import Data_encoding.
Definition balance
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t *
Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
RPC_service.get_service (Some "Access the balance of a contract." % string)
RPC_query.empty Tez.encoding
(op_div (op_divcolon custom_root Contract.rpc_arg) "balance" % string).
Definition manager_key
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t *
Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
(option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t) :=
RPC_service.get_service (Some "Access the manager of a contract." % string)
RPC_query.empty (option Signature.Public_key.encoding)
(op_div (op_divcolon custom_root Contract.rpc_arg) "manager_key" % string).
Definition delegate
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t *
Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t :=
RPC_service.get_service
(Some "Access the delegate of a contract, if any." % string)
RPC_query.empty Signature.Public_key_hash.encoding
(op_div (op_divcolon custom_root Contract.rpc_arg) "delegate" % string).
Definition counter
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t *
Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
Tezos_protocol_environment_alpha__Environment.Z.t :=
RPC_service.get_service
(Some "Access the counter of a contract, if any." % string)
RPC_query.empty z
(op_div (op_divcolon custom_root Contract.rpc_arg) "counter" % string).
Definition script
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t *
Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
Tezos_raw_protocol_alpha.Alpha_context.Script.t :=
RPC_service.get_service
(Some "Access the code and data of the contract." % string)
RPC_query.empty Script.encoding
(op_div (op_divcolon custom_root Contract.rpc_arg) "script" % string).
Definition storage
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t *
Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
Tezos_raw_protocol_alpha.Alpha_context.Script.expr :=
RPC_service.get_service (Some "Access the data of the contract." % string)
RPC_query.empty Script.expr_encoding
(op_div (op_divcolon custom_root Contract.rpc_arg) "storage" % string).
Definition entrypoint_type
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) * string) unit
unit Tezos_raw_protocol_alpha.Alpha_context.Script.expr :=
RPC_service.get_service
(Some "Return the type of the given entrypoint of the contract" % string)
RPC_query.empty Script.expr_encoding
(op_divcolon
(op_div (op_divcolon custom_root Contract.rpc_arg)
"entrypoints" % string) RPC_arg.string).
Definition list_entrypoints
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t *
Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
(list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr))) :=
RPC_service.get_service
(Some "Return the list of entrypoints of the contract" % string)
RPC_query.empty
(obj2
(dft None None "unreachable" % string
(Data_encoding.list None
(obj1
(req None None "path" % string
(Data_encoding.list None Michelson_v1_primitives.prim_encoding))))
[])
(req None None "entrypoints" % string (assoc Script.expr_encoding)))
(op_div (op_divcolon custom_root Contract.rpc_arg) "entrypoints" % string).
Definition contract_big_map_get_opt
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t *
Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
(option Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
RPC_service.post_service
(Some
"Access the value associated with a key in a big map of the contract (deprecated)."
% string) RPC_query.empty
(obj2 (req None None "key" % string Script.expr_encoding)
(req None None "type" % string Script.expr_encoding))
(option Script.expr_encoding)
(op_div (op_divcolon custom_root Contract.rpc_arg) "big_map_get" % string).
Definition big_map_get
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
Tezos_raw_protocol_alpha.Alpha_context.Big_map.id) *
Tezos_raw_protocol_alpha.Script_expr_hash.t) unit unit
Tezos_raw_protocol_alpha.Alpha_context.Script.expr :=
RPC_service.get_service
(Some "Access the value associated with a key in a big map." % string)
RPC_query.empty Script.expr_encoding
(op_divcolon (op_divcolon big_map_root Big_map.rpc_arg)
Script_expr_hash.rpc_arg).
Definition info
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t *
Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit info :=
RPC_service.get_service
(Some "Access the complete status of a contract." % string)
RPC_query.empty info_encoding (op_divcolon custom_root Contract.rpc_arg).
Definition list
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t unit unit
(list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) :=
RPC_service.get_service
(Some
"All existing contracts (including non-empty default contracts)." %
string) RPC_query.empty (list None Contract.encoding) custom_root.
End S.
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.list
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Contract.list ctxt) _return) in
let register_field {A : Type}
(s :
Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit A)
(f :
Tezos_raw_protocol_alpha.Alpha_context.t ->
Tezos_raw_protocol_alpha.Alpha_context.Contract.contract ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A))
: unit :=
register1 s
(fun ctxt =>
fun contract =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Contract._exists ctxt contract)
(fun function_parameter =>
match function_parameter with
| true => f ctxt contract
| false => raise OCaml.Not_found
end)) in
let register_opt_field {A : Type}
(s :
Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit A)
(f :
Tezos_raw_protocol_alpha.Alpha_context.t ->
Tezos_raw_protocol_alpha.Alpha_context.Contract.contract ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option A))) : unit :=
register_field s
(fun ctxt =>
fun a1 =>
op_gtgteqquestion (f ctxt a1)
(fun function_parameter =>
match function_parameter with
| None => raise OCaml.Not_found
| Some v => _return v
end)) in
let do_big_map_get
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (id :
Tezos_raw_protocol_alpha.Alpha_context.Big_map.id) (key :
Tezos_raw_protocol_alpha.Script_expr_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) :=
let ctxt := Gas.set_unlimited ctxt in
op_gtgteqquestion (Big_map._exists ctxt id)
(fun function_parameter =>
let '(ctxt, types) := function_parameter in
match types with
| None => raise OCaml.Not_found
| Some (_, value_type) =>
op_gtgteqquestion
(Lwt._return
(parse_ty ctxt true false false true (Micheline.root value_type)))
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty value_type,
ctxt) := function_parameter in
op_gtgteqquestion (Big_map.get_opt ctxt id key)
(fun function_parameter =>
let '(_ctxt, value) := function_parameter in
match value with
| None => raise OCaml.Not_found
| Some value =>
op_gtgteqquestion
(parse_data None ctxt true value_type
(Micheline.root value))
(fun function_parameter =>
let '(value, ctxt) := function_parameter in
op_gtgteqquestion
(unparse_data ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Readable
value_type value)
(fun function_parameter =>
let '(value, _ctxt) := function_parameter in
_return (Micheline.strip_locations value)))
end))
end) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := register_field S.balance Contract.get_balance in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.manager_key
(fun ctxt =>
fun contract =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match Contract.is_implicit contract with
| None => raise OCaml.Not_found
| Some mgr =>
op_gtgteqquestion (Contract.is_manager_key_revealed ctxt mgr)
(fun function_parameter =>
match function_parameter with
| false => return_none
| true =>
op_gtgteqquestion (Contract.get_manager_key ctxt mgr)
return_some
end)
end) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := register_opt_field S.delegate Delegate.get in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.counter
(fun ctxt =>
fun contract =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
match Contract.is_implicit contract with
| None => raise OCaml.Not_found
| Some mgr => Contract.get_counter ctxt mgr
end) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register_opt_field S.script
(fun c =>
fun v =>
op_gtgteqquestion (Contract.get_script c v)
(fun function_parameter =>
let '(_, v) := function_parameter in
_return v)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register_opt_field S.storage
(fun ctxt =>
fun contract =>
op_gtgteqquestion (Contract.get_script ctxt contract)
(fun function_parameter =>
let '(ctxt, script) := function_parameter in
match script with
| None => return_none
| Some script =>
let ctxt := Gas.set_unlimited ctxt in
op_gtgteqquestion (parse_script None ctxt true script)
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_script
script, ctxt) := function_parameter in
op_gtgteqquestion
(unparse_script ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Readable
script)
(fun function_parameter =>
let '(script, ctxt) := function_parameter in
op_gtgteqquestion
(Script.force_decode ctxt (storage script))
(fun function_parameter =>
let '(storage, _ctxt) := function_parameter in
return_some storage)))
end)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register2 S.entrypoint_type
(fun ctxt =>
fun v =>
fun entrypoint =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Contract.get_script_code ctxt v)
(fun function_parameter =>
let '(_, expr) := function_parameter in
match expr with
| None => raise OCaml.Not_found
| Some expr =>
let ctxt := Gas.set_unlimited ctxt in
let legacy := true in
op_gtgteqquestion (Script.force_decode ctxt expr)
(fun function_parameter =>
let '(expr, _) := function_parameter in
op_gtgteq
(Lwt._return
(op_gtgtquestion (parse_toplevel legacy expr)
(fun function_parameter =>
let '(arg_type, _, _, root_name) :=
function_parameter in
op_gtgtquestion
(parse_ty ctxt legacy true false true
arg_type)
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty
arg_type, _) := function_parameter in
Script_ir_translator.find_entrypoint
arg_type root_name entrypoint))))
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
(_f,
Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty
ty) =>
op_gtgteqquestion (unparse_ty ctxt ty)
(fun function_parameter =>
let '(ty_node, _) := function_parameter in
_return (Micheline.strip_locations ty_node))
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ => raise OCaml.Not_found
end))
end)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.list_entrypoints
(fun ctxt =>
fun v =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Contract.get_script_code ctxt v)
(fun function_parameter =>
let '(_, expr) := function_parameter in
match expr with
| None => raise OCaml.Not_found
| Some expr =>
let ctxt := Gas.set_unlimited ctxt in
let legacy := true in
op_gtgteqquestion (Script.force_decode ctxt expr)
(fun function_parameter =>
let '(expr, _) := function_parameter in
op_gtgteqquestion
(Lwt._return
(op_gtgtquestion (parse_toplevel legacy expr)
(fun function_parameter =>
let '(arg_type, _, _, root_name) :=
function_parameter in
op_gtgtquestion
(parse_ty ctxt legacy true false true arg_type)
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty
arg_type, _) := function_parameter in
Script_ir_translator.list_entrypoints
arg_type ctxt root_name))))
(fun function_parameter =>
let '(unreachable_entrypoint, map) :=
function_parameter in
_return
(unreachable_entrypoint,
(Entrypoints_map.fold
(fun entry =>
fun function_parameter =>
let '(_, ty) := function_parameter in
fun acc =>
cons
(entry, (Micheline.strip_locations ty))
acc) map []))))
end)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.contract_big_map_get_opt
(fun ctxt =>
fun contract =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(key, key_type) := function_parameter in
op_gtgteqquestion (Contract.get_script ctxt contract)
(fun function_parameter =>
let '(ctxt, script) := function_parameter in
op_gtgteqquestion
(Lwt._return
(Script_ir_translator.parse_packable_ty ctxt true
(Micheline.root key_type)))
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty
key_type, ctxt) := function_parameter in
op_gtgteqquestion
(Script_ir_translator.parse_data None ctxt true key_type
(Micheline.root key))
(fun function_parameter =>
let '(key, ctxt) := function_parameter in
op_gtgteqquestion
(Script_ir_translator.hash_data ctxt key_type key)
(fun function_parameter =>
let '(key, ctxt) := function_parameter in
match script with
| None => raise OCaml.Not_found
| Some script =>
let ctxt := Gas.set_unlimited ctxt in
op_gtgteqquestion
(parse_script None ctxt true script)
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_script
script, ctxt) := function_parameter in
op_gtgteqquestion
(Script_ir_translator.collect_big_maps
ctxt (storage_type script)
(storage script))
(fun function_parameter =>
let '(ids, _ctxt) := function_parameter
in
let ids :=
Script_ir_translator.list_of_big_map_ids
ids in
let fix find
(function_parameter :
list
Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option
(Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_raw_protocol_alpha.Alpha_context.Script.prim))) :=
match function_parameter with
| [] => return_none
| cons (_ as id) ids =>
(* ❌ Try-with are not handled *)
try
(op_gtgteqquestion
(do_big_map_get ctxt id key)
return_some)
end in
find ids))
end))))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register2 S.big_map_get
(fun ctxt =>
fun id =>
fun key =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
do_big_map_get ctxt id key) in
register_field S.info
(fun ctxt =>
fun contract =>
op_gtgteqquestion (Contract.get_balance ctxt contract)
(fun balance =>
op_gtgteqquestion (Delegate.get ctxt contract)
(fun delegate =>
op_gtgteqquestion
match Contract.is_implicit contract with
| Some manager =>
op_gtgteqquestion (Contract.get_counter ctxt manager)
(fun counter => return_some counter)
| None => _return None
end
(fun counter =>
op_gtgteqquestion (Contract.get_script ctxt contract)
(fun function_parameter =>
let '(ctxt, script) := function_parameter in
op_gtgteqquestion
match script with
| None => _return (None, ctxt)
| Some script =>
let ctxt := Gas.set_unlimited ctxt in
op_gtgteqquestion
(parse_script None ctxt true script)
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_script
script, ctxt) := function_parameter in
op_gtgteqquestion
(unparse_script ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Readable
script)
(fun function_parameter =>
let '(script, ctxt) := function_parameter in
_return ((Some script), ctxt)))
end
(fun function_parameter =>
let '(script, _ctxt) := function_parameter in
_return
{| balance := balance; delegate := delegate;
counter := counter; script := script |})))))).
Definition list {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(list Tezos_raw_protocol_alpha.Alpha_context.Contract.t)) :=
RPC_context.make_call0 S.list ctxt block tt tt.
Definition info {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
info) := RPC_context.make_call1 S.info ctxt block contract tt tt.
Definition balance {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
RPC_context.make_call1 S.balance ctxt block contract tt tt.
Definition manager_key {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D) (mgr : Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)) :=
RPC_context.make_call1 S.manager_key ctxt block
(Contract.implicit_contract mgr) tt tt.
Definition delegate {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t) :=
RPC_context.make_call1 S.delegate ctxt block contract tt tt.
Definition delegate_opt {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
RPC_context.make_opt_call1 S.delegate ctxt block contract tt tt.
Definition counter {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D) (mgr : Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_environment_alpha__Environment.Z.t) :=
RPC_context.make_call1 S.counter ctxt block (Contract.implicit_contract mgr)
tt tt.
Definition script {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Script.t) :=
RPC_context.make_call1 S.script ctxt block contract tt tt.
Definition script_opt {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(option Tezos_raw_protocol_alpha.Alpha_context.Script.t)) :=
RPC_context.make_opt_call1 S.script ctxt block contract tt tt.
Definition storage {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
RPC_context.make_call1 S.storage ctxt block contract tt tt.
Definition entrypoint_type {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
(entrypoint : string)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
RPC_context.make_call2 S.entrypoint_type ctxt block contract entrypoint tt tt.
Definition list_entrypoints {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
(list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr)))) :=
RPC_context.make_call1 S.list_entrypoints ctxt block contract tt tt.
Definition storage_opt {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
RPC_context.make_opt_call1 S.storage ctxt block contract tt tt.
Definition big_map_get {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D) (id : Tezos_raw_protocol_alpha.Alpha_context.Big_map.id)
(key : Tezos_raw_protocol_alpha.Script_expr_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
RPC_context.make_call2 S.big_map_get ctxt block id key tt tt.
Definition contract_big_map_get_opt {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
(key :
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
RPC_context.make_call1 S.contract_big_map_get_opt ctxt block contract tt key.
src/proto_alpha/lib_protocol/contract_storage.ml 213 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type error +=
| Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t
| (* `Temporary *)
Counter_in_the_past of Contract_repr.contract * Z.t * Z.t
| (* `Branch *)
Counter_in_the_future of Contract_repr.contract * Z.t * Z.t
| (* `Temporary *)
Unspendable_contract of Contract_repr.contract
| (* `Permanent *)
Non_existing_contract of Contract_repr.contract
| (* `Temporary *)
Empty_implicit_contract of Signature.Public_key_hash.t
| (* `Temporary *)
Empty_transaction of Contract_repr.t (* `Temporary *)
| Inconsistent_hash of
Signature.Public_key.t
* Signature.Public_key_hash.t
* Signature.Public_key_hash.t
| (* `Permanent *)
Inconsistent_public_key of
Signature.Public_key.t * Signature.Public_key.t
| (* `Permanent *)
Failure of string (* `Permanent *)
| Previously_revealed_key of Contract_repr.t (* `Permanent *)
| Unrevealed_manager_key of Contract_repr.t
(* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"contract.unspendable_contract"
~title:"Unspendable contract"
~description:
"An operation tried to spend tokens from an unspendable contract"
~pp:(fun ppf c ->
Format.fprintf
ppf
"The tokens of contract %a can only be spent by its script"
Contract_repr.pp
c)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Unspendable_contract c -> Some c | _ -> None)
(fun c -> Unspendable_contract c) ;
register_error_kind
`Temporary
~id:"contract.balance_too_low"
~title:"Balance too low"
~description:
"An operation tried to spend more tokens than the contract has"
~pp:(fun ppf (c, b, a) ->
Format.fprintf
ppf
"Balance of contract %a too low (%a) to spend %a"
Contract_repr.pp
c
Tez_repr.pp
b
Tez_repr.pp
a)
Data_encoding.(
obj3
(req "contract" Contract_repr.encoding)
(req "balance" Tez_repr.encoding)
(req "amount" Tez_repr.encoding))
(function Balance_too_low (c, b, a) -> Some (c, b, a) | _ -> None)
(fun (c, b, a) -> Balance_too_low (c, b, a)) ;
register_error_kind
`Temporary
~id:"contract.counter_in_the_future"
~title:"Invalid counter (not yet reached) in a manager operation"
~description:"An operation assumed a contract counter in the future"
~pp:(fun ppf (contract, exp, found) ->
Format.fprintf
ppf
"Counter %s not yet reached for contract %a (expected %s)"
(Z.to_string found)
Contract_repr.pp
contract
(Z.to_string exp))
Data_encoding.(
obj3
(req "contract" Contract_repr.encoding)
(req "expected" z)
(req "found" z))
(function Counter_in_the_future (c, x, y) -> Some (c, x, y) | _ -> None)
(fun (c, x, y) -> Counter_in_the_future (c, x, y)) ;
register_error_kind
`Branch
~id:"contract.counter_in_the_past"
~title:"Invalid counter (already used) in a manager operation"
~description:"An operation assumed a contract counter in the past"
~pp:(fun ppf (contract, exp, found) ->
Format.fprintf
ppf
"Counter %s already used for contract %a (expected %s)"
(Z.to_string found)
Contract_repr.pp
contract
(Z.to_string exp))
Data_encoding.(
obj3
(req "contract" Contract_repr.encoding)
(req "expected" z)
(req "found" z))
(function Counter_in_the_past (c, x, y) -> Some (c, x, y) | _ -> None)
(fun (c, x, y) -> Counter_in_the_past (c, x, y)) ;
register_error_kind
`Temporary
~id:"contract.non_existing_contract"
~title:"Non existing contract"
~description:
"A contract handle is not present in the context (either it never was \
or it has been destroyed)"
~pp:(fun ppf contract ->
Format.fprintf ppf "Contract %a does not exist" Contract_repr.pp contract)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Non_existing_contract c -> Some c | _ -> None)
(fun c -> Non_existing_contract c) ;
register_error_kind
`Permanent
~id:"contract.manager.inconsistent_hash"
~title:"Inconsistent public key hash"
~description:
"A revealed manager public key is inconsistent with the announced hash"
~pp:(fun ppf (k, eh, ph) ->
Format.fprintf
ppf
"The hash of the manager public key %s is not %a as announced but %a"
(Signature.Public_key.to_b58check k)
Signature.Public_key_hash.pp
ph
Signature.Public_key_hash.pp
eh)
Data_encoding.(
obj3
(req "public_key" Signature.Public_key.encoding)
(req "expected_hash" Signature.Public_key_hash.encoding)
(req "provided_hash" Signature.Public_key_hash.encoding))
(function Inconsistent_hash (k, eh, ph) -> Some (k, eh, ph) | _ -> None)
(fun (k, eh, ph) -> Inconsistent_hash (k, eh, ph)) ;
register_error_kind
`Permanent
~id:"contract.manager.inconsistent_public_key"
~title:"Inconsistent public key"
~description:
"A provided manager public key is different with the public key stored \
in the contract"
~pp:(fun ppf (eh, ph) ->
Format.fprintf
ppf
"Expected manager public key %s but %s was provided"
(Signature.Public_key.to_b58check ph)
(Signature.Public_key.to_b58check eh))
Data_encoding.(
obj2
(req "public_key" Signature.Public_key.encoding)
(req "expected_public_key" Signature.Public_key.encoding))
(function Inconsistent_public_key (eh, ph) -> Some (eh, ph) | _ -> None)
(fun (eh, ph) -> Inconsistent_public_key (eh, ph)) ;
register_error_kind
`Permanent
~id:"contract.failure"
~title:"Contract storage failure"
~description:"Unexpected contract storage error"
~pp:(fun ppf s -> Format.fprintf ppf "Contract_storage.Failure %S" s)
Data_encoding.(obj1 (req "message" string))
(function Failure s -> Some s | _ -> None)
(fun s -> Failure s) ;
register_error_kind
`Branch
~id:"contract.unrevealed_key"
~title:"Manager operation precedes key revelation"
~description:
"One tried to apply a manager operation without revealing the manager \
public key"
~pp:(fun ppf s ->
Format.fprintf
ppf
"Unrevealed manager key for contract %a."
Contract_repr.pp
s)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Unrevealed_manager_key s -> Some s | _ -> None)
(fun s -> Unrevealed_manager_key s) ;
register_error_kind
`Branch
~id:"contract.previously_revealed_key"
~title:"Manager operation already revealed"
~description:"One tried to revealed twice a manager public key"
~pp:(fun ppf s ->
Format.fprintf
ppf
"Previously revealed manager key for contract %a."
Contract_repr.pp
s)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Previously_revealed_key s -> Some s | _ -> None)
(fun s -> Previously_revealed_key s) ;
register_error_kind
`Branch
~id:"implicit.empty_implicit_contract"
~title:"Empty implicit contract"
~description:
"No manager operations are allowed on an empty implicit contract."
~pp:(fun ppf implicit ->
Format.fprintf
ppf
"Empty implicit contract (%a)"
Signature.Public_key_hash.pp
implicit)
Data_encoding.(obj1 (req "implicit" Signature.Public_key_hash.encoding))
(function Empty_implicit_contract c -> Some c | _ -> None)
(fun c -> Empty_implicit_contract c) ;
register_error_kind
`Branch
~id:"contract.empty_transaction"
~title:"Empty transaction"
~description:"Forbidden to credit 0ê© to a contract without code."
~pp:(fun ppf contract ->
Format.fprintf
ppf
"Transaction of 0ê© towards a contract without code are forbidden \
(%a)."
Contract_repr.pp
contract)
Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
(function Empty_transaction c -> Some c | _ -> None)
(fun c -> Empty_transaction c)
let failwith msg = fail (Failure msg)
type big_map_diff_item =
| Update of {
big_map : Z.t;
diff_key : Script_repr.expr;
diff_key_hash : Script_expr_hash.t;
diff_value : Script_repr.expr option;
}
| Clear of Z.t
| Copy of Z.t * Z.t
| Alloc of {
big_map : Z.t;
key_type : Script_repr.expr;
value_type : Script_repr.expr;
}
type big_map_diff = big_map_diff_item list
let big_map_diff_item_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"update"
(obj5
(req "action" (constant "update"))
(req "big_map" z)
(req "key_hash" Script_expr_hash.encoding)
(req "key" Script_repr.expr_encoding)
(opt "value" Script_repr.expr_encoding))
(function
| Update {big_map; diff_key_hash; diff_key; diff_value} ->
Some ((), big_map, diff_key_hash, diff_key, diff_value)
| _ ->
None)
(fun ((), big_map, diff_key_hash, diff_key, diff_value) ->
Update {big_map; diff_key_hash; diff_key; diff_value});
case
(Tag 1)
~title:"remove"
(obj2 (req "action" (constant "remove")) (req "big_map" z))
(function Clear big_map -> Some ((), big_map) | _ -> None)
(fun ((), big_map) -> Clear big_map);
case
(Tag 2)
~title:"copy"
(obj3
(req "action" (constant "copy"))
(req "source_big_map" z)
(req "destination_big_map" z))
(function Copy (src, dst) -> Some ((), src, dst) | _ -> None)
(fun ((), src, dst) -> Copy (src, dst));
case
(Tag 3)
~title:"alloc"
(obj4
(req "action" (constant "alloc"))
(req "big_map" z)
(req "key_type" Script_repr.expr_encoding)
(req "value_type" Script_repr.expr_encoding))
(function
| Alloc {big_map; key_type; value_type} ->
Some ((), big_map, key_type, value_type)
| _ ->
None)
(fun ((), big_map, key_type, value_type) ->
Alloc {big_map; key_type; value_type}) ]
let big_map_diff_encoding =
let open Data_encoding in
def "contract.big_map_diff" @@ list big_map_diff_item_encoding
let big_map_key_cost = 65
let big_map_cost = 33
let update_script_big_map c = function
| None ->
return (c, Z.zero)
| Some diff ->
fold_left_s
(fun (c, total) -> function Clear id ->
Storage.Big_map.Total_bytes.get c id
>>=? fun size ->
Storage.Big_map.remove_rec c id
>>= fun c ->
if Compare.Z.(id < Z.zero) then return (c, total)
else return (c, Z.sub (Z.sub total size) (Z.of_int big_map_cost))
| Copy (from, to_) ->
Storage.Big_map.copy c ~from ~to_
>>=? fun c ->
if Compare.Z.(to_ < Z.zero) then return (c, total)
else
Storage.Big_map.Total_bytes.get c from
>>=? fun size ->
return (c, Z.add (Z.add total size) (Z.of_int big_map_cost))
| Alloc {big_map; key_type; value_type} ->
Storage.Big_map.Total_bytes.init c big_map Z.zero
>>=? fun c ->
(* Annotations are erased to allow sharing on
[Copy]. The types from the contract code are used,
these ones are only used to make sure they are
compatible during transmissions between contracts,
and only need to be compatible, annotations
nonwhistanding. *)
let key_type =
Micheline.strip_locations
(Script_repr.strip_annotations (Micheline.root key_type))
in
let value_type =
Micheline.strip_locations
(Script_repr.strip_annotations (Micheline.root value_type))
in
Storage.Big_map.Key_type.init c big_map key_type
>>=? fun c ->
Storage.Big_map.Value_type.init c big_map value_type
>>=? fun c ->
if Compare.Z.(big_map < Z.zero) then return (c, total)
else return (c, Z.add total (Z.of_int big_map_cost))
| Update {big_map; diff_key_hash; diff_value = None} ->
Storage.Big_map.Contents.remove (c, big_map) diff_key_hash
>>=? fun (c, freed, existed) ->
let freed =
if existed then freed + big_map_key_cost else freed
in
Storage.Big_map.Total_bytes.get c big_map
>>=? fun size ->
Storage.Big_map.Total_bytes.set
c
big_map
(Z.sub size (Z.of_int freed))
>>=? fun c ->
if Compare.Z.(big_map < Z.zero) then return (c, total)
else return (c, Z.sub total (Z.of_int freed))
| Update {big_map; diff_key_hash; diff_value = Some v} ->
Storage.Big_map.Contents.init_set (c, big_map) diff_key_hash v
>>=? fun (c, size_diff, existed) ->
let size_diff =
if existed then size_diff else size_diff + big_map_key_cost
in
Storage.Big_map.Total_bytes.get c big_map
>>=? fun size ->
Storage.Big_map.Total_bytes.set
c
big_map
(Z.add size (Z.of_int size_diff))
>>=? fun c ->
if Compare.Z.(big_map < Z.zero) then return (c, total)
else return (c, Z.add total (Z.of_int size_diff)))
(c, Z.zero)
diff
let create_base c ?(prepaid_bootstrap_storage = false)
(* Free space for bootstrap contracts *)
contract ~balance ~manager ~delegate ?script () =
( match Contract_repr.is_implicit contract with
| None ->
return c
| Some _ ->
Storage.Contract.Global_counter.get c
>>=? fun counter -> Storage.Contract.Counter.init c contract counter )
>>=? fun c ->
Storage.Contract.Balance.init c contract balance
>>=? fun c ->
( match manager with
| Some manager ->
Storage.Contract.Manager.init c contract (Manager_repr.Hash manager)
| None ->
return c )
>>=? fun c ->
( match delegate with
| None ->
return c
| Some delegate ->
Delegate_storage.init c contract delegate )
>>=? fun c ->
match script with
| Some ({Script_repr.code; storage}, big_map_diff) ->
Storage.Contract.Code.init c contract code
>>=? fun (c, code_size) ->
Storage.Contract.Storage.init c contract storage
>>=? fun (c, storage_size) ->
update_script_big_map c big_map_diff
>>=? fun (c, big_map_size) ->
let total_size =
Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size
in
assert (Compare.Z.(total_size >= Z.zero)) ;
let prepaid_bootstrap_storage =
if prepaid_bootstrap_storage then total_size else Z.zero
in
Storage.Contract.Paid_storage_space.init
c
contract
prepaid_bootstrap_storage
>>=? fun c ->
Storage.Contract.Used_storage_space.init c contract total_size
| None ->
return c
let originate c ?prepaid_bootstrap_storage contract ~balance ~script ~delegate
=
create_base
c
?prepaid_bootstrap_storage
contract
~balance
~manager:None
~delegate
~script
()
let create_implicit c manager ~balance =
create_base
c
(Contract_repr.implicit_contract manager)
~balance
~manager:(Some manager)
?script:None
~delegate:None
()
let delete c contract =
match Contract_repr.is_implicit contract with
| None ->
(* For non implicit contract Big_map should be cleared *)
failwith "Non implicit contracts cannot be removed"
| Some _ ->
Delegate_storage.remove c contract
>>=? fun c ->
Storage.Contract.Balance.delete c contract
>>=? fun c ->
Storage.Contract.Manager.delete c contract
>>=? fun c ->
Storage.Contract.Counter.delete c contract
>>=? fun c ->
Storage.Contract.Code.remove c contract
>>=? fun (c, _, _) ->
Storage.Contract.Storage.remove c contract
>>=? fun (c, _, _) ->
Storage.Contract.Paid_storage_space.remove c contract
>>= fun c ->
Storage.Contract.Used_storage_space.remove c contract
>>= fun c -> return c
let allocated c contract =
Storage.Contract.Balance.get_option c contract
>>=? function None -> return_false | Some _ -> return_true
let exists c contract =
match Contract_repr.is_implicit contract with
| Some _ ->
return_true
| None ->
allocated c contract
let must_exist c contract =
exists c contract
>>=? function
| true -> return_unit | false -> fail (Non_existing_contract contract)
let must_be_allocated c contract =
allocated c contract
>>=? function
| true ->
return_unit
| false -> (
match Contract_repr.is_implicit contract with
| Some pkh ->
fail (Empty_implicit_contract pkh)
| None ->
fail (Non_existing_contract contract) )
let list c = Storage.Contract.list c
let fresh_contract_from_current_nonce c =
Lwt.return (Raw_context.increment_origination_nonce c)
>>=? fun (c, nonce) -> return (c, Contract_repr.originated_contract nonce)
let originated_from_current_nonce ~since:ctxt_since ~until:ctxt_until =
Lwt.return (Raw_context.origination_nonce ctxt_since)
>>=? fun since ->
Lwt.return (Raw_context.origination_nonce ctxt_until)
>>=? fun until ->
filter_map_s
(fun contract ->
exists ctxt_until contract
>>=? function true -> return_some contract | false -> return_none)
(Contract_repr.originated_contracts ~since ~until)
let check_counter_increment c manager counter =
let contract = Contract_repr.implicit_contract manager in
Storage.Contract.Counter.get c contract
>>=? fun contract_counter ->
let expected = Z.succ contract_counter in
if Compare.Z.(expected = counter) then return_unit
else if Compare.Z.(expected > counter) then
fail (Counter_in_the_past (contract, expected, counter))
else fail (Counter_in_the_future (contract, expected, counter))
let increment_counter c manager =
let contract = Contract_repr.implicit_contract manager in
Storage.Contract.Global_counter.get c
>>=? fun global_counter ->
Storage.Contract.Global_counter.set c (Z.succ global_counter)
>>=? fun c ->
Storage.Contract.Counter.get c contract
>>=? fun contract_counter ->
Storage.Contract.Counter.set c contract (Z.succ contract_counter)
let get_script_code c contract = Storage.Contract.Code.get_option c contract
let get_script c contract =
Storage.Contract.Code.get_option c contract
>>=? fun (c, code) ->
Storage.Contract.Storage.get_option c contract
>>=? fun (c, storage) ->
match (code, storage) with
| (None, None) ->
return (c, None)
| (Some code, Some storage) ->
return (c, Some {Script_repr.code; storage})
| (None, Some _) | (Some _, None) ->
failwith "get_script"
let get_storage ctxt contract =
Storage.Contract.Storage.get_option ctxt contract
>>=? function
| (ctxt, None) ->
return (ctxt, None)
| (ctxt, Some storage) ->
Lwt.return (Script_repr.force_decode storage)
>>=? fun (storage, cost) ->
Lwt.return (Raw_context.consume_gas ctxt cost)
>>=? fun ctxt -> return (ctxt, Some storage)
let get_counter c manager =
let contract = Contract_repr.implicit_contract manager in
Storage.Contract.Counter.get_option c contract
>>=? function
| None -> (
match Contract_repr.is_implicit contract with
| Some _ ->
Storage.Contract.Global_counter.get c
| None ->
failwith "get_counter" )
| Some v ->
return v
let get_manager_key c manager =
let contract = Contract_repr.implicit_contract manager in
Storage.Contract.Manager.get_option c contract
>>=? function
| None ->
failwith "get_manager_key"
| Some (Manager_repr.Hash _) ->
fail (Unrevealed_manager_key contract)
| Some (Manager_repr.Public_key v) ->
return v
let is_manager_key_revealed c manager =
let contract = Contract_repr.implicit_contract manager in
Storage.Contract.Manager.get_option c contract
>>=? function
| None ->
return_false
| Some (Manager_repr.Hash _) ->
return_false
| Some (Manager_repr.Public_key _) ->
return_true
let reveal_manager_key c manager public_key =
let contract = Contract_repr.implicit_contract manager in
Storage.Contract.Manager.get c contract
>>=? function
| Public_key _ ->
fail (Previously_revealed_key contract)
| Hash v ->
let actual_hash = Signature.Public_key.hash public_key in
if Signature.Public_key_hash.equal actual_hash v then
let v = Manager_repr.Public_key public_key in
Storage.Contract.Manager.set c contract v >>=? fun c -> return c
else fail (Inconsistent_hash (public_key, v, actual_hash))
let get_balance c contract =
Storage.Contract.Balance.get_option c contract
>>=? function
| None -> (
match Contract_repr.is_implicit contract with
| Some _ ->
return Tez_repr.zero
| None ->
failwith "get_balance" )
| Some v ->
return v
let update_script_storage c contract storage big_map_diff =
let storage = Script_repr.lazy_expr storage in
update_script_big_map c big_map_diff
>>=? fun (c, big_map_size_diff) ->
Storage.Contract.Storage.set c contract storage
>>=? fun (c, size_diff) ->
Storage.Contract.Used_storage_space.get c contract
>>=? fun previous_size ->
let new_size =
Z.add previous_size (Z.add big_map_size_diff (Z.of_int size_diff))
in
Storage.Contract.Used_storage_space.set c contract new_size
let spend c contract amount =
Storage.Contract.Balance.get c contract
>>=? fun balance ->
match Tez_repr.(balance -? amount) with
| Error _ ->
fail (Balance_too_low (contract, balance, amount))
| Ok new_balance -> (
Storage.Contract.Balance.set c contract new_balance
>>=? fun c ->
Roll_storage.Contract.remove_amount c contract amount
>>=? fun c ->
if Tez_repr.(new_balance > Tez_repr.zero) then return c
else
match Contract_repr.is_implicit contract with
| None ->
return c (* Never delete originated contracts *)
| Some pkh -> (
Delegate_storage.get c contract
>>=? function
| Some pkh' ->
(* Don't delete "delegate" contract *)
assert (Signature.Public_key_hash.equal pkh pkh') ;
return c
| None ->
(* Delete empty implicit contract *)
delete c contract ) )
let credit c contract amount =
( if Tez_repr.(amount <> Tez_repr.zero) then return c
else
Storage.Contract.Code.mem c contract
>>=? fun (c, target_has_code) ->
fail_unless target_has_code (Empty_transaction contract)
>>=? fun () -> return c )
>>=? fun c ->
Storage.Contract.Balance.get_option c contract
>>=? function
| None -> (
match Contract_repr.is_implicit contract with
| None ->
fail (Non_existing_contract contract)
| Some manager ->
create_implicit c manager ~balance:amount )
| Some balance ->
Lwt.return Tez_repr.(amount +? balance)
>>=? fun balance ->
Storage.Contract.Balance.set c contract balance
>>=? fun c -> Roll_storage.Contract.add_amount c contract amount
let init c = Storage.Contract.Global_counter.init c Z.zero
let used_storage_space c contract =
Storage.Contract.Used_storage_space.get_option c contract
>>=? function None -> return Z.zero | Some fees -> return fees
let paid_storage_space c contract =
Storage.Contract.Paid_storage_space.get_option c contract
>>=? function None -> return Z.zero | Some paid_space -> return paid_space
let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space
=
Storage.Contract.Paid_storage_space.get c contract
>>=? fun already_paid_space ->
if Compare.Z.(already_paid_space >= new_storage_space) then return (Z.zero, c)
else
let to_pay = Z.sub new_storage_space already_paid_space in
Storage.Contract.Paid_storage_space.set c contract new_storage_space
>>=? fun c -> return (to_pay, c)
src/proto_alpha/lib_protocol/contract_storage.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition failwith {A : Type} (msg : string)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
fail (Tezos_protocol_environment_alpha__Environment.Error_monad.Failure msg).
Inductive big_map_diff_item : Type :=
| Update : Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_raw_protocol_alpha.Script_repr.expr ->
Tezos_raw_protocol_alpha.Script_expr_hash.t ->
(option Tezos_raw_protocol_alpha.Script_repr.expr) -> big_map_diff_item
| Clear : Tezos_protocol_environment_alpha__Environment.Z.t -> big_map_diff_item
| Copy : Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t -> big_map_diff_item
| Alloc : Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_raw_protocol_alpha.Script_repr.expr ->
Tezos_raw_protocol_alpha.Script_repr.expr -> big_map_diff_item.
Definition big_map_diff := list big_map_diff_item.
Definition big_map_diff_item_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
big_map_diff_item :=
union None
(cons
(case "update" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
(obj5 (req None None "action" % string (constant "update" % string))
(req None None "big_map" % string z)
(req None None "key_hash" % string Script_expr_hash.encoding)
(req None None "key" % string Script_repr.expr_encoding)
(opt None None "value" % string Script_repr.expr_encoding))
(fun function_parameter =>
match function_parameter with
|
Update {|
big_map := big_map;
diff_key := diff_key;
diff_key_hash := diff_key_hash;
diff_value := diff_value
|} => Some (tt, big_map, diff_key_hash, diff_key, diff_value)
| _ => None
end)
(fun function_parameter =>
let '(tt, big_map, diff_key_hash, diff_key, diff_value) :=
function_parameter in
Update
{| big_map := big_map; diff_key := diff_key;
diff_key_hash := diff_key_hash; diff_value := diff_value |}))
(cons
(case "remove" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
(obj2 (req None None "action" % string (constant "remove" % string))
(req None None "big_map" % string z))
(fun function_parameter =>
match function_parameter with
| Clear big_map => Some (tt, big_map)
| _ => None
end)
(fun function_parameter =>
let '(tt, big_map) := function_parameter in
Clear big_map))
(cons
(case "copy" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 2)
(obj3 (req None None "action" % string (constant "copy" % string))
(req None None "source_big_map" % string z)
(req None None "destination_big_map" % string z))
(fun function_parameter =>
match function_parameter with
| Copy src dst => Some (tt, src, dst)
| _ => None
end)
(fun function_parameter =>
let '(tt, src, dst) := function_parameter in
Copy src dst))
(cons
(case "alloc" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 3)
(obj4
(req None None "action" % string (constant "alloc" % string))
(req None None "big_map" % string z)
(req None None "key_type" % string Script_repr.expr_encoding)
(req None None "value_type" % string Script_repr.expr_encoding))
(fun function_parameter =>
match function_parameter with
|
Alloc {|
big_map := big_map;
key_type := key_type;
value_type := value_type
|} => Some (tt, big_map, key_type, value_type)
| _ => None
end)
(fun function_parameter =>
let '(tt, big_map, key_type, value_type) := function_parameter
in
Alloc
{| big_map := big_map; key_type := key_type;
value_type := value_type |})) [])))).
Definition big_map_diff_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(list big_map_diff_item) :=
op_atat
(let arg := def "contract.big_map_diff" % string in
fun eta => arg None None eta) (list None big_map_diff_item_encoding).
Definition big_map_key_cost : Z := 65.
Definition big_map_cost : Z := 33.
Definition update_script_big_map
(c : Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.context)
(function_parameter : option (list big_map_diff_item))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.context *
Tezos_protocol_environment_alpha__Environment.Z.t)) :=
match function_parameter with
| None => _return (c, Z.zero)
| Some diff =>
fold_left_s
(fun function_parameter =>
let '(c, total) := function_parameter in
fun function_parameter =>
match function_parameter with
| Clear id =>
op_gtgteqquestion (Storage.Big_map.Total_bytes.get c id)
(fun size =>
op_gtgteq (Storage.Big_map.remove_rec c id)
(fun c =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
id Z.zero then
_return (c, total)
else
_return
(c, (Z.sub (Z.sub total size) (Z.of_int big_map_cost)))))
| Copy from to_ =>
op_gtgteqquestion (Storage.Big_map.copy c from to_)
(fun c =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
to_ Z.zero then
_return (c, total)
else
op_gtgteqquestion (Storage.Big_map.Total_bytes.get c from)
(fun size =>
_return
(c, (Z.add (Z.add total size) (Z.of_int big_map_cost)))))
|
Alloc {|
big_map := big_map;
key_type := key_type;
value_type := value_type
|} =>
op_gtgteqquestion
(Storage.Big_map.Total_bytes.init c big_map Z.zero)
(fun c =>
let key_type :=
Micheline.strip_locations
(Script_repr.strip_annotations (Micheline.root key_type)) in
let value_type :=
Micheline.strip_locations
(Script_repr.strip_annotations (Micheline.root value_type))
in
op_gtgteqquestion
(Storage.Big_map.Key_type.init c big_map key_type)
(fun c =>
op_gtgteqquestion
(Storage.Big_map.Value_type.init c big_map value_type)
(fun c =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
big_map Z.zero then
_return (c, total)
else
_return (c, (Z.add total (Z.of_int big_map_cost))))))
|
Update {|
big_map := big_map;
diff_key_hash := diff_key_hash;
diff_value := None
|} =>
op_gtgteqquestion
(Storage.Big_map.Contents.remove (c, big_map) diff_key_hash)
(fun function_parameter =>
let '(c, freed, existed) := function_parameter in
let freed :=
if existed then
op_plus freed big_map_key_cost
else
freed in
op_gtgteqquestion (Storage.Big_map.Total_bytes.get c big_map)
(fun size =>
op_gtgteqquestion
(Storage.Big_map.Total_bytes.set c big_map
(Z.sub size (Z.of_int freed)))
(fun c =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
big_map Z.zero then
_return (c, total)
else
_return (c, (Z.sub total (Z.of_int freed))))))
|
Update {|
big_map := big_map;
diff_key_hash := diff_key_hash;
diff_value := Some v
|} =>
op_gtgteqquestion
(Storage.Big_map.Contents.init_set (c, big_map) diff_key_hash v)
(fun function_parameter =>
let '(c, size_diff, existed) := function_parameter in
let size_diff :=
if existed then
size_diff
else
op_plus size_diff big_map_key_cost in
op_gtgteqquestion (Storage.Big_map.Total_bytes.get c big_map)
(fun size =>
op_gtgteqquestion
(Storage.Big_map.Total_bytes.set c big_map
(Z.add size (Z.of_int size_diff)))
(fun c =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
big_map Z.zero then
_return (c, total)
else
_return (c, (Z.add total (Z.of_int size_diff))))))
end) (c, Z.zero) diff
end.
Definition create_base
(c : Tezos_raw_protocol_alpha.Raw_context.t) (op_staroptstar : option bool)
: Tezos_raw_protocol_alpha.Contract_repr.contract ->
Tezos_raw_protocol_alpha.Storage.Contract.Balance.value ->
(option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
->
(option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
->
(option
(Tezos_raw_protocol_alpha.Script_repr.t *
(option (list big_map_diff_item)))) ->
unit ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let prepaid_bootstrap_storage :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun contract =>
fun balance =>
fun manager =>
fun delegate =>
fun script =>
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
match Contract_repr.is_implicit contract with
| None => _return c
| Some _ =>
op_gtgteqquestion (Storage.Contract.Global_counter.get c)
(fun counter =>
Storage.Contract.Counter.init c contract counter)
end
(fun c =>
op_gtgteqquestion
(Storage.Contract.Balance.init c contract balance)
(fun c =>
op_gtgteqquestion
match manager with
| Some manager =>
Storage.Contract.Manager.init c contract
(Tezos_raw_protocol_alpha.Manager_repr.Hash manager)
| None => _return c
end
(fun c =>
op_gtgteqquestion
match delegate with
| None => _return c
| Some delegate =>
Delegate_storage.init c contract delegate
end
(fun c =>
match script with
|
Some
({|
Script_repr.code := code;
Script_repr.storage := storage
|}, big_map_diff) =>
op_gtgteqquestion
(Storage.Contract.Code.init c contract code)
(fun function_parameter =>
let '(c, code_size) := function_parameter in
op_gtgteqquestion
(Storage.Contract.Storage.init c contract
storage)
(fun function_parameter =>
let '(c, storage_size) :=
function_parameter in
op_gtgteqquestion
(update_script_big_map c big_map_diff)
(fun function_parameter =>
let '(c, big_map_size) :=
function_parameter in
let total_size :=
Z.add
(Z.add (Z.of_int code_size)
(Z.of_int storage_size))
big_map_size in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
total_size Z.zero) in
let prepaid_bootstrap_storage :=
if prepaid_bootstrap_storage then
total_size
else
Z.zero in
op_gtgteqquestion
(Storage.Contract.Paid_storage_space.init
c contract
prepaid_bootstrap_storage)
(fun c =>
Storage.Contract.Used_storage_space.init
c contract total_size))))
| None => _return c
end)))).
Definition originate
(c : Tezos_raw_protocol_alpha.Raw_context.t)
(prepaid_bootstrap_storage : option bool)
(contract : Tezos_raw_protocol_alpha.Contract_repr.contract)
(balance : Tezos_raw_protocol_alpha.Storage.Contract.Balance.value)
(script :
Tezos_raw_protocol_alpha.Script_repr.t * (option (list big_map_diff_item)))
(delegate :
option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
create_base c prepaid_bootstrap_storage contract balance None delegate
(Some script) tt.
Definition create_implicit
(c : Tezos_raw_protocol_alpha.Raw_context.t)
(manager :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(balance : Tezos_raw_protocol_alpha.Storage.Contract.Balance.value)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
create_base c None (Contract_repr.implicit_contract manager) balance
(Some manager) None None tt.
Definition delete
(c : Tezos_raw_protocol_alpha.Raw_context.t)
(contract : Tezos_raw_protocol_alpha.Contract_repr.contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
match Contract_repr.is_implicit contract with
| None => failwith "Non implicit contracts cannot be removed" % string
| Some _ =>
op_gtgteqquestion (Delegate_storage.remove c contract)
(fun c =>
op_gtgteqquestion (Storage.Contract.Balance.delete c contract)
(fun c =>
op_gtgteqquestion (Storage.Contract.Manager.delete c contract)
(fun c =>
op_gtgteqquestion (Storage.Contract.Counter.delete c contract)
(fun c =>
op_gtgteqquestion (Storage.Contract.Code.remove c contract)
(fun function_parameter =>
let '(c, _, _) := function_parameter in
op_gtgteqquestion
(Storage.Contract.Storage.remove c contract)
(fun function_parameter =>
let '(c, _, _) := function_parameter in
op_gtgteq
(Storage.Contract.Paid_storage_space.remove c
contract)
(fun c =>
op_gtgteq
(Storage.Contract.Used_storage_space.remove c
contract) (fun c => _return c))))))))
end.
Definition allocated
(c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
op_gtgteqquestion (Storage.Contract.Balance.get_option c contract)
(fun function_parameter =>
match function_parameter with
| None => return_false
| Some _ => return_true
end).
Definition _exists
(c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
(contract : Tezos_raw_protocol_alpha.Contract_repr.contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
match Contract_repr.is_implicit contract with
| Some _ => return_true
| None => allocated c contract
end.
Definition must_exist
(c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
(contract : Tezos_raw_protocol_alpha.Contract_repr.contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
op_gtgteqquestion (_exists c contract)
(fun function_parameter =>
match function_parameter with
| true => return_unit
| false =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Non_existing_contract
contract)
end).
Definition must_be_allocated
(c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
op_gtgteqquestion (allocated c contract)
(fun function_parameter =>
match function_parameter with
| true => return_unit
| false =>
match Contract_repr.is_implicit contract with
| Some pkh =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_implicit_contract
pkh)
| None =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Non_existing_contract
contract)
end
end).
Definition list (c : Tezos_raw_protocol_alpha.Raw_context.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(list Tezos_raw_protocol_alpha.Contract_repr.t) := Storage.Contract.list c.
Definition fresh_contract_from_current_nonce
(c : Tezos_raw_protocol_alpha.Raw_context.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t *
Tezos_raw_protocol_alpha.Contract_repr.contract)) :=
op_gtgteqquestion (Lwt._return (Raw_context.increment_origination_nonce c))
(fun function_parameter =>
let '(c, nonce) := function_parameter in
_return (c, (Contract_repr.originated_contract nonce))).
Definition originated_from_current_nonce
(ctxt_since : Tezos_raw_protocol_alpha.Raw_context.t)
(ctxt_until : Tezos_raw_protocol_alpha.Raw_context.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list Tezos_raw_protocol_alpha.Contract_repr.contract)) :=
op_gtgteqquestion (Lwt._return (Raw_context.origination_nonce ctxt_since))
(fun since =>
op_gtgteqquestion (Lwt._return (Raw_context.origination_nonce ctxt_until))
(fun until =>
filter_map_s
(fun contract =>
op_gtgteqquestion (_exists ctxt_until contract)
(fun function_parameter =>
match function_parameter with
| true => return_some contract
| false => return_none
end)) (Contract_repr.originated_contracts since until))).
Definition check_counter_increment
(c : Tezos_raw_protocol_alpha.Storage.Contract.Counter.context)
(manager :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(counter :
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let contract := Contract_repr.implicit_contract manager in
op_gtgteqquestion (Storage.Contract.Counter.get c contract)
(fun contract_counter =>
let expected := Z.succ contract_counter in
if
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
expected counter then
return_unit
else
if
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
expected counter then
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Counter_in_the_past
contract expected counter)
else
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Counter_in_the_future
contract expected counter)).
Definition increment_counter
(c : Tezos_raw_protocol_alpha.Raw_context.t)
(manager :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let contract := Contract_repr.implicit_contract manager in
op_gtgteqquestion (Storage.Contract.Global_counter.get c)
(fun global_counter =>
op_gtgteqquestion
(Storage.Contract.Global_counter.set c (Z.succ global_counter))
(fun c =>
op_gtgteqquestion (Storage.Contract.Counter.get c contract)
(fun contract_counter =>
Storage.Contract.Counter.set c contract (Z.succ contract_counter)))).
Definition get_script_code
(c : Tezos_raw_protocol_alpha.Storage.Contract.Code.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Code.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t *
(option Tezos_raw_protocol_alpha.Storage.Contract.Code.value))) :=
Storage.Contract.Code.get_option c contract.
Definition get_script
(c : Tezos_raw_protocol_alpha.Storage.Contract.Code.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Code.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t *
(option Tezos_raw_protocol_alpha.Script_repr.t))) :=
op_gtgteqquestion (Storage.Contract.Code.get_option c contract)
(fun function_parameter =>
let '(c, code) := function_parameter in
op_gtgteqquestion (Storage.Contract.Storage.get_option c contract)
(fun function_parameter =>
let '(c, storage) := function_parameter in
match (code, storage) with
| (None, None) => _return (c, None)
| (Some code, Some storage) =>
_return
(c,
(Some
{| Script_repr.code := code; Script_repr.storage := storage |}))
| (None, Some _) | (Some _, None) => failwith "get_script" % string
end)).
Definition get_storage
(ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Storage.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Storage.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t *
(option Tezos_raw_protocol_alpha.Script_repr.expr))) :=
op_gtgteqquestion (Storage.Contract.Storage.get_option ctxt contract)
(fun function_parameter =>
match function_parameter with
| (ctxt, None) => _return (ctxt, None)
| (ctxt, Some storage) =>
op_gtgteqquestion (Lwt._return (Script_repr.force_decode storage))
(fun function_parameter =>
let '(storage, cost) := function_parameter in
op_gtgteqquestion (Lwt._return (Raw_context.consume_gas ctxt cost))
(fun ctxt => _return (ctxt, (Some storage))))
end).
Definition get_counter
(c : Tezos_raw_protocol_alpha.Storage.Contract.Counter.context)
(manager :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Z.t) :=
let contract := Contract_repr.implicit_contract manager in
op_gtgteqquestion (Storage.Contract.Counter.get_option c contract)
(fun function_parameter =>
match function_parameter with
| None =>
match Contract_repr.is_implicit contract with
| Some _ => Storage.Contract.Global_counter.get c
| None => failwith "get_counter" % string
end
| Some v => _return v
end).
Definition get_manager_key
(c : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
(manager :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t) :=
let contract := Contract_repr.implicit_contract manager in
op_gtgteqquestion (Storage.Contract.Manager.get_option c contract)
(fun function_parameter =>
match function_parameter with
| None => failwith "get_manager_key" % string
| Some (Tezos_raw_protocol_alpha.Manager_repr.Hash _) =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unrevealed_manager_key
contract)
| Some (Tezos_raw_protocol_alpha.Manager_repr.Public_key v) => _return v
end).
Definition is_manager_key_revealed
(c : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
(manager :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
let contract := Contract_repr.implicit_contract manager in
op_gtgteqquestion (Storage.Contract.Manager.get_option c contract)
(fun function_parameter =>
match function_parameter with
| None => return_false
| Some (Tezos_raw_protocol_alpha.Manager_repr.Hash _) => return_false
| Some (Tezos_raw_protocol_alpha.Manager_repr.Public_key _) => return_true
end).
Definition reveal_manager_key
(c : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
(manager :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(public_key :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let contract := Contract_repr.implicit_contract manager in
op_gtgteqquestion (Storage.Contract.Manager.get c contract)
(fun function_parameter =>
match function_parameter with
| Tezos_raw_protocol_alpha.Manager_repr.Public_key _ =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Previously_revealed_key
contract)
| Tezos_raw_protocol_alpha.Manager_repr.Hash v =>
let actual_hash := Signature.Public_key.hash public_key in
if Signature.Public_key_hash.equal actual_hash v then
let v := Tezos_raw_protocol_alpha.Manager_repr.Public_key public_key
in
op_gtgteqquestion (Storage.Contract.Manager.set c contract v)
(fun c => _return c)
else
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_hash
public_key v actual_hash)
end).
Definition get_balance
(c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Tez_repr.t) :=
op_gtgteqquestion (Storage.Contract.Balance.get_option c contract)
(fun function_parameter =>
match function_parameter with
| None =>
match Contract_repr.is_implicit contract with
| Some _ => _return Tez_repr.zero
| None => failwith "get_balance" % string
end
| Some v => _return v
end).
Definition update_script_storage
(c : Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Storage.key)
(storage : Tezos_raw_protocol_alpha.Script_repr.expr)
(big_map_diff : option (list big_map_diff_item))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let storage := Script_repr.lazy_expr storage in
op_gtgteqquestion (update_script_big_map c big_map_diff)
(fun function_parameter =>
let '(c, big_map_size_diff) := function_parameter in
op_gtgteqquestion (Storage.Contract.Storage.set c contract storage)
(fun function_parameter =>
let '(c, size_diff) := function_parameter in
op_gtgteqquestion (Storage.Contract.Used_storage_space.get c contract)
(fun previous_size =>
let new_size :=
Z.add previous_size
(Z.add big_map_size_diff (Z.of_int size_diff)) in
Storage.Contract.Used_storage_space.set c contract new_size))).
Definition spend
(c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
(amount : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteqquestion (Storage.Contract.Balance.get c contract)
(fun balance =>
match op_minusquestion balance amount with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
contract balance amount)
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok new_balance
=>
op_gtgteqquestion (Storage.Contract.Balance.set c contract new_balance)
(fun c =>
op_gtgteqquestion
(Roll_storage.Contract.remove_amount c contract amount)
(fun c =>
if op_gt new_balance Tez_repr.zero then
_return c
else
match Contract_repr.is_implicit contract with
| None => _return c
| Some pkh =>
op_gtgteqquestion (Delegate_storage.get c contract)
(fun function_parameter =>
match function_parameter with
| Some pkh' =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (Signature.Public_key_hash.equal pkh pkh') in
_return c
| None => delete c contract
end)
end))
end).
Definition credit
(c : Tezos_raw_protocol_alpha.Storage.Contract.Code.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Code.key)
(amount : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteqquestion
(if op_ltgt amount Tez_repr.zero then
_return c
else
op_gtgteqquestion (Storage.Contract.Code.mem c contract)
(fun function_parameter =>
let '(c, target_has_code) := function_parameter in
op_gtgteqquestion
(fail_unless target_has_code
(Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_transaction
contract))
(fun function_parameter =>
let 'tt := function_parameter in
_return c)))
(fun c =>
op_gtgteqquestion (Storage.Contract.Balance.get_option c contract)
(fun function_parameter =>
match function_parameter with
| None =>
match Contract_repr.is_implicit contract with
| None =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Non_existing_contract
contract)
| Some manager => create_implicit c manager amount
end
| Some balance =>
op_gtgteqquestion (Lwt._return (op_plusquestion amount balance))
(fun balance =>
op_gtgteqquestion
(Storage.Contract.Balance.set c contract balance)
(fun c => Roll_storage.Contract.add_amount c contract amount))
end)).
Definition init (c : Tezos_raw_protocol_alpha.Raw_context.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
Storage.Contract.Global_counter.init c Z.zero.
Definition used_storage_space
(c : Tezos_raw_protocol_alpha.Storage.Contract.Used_storage_space.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Used_storage_space.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Z.t) :=
op_gtgteqquestion (Storage.Contract.Used_storage_space.get_option c contract)
(fun function_parameter =>
match function_parameter with
| None => _return Z.zero
| Some fees => _return fees
end).
Definition paid_storage_space
(c : Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Z.t) :=
op_gtgteqquestion (Storage.Contract.Paid_storage_space.get_option c contract)
(fun function_parameter =>
match function_parameter with
| None => _return Z.zero
| Some paid_space => _return paid_space
end).
Definition set_paid_storage_space_and_return_fees_to_pay
(c : Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.key)
(new_storage_space :
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_protocol_environment_alpha__Environment.Z.t *
Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.context)) :=
op_gtgteqquestion (Storage.Contract.Paid_storage_space.get c contract)
(fun already_paid_space =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
already_paid_space new_storage_space then
_return (Z.zero, c)
else
let to_pay := Z.sub new_storage_space already_paid_space in
op_gtgteqquestion
(Storage.Contract.Paid_storage_space.set c contract new_storage_space)
(fun c => _return (to_pay, c))).
src/proto_alpha/lib_protocol/cycle_repr.ml 17 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = int32
type cycle = t
let encoding = Data_encoding.int32
let rpc_arg =
let construct = Int32.to_string in
let destruct str =
match Int32.of_string str with
| exception _ ->
Error "Cannot parse cycle"
| cycle ->
Ok cycle
in
RPC_arg.make
~descr:"A cycle integer"
~name:"block_cycle"
~construct
~destruct
()
let pp ppf cycle = Format.fprintf ppf "%ld" cycle
include (Compare.Int32 : Compare.S with type t := t)
module Map = Map.Make (Compare.Int32)
let root = 0l
let succ = Int32.succ
let pred = function 0l -> None | i -> Some (Int32.pred i)
let add c i =
assert (Compare.Int.(i > 0)) ;
Int32.add c (Int32.of_int i)
let sub c i =
assert (Compare.Int.(i > 0)) ;
let r = Int32.sub c (Int32.of_int i) in
if Compare.Int32.(r < 0l) then None else Some r
let to_int32 i = i
let of_int32_exn l =
if Compare.Int32.(l >= 0l) then l
else invalid_arg "Level_repr.Cycle.of_int32"
module Index = struct
type t = cycle
let path_length = 1
let to_path c l = Int32.to_string (to_int32 c) :: l
let of_path = function
| [s] -> (
try Some (Int32.of_string s) with _ -> None )
| _ ->
None
let rpc_arg = rpc_arg
let encoding = encoding
let compare = compare
end
src/proto_alpha/lib_protocol/cycle_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := int32.
Definition cycle := t.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
Data_encoding.int32.
Definition rpc_arg
: Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 :=
let construct := Int32.to_string in
let destruct (str : string)
: Tezos_protocol_environment_alpha__Environment.Pervasives.result int32
string :=
let 'cycle := Int32.of_string str in
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok cycle in
RPC_arg.make (Some "A cycle integer" % string) "block_cycle" % string destruct
construct tt.
Definition pp
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
(cycle : int32) : unit :=
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
"%ld" % string) cycle.
(* ❌ Structure item `include` not handled. *)
include
(* ❌ Applications of functors are not handled. *)
functor_application
Definition root : int32 :=
(* ❌ Constant of type int32 is converted to int *)
0.
Definition succ : int32 -> int32 := Int32.succ.
Definition pred (function_parameter : int32) : option int32 :=
match function_parameter with
|
(* ❌ Constant of type int32 is converted to int *)
0 => None
| i => Some (Int32.pred i)
end.
Definition add
(c : int32)
(i :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: int32 :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
i 0) in
Int32.add c (Int32.of_int i).
Definition sub
(c : int32)
(i :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: option int32 :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
i 0) in
let r := Int32.sub c (Int32.of_int i) in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
r
(* ❌ Constant of type int32 is converted to int *)
0 then
None
else
Some r.
Definition to_int32 {A : Type} (i : A) : A := i.
Definition of_int32_exn
(l :
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
l
(* ❌ Constant of type int32 is converted to int *)
0 then
l
else
invalid_arg "Level_repr.Cycle.of_int32" % string.
Module Index.
Definition t := cycle.
Definition path_length : Z := 1.
Definition to_path (c : int32) (l : list string) : list string :=
cons (Int32.to_string (to_int32 c)) l.
Definition of_path (function_parameter : list string) : option int32 :=
match function_parameter with
| cons s [] =>
(* ❌ Try-with are not handled *)
try (Some (Int32.of_string s))
| _ => None
end.
Definition rpc_arg
: Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 := rpc_arg.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
encoding.
Definition compare : t -> t -> Z := compare.
End Index.
src/proto_alpha/lib_protocol/delegate_services.ml 334 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
type info = {
balance : Tez.t;
frozen_balance : Tez.t;
frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t;
staking_balance : Tez.t;
delegated_contracts : Contract_repr.t list;
delegated_balance : Tez.t;
deactivated : bool;
grace_period : Cycle.t;
}
let info_encoding =
let open Data_encoding in
conv
(fun { balance;
frozen_balance;
frozen_balance_by_cycle;
staking_balance;
delegated_contracts;
delegated_balance;
deactivated;
grace_period } ->
( balance,
frozen_balance,
frozen_balance_by_cycle,
staking_balance,
delegated_contracts,
delegated_balance,
deactivated,
grace_period ))
(fun ( balance,
frozen_balance,
frozen_balance_by_cycle,
staking_balance,
delegated_contracts,
delegated_balance,
deactivated,
grace_period ) ->
{
balance;
frozen_balance;
frozen_balance_by_cycle;
staking_balance;
delegated_contracts;
delegated_balance;
deactivated;
grace_period;
})
(obj8
(req "balance" Tez.encoding)
(req "frozen_balance" Tez.encoding)
(req "frozen_balance_by_cycle" Delegate.frozen_balance_by_cycle_encoding)
(req "staking_balance" Tez.encoding)
(req "delegated_contracts" (list Contract_repr.encoding))
(req "delegated_balance" Tez.encoding)
(req "deactivated" bool)
(req "grace_period" Cycle.encoding))
module S = struct
let path = RPC_path.(open_root / "context" / "delegates")
open Data_encoding
type list_query = {active : bool; inactive : bool}
let list_query : list_query RPC_query.t =
let open RPC_query in
query (fun active inactive -> {active; inactive})
|+ flag "active" (fun t -> t.active)
|+ flag "inactive" (fun t -> t.inactive)
|> seal
let list_delegate =
RPC_service.get_service
~description:"Lists all registered delegates."
~query:list_query
~output:(list Signature.Public_key_hash.encoding)
path
let path = RPC_path.(path /: Signature.Public_key_hash.rpc_arg)
let info =
RPC_service.get_service
~description:"Everything about a delegate."
~query:RPC_query.empty
~output:info_encoding
path
let balance =
RPC_service.get_service
~description:
"Returns the full balance of a given delegate, including the frozen \
balances."
~query:RPC_query.empty
~output:Tez.encoding
RPC_path.(path / "balance")
let frozen_balance =
RPC_service.get_service
~description:
"Returns the total frozen balances of a given delegate, this includes \
the frozen deposits, rewards and fees."
~query:RPC_query.empty
~output:Tez.encoding
RPC_path.(path / "frozen_balance")
let frozen_balance_by_cycle =
RPC_service.get_service
~description:
"Returns the frozen balances of a given delegate, indexed by the \
cycle by which it will be unfrozen"
~query:RPC_query.empty
~output:Delegate.frozen_balance_by_cycle_encoding
RPC_path.(path / "frozen_balance_by_cycle")
let staking_balance =
RPC_service.get_service
~description:
"Returns the total amount of tokens delegated to a given delegate. \
This includes the balances of all the contracts that delegate to it, \
but also the balance of the delegate itself and its frozen fees and \
deposits. The rewards do not count in the delegated balance until \
they are unfrozen."
~query:RPC_query.empty
~output:Tez.encoding
RPC_path.(path / "staking_balance")
let delegated_contracts =
RPC_service.get_service
~description:
"Returns the list of contracts that delegate to a given delegate."
~query:RPC_query.empty
~output:(list Contract_repr.encoding)
RPC_path.(path / "delegated_contracts")
let delegated_balance =
RPC_service.get_service
~description:
"Returns the balances of all the contracts that delegate to a given \
delegate. This excludes the delegate's own balance and its frozen \
balances."
~query:RPC_query.empty
~output:Tez.encoding
RPC_path.(path / "delegated_balance")
let deactivated =
RPC_service.get_service
~description:
"Tells whether the delegate is currently tagged as deactivated or not."
~query:RPC_query.empty
~output:bool
RPC_path.(path / "deactivated")
let grace_period =
RPC_service.get_service
~description:
"Returns the cycle by the end of which the delegate might be \
deactivated if she fails to execute any delegate action. A \
deactivated delegate might be reactivated (without loosing any \
rolls) by simply re-registering as a delegate. For deactivated \
delegates, this value contains the cycle by which they were \
deactivated."
~query:RPC_query.empty
~output:Cycle.encoding
RPC_path.(path / "grace_period")
end
let register () =
let open Services_registration in
register0 S.list_delegate (fun ctxt q () ->
Delegate.list ctxt
>>= fun delegates ->
if q.active && q.inactive then return delegates
else if q.active then
filter_map_s
(fun pkh ->
Delegate.deactivated ctxt pkh
>>=? function true -> return_none | false -> return_some pkh)
delegates
else if q.inactive then
filter_map_s
(fun pkh ->
Delegate.deactivated ctxt pkh
>>=? function false -> return_none | true -> return_some pkh)
delegates
else return_nil) ;
register1 S.info (fun ctxt pkh () () ->
Delegate.full_balance ctxt pkh
>>=? fun balance ->
Delegate.frozen_balance ctxt pkh
>>=? fun frozen_balance ->
Delegate.frozen_balance_by_cycle ctxt pkh
>>= fun frozen_balance_by_cycle ->
Delegate.staking_balance ctxt pkh
>>=? fun staking_balance ->
Delegate.delegated_contracts ctxt pkh
>>= fun delegated_contracts ->
Delegate.delegated_balance ctxt pkh
>>=? fun delegated_balance ->
Delegate.deactivated ctxt pkh
>>=? fun deactivated ->
Delegate.grace_period ctxt pkh
>>=? fun grace_period ->
return
{
balance;
frozen_balance;
frozen_balance_by_cycle;
staking_balance;
delegated_contracts;
delegated_balance;
deactivated;
grace_period;
}) ;
register1 S.balance (fun ctxt pkh () () -> Delegate.full_balance ctxt pkh) ;
register1 S.frozen_balance (fun ctxt pkh () () ->
Delegate.frozen_balance ctxt pkh) ;
register1 S.frozen_balance_by_cycle (fun ctxt pkh () () ->
Delegate.frozen_balance_by_cycle ctxt pkh >>= return) ;
register1 S.staking_balance (fun ctxt pkh () () ->
Delegate.staking_balance ctxt pkh) ;
register1 S.delegated_contracts (fun ctxt pkh () () ->
Delegate.delegated_contracts ctxt pkh >>= return) ;
register1 S.delegated_balance (fun ctxt pkh () () ->
Delegate.delegated_balance ctxt pkh) ;
register1 S.deactivated (fun ctxt pkh () () -> Delegate.deactivated ctxt pkh) ;
register1 S.grace_period (fun ctxt pkh () () ->
Delegate.grace_period ctxt pkh)
let list ctxt block ?(active = true) ?(inactive = false) () =
RPC_context.make_call0 S.list_delegate ctxt block {active; inactive} ()
let info ctxt block pkh = RPC_context.make_call1 S.info ctxt block pkh () ()
let balance ctxt block pkh =
RPC_context.make_call1 S.balance ctxt block pkh () ()
let frozen_balance ctxt block pkh =
RPC_context.make_call1 S.frozen_balance ctxt block pkh () ()
let frozen_balance_by_cycle ctxt block pkh =
RPC_context.make_call1 S.frozen_balance_by_cycle ctxt block pkh () ()
let staking_balance ctxt block pkh =
RPC_context.make_call1 S.staking_balance ctxt block pkh () ()
let delegated_contracts ctxt block pkh =
RPC_context.make_call1 S.delegated_contracts ctxt block pkh () ()
let delegated_balance ctxt block pkh =
RPC_context.make_call1 S.delegated_balance ctxt block pkh () ()
let deactivated ctxt block pkh =
RPC_context.make_call1 S.deactivated ctxt block pkh () ()
let grace_period ctxt block pkh =
RPC_context.make_call1 S.grace_period ctxt block pkh () ()
let requested_levels ~default ctxt cycles levels =
match (levels, cycles) with
| ([], []) ->
return [default]
| (levels, cycles) ->
(* explicitly fail when requested levels or cycle are in the past...
or too far in the future... *)
let levels =
List.sort_uniq
Level.compare
(List.concat
( List.map (Level.from_raw ctxt) levels
:: List.map (Level.levels_in_cycle ctxt) cycles ))
in
map_s
(fun level ->
let current_level = Level.current ctxt in
if Level.(level <= current_level) then return (level, None)
else
Baking.earlier_predecessor_timestamp ctxt level
>>=? fun timestamp -> return (level, Some timestamp))
levels
module Baking_rights = struct
type t = {
level : Raw_level.t;
delegate : Signature.Public_key_hash.t;
priority : int;
timestamp : Timestamp.t option;
}
let encoding =
let open Data_encoding in
conv
(fun {level; delegate; priority; timestamp} ->
(level, delegate, priority, timestamp))
(fun (level, delegate, priority, timestamp) ->
{level; delegate; priority; timestamp})
(obj4
(req "level" Raw_level.encoding)
(req "delegate" Signature.Public_key_hash.encoding)
(req "priority" uint16)
(opt "estimated_time" Timestamp.encoding))
module S = struct
open Data_encoding
let custom_root = RPC_path.(open_root / "helpers" / "baking_rights")
type baking_rights_query = {
levels : Raw_level.t list;
cycles : Cycle.t list;
delegates : Signature.Public_key_hash.t list;
max_priority : int option;
all : bool;
}
let baking_rights_query =
let open RPC_query in
query (fun levels cycles delegates max_priority all ->
{levels; cycles; delegates; max_priority; all})
|+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels)
|+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles)
|+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t ->
t.delegates)
|+ opt_field "max_priority" RPC_arg.int (fun t -> t.max_priority)
|+ flag "all" (fun t -> t.all)
|> seal
let baking_rights =
RPC_service.get_service
~description:
"Retrieves the list of delegates allowed to bake a block.\n\
By default, it gives the best baking priorities for bakers that \
have at least one opportunity below the 64th priority for the next \
block.\n\
Parameters `level` and `cycle` can be used to specify the (valid) \
level(s) in the past or future at which the baking rights have to \
be returned. Parameter `delegate` can be used to restrict the \
results to the given delegates. If parameter `all` is set, all the \
baking opportunities for each baker at each level are returned, \
instead of just the first one.\n\
Returns the list of baking slots. Also returns the minimal \
timestamps that correspond to these slots. The timestamps are \
omitted for levels in the past, and are only estimates for levels \
later that the next block, based on the hypothesis that all \
predecessor blocks were baked at the first priority."
~query:baking_rights_query
~output:(list encoding)
custom_root
end
let baking_priorities ctxt max_prio (level, pred_timestamp) =
Baking.baking_priorities ctxt level
>>=? fun contract_list ->
let rec loop l acc priority =
if Compare.Int.(priority >= max_prio) then return (List.rev acc)
else
let (Misc.LCons (pk, next)) = l in
let delegate = Signature.Public_key.hash pk in
( match pred_timestamp with
| None ->
return_none
| Some pred_timestamp ->
Baking.minimal_time ctxt priority pred_timestamp
>>=? fun t -> return_some t )
>>=? fun timestamp ->
let acc =
{level = level.level; delegate; priority; timestamp} :: acc
in
next () >>=? fun l -> loop l acc (priority + 1)
in
loop contract_list [] 0
let remove_duplicated_delegates rights =
List.rev @@ fst
@@ List.fold_left
(fun (acc, previous) r ->
if Signature.Public_key_hash.Set.mem r.delegate previous then
(acc, previous)
else
(r :: acc, Signature.Public_key_hash.Set.add r.delegate previous))
([], Signature.Public_key_hash.Set.empty)
rights
let register () =
let open Services_registration in
register0 S.baking_rights (fun ctxt q () ->
requested_levels
~default:
( Level.succ ctxt (Level.current ctxt),
Some (Timestamp.current ctxt) )
ctxt
q.cycles
q.levels
>>=? fun levels ->
let max_priority =
match q.max_priority with None -> 64 | Some max -> max
in
map_s (baking_priorities ctxt max_priority) levels
>>=? fun rights ->
let rights =
if q.all then rights else List.map remove_duplicated_delegates rights
in
let rights = List.concat rights in
match q.delegates with
| [] ->
return rights
| _ :: _ as delegates ->
let is_requested p =
List.exists
(Signature.Public_key_hash.equal p.delegate)
delegates
in
return (List.filter is_requested rights))
let get ctxt ?(levels = []) ?(cycles = []) ?(delegates = []) ?(all = false)
?max_priority block =
RPC_context.make_call0
S.baking_rights
ctxt
block
{levels; cycles; delegates; max_priority; all}
()
end
module Endorsing_rights = struct
type t = {
level : Raw_level.t;
delegate : Signature.Public_key_hash.t;
slots : int list;
estimated_time : Time.t option;
}
let encoding =
let open Data_encoding in
conv
(fun {level; delegate; slots; estimated_time} ->
(level, delegate, slots, estimated_time))
(fun (level, delegate, slots, estimated_time) ->
{level; delegate; slots; estimated_time})
(obj4
(req "level" Raw_level.encoding)
(req "delegate" Signature.Public_key_hash.encoding)
(req "slots" (list uint16))
(opt "estimated_time" Timestamp.encoding))
module S = struct
open Data_encoding
let custom_root = RPC_path.(open_root / "helpers" / "endorsing_rights")
type endorsing_rights_query = {
levels : Raw_level.t list;
cycles : Cycle.t list;
delegates : Signature.Public_key_hash.t list;
}
let endorsing_rights_query =
let open RPC_query in
query (fun levels cycles delegates -> {levels; cycles; delegates})
|+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels)
|+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles)
|+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t ->
t.delegates)
|> seal
let endorsing_rights =
RPC_service.get_service
~description:
"Retrieves the delegates allowed to endorse a block.\n\
By default, it gives the endorsement slots for delegates that have \
at least one in the next block.\n\
Parameters `level` and `cycle` can be used to specify the (valid) \
level(s) in the past or future at which the endorsement rights \
have to be returned. Parameter `delegate` can be used to restrict \
the results to the given delegates.\n\
Returns the list of endorsement slots. Also returns the minimal \
timestamps that correspond to these slots. The timestamps are \
omitted for levels in the past, and are only estimates for levels \
later that the next block, based on the hypothesis that all \
predecessor blocks were baked at the first priority."
~query:endorsing_rights_query
~output:(list encoding)
custom_root
end
let endorsement_slots ctxt (level, estimated_time) =
Baking.endorsement_rights ctxt level
>>=? fun rights ->
return
(Signature.Public_key_hash.Map.fold
(fun delegate (_, slots, _) acc ->
{level = level.level; delegate; slots; estimated_time} :: acc)
rights
[])
let register () =
let open Services_registration in
register0 S.endorsing_rights (fun ctxt q () ->
requested_levels
~default:(Level.current ctxt, Some (Timestamp.current ctxt))
ctxt
q.cycles
q.levels
>>=? fun levels ->
map_s (endorsement_slots ctxt) levels
>>=? fun rights ->
let rights = List.concat rights in
match q.delegates with
| [] ->
return rights
| _ :: _ as delegates ->
let is_requested p =
List.exists
(Signature.Public_key_hash.equal p.delegate)
delegates
in
return (List.filter is_requested rights))
let get ctxt ?(levels = []) ?(cycles = []) ?(delegates = []) block =
RPC_context.make_call0
S.endorsing_rights
ctxt
block
{levels; cycles; delegates}
()
end
module Endorsing_power = struct
let endorsing_power ctxt (operation, chain_id) =
let (Operation_data data) = operation.protocol_data in
match data.contents with
| Single (Endorsement _) ->
Baking.check_endorsement_rights
ctxt
chain_id
{shell = operation.shell; protocol_data = data}
>>=? fun (_, slots, _) -> return (List.length slots)
| _ ->
failwith "Operation is not an endorsement"
module S = struct
let endorsing_power =
let open Data_encoding in
RPC_service.post_service
~description:
"Get the endorsing power of an endorsement, that is, the number of \
slots that the endorser has"
~query:RPC_query.empty
~input:
(obj2
(req "endorsement_operation" Operation.encoding)
(req "chain_id" Chain_id.encoding))
~output:int31
RPC_path.(open_root / "endorsing_power")
end
let register () =
let open Services_registration in
register0 S.endorsing_power (fun ctxt () (op, chain_id) ->
endorsing_power ctxt (op, chain_id))
let get ctxt block op chain_id =
RPC_context.make_call0 S.endorsing_power ctxt block () (op, chain_id)
end
module Required_endorsements = struct
let required_endorsements ctxt block_delay =
return (Baking.minimum_allowed_endorsements ctxt ~block_delay)
module S = struct
type t = {block_delay : Period.t}
let required_endorsements_query =
let open RPC_query in
query (fun block_delay -> {block_delay})
|+ field "block_delay" Period.rpc_arg Period.zero (fun t ->
t.block_delay)
|> seal
let required_endorsements =
let open Data_encoding in
RPC_service.get_service
~description:
"Minimum number of endorsements for a block to be valid, given a \
delay of the block's timestamp with respect to the minimum time to \
bake at the block's priority"
~query:required_endorsements_query
~output:int31
RPC_path.(open_root / "required_endorsements")
end
let register () =
let open Services_registration in
register0 S.required_endorsements (fun ctxt {block_delay} () ->
required_endorsements ctxt block_delay)
let get ctxt block block_delay =
RPC_context.make_call0 S.required_endorsements ctxt block {block_delay} ()
end
module Minimal_valid_time = struct
let minimal_valid_time ctxt ~priority ~endorsing_power =
Baking.minimal_valid_time ctxt ~priority ~endorsing_power
module S = struct
type t = {priority : int; endorsing_power : int}
let minimal_valid_time_query =
let open RPC_query in
query (fun priority endorsing_power -> {priority; endorsing_power})
|+ field "priority" RPC_arg.int 0 (fun t -> t.priority)
|+ field "endorsing_power" RPC_arg.int 0 (fun t -> t.endorsing_power)
|> seal
let minimal_valid_time =
RPC_service.get_service
~description:
"Minimal valid time for a block given a priority and an endorsing \
power."
~query:minimal_valid_time_query
~output:Time.encoding
RPC_path.(open_root / "minimal_valid_time")
end
let register () =
let open Services_registration in
register0 S.minimal_valid_time (fun ctxt {priority; endorsing_power} () ->
minimal_valid_time ctxt ~priority ~endorsing_power)
let get ctxt block priority endorsing_power =
RPC_context.make_call0
S.minimal_valid_time
ctxt
block
{priority; endorsing_power}
()
end
let register () =
register () ;
Baking_rights.register () ;
Endorsing_rights.register () ;
Endorsing_power.register () ;
Required_endorsements.register () ;
Minimal_valid_time.register ()
let endorsement_rights ctxt level =
Endorsing_rights.endorsement_slots ctxt (level, None)
>>=? fun l ->
return (List.map (fun {Endorsing_rights.delegate; _} -> delegate) l)
let baking_rights ctxt max_priority =
let max = match max_priority with None -> 64 | Some m -> m in
let level = Level.current ctxt in
Baking_rights.baking_priorities ctxt max (level, None)
>>=? fun l ->
return
( level.level,
List.map
(fun {Baking_rights.delegate; timestamp; _} -> (delegate, timestamp))
l )
let endorsing_power ctxt operation =
Endorsing_power.endorsing_power ctxt operation
let required_endorsements ctxt delay =
Required_endorsements.required_endorsements ctxt delay
let minimal_valid_time ctxt priority endorsing_power =
Minimal_valid_time.minimal_valid_time ctxt priority endorsing_power
src/proto_alpha/lib_protocol/delegate_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Record info := {
balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
frozen_balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
frozen_balance_by_cycle :
Tezos_raw_protocol_alpha.Alpha_context.Cycle.Map.t
Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance;
staking_balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
delegated_contracts : list Tezos_raw_protocol_alpha.Contract_repr.t;
delegated_balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
deactivated : bool;
grace_period : Tezos_raw_protocol_alpha.Alpha_context.Cycle.t }.
Definition info_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding info :=
conv
(fun function_parameter =>
let '{|
balance := balance;
frozen_balance := frozen_balance;
frozen_balance_by_cycle := frozen_balance_by_cycle;
staking_balance := staking_balance;
delegated_contracts := delegated_contracts;
delegated_balance := delegated_balance;
deactivated := deactivated;
grace_period := grace_period
|} := function_parameter in
(balance, frozen_balance, frozen_balance_by_cycle, staking_balance,
delegated_contracts, delegated_balance, deactivated, grace_period))
(fun function_parameter =>
let
'(balance, frozen_balance, frozen_balance_by_cycle, staking_balance,
delegated_contracts, delegated_balance, deactivated, grace_period) :=
function_parameter in
{| balance := balance; frozen_balance := frozen_balance;
frozen_balance_by_cycle := frozen_balance_by_cycle;
staking_balance := staking_balance;
delegated_contracts := delegated_contracts;
delegated_balance := delegated_balance; deactivated := deactivated;
grace_period := grace_period |}) None
(obj8 (req None None "balance" % string Tez.encoding)
(req None None "frozen_balance" % string Tez.encoding)
(req None None "frozen_balance_by_cycle" % string
Delegate.frozen_balance_by_cycle_encoding)
(req None None "staking_balance" % string Tez.encoding)
(req None None "delegated_contracts" % string
(list None Contract_repr.encoding))
(req None None "delegated_balance" % string Tez.encoding)
(req None None "deactivated" % string bool)
(req None None "grace_period" % string Cycle.encoding)).
Module S.
Definition path
: Tezos_protocol_environment_alpha__Environment.RPC_path.path
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
op_div (op_div open_root "context" % string) "delegates" % string.
Import Data_encoding.
Record list_query := {
active : bool;
inactive : bool }.
Definition list_query
: Tezos_protocol_environment_alpha__Environment.RPC_query.t list_query :=
op_pipegt
(op_pipeplus
(op_pipeplus
(query
(fun active =>
fun inactive => {| active := active; inactive := inactive |}))
(flag None "active" % string (fun t => active t)))
(flag None "inactive" % string (fun t => inactive t))) seal.
Definition list_delegate
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
list_query unit
(list
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t) :=
RPC_service.get_service (Some "Lists all registered delegates." % string)
list_query (list None Signature.Public_key_hash.encoding) path.
Definition path
: Tezos_protocol_environment_alpha__Environment.RPC_path.path
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t) :=
op_divcolon path Signature.Public_key_hash.rpc_arg.
Definition info
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
unit unit info :=
RPC_service.get_service (Some "Everything about a delegate." % string)
RPC_query.empty info_encoding path.
Definition balance
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
unit unit Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
RPC_service.get_service
(Some
"Returns the full balance of a given delegate, including the frozen balances."
% string) RPC_query.empty Tez.encoding
(op_div path "balance" % string).
Definition frozen_balance
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
unit unit Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
RPC_service.get_service
(Some
"Returns the total frozen balances of a given delegate, this includes the frozen deposits, rewards and fees."
% string) RPC_query.empty Tez.encoding
(op_div path "frozen_balance" % string).
Definition frozen_balance_by_cycle
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
unit unit
(Tezos_raw_protocol_alpha__Alpha_context.Cycle.Map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance) :=
RPC_service.get_service
(Some
"Returns the frozen balances of a given delegate, indexed by the cycle by which it will be unfrozen"
% string) RPC_query.empty Delegate.frozen_balance_by_cycle_encoding
(op_div path "frozen_balance_by_cycle" % string).
Definition staking_balance
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
unit unit Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
RPC_service.get_service
(Some
"Returns the total amount of tokens delegated to a given delegate. This includes the balances of all the contracts that delegate to it, but also the balance of the delegate itself and its frozen fees and deposits. The rewards do not count in the delegated balance until they are unfrozen."
% string) RPC_query.empty Tez.encoding
(op_div path "staking_balance" % string).
Definition delegated_contracts
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
unit unit (list Tezos_raw_protocol_alpha.Contract_repr.contract) :=
RPC_service.get_service
(Some
"Returns the list of contracts that delegate to a given delegate." %
string) RPC_query.empty (list None Contract_repr.encoding)
(op_div path "delegated_contracts" % string).
Definition delegated_balance
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
unit unit Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
RPC_service.get_service
(Some
"Returns the balances of all the contracts that delegate to a given delegate. This excludes the delegate's own balance and its frozen balances."
% string) RPC_query.empty Tez.encoding
(op_div path "delegated_balance" % string).
Definition deactivated
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
unit unit bool :=
RPC_service.get_service
(Some
"Tells whether the delegate is currently tagged as deactivated or not."
% string) RPC_query.empty bool (op_div path "deactivated" % string).
Definition grace_period
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
unit unit Tezos_raw_protocol_alpha.Alpha_context.Cycle.t :=
RPC_service.get_service
(Some
"Returns the cycle by the end of which the delegate might be deactivated if she fails to execute any delegate action. A deactivated delegate might be reactivated (without loosing any rolls) by simply re-registering as a delegate. For deactivated delegates, this value contains the cycle by which they were deactivated."
% string) RPC_query.empty Cycle.encoding
(op_div path "grace_period" % string).
End S.
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.list_delegate
(fun ctxt =>
fun q =>
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Delegate.list ctxt)
(fun delegates =>
if op_andand (active q) (inactive q) then
_return delegates
else
if active q then
filter_map_s
(fun pkh =>
op_gtgteqquestion (Delegate.deactivated ctxt pkh)
(fun function_parameter =>
match function_parameter with
| true => return_none
| false => return_some pkh
end)) delegates
else
if inactive q then
filter_map_s
(fun pkh =>
op_gtgteqquestion (Delegate.deactivated ctxt pkh)
(fun function_parameter =>
match function_parameter with
| false => return_none
| true => return_some pkh
end)) delegates
else
return_nil)) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.info
(fun ctxt =>
fun pkh =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Delegate.full_balance ctxt pkh)
(fun balance =>
op_gtgteqquestion (Delegate.frozen_balance ctxt pkh)
(fun frozen_balance =>
op_gtgteq (Delegate.frozen_balance_by_cycle ctxt pkh)
(fun frozen_balance_by_cycle =>
op_gtgteqquestion (Delegate.staking_balance ctxt pkh)
(fun staking_balance =>
op_gtgteq (Delegate.delegated_contracts ctxt pkh)
(fun delegated_contracts =>
op_gtgteqquestion
(Delegate.delegated_balance ctxt pkh)
(fun delegated_balance =>
op_gtgteqquestion
(Delegate.deactivated ctxt pkh)
(fun deactivated =>
op_gtgteqquestion
(Delegate.grace_period ctxt pkh)
(fun grace_period =>
_return
{| balance := balance;
frozen_balance :=
frozen_balance;
frozen_balance_by_cycle :=
frozen_balance_by_cycle;
staking_balance :=
staking_balance;
delegated_contracts :=
delegated_contracts;
delegated_balance :=
delegated_balance;
deactivated := deactivated;
grace_period := grace_period
|}))))))))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.balance
(fun ctxt =>
fun pkh =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Delegate.full_balance ctxt pkh) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.frozen_balance
(fun ctxt =>
fun pkh =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Delegate.frozen_balance ctxt pkh) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.frozen_balance_by_cycle
(fun ctxt =>
fun pkh =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Delegate.frozen_balance_by_cycle ctxt pkh) _return) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.staking_balance
(fun ctxt =>
fun pkh =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Delegate.staking_balance ctxt pkh) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.delegated_contracts
(fun ctxt =>
fun pkh =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Delegate.delegated_contracts ctxt pkh) _return) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.delegated_balance
(fun ctxt =>
fun pkh =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Delegate.delegated_balance ctxt pkh) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register1 S.deactivated
(fun ctxt =>
fun pkh =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Delegate.deactivated ctxt pkh) in
register1 S.grace_period
(fun ctxt =>
fun pkh =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Delegate.grace_period ctxt pkh).
Definition list {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D) (op_staroptstar : option bool)
: (option bool) ->
unit ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(list
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
let active :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => true
end in
fun op_staroptstar =>
let inactive :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun function_parameter =>
let 'tt := function_parameter in
RPC_context.make_call0 S.list_delegate ctxt block
{| active := active; inactive := inactive |} tt.
Definition info {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(pkh :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
info) := RPC_context.make_call1 S.info ctxt block pkh tt tt.
Definition balance {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(pkh :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
RPC_context.make_call1 S.balance ctxt block pkh tt tt.
Definition frozen_balance {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(pkh :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
RPC_context.make_call1 S.frozen_balance ctxt block pkh tt tt.
Definition frozen_balance_by_cycle {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(pkh :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(Tezos_raw_protocol_alpha__Alpha_context.Cycle.Map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance)) :=
RPC_context.make_call1 S.frozen_balance_by_cycle ctxt block pkh tt tt.
Definition staking_balance {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(pkh :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
RPC_context.make_call1 S.staking_balance ctxt block pkh tt tt.
Definition delegated_contracts {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(pkh :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(list Tezos_raw_protocol_alpha.Contract_repr.contract)) :=
RPC_context.make_call1 S.delegated_contracts ctxt block pkh tt tt.
Definition delegated_balance {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(pkh :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
RPC_context.make_call1 S.delegated_balance ctxt block pkh tt tt.
Definition deactivated {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(pkh :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
bool) := RPC_context.make_call1 S.deactivated ctxt block pkh tt tt.
Definition grace_period {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(pkh :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Cycle.t) :=
RPC_context.make_call1 S.grace_period ctxt block pkh tt tt.
Definition requested_levels
(default :
Tezos_raw_protocol_alpha.Alpha_context.Level.t *
(option Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t))
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(cycles : list Tezos_raw_protocol_alpha__Alpha_context.Cycle.t)
(levels : list Tezos_raw_protocol_alpha__Alpha_context.Raw_level.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list
(Tezos_raw_protocol_alpha.Alpha_context.Level.t *
(option Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)))) :=
match (levels, cycles) with
| ([], []) => _return (cons default [])
| (levels, cycles) =>
let levels :=
List.sort_uniq Level.compare
(List.concat
(cons
(List.map
(let arg := Level.from_raw ctxt in
fun eta => arg None eta) levels)
(List.map (Level.levels_in_cycle ctxt) cycles))) in
map_s
(fun level =>
let current_level := Level.current ctxt in
if op_lteq level current_level then
_return (level, None)
else
op_gtgteqquestion (Baking.earlier_predecessor_timestamp ctxt level)
(fun timestamp => _return (level, (Some timestamp)))) levels
end.
Module Baking_rights.
Record t := {
level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t;
delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
priority : Z;
timestamp : option Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t }.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
conv
(fun function_parameter =>
let '{|
level := level;
delegate := delegate;
priority := priority;
timestamp := timestamp
|} := function_parameter in
(level, delegate, priority, timestamp))
(fun function_parameter =>
let '(level, delegate, priority, timestamp) := function_parameter in
{| level := level; delegate := delegate; priority := priority;
timestamp := timestamp |}) None
(obj4 (req None None "level" % string Raw_level.encoding)
(req None None "delegate" % string Signature.Public_key_hash.encoding)
(req None None "priority" % string uint16)
(opt None None "estimated_time" % string Timestamp.encoding)).
Module S.
Import Data_encoding.
Definition custom_root
: Tezos_protocol_environment_alpha__Environment.RPC_path.path
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
op_div (op_div open_root "helpers" % string) "baking_rights" % string.
Record baking_rights_query := {
levels : list Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t;
cycles : list Tezos_raw_protocol_alpha.Alpha_context.Cycle.t;
delegates :
list
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
max_priority : option Z;
all : bool }.
Definition baking_rights_query
: Tezos_protocol_environment_alpha__Environment.RPC_query.t
baking_rights_query :=
op_pipegt
(op_pipeplus
(op_pipeplus
(op_pipeplus
(op_pipeplus
(op_pipeplus
(query
(fun levels =>
fun cycles =>
fun delegates =>
fun max_priority =>
fun all =>
{| levels := levels; cycles := cycles;
delegates := delegates;
max_priority := max_priority; all := all |}))
(multi_field None "level" % string Raw_level.rpc_arg
(fun t => levels t)))
(multi_field None "cycle" % string Cycle.rpc_arg
(fun t => cycles t)))
(multi_field None "delegate" % string
Signature.Public_key_hash.rpc_arg (fun t => delegates t)))
(opt_field None "max_priority" % string RPC_arg.int
(fun t => max_priority t)))
(flag None "all" % string (fun t => all t))) seal.
Definition baking_rights
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
baking_rights_query unit (list t) :=
RPC_service.get_service
(Some
"Retrieves the list of delegates allowed to bake a block.
By default, it gives the best baking priorities for bakers that have at least one opportunity below the 64th priority for the next block.
Parameters `level` and `cycle` can be used to specify the (valid) level(s) in the past or future at which the baking rights have to be returned. Parameter `delegate` can be used to restrict the results to the given delegates. If parameter `all` is set, all the baking opportunities for each baker at each level are returned, instead of just the first one.
Returns the list of baking slots. Also returns the minimal timestamps that correspond to these slots. The timestamps are omitted for levels in the past, and are only estimates for levels later that the next block, based on the hypothesis that all predecessor blocks were baked at the first priority."
% string) baking_rights_query (list None encoding) custom_root.
End S.
Definition baking_priorities
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(max_prio :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(function_parameter :
Tezos_raw_protocol_alpha.Alpha_context.Level.t *
(option Tezos_protocol_environment_alpha__Environment.Time.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list t)) :=
let '(level, pred_timestamp) := function_parameter in
op_gtgteqquestion (Baking.baking_priorities ctxt level)
(fun contract_list =>
let fix loop
(l :
Tezos_raw_protocol_alpha.Misc.lazy_list_t
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
(acc : list t) (priority :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list t)) :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
priority max_prio then
_return (List.rev acc)
else
let 'Tezos_raw_protocol_alpha.Misc.LCons pk next := l in
let delegate := Signature.Public_key.hash pk in
op_gtgteqquestion
match pred_timestamp with
| None => return_none
| Some pred_timestamp =>
op_gtgteqquestion
(Baking.minimal_time ctxt priority pred_timestamp)
(fun t => return_some t)
end
(fun timestamp =>
let acc :=
cons
{| level := level level; delegate := delegate;
priority := priority; timestamp := timestamp |} acc in
op_gtgteqquestion (next tt)
(fun l => loop l acc (op_plus priority 1))) in
loop contract_list [] 0).
Definition remove_duplicated_delegates (rights : list t) : list t :=
op_atat List.rev
(op_atat fst
(List.fold_left
(fun function_parameter =>
let '(acc, previous) := function_parameter in
fun r =>
if Signature.Public_key_hash.Set.mem (delegate r) previous then
(acc, previous)
else
((cons r acc),
(Signature.Public_key_hash.Set.add (delegate r) previous)))
([], Signature.Public_key_hash.Set.empty) rights)).
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
register0 S.baking_rights
(fun ctxt =>
fun q =>
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(requested_levels
((Level.succ ctxt (Level.current ctxt)),
(Some (Timestamp.current ctxt))) ctxt (cycles q) (levels q))
(fun levels =>
let max_priority :=
match max_priority q with
| None => 64
| Some max => max
end in
op_gtgteqquestion
(map_s (baking_priorities ctxt max_priority) levels)
(fun rights =>
let rights :=
if all q then
rights
else
List.map remove_duplicated_delegates rights in
let rights := List.concat rights in
match delegates q with
| [] => _return rights
| (cons _ _) as delegates =>
let is_requested (p : t) : bool :=
List._exists
(Signature.Public_key_hash.equal (delegate p))
delegates in
_return (List.filter is_requested rights)
end))).
Definition get {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(op_staroptstar :
option (list Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t))
: (option (list Tezos_raw_protocol_alpha.Alpha_context.Cycle.t)) ->
(option
(list
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t))
->
(option bool) ->
(option Z) ->
D ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(list t)) :=
let levels :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun op_staroptstar =>
let cycles :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun op_staroptstar =>
let delegates :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun op_staroptstar =>
let all :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun max_priority =>
fun block =>
RPC_context.make_call0 S.baking_rights ctxt block
{| levels := levels; cycles := cycles; delegates := delegates;
max_priority := max_priority; all := all |} tt.
End Baking_rights.
Module Endorsing_rights.
Record t := {
level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t;
delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
slots : list Z;
estimated_time : option Tezos_protocol_environment_alpha__Environment.Time.t
}.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
conv
(fun function_parameter =>
let '{|
level := level;
delegate := delegate;
slots := slots;
estimated_time := estimated_time
|} := function_parameter in
(level, delegate, slots, estimated_time))
(fun function_parameter =>
let '(level, delegate, slots, estimated_time) := function_parameter in
{| level := level; delegate := delegate; slots := slots;
estimated_time := estimated_time |}) None
(obj4 (req None None "level" % string Raw_level.encoding)
(req None None "delegate" % string Signature.Public_key_hash.encoding)
(req None None "slots" % string (list None uint16))
(opt None None "estimated_time" % string Timestamp.encoding)).
Module S.
Import Data_encoding.
Definition custom_root
: Tezos_protocol_environment_alpha__Environment.RPC_path.path
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
op_div (op_div open_root "helpers" % string) "endorsing_rights" % string.
Record endorsing_rights_query := {
levels : list Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t;
cycles : list Tezos_raw_protocol_alpha.Alpha_context.Cycle.t;
delegates :
list
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
}.
Definition endorsing_rights_query
: Tezos_protocol_environment_alpha__Environment.RPC_query.t
endorsing_rights_query :=
op_pipegt
(op_pipeplus
(op_pipeplus
(op_pipeplus
(query
(fun levels =>
fun cycles =>
fun delegates =>
{| levels := levels; cycles := cycles;
delegates := delegates |}))
(multi_field None "level" % string Raw_level.rpc_arg
(fun t => levels t)))
(multi_field None "cycle" % string Cycle.rpc_arg (fun t => cycles t)))
(multi_field None "delegate" % string
Signature.Public_key_hash.rpc_arg (fun t => delegates t))) seal.
Definition endorsing_rights
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
endorsing_rights_query unit (list t) :=
RPC_service.get_service
(Some
"Retrieves the delegates allowed to endorse a block.
By default, it gives the endorsement slots for delegates that have at least one in the next block.
Parameters `level` and `cycle` can be used to specify the (valid) level(s) in the past or future at which the endorsement rights have to be returned. Parameter `delegate` can be used to restrict the results to the given delegates.
Returns the list of endorsement slots. Also returns the minimal timestamps that correspond to these slots. The timestamps are omitted for levels in the past, and are only estimates for levels later that the next block, based on the hypothesis that all predecessor blocks were baked at the first priority."
% string) endorsing_rights_query (list None encoding) custom_root.
End S.
Definition endorsement_slots
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(function_parameter :
Tezos_raw_protocol_alpha.Alpha_context.Level.t *
(option Tezos_protocol_environment_alpha__Environment.Time.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list t)) :=
let '(level, estimated_time) := function_parameter in
op_gtgteqquestion (Baking.endorsement_rights ctxt level)
(fun rights =>
_return
(Signature.Public_key_hash.Map.fold
(fun delegate =>
fun function_parameter =>
let '(_, slots, _) := function_parameter in
fun acc =>
cons
{| level := level level; delegate := delegate;
slots := slots; estimated_time := estimated_time |} acc)
rights [])).
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
register0 S.endorsing_rights
(fun ctxt =>
fun q =>
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(requested_levels
((Level.current ctxt), (Some (Timestamp.current ctxt))) ctxt
(cycles q) (levels q))
(fun levels =>
op_gtgteqquestion (map_s (endorsement_slots ctxt) levels)
(fun rights =>
let rights := List.concat rights in
match delegates q with
| [] => _return rights
| (cons _ _) as delegates =>
let is_requested (p : t) : bool :=
List._exists
(Signature.Public_key_hash.equal (delegate p))
delegates in
_return (List.filter is_requested rights)
end))).
Definition get {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(op_staroptstar :
option (list Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t))
: (option (list Tezos_raw_protocol_alpha.Alpha_context.Cycle.t)) ->
(option
(list
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t))
->
D ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(list t)) :=
let levels :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun op_staroptstar =>
let cycles :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun op_staroptstar =>
let delegates :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun block =>
RPC_context.make_call0 S.endorsing_rights ctxt block
{| levels := levels; cycles := cycles; delegates := delegates |} tt.
End Endorsing_rights.
Module Endorsing_power.
Definition endorsing_power
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(function_parameter :
Tezos_raw_protocol_alpha.Alpha_context.packed_operation *
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
let '(operation, chain_id) := function_parameter in
let 'Tezos_raw_protocol_alpha.Alpha_context.Operation_data data :=
protocol_data operation in
match contents data with
|
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Endorsement _) =>
op_gtgteqquestion
(Baking.check_endorsement_rights ctxt chain_id
{| shell := shell operation; protocol_data := data |})
(fun function_parameter =>
let '(_, slots, _) := function_parameter in
_return (List.length slots))
| _ => failwith "Operation is not an endorsement" % string
end.
Module S.
Definition endorsing_power
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
(Tezos_raw_protocol_alpha.Alpha_context.Operation.packed *
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
Z :=
RPC_service.post_service
(Some
"Get the endorsing power of an endorsement, that is, the number of slots that the endorser has"
% string) RPC_query.empty
(obj2
(req None None "endorsement_operation" % string Operation.encoding)
(req None None "chain_id" % string
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)))
int31 (op_div open_root "endorsing_power" % string).
End S.
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
register0 S.endorsing_power
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(op, chain_id) := function_parameter in
endorsing_power ctxt (op, chain_id)).
Definition get {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D) (op : Tezos_raw_protocol_alpha.Alpha_context.Operation.packed)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Z) :=
RPC_context.make_call0 S.endorsing_power ctxt block tt (op, chain_id).
End Endorsing_power.
Module Required_endorsements.
Definition required_endorsements
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
_return (Baking.minimum_allowed_endorsements ctxt block_delay).
Module S.
Record t := {
block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t }.
Definition required_endorsements_query
: Tezos_protocol_environment_alpha__Environment.RPC_query.t t :=
op_pipegt
(op_pipeplus
(query (fun block_delay => {| block_delay := block_delay |}))
(field None "block_delay" % string Period.rpc_arg Period.zero
(fun t => block_delay t))) seal.
Definition required_endorsements
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context t unit
Z :=
RPC_service.get_service
(Some
"Minimum number of endorsements for a block to be valid, given a delay of the block's timestamp with respect to the minimum time to bake at the block's priority"
% string) required_endorsements_query int31
(op_div open_root "required_endorsements" % string).
End S.
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
register0 S.required_endorsements
(fun ctxt =>
fun function_parameter =>
let '{| block_delay := block_delay |} := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
required_endorsements ctxt block_delay).
Definition get {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D) (block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Z) :=
RPC_context.make_call0 S.required_endorsements ctxt block
{| block_delay := block_delay |} tt.
End Required_endorsements.
Module Minimal_valid_time.
Definition minimal_valid_time
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (priority : Z)
(endorsing_power : Z)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Time.t) :=
Baking.minimal_valid_time ctxt priority endorsing_power.
Module S.
Record t := {
priority : Z;
endorsing_power : Z }.
Definition minimal_valid_time_query
: Tezos_protocol_environment_alpha__Environment.RPC_query.t t :=
op_pipegt
(op_pipeplus
(op_pipeplus
(query
(fun priority =>
fun endorsing_power =>
{| priority := priority; endorsing_power := endorsing_power |}))
(field None "priority" % string RPC_arg.int 0 (fun t => priority t)))
(field None "endorsing_power" % string RPC_arg.int 0
(fun t => endorsing_power t))) seal.
Definition minimal_valid_time
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context t unit
Tezos_protocol_environment_alpha__Environment.Time.t :=
RPC_service.get_service
(Some
"Minimal valid time for a block given a priority and an endorsing power."
% string) minimal_valid_time_query Time.encoding
(op_div open_root "minimal_valid_time" % string).
End S.
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
register0 S.minimal_valid_time
(fun ctxt =>
fun function_parameter =>
let '{| priority := priority; endorsing_power := endorsing_power |} :=
function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
minimal_valid_time ctxt priority endorsing_power).
Definition get {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D) (priority : Z) (endorsing_power : Z)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_environment_alpha__Environment.Time.t) :=
RPC_context.make_call0 S.minimal_valid_time ctxt block
{| priority := priority; endorsing_power := endorsing_power |} tt.
End Minimal_valid_time.
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := register tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Baking_rights.register tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Endorsing_rights.register tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Endorsing_power.register tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Required_endorsements.register tt in
Minimal_valid_time.register tt.
Definition endorsement_rights
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(level : Tezos_raw_protocol_alpha.Alpha_context.Level.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
op_gtgteqquestion (Endorsing_rights.endorsement_slots ctxt (level, None))
(fun l =>
_return
(List.map
(fun function_parameter =>
let '{| Endorsing_rights.delegate := delegate |} :=
function_parameter in
delegate) l)).
Definition baking_rights
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(max_priority :
option
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha__Alpha_context.Raw_level.t *
(list
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* (option Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t))))) :=
let max :=
match max_priority with
| None => 64
| Some m => m
end in
let level := Level.current ctxt in
op_gtgteqquestion (Baking_rights.baking_priorities ctxt max (level, None))
(fun l =>
_return
((level level),
(List.map
(fun function_parameter =>
let '{|
Baking_rights.delegate := delegate;
Baking_rights.timestamp := timestamp
|} := function_parameter in
(delegate, timestamp)) l))).
Definition endorsing_power
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(operation :
Tezos_raw_protocol_alpha.Alpha_context.packed_operation *
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
Endorsing_power.endorsing_power ctxt operation.
Definition required_endorsements
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
Required_endorsements.required_endorsements ctxt delay.
Definition minimal_valid_time
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (priority : Z)
(endorsing_power : Z)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Time.t) :=
Minimal_valid_time.minimal_valid_time ctxt priority endorsing_power.
src/proto_alpha/lib_protocol/delegate_storage.ml 187 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type balance =
| Contract of Contract_repr.t
| Rewards of Signature.Public_key_hash.t * Cycle_repr.t
| Fees of Signature.Public_key_hash.t * Cycle_repr.t
| Deposits of Signature.Public_key_hash.t * Cycle_repr.t
let balance_encoding =
let open Data_encoding in
def "operation_metadata.alpha.balance"
@@ union
[ case
(Tag 0)
~title:"Contract"
(obj2
(req "kind" (constant "contract"))
(req "contract" Contract_repr.encoding))
(function Contract c -> Some ((), c) | _ -> None)
(fun ((), c) -> Contract c);
case
(Tag 1)
~title:"Rewards"
(obj4
(req "kind" (constant "freezer"))
(req "category" (constant "rewards"))
(req "delegate" Signature.Public_key_hash.encoding)
(req "cycle" Cycle_repr.encoding))
(function Rewards (d, l) -> Some ((), (), d, l) | _ -> None)
(fun ((), (), d, l) -> Rewards (d, l));
case
(Tag 2)
~title:"Fees"
(obj4
(req "kind" (constant "freezer"))
(req "category" (constant "fees"))
(req "delegate" Signature.Public_key_hash.encoding)
(req "cycle" Cycle_repr.encoding))
(function Fees (d, l) -> Some ((), (), d, l) | _ -> None)
(fun ((), (), d, l) -> Fees (d, l));
case
(Tag 3)
~title:"Deposits"
(obj4
(req "kind" (constant "freezer"))
(req "category" (constant "deposits"))
(req "delegate" Signature.Public_key_hash.encoding)
(req "cycle" Cycle_repr.encoding))
(function Deposits (d, l) -> Some ((), (), d, l) | _ -> None)
(fun ((), (), d, l) -> Deposits (d, l)) ]
type balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t
let balance_update_encoding =
let open Data_encoding in
def "operation_metadata.alpha.balance_update"
@@ obj1
(req
"change"
(conv
(function
| Credited v ->
Tez_repr.to_mutez v
| Debited v ->
Int64.neg (Tez_repr.to_mutez v))
( Json.wrap_error
@@ fun v ->
if Compare.Int64.(v < 0L) then
match Tez_repr.of_mutez (Int64.neg v) with
| Some v ->
Debited v
| None ->
failwith "Qty.of_mutez"
else
match Tez_repr.of_mutez v with
| Some v ->
Credited v
| None ->
failwith "Qty.of_mutez" )
int64))
type balance_updates = (balance * balance_update) list
let balance_updates_encoding =
let open Data_encoding in
def "operation_metadata.alpha.balance_updates"
@@ list (merge_objs balance_encoding balance_update_encoding)
let cleanup_balance_updates balance_updates =
List.filter
(fun (_, (Credited update | Debited update)) ->
not (Tez_repr.equal update Tez_repr.zero))
balance_updates
type frozen_balance = {
deposit : Tez_repr.t;
fees : Tez_repr.t;
rewards : Tez_repr.t;
}
let frozen_balance_encoding =
let open Data_encoding in
conv
(fun {deposit; fees; rewards} -> (deposit, fees, rewards))
(fun (deposit, fees, rewards) -> {deposit; fees; rewards})
(obj3
(req "deposit" Tez_repr.encoding)
(req "fees" Tez_repr.encoding)
(req "rewards" Tez_repr.encoding))
type error +=
| No_deletion of Signature.Public_key_hash.t (* `Permanent *)
| Active_delegate (* `Temporary *)
| Current_delegate (* `Temporary *)
| Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *)
| Balance_too_low_for_deposit of {
delegate : Signature.Public_key_hash.t;
deposit : Tez_repr.t;
balance : Tez_repr.t;
}
(* `Temporary *)
let () =
register_error_kind
`Permanent
~id:"delegate.no_deletion"
~title:"Forbidden delegate deletion"
~description:"Tried to unregister a delegate"
~pp:(fun ppf delegate ->
Format.fprintf
ppf
"Delegate deletion is forbidden (%a)"
Signature.Public_key_hash.pp
delegate)
Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
(function No_deletion c -> Some c | _ -> None)
(fun c -> No_deletion c) ;
register_error_kind
`Temporary
~id:"delegate.already_active"
~title:"Delegate already active"
~description:"Useless delegate reactivation"
~pp:(fun ppf () ->
Format.fprintf ppf "The delegate is still active, no need to refresh it")
Data_encoding.empty
(function Active_delegate -> Some () | _ -> None)
(fun () -> Active_delegate) ;
register_error_kind
`Temporary
~id:"delegate.unchanged"
~title:"Unchanged delegated"
~description:"Contract already delegated to the given delegate"
~pp:(fun ppf () ->
Format.fprintf
ppf
"The contract is already delegated to the same delegate")
Data_encoding.empty
(function Current_delegate -> Some () | _ -> None)
(fun () -> Current_delegate) ;
register_error_kind
`Permanent
~id:"delegate.empty_delegate_account"
~title:"Empty delegate account"
~description:
"Cannot register a delegate when its implicit account is empty"
~pp:(fun ppf delegate ->
Format.fprintf
ppf
"Delegate registration is forbidden when the delegate\n\
\ implicit account is empty (%a)"
Signature.Public_key_hash.pp
delegate)
Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
(function Empty_delegate_account c -> Some c | _ -> None)
(fun c -> Empty_delegate_account c) ;
register_error_kind
`Temporary
~id:"delegate.balance_too_low_for_deposit"
~title:"Balance too low for deposit"
~description:"Cannot freeze deposit when the balance is too low"
~pp:(fun ppf (delegate, balance, deposit) ->
Format.fprintf
ppf
"Delegate %a has a too low balance (%a) to deposit %a"
Signature.Public_key_hash.pp
delegate
Tez_repr.pp
balance
Tez_repr.pp
deposit)
Data_encoding.(
obj3
(req "delegate" Signature.Public_key_hash.encoding)
(req "balance" Tez_repr.encoding)
(req "deposit" Tez_repr.encoding))
(function
| Balance_too_low_for_deposit {delegate; balance; deposit} ->
Some (delegate, balance, deposit)
| _ ->
None)
(fun (delegate, balance, deposit) ->
Balance_too_low_for_deposit {delegate; balance; deposit})
let link c contract delegate =
Storage.Contract.Balance.get c contract
>>=? fun balance ->
Roll_storage.Delegate.add_amount c delegate balance
>>=? fun c ->
Storage.Contract.Delegated.add
(c, Contract_repr.implicit_contract delegate)
contract
>>= fun c -> return c
let unlink c contract =
Storage.Contract.Balance.get c contract
>>=? fun balance ->
Storage.Contract.Delegate.get_option c contract
>>=? function
| None ->
return c
| Some delegate ->
(* Removes the balance of the contract from the delegate *)
Roll_storage.Delegate.remove_amount c delegate balance
>>=? fun c ->
Storage.Contract.Delegated.del
(c, Contract_repr.implicit_contract delegate)
contract
>>= fun c -> return c
let known c delegate =
Storage.Contract.Manager.get_option
c
(Contract_repr.implicit_contract delegate)
>>=? function
| None | Some (Manager_repr.Hash _) ->
return_false
| Some (Manager_repr.Public_key _) ->
return_true
(* A delegate is registered if its "implicit account" delegates to itself. *)
let registered c delegate =
Storage.Contract.Delegate.get_option
c
(Contract_repr.implicit_contract delegate)
>>=? function
| Some current_delegate ->
return @@ Signature.Public_key_hash.equal delegate current_delegate
| None ->
return_false
let init ctxt contract delegate =
known ctxt delegate
>>=? fun known_delegate ->
fail_unless known_delegate (Roll_storage.Unregistered_delegate delegate)
>>=? fun () ->
registered ctxt delegate
>>=? fun is_registered ->
fail_unless is_registered (Roll_storage.Unregistered_delegate delegate)
>>=? fun () ->
Storage.Contract.Delegate.init ctxt contract delegate
>>=? fun ctxt -> link ctxt contract delegate
let get = Roll_storage.get_contract_delegate
let set c contract delegate =
match delegate with
| None -> (
let delete () =
unlink c contract
>>=? fun c ->
Storage.Contract.Delegate.remove c contract >>= fun c -> return c
in
match Contract_repr.is_implicit contract with
| Some pkh ->
(* check if contract is a registered delegate *)
registered c pkh
>>=? fun is_registered ->
if is_registered then fail (No_deletion pkh) else delete ()
| None ->
delete () )
| Some delegate ->
known c delegate
>>=? fun known_delegate ->
registered c delegate
>>=? fun registered_delegate ->
let self_delegation =
match Contract_repr.is_implicit contract with
| Some pkh ->
Signature.Public_key_hash.equal pkh delegate
| None ->
false
in
if (not known_delegate) || not (registered_delegate || self_delegation)
then fail (Roll_storage.Unregistered_delegate delegate)
else
Storage.Contract.Delegate.get_option c contract
>>=? (function
| Some current_delegate
when Signature.Public_key_hash.equal delegate current_delegate
->
if self_delegation then
Roll_storage.Delegate.is_inactive c delegate
>>=? function
| true -> return_unit | false -> fail Active_delegate
else fail Current_delegate
| None | Some _ ->
return_unit)
>>=? fun () ->
(* check if contract is a registered delegate *)
( match Contract_repr.is_implicit contract with
| Some pkh ->
registered c pkh
>>=? fun is_registered ->
(* allow self-delegation to re-activate *)
if (not self_delegation) && is_registered then
fail (No_deletion pkh)
else return_unit
| None ->
return_unit )
>>=? fun () ->
Storage.Contract.Balance.mem c contract
>>= fun exists ->
fail_when
(self_delegation && not exists)
(Empty_delegate_account delegate)
>>=? fun () ->
unlink c contract
>>=? fun c ->
Storage.Contract.Delegate.init_set c contract delegate
>>= fun c ->
link c contract delegate
>>=? fun c ->
( if self_delegation then
Storage.Delegates.add c delegate
>>= fun c ->
Roll_storage.Delegate.set_active c delegate >>=? fun c -> return c
else return c )
>>=? fun c -> return c
let remove ctxt contract = unlink ctxt contract
let delegated_contracts ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
Storage.Contract.Delegated.elements (ctxt, contract)
let get_frozen_deposit ctxt contract cycle =
Storage.Contract.Frozen_deposits.get_option (ctxt, contract) cycle
>>=? function None -> return Tez_repr.zero | Some frozen -> return frozen
let credit_frozen_deposit ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_deposit ctxt contract cycle
>>=? fun old_amount ->
Lwt.return Tez_repr.(old_amount +? amount)
>>=? fun new_amount ->
Storage.Contract.Frozen_deposits.init_set (ctxt, contract) cycle new_amount
>>= fun ctxt ->
Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
>>= fun ctxt -> return ctxt
let freeze_deposit ctxt delegate amount =
let {Level_repr.cycle; _} = Level_storage.current ctxt in
Roll_storage.Delegate.set_active ctxt delegate
>>=? fun ctxt ->
let contract = Contract_repr.implicit_contract delegate in
Storage.Contract.Balance.get ctxt contract
>>=? fun balance ->
Lwt.return
(record_trace
(Balance_too_low_for_deposit {delegate; deposit = amount; balance})
Tez_repr.(balance -? amount))
>>=? fun new_balance ->
Storage.Contract.Balance.set ctxt contract new_balance
>>=? fun ctxt -> credit_frozen_deposit ctxt delegate cycle amount
let get_frozen_fees ctxt contract cycle =
Storage.Contract.Frozen_fees.get_option (ctxt, contract) cycle
>>=? function None -> return Tez_repr.zero | Some frozen -> return frozen
let credit_frozen_fees ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_fees ctxt contract cycle
>>=? fun old_amount ->
Lwt.return Tez_repr.(old_amount +? amount)
>>=? fun new_amount ->
Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount
>>= fun ctxt ->
Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
>>= fun ctxt -> return ctxt
let freeze_fees ctxt delegate amount =
let {Level_repr.cycle; _} = Level_storage.current ctxt in
Roll_storage.Delegate.add_amount ctxt delegate amount
>>=? fun ctxt -> credit_frozen_fees ctxt delegate cycle amount
let burn_fees ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_fees ctxt contract cycle
>>=? fun old_amount ->
( match Tez_repr.(old_amount -? amount) with
| Ok new_amount ->
Roll_storage.Delegate.remove_amount ctxt delegate amount
>>=? fun ctxt -> return (new_amount, ctxt)
| Error _ ->
Roll_storage.Delegate.remove_amount ctxt delegate old_amount
>>=? fun ctxt -> return (Tez_repr.zero, ctxt) )
>>=? fun (new_amount, ctxt) ->
Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount
>>= fun ctxt -> return ctxt
let get_frozen_rewards ctxt contract cycle =
Storage.Contract.Frozen_rewards.get_option (ctxt, contract) cycle
>>=? function None -> return Tez_repr.zero | Some frozen -> return frozen
let credit_frozen_rewards ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_rewards ctxt contract cycle
>>=? fun old_amount ->
Lwt.return Tez_repr.(old_amount +? amount)
>>=? fun new_amount ->
Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount
>>= fun ctxt ->
Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
>>= fun ctxt -> return ctxt
let freeze_rewards ctxt delegate amount =
let {Level_repr.cycle; _} = Level_storage.current ctxt in
credit_frozen_rewards ctxt delegate cycle amount
let burn_rewards ctxt delegate cycle amount =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_rewards ctxt contract cycle
>>=? fun old_amount ->
let new_amount =
match Tez_repr.(old_amount -? amount) with
| Error _ ->
Tez_repr.zero
| Ok new_amount ->
new_amount
in
Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount
>>= fun ctxt -> return ctxt
let unfreeze ctxt delegate cycle =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_deposit ctxt contract cycle
>>=? fun deposit ->
get_frozen_fees ctxt contract cycle
>>=? fun fees ->
get_frozen_rewards ctxt contract cycle
>>=? fun rewards ->
Storage.Contract.Balance.get ctxt contract
>>=? fun balance ->
Lwt.return Tez_repr.(deposit +? fees)
>>=? fun unfrozen_amount ->
Lwt.return Tez_repr.(unfrozen_amount +? rewards)
>>=? fun unfrozen_amount ->
Lwt.return Tez_repr.(balance +? unfrozen_amount)
>>=? fun balance ->
Storage.Contract.Balance.set ctxt contract balance
>>=? fun ctxt ->
Roll_storage.Delegate.add_amount ctxt delegate rewards
>>=? fun ctxt ->
Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle
>>= fun ctxt ->
Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle
>>= fun ctxt ->
Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle
>>= fun ctxt ->
return
( ctxt,
cleanup_balance_updates
[ (Deposits (delegate, cycle), Debited deposit);
(Fees (delegate, cycle), Debited fees);
(Rewards (delegate, cycle), Debited rewards);
( Contract (Contract_repr.implicit_contract delegate),
Credited unfrozen_amount ) ] )
let cycle_end ctxt last_cycle unrevealed =
let preserved = Constants_storage.preserved_cycles ctxt in
( match Cycle_repr.pred last_cycle with
| None ->
return (ctxt, [])
| Some revealed_cycle ->
List.fold_left
(fun acc (u : Nonce_storage.unrevealed) ->
acc
>>=? fun (ctxt, balance_updates) ->
burn_fees ctxt u.delegate revealed_cycle u.fees
>>=? fun ctxt ->
burn_rewards ctxt u.delegate revealed_cycle u.rewards
>>=? fun ctxt ->
let bus =
[ (Fees (u.delegate, revealed_cycle), Debited u.fees);
(Rewards (u.delegate, revealed_cycle), Debited u.rewards) ]
in
return (ctxt, bus @ balance_updates))
(return (ctxt, []))
unrevealed )
>>=? fun (ctxt, balance_updates) ->
match Cycle_repr.sub last_cycle preserved with
| None ->
return (ctxt, balance_updates, [])
| Some unfrozen_cycle ->
Storage.Delegates_with_frozen_balance.fold
(ctxt, unfrozen_cycle)
~init:(Ok (ctxt, balance_updates))
~f:(fun delegate acc ->
Lwt.return acc
>>=? fun (ctxt, bus) ->
unfreeze ctxt delegate unfrozen_cycle
>>=? fun (ctxt, balance_updates) ->
return (ctxt, balance_updates @ bus))
>>=? fun (ctxt, balance_updates) ->
Storage.Delegates_with_frozen_balance.clear (ctxt, unfrozen_cycle)
>>= fun ctxt ->
Storage.Active_delegates_with_rolls.fold
ctxt
~init:(Ok (ctxt, []))
~f:(fun delegate acc ->
Lwt.return acc
>>=? fun (ctxt, deactivated) ->
Storage.Contract.Delegate_desactivation.get
ctxt
(Contract_repr.implicit_contract delegate)
>>=? fun cycle ->
if Cycle_repr.(cycle <= last_cycle) then
Roll_storage.Delegate.set_inactive ctxt delegate
>>=? fun ctxt -> return (ctxt, delegate :: deactivated)
else return (ctxt, deactivated))
>>=? fun (ctxt, deactivated) ->
return (ctxt, balance_updates, deactivated)
let punish ctxt delegate cycle =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_deposit ctxt contract cycle
>>=? fun deposit ->
get_frozen_fees ctxt contract cycle
>>=? fun fees ->
get_frozen_rewards ctxt contract cycle
>>=? fun rewards ->
Roll_storage.Delegate.remove_amount ctxt delegate deposit
>>=? fun ctxt ->
Roll_storage.Delegate.remove_amount ctxt delegate fees
>>=? fun ctxt ->
(* Rewards are not accounted in the delegate's rolls yet... *)
Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle
>>= fun ctxt ->
Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle
>>= fun ctxt ->
Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle
>>= fun ctxt -> return (ctxt, {deposit; fees; rewards})
let has_frozen_balance ctxt delegate cycle =
let contract = Contract_repr.implicit_contract delegate in
get_frozen_deposit ctxt contract cycle
>>=? fun deposit ->
if Tez_repr.(deposit <> zero) then return_true
else
get_frozen_fees ctxt contract cycle
>>=? fun fees ->
if Tez_repr.(fees <> zero) then return_true
else
get_frozen_rewards ctxt contract cycle
>>=? fun rewards -> return Tez_repr.(rewards <> zero)
let frozen_balance_by_cycle_encoding =
let open Data_encoding in
conv
Cycle_repr.Map.bindings
(List.fold_left
(fun m (c, b) -> Cycle_repr.Map.add c b m)
Cycle_repr.Map.empty)
(list
(merge_objs
(obj1 (req "cycle" Cycle_repr.encoding))
frozen_balance_encoding))
let empty_frozen_balance =
{deposit = Tez_repr.zero; fees = Tez_repr.zero; rewards = Tez_repr.zero}
let frozen_balance_by_cycle ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
let map = Cycle_repr.Map.empty in
Storage.Contract.Frozen_deposits.fold
(ctxt, contract)
~init:map
~f:(fun cycle amount map ->
Lwt.return
(Cycle_repr.Map.add
cycle
{empty_frozen_balance with deposit = amount}
map))
>>= fun map ->
Storage.Contract.Frozen_fees.fold
(ctxt, contract)
~init:map
~f:(fun cycle amount map ->
let balance =
match Cycle_repr.Map.find_opt cycle map with
| None ->
empty_frozen_balance
| Some balance ->
balance
in
Lwt.return (Cycle_repr.Map.add cycle {balance with fees = amount} map))
>>= fun map ->
Storage.Contract.Frozen_rewards.fold
(ctxt, contract)
~init:map
~f:(fun cycle amount map ->
let balance =
match Cycle_repr.Map.find_opt cycle map with
| None ->
empty_frozen_balance
| Some balance ->
balance
in
Lwt.return (Cycle_repr.Map.add cycle {balance with rewards = amount} map))
>>= fun map -> Lwt.return map
let frozen_balance ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
let balance = Ok Tez_repr.zero in
Storage.Contract.Frozen_deposits.fold
(ctxt, contract)
~init:balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
>>= fun balance ->
Storage.Contract.Frozen_fees.fold
(ctxt, contract)
~init:balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
>>= fun balance ->
Storage.Contract.Frozen_rewards.fold
(ctxt, contract)
~init:balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
>>= fun balance -> Lwt.return balance
let full_balance ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
frozen_balance ctxt delegate
>>=? fun frozen_balance ->
Storage.Contract.Balance.get ctxt contract
>>=? fun balance -> Lwt.return Tez_repr.(frozen_balance +? balance)
let deactivated = Roll_storage.Delegate.is_inactive
let grace_period ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
Storage.Contract.Delegate_desactivation.get ctxt contract
let staking_balance ctxt delegate =
let token_per_rolls = Constants_storage.tokens_per_roll ctxt in
Roll_storage.get_rolls ctxt delegate
>>=? fun rolls ->
Roll_storage.get_change ctxt delegate
>>=? fun change ->
let rolls = Int64.of_int (List.length rolls) in
Lwt.return Tez_repr.(token_per_rolls *? rolls)
>>=? fun balance -> Lwt.return Tez_repr.(balance +? change)
let delegated_balance ctxt delegate =
let contract = Contract_repr.implicit_contract delegate in
staking_balance ctxt delegate
>>=? fun staking_balance ->
Storage.Contract.Balance.get ctxt contract
>>= fun self_staking_balance ->
Storage.Contract.Frozen_deposits.fold
(ctxt, contract)
~init:self_staking_balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
>>= fun self_staking_balance ->
Storage.Contract.Frozen_fees.fold
(ctxt, contract)
~init:self_staking_balance
~f:(fun _cycle amount acc ->
Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
>>=? fun self_staking_balance ->
Lwt.return Tez_repr.(staking_balance -? self_staking_balance)
let fold = Storage.Delegates.fold
let list = Storage.Delegates.elements
src/proto_alpha/lib_protocol/delegate_storage.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive balance : Type :=
| Contract : Tezos_raw_protocol_alpha.Contract_repr.t -> balance
| Rewards :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
Tezos_raw_protocol_alpha.Cycle_repr.t -> balance
| Fees :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
Tezos_raw_protocol_alpha.Cycle_repr.t -> balance
| Deposits :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
Tezos_raw_protocol_alpha.Cycle_repr.t -> balance.
Definition balance_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding balance :=
op_atat
(let arg := def "operation_metadata.alpha.balance" % string in
fun eta => arg None None eta)
(union None
(cons
(case "Contract" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
(obj2 (req None None "kind" % string (constant "contract" % string))
(req None None "contract" % string Contract_repr.encoding))
(fun function_parameter =>
match function_parameter with
| Contract c => Some (tt, c)
| _ => None
end)
(fun function_parameter =>
let '(tt, c) := function_parameter in
Contract c))
(cons
(case "Rewards" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
(obj4 (req None None "kind" % string (constant "freezer" % string))
(req None None "category" % string (constant "rewards" % string))
(req None None "delegate" % string
Signature.Public_key_hash.encoding)
(req None None "cycle" % string Cycle_repr.encoding))
(fun function_parameter =>
match function_parameter with
| Rewards d l => Some (tt, tt, d, l)
| _ => None
end)
(fun function_parameter =>
let '(tt, tt, d, l) := function_parameter in
Rewards d l))
(cons
(case "Fees" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 2)
(obj4
(req None None "kind" % string (constant "freezer" % string))
(req None None "category" % string (constant "fees" % string))
(req None None "delegate" % string
Signature.Public_key_hash.encoding)
(req None None "cycle" % string Cycle_repr.encoding))
(fun function_parameter =>
match function_parameter with
| Fees d l => Some (tt, tt, d, l)
| _ => None
end)
(fun function_parameter =>
let '(tt, tt, d, l) := function_parameter in
Fees d l))
(cons
(case "Deposits" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag
3)
(obj4
(req None None "kind" % string (constant "freezer" % string))
(req None None "category" % string
(constant "deposits" % string))
(req None None "delegate" % string
Signature.Public_key_hash.encoding)
(req None None "cycle" % string Cycle_repr.encoding))
(fun function_parameter =>
match function_parameter with
| Deposits d l => Some (tt, tt, d, l)
| _ => None
end)
(fun function_parameter =>
let '(tt, tt, d, l) := function_parameter in
Deposits d l)) []))))).
Inductive balance_update : Type :=
| Debited : Tezos_raw_protocol_alpha.Tez_repr.t -> balance_update
| Credited : Tezos_raw_protocol_alpha.Tez_repr.t -> balance_update.
Definition balance_update_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
balance_update :=
op_atat
(let arg := def "operation_metadata.alpha.balance_update" % string in
fun eta => arg None None eta)
(obj1
(req None None "change" % string
(conv
(fun function_parameter =>
match function_parameter with
| Credited v => Tez_repr.to_mutez v
| Debited v => Int64.neg (Tez_repr.to_mutez v)
end)
(op_atat Json.wrap_error
(fun v =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
v
(* ❌ Constant of type int64 is converted to int *)
0 then
match Tez_repr.of_mutez (Int64.neg v) with
| Some v => Debited v
| None => failwith "Qty.of_mutez" % string
end
else
match Tez_repr.of_mutez v with
| Some v => Credited v
| None => failwith "Qty.of_mutez" % string
end)) None int64))).
Definition balance_updates := list (balance * balance_update).
Definition balance_updates_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(list (balance * balance_update)) :=
op_atat
(let arg := def "operation_metadata.alpha.balance_updates" % string in
fun eta => arg None None eta)
(list None (merge_objs balance_encoding balance_update_encoding)).
Definition cleanup_balance_updates {A : Type}
(balance_updates : list (A * balance_update)) : list (A * balance_update) :=
List.filter
(fun function_parameter =>
let '(_, Credited update | Debited update) := function_parameter in
not (Tez_repr.equal update Tez_repr.zero)) balance_updates.
Record frozen_balance := {
deposit : Tezos_raw_protocol_alpha.Tez_repr.t;
fees : Tezos_raw_protocol_alpha.Tez_repr.t;
rewards : Tezos_raw_protocol_alpha.Tez_repr.t }.
Definition frozen_balance_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
frozen_balance :=
conv
(fun function_parameter =>
let '{| deposit := deposit; fees := fees; rewards := rewards |} :=
function_parameter in
(deposit, fees, rewards))
(fun function_parameter =>
let '(deposit, fees, rewards) := function_parameter in
{| deposit := deposit; fees := fees; rewards := rewards |}) None
(obj3 (req None None "deposit" % string Tez_repr.encoding)
(req None None "fees" % string Tez_repr.encoding)
(req None None "rewards" % string Tez_repr.encoding)).
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition link
(c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteqquestion (Storage.Contract.Balance.get c contract)
(fun balance =>
op_gtgteqquestion (Roll_storage.Delegate.add_amount c delegate balance)
(fun c =>
op_gtgteq
(Storage.Contract.Delegated.add
(c, (Contract_repr.implicit_contract delegate)) contract)
(fun c => _return c))).
Definition unlink
(c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Contract.Balance.context) :=
op_gtgteqquestion (Storage.Contract.Balance.get c contract)
(fun balance =>
op_gtgteqquestion (Storage.Contract.Delegate.get_option c contract)
(fun function_parameter =>
match function_parameter with
| None => _return c
| Some delegate =>
op_gtgteqquestion
(Roll_storage.Delegate.remove_amount c delegate balance)
(fun c =>
op_gtgteq
(Storage.Contract.Delegated.del
(c, (Contract_repr.implicit_contract delegate)) contract)
(fun c => _return c))
end)).
Definition known
(c : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
op_gtgteqquestion
(Storage.Contract.Manager.get_option c
(Contract_repr.implicit_contract delegate))
(fun function_parameter =>
match function_parameter with
| None | Some (Tezos_raw_protocol_alpha.Manager_repr.Hash _) =>
return_false
| Some (Tezos_raw_protocol_alpha.Manager_repr.Public_key _) => return_true
end).
Definition registered
(c : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
op_gtgteqquestion
(Storage.Contract.Delegate.get_option c
(Contract_repr.implicit_contract delegate))
(fun function_parameter =>
match function_parameter with
| Some current_delegate =>
op_atat _return
(Signature.Public_key_hash.equal delegate current_delegate)
| None => return_false
end).
Definition init
(ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.key)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteqquestion (known ctxt delegate)
(fun known_delegate =>
op_gtgteqquestion
(fail_unless known_delegate
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unregistered_delegate
delegate))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (registered ctxt delegate)
(fun is_registered =>
op_gtgteqquestion
(fail_unless is_registered
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unregistered_delegate
delegate))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Storage.Contract.Delegate.init ctxt contract delegate)
(fun ctxt => link ctxt contract delegate))))).
Definition get
: Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_raw_protocol_alpha.Contract_repr.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
Roll_storage.get_contract_delegate.
Definition set
(c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
(delegate :
option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
match delegate with
| None =>
let delete (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let 'tt := function_parameter in
op_gtgteqquestion (unlink c contract)
(fun c =>
op_gtgteq (Storage.Contract.Delegate.remove c contract)
(fun c => _return c)) in
match Contract_repr.is_implicit contract with
| Some pkh =>
op_gtgteqquestion (registered c pkh)
(fun is_registered =>
if is_registered then
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.No_deletion
pkh)
else
delete tt)
| None => delete tt
end
| Some delegate =>
op_gtgteqquestion (known c delegate)
(fun known_delegate =>
op_gtgteqquestion (registered c delegate)
(fun registered_delegate =>
let self_delegation :=
match Contract_repr.is_implicit contract with
| Some pkh => Signature.Public_key_hash.equal pkh delegate
| None => false
end in
if
op_pipepipe (not known_delegate)
(not (op_pipepipe registered_delegate self_delegation)) then
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unregistered_delegate
delegate)
else
op_gtgteqquestion
(op_gtgteqquestion
(Storage.Contract.Delegate.get_option c contract)
(fun function_parameter =>
match function_parameter with
| Some current_delegate =>
if self_delegation then
op_gtgteqquestion
(Roll_storage.Delegate.is_inactive c delegate)
(fun function_parameter =>
match function_parameter with
| true => return_unit
| false =>
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Active_delegate
end)
else
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Current_delegate
| None | Some _ => return_unit
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
match Contract_repr.is_implicit contract with
| Some pkh =>
op_gtgteqquestion (registered c pkh)
(fun is_registered =>
if op_andand (not self_delegation) is_registered then
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.No_deletion
pkh)
else
return_unit)
| None => return_unit
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Storage.Contract.Balance.mem c contract)
(fun _exists =>
op_gtgteqquestion
(fail_when (op_andand self_delegation (not _exists))
(Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_delegate_account
delegate))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (unlink c contract)
(fun c =>
op_gtgteq
(Storage.Contract.Delegate.init_set c
contract delegate)
(fun c =>
op_gtgteqquestion
(link c contract delegate)
(fun c =>
op_gtgteqquestion
(if self_delegation then
op_gtgteq
(Storage.Delegates.add c
delegate)
(fun c =>
op_gtgteqquestion
(Roll_storage.Delegate.set_active
c delegate)
(fun c => _return c))
else
_return c) (fun c => _return c))))))))))
end.
Definition remove
(ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Contract.Balance.context) :=
unlink ctxt contract.
Definition delegated_contracts
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(list Tezos_raw_protocol_alpha.Storage.Contract.Delegated.elt) :=
let contract := Contract_repr.implicit_contract delegate in
Storage.Contract.Delegated.elements (ctxt, contract).
Definition get_frozen_deposit
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(contract : Tezos_raw_protocol_alpha.Contract_repr.t)
(cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Tez_repr.t) :=
op_gtgteqquestion
(Storage.Contract.Frozen_deposits.get_option (ctxt, contract) cycle)
(fun function_parameter =>
match function_parameter with
| None => _return Tez_repr.zero
| Some frozen => _return frozen
end).
Definition credit_frozen_deposit
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
(amount : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let contract := Contract_repr.implicit_contract delegate in
op_gtgteqquestion (get_frozen_deposit ctxt contract cycle)
(fun old_amount =>
op_gtgteqquestion (Lwt._return (op_plusquestion old_amount amount))
(fun new_amount =>
op_gtgteq
(Storage.Contract.Frozen_deposits.init_set (ctxt, contract) cycle
new_amount)
(fun ctxt =>
op_gtgteq
(Storage.Delegates_with_frozen_balance.add (ctxt, cycle)
delegate) (fun ctxt => _return ctxt)))).
Definition freeze_deposit
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(amount : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let '{| Level_repr.cycle := cycle |} := Level_storage.current ctxt in
op_gtgteqquestion (Roll_storage.Delegate.set_active ctxt delegate)
(fun ctxt =>
let contract := Contract_repr.implicit_contract delegate in
op_gtgteqquestion (Storage.Contract.Balance.get ctxt contract)
(fun balance =>
op_gtgteqquestion
(Lwt._return
(record_trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low_for_deposit
{| delegate := delegate; deposit := amount; balance := balance
|}) (op_minusquestion balance amount)))
(fun new_balance =>
op_gtgteqquestion
(Storage.Contract.Balance.set ctxt contract new_balance)
(fun ctxt => credit_frozen_deposit ctxt delegate cycle amount)))).
Definition get_frozen_fees
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(contract : Tezos_raw_protocol_alpha.Contract_repr.t)
(cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Tez_repr.t) :=
op_gtgteqquestion
(Storage.Contract.Frozen_fees.get_option (ctxt, contract) cycle)
(fun function_parameter =>
match function_parameter with
| None => _return Tez_repr.zero
| Some frozen => _return frozen
end).
Definition credit_frozen_fees
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.key)
(amount : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let contract := Contract_repr.implicit_contract delegate in
op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
(fun old_amount =>
op_gtgteqquestion (Lwt._return (op_plusquestion old_amount amount))
(fun new_amount =>
op_gtgteq
(Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle
new_amount)
(fun ctxt =>
op_gtgteq
(Storage.Delegates_with_frozen_balance.add (ctxt, cycle)
delegate) (fun ctxt => _return ctxt)))).
Definition freeze_fees
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(amount : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let '{| Level_repr.cycle := cycle |} := Level_storage.current ctxt in
op_gtgteqquestion (Roll_storage.Delegate.add_amount ctxt delegate amount)
(fun ctxt => credit_frozen_fees ctxt delegate cycle amount).
Definition burn_fees
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.key)
(amount : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let contract := Contract_repr.implicit_contract delegate in
op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
(fun old_amount =>
op_gtgteqquestion
match op_minusquestion old_amount amount with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok new_amount
=>
op_gtgteqquestion
(Roll_storage.Delegate.remove_amount ctxt delegate amount)
(fun ctxt => _return (new_amount, ctxt))
| Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ =>
op_gtgteqquestion
(Roll_storage.Delegate.remove_amount ctxt delegate old_amount)
(fun ctxt => _return (Tez_repr.zero, ctxt))
end
(fun function_parameter =>
let '(new_amount, ctxt) := function_parameter in
op_gtgteq
(Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle
new_amount) (fun ctxt => _return ctxt))).
Definition get_frozen_rewards
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(contract : Tezos_raw_protocol_alpha.Contract_repr.t)
(cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Tez_repr.t) :=
op_gtgteqquestion
(Storage.Contract.Frozen_rewards.get_option (ctxt, contract) cycle)
(fun function_parameter =>
match function_parameter with
| None => _return Tez_repr.zero
| Some frozen => _return frozen
end).
Definition credit_frozen_rewards
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.key)
(amount : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let contract := Contract_repr.implicit_contract delegate in
op_gtgteqquestion (get_frozen_rewards ctxt contract cycle)
(fun old_amount =>
op_gtgteqquestion (Lwt._return (op_plusquestion old_amount amount))
(fun new_amount =>
op_gtgteq
(Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle
new_amount)
(fun ctxt =>
op_gtgteq
(Storage.Delegates_with_frozen_balance.add (ctxt, cycle)
delegate) (fun ctxt => _return ctxt)))).
Definition freeze_rewards
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(amount : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let '{| Level_repr.cycle := cycle |} := Level_storage.current ctxt in
credit_frozen_rewards ctxt delegate cycle amount.
Definition burn_rewards
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.key)
(amount : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let contract := Contract_repr.implicit_contract delegate in
op_gtgteqquestion (get_frozen_rewards ctxt contract cycle)
(fun old_amount =>
let new_amount :=
match op_minusquestion old_amount amount with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ =>
Tez_repr.zero
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok new_amount
=> new_amount
end in
op_gtgteq
(Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle
new_amount) (fun ctxt => _return ctxt)).
Definition unfreeze
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t *
(list (balance * balance_update)))) :=
let contract := Contract_repr.implicit_contract delegate in
op_gtgteqquestion (get_frozen_deposit ctxt contract cycle)
(fun deposit =>
op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
(fun fees =>
op_gtgteqquestion (get_frozen_rewards ctxt contract cycle)
(fun rewards =>
op_gtgteqquestion (Storage.Contract.Balance.get ctxt contract)
(fun balance =>
op_gtgteqquestion (Lwt._return (op_plusquestion deposit fees))
(fun unfrozen_amount =>
op_gtgteqquestion
(Lwt._return (op_plusquestion unfrozen_amount rewards))
(fun unfrozen_amount =>
op_gtgteqquestion
(Lwt._return
(op_plusquestion balance unfrozen_amount))
(fun balance =>
op_gtgteqquestion
(Storage.Contract.Balance.set ctxt contract
balance)
(fun ctxt =>
op_gtgteqquestion
(Roll_storage.Delegate.add_amount ctxt
delegate rewards)
(fun ctxt =>
op_gtgteq
(Storage.Contract.Frozen_deposits.remove
(ctxt, contract) cycle)
(fun ctxt =>
op_gtgteq
(Storage.Contract.Frozen_fees.remove
(ctxt, contract) cycle)
(fun ctxt =>
op_gtgteq
(Storage.Contract.Frozen_rewards.remove
(ctxt, contract) cycle)
(fun ctxt =>
_return
(ctxt,
(cleanup_balance_updates
(cons
((Deposits delegate
cycle),
(Debited deposit))
(cons
((Fees delegate
cycle),
(Debited fees))
(cons
((Rewards delegate
cycle),
(Debited rewards))
(cons
((Contract
(Contract_repr.implicit_contract
delegate)),
(Credited
unfrozen_amount))
[])))))))))))))))))).
Definition cycle_end
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
(last_cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
(unrevealed : list Tezos_raw_protocol_alpha.Nonce_storage.unrevealed)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.context *
(list (balance * balance_update)) *
(list Tezos_raw_protocol_alpha.Storage.Active_delegates_with_rolls.elt))) :=
let preserved := Constants_storage.preserved_cycles ctxt in
op_gtgteqquestion
match Cycle_repr.pred last_cycle with
| None => _return (ctxt, [])
| Some revealed_cycle =>
List.fold_left
(fun acc =>
fun u =>
op_gtgteqquestion acc
(fun function_parameter =>
let '(ctxt, balance_updates) := function_parameter in
op_gtgteqquestion
(burn_fees ctxt (delegate u) revealed_cycle (fees u))
(fun ctxt =>
op_gtgteqquestion
(burn_rewards ctxt (delegate u) revealed_cycle (rewards u))
(fun ctxt =>
let bus :=
cons
((Fees (delegate u) revealed_cycle),
(Debited (fees u)))
(cons
((Rewards (delegate u) revealed_cycle),
(Debited (rewards u))) []) in
_return (ctxt, (op_at bus balance_updates))))))
(_return (ctxt, [])) unrevealed
end
(fun function_parameter =>
let '(ctxt, balance_updates) := function_parameter in
match Cycle_repr.sub last_cycle preserved with
| None => _return (ctxt, balance_updates, [])
| Some unfrozen_cycle =>
op_gtgteqquestion
(Storage.Delegates_with_frozen_balance.fold (ctxt, unfrozen_cycle)
(Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
(ctxt, balance_updates))
(fun delegate =>
fun acc =>
op_gtgteqquestion (Lwt._return acc)
(fun function_parameter =>
let '(ctxt, bus) := function_parameter in
op_gtgteqquestion (unfreeze ctxt delegate unfrozen_cycle)
(fun function_parameter =>
let '(ctxt, balance_updates) := function_parameter in
_return (ctxt, (op_at balance_updates bus))))))
(fun function_parameter =>
let '(ctxt, balance_updates) := function_parameter in
op_gtgteq
(Storage.Delegates_with_frozen_balance.clear
(ctxt, unfrozen_cycle))
(fun ctxt =>
op_gtgteqquestion
(Storage.Active_delegates_with_rolls.fold ctxt
(Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
(ctxt, []))
(fun delegate =>
fun acc =>
op_gtgteqquestion (Lwt._return acc)
(fun function_parameter =>
let '(ctxt, deactivated) := function_parameter in
op_gtgteqquestion
(Storage.Contract.Delegate_desactivation.get ctxt
(Contract_repr.implicit_contract delegate))
(fun cycle =>
if op_lteq cycle last_cycle then
op_gtgteqquestion
(Roll_storage.Delegate.set_inactive ctxt
delegate)
(fun ctxt =>
_return
(ctxt, (cons delegate deactivated)))
else
_return (ctxt, deactivated)))))
(fun function_parameter =>
let '(ctxt, deactivated) := function_parameter in
_return (ctxt, balance_updates, deactivated))))
end).
Definition punish
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * frozen_balance)) :=
let contract := Contract_repr.implicit_contract delegate in
op_gtgteqquestion (get_frozen_deposit ctxt contract cycle)
(fun deposit =>
op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
(fun fees =>
op_gtgteqquestion (get_frozen_rewards ctxt contract cycle)
(fun rewards =>
op_gtgteqquestion
(Roll_storage.Delegate.remove_amount ctxt delegate deposit)
(fun ctxt =>
op_gtgteqquestion
(Roll_storage.Delegate.remove_amount ctxt delegate fees)
(fun ctxt =>
op_gtgteq
(Storage.Contract.Frozen_deposits.remove
(ctxt, contract) cycle)
(fun ctxt =>
op_gtgteq
(Storage.Contract.Frozen_fees.remove
(ctxt, contract) cycle)
(fun ctxt =>
op_gtgteq
(Storage.Contract.Frozen_rewards.remove
(ctxt, contract) cycle)
(fun ctxt =>
_return
(ctxt,
{| deposit := deposit; fees := fees;
rewards := rewards |}))))))))).
Definition has_frozen_balance
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
let contract := Contract_repr.implicit_contract delegate in
op_gtgteqquestion (get_frozen_deposit ctxt contract cycle)
(fun deposit =>
if op_ltgt deposit zero then
return_true
else
op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
(fun fees =>
if op_ltgt fees zero then
return_true
else
op_gtgteqquestion (get_frozen_rewards ctxt contract cycle)
(fun rewards => _return (op_ltgt rewards zero)))).
Definition frozen_balance_by_cycle_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(Tezos_raw_protocol_alpha.Cycle_repr.Map.t frozen_balance) :=
conv Cycle_repr.Map.bindings
(List.fold_left
(fun m =>
fun function_parameter =>
let '(c, b) := function_parameter in
Cycle_repr.Map.add c b m) Cycle_repr.Map.empty) None
(list None
(merge_objs (obj1 (req None None "cycle" % string Cycle_repr.encoding))
frozen_balance_encoding)).
Definition empty_frozen_balance : frozen_balance :=
{| deposit := Tez_repr.zero; fees := Tez_repr.zero; rewards := Tez_repr.zero
|}.
Definition frozen_balance_by_cycle
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_raw_protocol_alpha.Cycle_repr.Map.t frozen_balance) :=
let contract := Contract_repr.implicit_contract delegate in
let map := Cycle_repr.Map.empty in
op_gtgteq
(Storage.Contract.Frozen_deposits.fold (ctxt, contract) map
(fun cycle =>
fun amount =>
fun map =>
Lwt._return
(Cycle_repr.Map.add cycle
(* ❌ Record substitution not handled *)
record_substitution map)))
(fun map =>
op_gtgteq
(Storage.Contract.Frozen_fees.fold (ctxt, contract) map
(fun cycle =>
fun amount =>
fun map =>
let balance :=
match Cycle_repr.Map.find_opt cycle map with
| None => empty_frozen_balance
| Some balance => balance
end in
Lwt._return
(Cycle_repr.Map.add cycle
(* ❌ Record substitution not handled *)
record_substitution map)))
(fun map =>
op_gtgteq
(Storage.Contract.Frozen_rewards.fold (ctxt, contract) map
(fun cycle =>
fun amount =>
fun map =>
let balance :=
match Cycle_repr.Map.find_opt cycle map with
| None => empty_frozen_balance
| Some balance => balance
end in
Lwt._return
(Cycle_repr.Map.add cycle
(* ❌ Record substitution not handled *)
record_substitution map))) (fun map => Lwt._return map))).
Definition frozen_balance
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Pervasives.result
Tezos_raw_protocol_alpha.Tez_repr.t
(list Tezos_protocol_environment_alpha__Environment.Error_monad.error)) :=
let contract := Contract_repr.implicit_contract delegate in
let balance :=
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Tez_repr.zero in
op_gtgteq
(Storage.Contract.Frozen_deposits.fold (ctxt, contract) balance
(fun _cycle =>
fun amount =>
fun acc =>
op_gtgteqquestion (Lwt._return acc)
(fun acc => Lwt._return (op_plusquestion acc amount))))
(fun balance =>
op_gtgteq
(Storage.Contract.Frozen_fees.fold (ctxt, contract) balance
(fun _cycle =>
fun amount =>
fun acc =>
op_gtgteqquestion (Lwt._return acc)
(fun acc => Lwt._return (op_plusquestion acc amount))))
(fun balance =>
op_gtgteq
(Storage.Contract.Frozen_rewards.fold (ctxt, contract) balance
(fun _cycle =>
fun amount =>
fun acc =>
op_gtgteqquestion (Lwt._return acc)
(fun acc => Lwt._return (op_plusquestion acc amount))))
(fun balance => Lwt._return balance))).
Definition full_balance
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Tez_repr.t) :=
let contract := Contract_repr.implicit_contract delegate in
op_gtgteqquestion (frozen_balance ctxt delegate)
(fun frozen_balance =>
op_gtgteqquestion (Storage.Contract.Balance.get ctxt contract)
(fun balance => Lwt._return (op_plusquestion frozen_balance balance))).
Definition deactivated
: Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
Roll_storage.Delegate.is_inactive.
Definition grace_period
(ctxt :
Tezos_raw_protocol_alpha.Storage.Contract.Delegate_desactivation.context)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Contract.Delegate_desactivation.value) :=
let contract := Contract_repr.implicit_contract delegate in
Storage.Contract.Delegate_desactivation.get ctxt contract.
Definition staking_balance
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Tez_repr.t) :=
let token_per_rolls := Constants_storage.tokens_per_roll ctxt in
op_gtgteqquestion (Roll_storage.get_rolls ctxt delegate)
(fun rolls =>
op_gtgteqquestion (Roll_storage.get_change ctxt delegate)
(fun change =>
let rolls := Int64.of_int (List.length rolls) in
op_gtgteqquestion
(Lwt._return (op_starquestion token_per_rolls rolls))
(fun balance => Lwt._return (op_plusquestion balance change)))).
Definition delegated_balance
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Tez_repr.t) :=
let contract := Contract_repr.implicit_contract delegate in
op_gtgteqquestion (staking_balance ctxt delegate)
(fun staking_balance =>
op_gtgteq (Storage.Contract.Balance.get ctxt contract)
(fun self_staking_balance =>
op_gtgteq
(Storage.Contract.Frozen_deposits.fold (ctxt, contract)
self_staking_balance
(fun _cycle =>
fun amount =>
fun acc =>
op_gtgteqquestion (Lwt._return acc)
(fun acc => Lwt._return (op_plusquestion acc amount))))
(fun self_staking_balance =>
op_gtgteqquestion
(Storage.Contract.Frozen_fees.fold (ctxt, contract)
self_staking_balance
(fun _cycle =>
fun amount =>
fun acc =>
op_gtgteqquestion (Lwt._return acc)
(fun acc => Lwt._return (op_plusquestion acc amount))))
(fun self_staking_balance =>
Lwt._return
(op_minusquestion staking_balance self_staking_balance))))).
Definition fold {A : Type}
: Tezos_raw_protocol_alpha.Storage.Delegates.context ->
A ->
(Tezos_raw_protocol_alpha.Storage.Delegates.elt ->
A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
Storage.Delegates.fold.
Definition list
: Tezos_raw_protocol_alpha.Storage.Delegates.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(list Tezos_raw_protocol_alpha.Storage.Delegates.elt) :=
Storage.Delegates.elements.
src/proto_alpha/lib_protocol/fees_storage.ml 9 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type error += Cannot_pay_storage_fee (* `Temporary *)
type error += Operation_quota_exceeded (* `Temporary *)
type error += Storage_limit_too_high (* `Permanent *)
let () =
let open Data_encoding in
register_error_kind
`Temporary
~id:"contract.cannot_pay_storage_fee"
~title:"Cannot pay storage fee"
~description:"The storage fee is higher than the contract balance"
~pp:(fun ppf () -> Format.fprintf ppf "Cannot pay storage storage fee")
Data_encoding.empty
(function Cannot_pay_storage_fee -> Some () | _ -> None)
(fun () -> Cannot_pay_storage_fee) ;
register_error_kind
`Temporary
~id:"storage_exhausted.operation"
~title:"Storage quota exceeded for the operation"
~description:
"A script or one of its callee wrote more bytes than the operation said \
it would"
Data_encoding.empty
(function Operation_quota_exceeded -> Some () | _ -> None)
(fun () -> Operation_quota_exceeded) ;
register_error_kind
`Permanent
~id:"storage_limit_too_high"
~title:"Storage limit out of protocol hard bounds"
~description:"A transaction tried to exceed the hard limit on storage"
empty
(function Storage_limit_too_high -> Some () | _ -> None)
(fun () -> Storage_limit_too_high)
let origination_burn c =
let origination_size = Constants_storage.origination_size c in
let cost_per_byte = Constants_storage.cost_per_byte c in
(* the origination burn, measured in bytes *)
Lwt.return Tez_repr.(cost_per_byte *? Int64.of_int origination_size)
>>=? fun to_be_paid ->
return (Raw_context.update_allocated_contracts_count c, to_be_paid)
let record_paid_storage_space c contract =
Contract_storage.used_storage_space c contract
>>=? fun size ->
Contract_storage.set_paid_storage_space_and_return_fees_to_pay
c
contract
size
>>=? fun (to_be_paid, c) ->
let c = Raw_context.update_storage_space_to_pay c to_be_paid in
let cost_per_byte = Constants_storage.cost_per_byte c in
Lwt.return Tez_repr.(cost_per_byte *? Z.to_int64 to_be_paid)
>>=? fun to_burn -> return (c, size, to_be_paid, to_burn)
let burn_storage_fees c ~storage_limit ~payer =
let origination_size = Constants_storage.origination_size c in
let (c, storage_space_to_pay, allocated_contracts) =
Raw_context.clear_storage_space_to_pay c
in
let storage_space_for_allocated_contracts =
Z.mul (Z.of_int allocated_contracts) (Z.of_int origination_size)
in
let consumed =
Z.add storage_space_to_pay storage_space_for_allocated_contracts
in
let remaining = Z.sub storage_limit consumed in
if Compare.Z.(remaining < Z.zero) then fail Operation_quota_exceeded
else
let cost_per_byte = Constants_storage.cost_per_byte c in
Lwt.return Tez_repr.(cost_per_byte *? Z.to_int64 consumed)
>>=? fun to_burn ->
(* Burning the fees... *)
if Tez_repr.(to_burn = Tez_repr.zero) then
(* If the payer was was deleted by transfering all its balance, and no space was used,
burning zero would fail *)
return c
else
trace
Cannot_pay_storage_fee
( Contract_storage.must_exist c payer
>>=? fun () -> Contract_storage.spend c payer to_burn )
>>=? fun c -> return c
let check_storage_limit c ~storage_limit =
if
Compare.Z.(
storage_limit
> (Raw_context.constants c).hard_storage_limit_per_operation)
|| Compare.Z.(storage_limit < Z.zero)
then error Storage_limit_too_high
else ok ()
let start_counting_storage_fees c = Raw_context.init_storage_space_to_pay c
src/proto_alpha/lib_protocol/fees_storage.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition origination_burn (c : Tezos_raw_protocol_alpha.Raw_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t *
Tezos_raw_protocol_alpha.Tez_repr.t)) :=
let origination_size := Constants_storage.origination_size c in
let cost_per_byte := Constants_storage.cost_per_byte c in
op_gtgteqquestion
(Lwt._return (op_starquestion cost_per_byte (Int64.of_int origination_size)))
(fun to_be_paid =>
_return ((Raw_context.update_allocated_contracts_count c), to_be_paid)).
Definition record_paid_storage_space
(c : Tezos_raw_protocol_alpha.Raw_context.t)
(contract : Tezos_raw_protocol_alpha.Contract_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t *
Tezos_protocol_environment_alpha__Environment.Z.t *
Tezos_protocol_environment_alpha__Environment.Z.t *
Tezos_raw_protocol_alpha.Tez_repr.t)) :=
op_gtgteqquestion (Contract_storage.used_storage_space c contract)
(fun size =>
op_gtgteqquestion
(Contract_storage.set_paid_storage_space_and_return_fees_to_pay c
contract size)
(fun function_parameter =>
let '(to_be_paid, c) := function_parameter in
let c := Raw_context.update_storage_space_to_pay c to_be_paid in
let cost_per_byte := Constants_storage.cost_per_byte c in
op_gtgteqquestion
(Lwt._return (op_starquestion cost_per_byte (Z.to_int64 to_be_paid)))
(fun to_burn => _return (c, size, to_be_paid, to_burn)))).
Definition burn_storage_fees
(c : Tezos_raw_protocol_alpha.Raw_context.context)
(storage_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
(payer : Tezos_raw_protocol_alpha.Contract_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let origination_size := Constants_storage.origination_size c in
let '(c, storage_space_to_pay, allocated_contracts) :=
Raw_context.clear_storage_space_to_pay c in
let storage_space_for_allocated_contracts :=
Z.mul (Z.of_int allocated_contracts) (Z.of_int origination_size) in
let consumed :=
Z.add storage_space_to_pay storage_space_for_allocated_contracts in
let remaining := Z.sub storage_limit consumed in
if
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
remaining Z.zero then
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Operation_quota_exceeded
else
let cost_per_byte := Constants_storage.cost_per_byte c in
op_gtgteqquestion
(Lwt._return (op_starquestion cost_per_byte (Z.to_int64 consumed)))
(fun to_burn =>
if op_eq to_burn Tez_repr.zero then
_return c
else
op_gtgteqquestion
(trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_pay_storage_fee
(op_gtgteqquestion (Contract_storage.must_exist c payer)
(fun function_parameter =>
let 'tt := function_parameter in
Contract_storage.spend c payer to_burn))) (fun c => _return c)).
Definition check_storage_limit
(c : Tezos_raw_protocol_alpha.Raw_context.context)
(storage_limit :
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
if
op_pipepipe
(Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
storage_limit
(hard_storage_limit_per_operation (Raw_context.constants c)))
(Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
storage_limit Z.zero) then
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Storage_limit_too_high
else
ok tt.
Definition start_counting_storage_fees
(c : Tezos_raw_protocol_alpha.Raw_context.t)
: Tezos_raw_protocol_alpha.Raw_context.t :=
Raw_context.init_storage_space_to_pay c.
src/proto_alpha/lib_protocol/fitness_repr.ml 5 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type error += Invalid_fitness (* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"invalid_fitness"
~title:"Invalid fitness"
~description:"Fitness representation should be exactly 8 bytes long."
~pp:(fun ppf () -> Format.fprintf ppf "Invalid fitness")
Data_encoding.empty
(function Invalid_fitness -> Some () | _ -> None)
(fun () -> Invalid_fitness)
let int64_to_bytes i =
let b = MBytes.create 8 in
MBytes.set_int64 b 0 i ; b
let int64_of_bytes b =
if Compare.Int.(MBytes.length b <> 8) then error Invalid_fitness
else ok (MBytes.get_int64 b 0)
let from_int64 fitness =
[MBytes.of_string Constants_repr.version_number; int64_to_bytes fitness]
let to_int64 = function
| [version; fitness]
when Compare.String.(
MBytes.to_string version = Constants_repr.version_number) ->
int64_of_bytes fitness
| [version; _fitness (* ignored since higher version takes priority *)]
when Compare.String.(
MBytes.to_string version = Constants_repr.version_number_004) ->
ok 0L
| [] ->
ok 0L
| _ ->
error Invalid_fitness
src/proto_alpha/lib_protocol/fitness_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition int64_to_bytes (i : int64)
: Tezos_protocol_environment_alpha__Environment.MBytes.t :=
let b := MBytes.create 8 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := MBytes.set_int64 b 0 i in
b.
Definition int64_of_bytes
(b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int64 :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt)
(MBytes.length b) 8 then
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_fitness
else
ok (MBytes.get_int64 b 0).
Definition from_int64 (fitness : int64)
: list Tezos_protocol_environment_alpha__Environment.MBytes.t :=
cons (MBytes.of_string Constants_repr.version_number)
(cons (int64_to_bytes fitness) []).
Definition to_int64
(function_parameter :
list Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int64 :=
match function_parameter with
| cons version (cons fitness []) => int64_of_bytes fitness
| cons version (cons _fitness []) =>
ok
(* ❌ Constant of type int64 is converted to int *)
0
| [] =>
ok
(* ❌ Constant of type int64 is converted to int *)
0
| _ =>
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_fitness
end.
src/proto_alpha/lib_protocol/fitness_storage.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) let current = Raw_context.current_fitness let increase ?(gap = 1) ctxt = let fitness = current ctxt in Raw_context.set_current_fitness ctxt (Int64.add (Int64.of_int gap) fitness)
src/proto_alpha/lib_protocol/fitness_storage.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition current
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_protocol_environment_alpha__Environment.Int64.t :=
Raw_context.current_fitness.
Definition increase (op_staroptstar : option Z)
: Tezos_raw_protocol_alpha.Raw_context.context ->
Tezos_raw_protocol_alpha.Raw_context.t :=
let gap :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 1
end in
fun ctxt =>
let fitness := current ctxt in
Raw_context.set_current_fitness ctxt (Int64.add (Int64.of_int gap) fitness).
src/proto_alpha/lib_protocol/gas_limit_repr.ml 8 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = Unaccounted | Limited of {remaining : Z.t}
type internal_gas = Z.t
type cost = {
allocations : Z.t;
steps : Z.t;
reads : Z.t;
writes : Z.t;
bytes_read : Z.t;
bytes_written : Z.t;
}
let encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Limited"
z
(function Limited {remaining} -> Some remaining | _ -> None)
(fun remaining -> Limited {remaining});
case
(Tag 1)
~title:"Unaccounted"
(constant "unaccounted")
(function Unaccounted -> Some () | _ -> None)
(fun () -> Unaccounted) ]
let pp ppf = function
| Unaccounted ->
Format.fprintf ppf "unaccounted"
| Limited {remaining} ->
Format.fprintf ppf "%s units remaining" (Z.to_string remaining)
let cost_encoding =
let open Data_encoding in
conv
(fun {allocations; steps; reads; writes; bytes_read; bytes_written} ->
(allocations, steps, reads, writes, bytes_read, bytes_written))
(fun (allocations, steps, reads, writes, bytes_read, bytes_written) ->
{allocations; steps; reads; writes; bytes_read; bytes_written})
(obj6
(req "allocations" z)
(req "steps" z)
(req "reads" z)
(req "writes" z)
(req "bytes_read" z)
(req "bytes_written" z))
let pp_cost ppf {allocations; steps; reads; writes; bytes_read; bytes_written}
=
Format.fprintf
ppf
"(steps: %s, allocs: %s, reads: %s (%s bytes), writes: %s (%s bytes))"
(Z.to_string steps)
(Z.to_string allocations)
(Z.to_string reads)
(Z.to_string bytes_read)
(Z.to_string writes)
(Z.to_string bytes_written)
type error += Block_quota_exceeded (* `Temporary *)
type error += Operation_quota_exceeded (* `Temporary *)
let allocation_weight = Z.of_int 2
let step_weight = Z.of_int 1
let read_base_weight = Z.of_int 100
let write_base_weight = Z.of_int 160
let byte_read_weight = Z.of_int 10
let byte_written_weight = Z.of_int 15
let rescaling_bits = 7
let rescaling_mask = Z.sub (Z.shift_left Z.one rescaling_bits) Z.one
let scale (z : Z.t) = Z.shift_left z rescaling_bits
let rescale (z : Z.t) = Z.shift_right z rescaling_bits
let cost_to_internal_gas (cost : cost) : internal_gas =
Z.add
(Z.add
(Z.mul cost.allocations allocation_weight)
(Z.mul cost.steps step_weight))
(Z.add
(Z.add
(Z.mul cost.reads read_base_weight)
(Z.mul cost.writes write_base_weight))
(Z.add
(Z.mul cost.bytes_read byte_read_weight)
(Z.mul cost.bytes_written byte_written_weight)))
let internal_gas_to_gas internal_gas : Z.t * internal_gas =
let gas = rescale internal_gas in
let rest = Z.logand internal_gas rescaling_mask in
(gas, rest)
let consume block_gas operation_gas internal_gas cost =
match operation_gas with
| Unaccounted ->
ok (block_gas, Unaccounted, internal_gas)
| Limited {remaining} ->
let cost_internal_gas = cost_to_internal_gas cost in
let total_internal_gas = Z.add cost_internal_gas internal_gas in
let (gas, rest) = internal_gas_to_gas total_internal_gas in
if Compare.Z.(gas > Z.zero) then
let remaining = Z.sub remaining gas in
let block_remaining = Z.sub block_gas gas in
if Compare.Z.(remaining < Z.zero) then error Operation_quota_exceeded
else if Compare.Z.(block_remaining < Z.zero) then
error Block_quota_exceeded
else ok (block_remaining, Limited {remaining}, rest)
else ok (block_gas, operation_gas, total_internal_gas)
let check_enough block_gas operation_gas internal_gas cost =
consume block_gas operation_gas internal_gas cost
>|? fun (_block_remainig, _remaining, _internal_gas) -> ()
let internal_gas_zero : internal_gas = Z.zero
let alloc_cost n =
{
allocations = scale (Z.of_int (n + 1));
steps = Z.zero;
reads = Z.zero;
writes = Z.zero;
bytes_read = Z.zero;
bytes_written = Z.zero;
}
let alloc_bytes_cost n = alloc_cost ((n + 7) / 8)
let alloc_bits_cost n = alloc_cost ((n + 63) / 64)
let atomic_step_cost n =
{
allocations = Z.zero;
steps = Z.of_int (2 * n);
reads = Z.zero;
writes = Z.zero;
bytes_read = Z.zero;
bytes_written = Z.zero;
}
let step_cost n =
{
allocations = Z.zero;
steps = scale (Z.of_int n);
reads = Z.zero;
writes = Z.zero;
bytes_read = Z.zero;
bytes_written = Z.zero;
}
let free =
{
allocations = Z.zero;
steps = Z.zero;
reads = Z.zero;
writes = Z.zero;
bytes_read = Z.zero;
bytes_written = Z.zero;
}
let read_bytes_cost n =
{
allocations = Z.zero;
steps = Z.zero;
reads = scale Z.one;
writes = Z.zero;
bytes_read = scale n;
bytes_written = Z.zero;
}
let write_bytes_cost n =
{
allocations = Z.zero;
steps = Z.zero;
reads = Z.zero;
writes = Z.one;
bytes_read = Z.zero;
bytes_written = scale n;
}
let ( +@ ) x y =
{
allocations = Z.add x.allocations y.allocations;
steps = Z.add x.steps y.steps;
reads = Z.add x.reads y.reads;
writes = Z.add x.writes y.writes;
bytes_read = Z.add x.bytes_read y.bytes_read;
bytes_written = Z.add x.bytes_written y.bytes_written;
}
let ( *@ ) x y =
{
allocations = Z.mul (Z.of_int x) y.allocations;
steps = Z.mul (Z.of_int x) y.steps;
reads = Z.mul (Z.of_int x) y.reads;
writes = Z.mul (Z.of_int x) y.writes;
bytes_read = Z.mul (Z.of_int x) y.bytes_read;
bytes_written = Z.mul (Z.of_int x) y.bytes_written;
}
let alloc_mbytes_cost n = alloc_cost 12 +@ alloc_bytes_cost n
let () =
let open Data_encoding in
register_error_kind
`Temporary
~id:"gas_exhausted.operation"
~title:"Gas quota exceeded for the operation"
~description:
"A script or one of its callee took more time than the operation said \
it would"
empty
(function Operation_quota_exceeded -> Some () | _ -> None)
(fun () -> Operation_quota_exceeded) ;
register_error_kind
`Temporary
~id:"gas_exhausted.block"
~title:"Gas quota exceeded for the block"
~description:
"The sum of gas consumed by all the operations in the block exceeds the \
hard gas limit per block"
empty
(function Block_quota_exceeded -> Some () | _ -> None)
(fun () -> Block_quota_exceeded)
src/proto_alpha/lib_protocol/gas_limit_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive t : Type :=
| Unaccounted : t
| Limited : Tezos_protocol_environment_alpha__Environment.Z.t -> t.
Definition internal_gas := Tezos_protocol_environment_alpha__Environment.Z.t.
Record cost := {
allocations : Tezos_protocol_environment_alpha__Environment.Z.t;
steps : Tezos_protocol_environment_alpha__Environment.Z.t;
reads : Tezos_protocol_environment_alpha__Environment.Z.t;
writes : Tezos_protocol_environment_alpha__Environment.Z.t;
bytes_read : Tezos_protocol_environment_alpha__Environment.Z.t;
bytes_written : Tezos_protocol_environment_alpha__Environment.Z.t }.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
union None
(cons
(case "Limited" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0) z
(fun function_parameter =>
match function_parameter with
| Limited {| remaining := remaining |} => Some remaining
| _ => None
end) (fun remaining => Limited {| remaining := remaining |}))
(cons
(case "Unaccounted" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
(constant "unaccounted" % string)
(fun function_parameter =>
match function_parameter with
| Unaccounted => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Unaccounted)) [])).
Definition pp
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
(function_parameter : t) : unit :=
match function_parameter with
| Unaccounted =>
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"unaccounted" % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
"unaccounted" % string)
| Limited {| remaining := remaining |} =>
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
" units remaining" % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format))
"%s units remaining" % string) (Z.to_string remaining)
end.
Definition cost_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding cost :=
conv
(fun function_parameter =>
let '{|
allocations := allocations;
steps := steps;
reads := reads;
writes := writes;
bytes_read := bytes_read;
bytes_written := bytes_written
|} := function_parameter in
(allocations, steps, reads, writes, bytes_read, bytes_written))
(fun function_parameter =>
let '(allocations, steps, reads, writes, bytes_read, bytes_written) :=
function_parameter in
{| allocations := allocations; steps := steps; reads := reads;
writes := writes; bytes_read := bytes_read;
bytes_written := bytes_written |}) None
(obj6 (req None None "allocations" % string z)
(req None None "steps" % string z) (req None None "reads" % string z)
(req None None "writes" % string z)
(req None None "bytes_read" % string z)
(req None None "bytes_written" % string z)).
Definition pp_cost
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
(function_parameter : cost) : unit :=
let '{|
allocations := allocations;
steps := steps;
reads := reads;
writes := writes;
bytes_read := bytes_read;
bytes_written := bytes_written
|} := function_parameter in
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"(steps: " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
", allocs: " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
", reads: " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
" (" % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
" bytes), writes: " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
" (" % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
" bytes))" % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))))))))))))
"(steps: %s, allocs: %s, reads: %s (%s bytes), writes: %s (%s bytes))" %
string) (Z.to_string steps) (Z.to_string allocations)
(Z.to_string reads) (Z.to_string bytes_read) (Z.to_string writes)
(Z.to_string bytes_written).
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition allocation_weight
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.of_int 2.
Definition step_weight : Tezos_protocol_environment_alpha__Environment.Z.t :=
Z.of_int 1.
Definition read_base_weight
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.of_int 100.
Definition write_base_weight
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.of_int 160.
Definition byte_read_weight
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.of_int 10.
Definition byte_written_weight
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.of_int 15.
Definition rescaling_bits : Z := 7.
Definition rescaling_mask : Tezos_protocol_environment_alpha__Environment.Z.t :=
Z.sub (Z.shift_left Z.one rescaling_bits) Z.one.
Definition scale (z : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_protocol_environment_alpha__Environment.Z.t :=
Z.shift_left z rescaling_bits.
Definition rescale (z : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_protocol_environment_alpha__Environment.Z.t :=
Z.shift_right z rescaling_bits.
Definition cost_to_internal_gas (cost : cost) : internal_gas :=
Z.add
(Z.add (Z.mul (allocations cost) allocation_weight)
(Z.mul (steps cost) step_weight))
(Z.add
(Z.add (Z.mul (reads cost) read_base_weight)
(Z.mul (writes cost) write_base_weight))
(Z.add (Z.mul (bytes_read cost) byte_read_weight)
(Z.mul (bytes_written cost) byte_written_weight))).
Definition internal_gas_to_gas
(internal_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_protocol_environment_alpha__Environment.Z.t * internal_gas :=
let gas := rescale internal_gas in
let rest := Z.logand internal_gas rescaling_mask in
(gas, rest).
Definition consume
(block_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
(operation_gas : t)
(internal_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
(cost : cost)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_protocol_environment_alpha__Environment.Z.t * t *
Tezos_protocol_environment_alpha__Environment.Z.t) :=
match operation_gas with
| Unaccounted => ok (block_gas, Unaccounted, internal_gas)
| Limited {| remaining := remaining |} =>
let cost_internal_gas := cost_to_internal_gas cost in
let total_internal_gas := Z.add cost_internal_gas internal_gas in
let '(gas, rest) := internal_gas_to_gas total_internal_gas in
if
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
gas Z.zero then
let remaining := Z.sub remaining gas in
let block_remaining := Z.sub block_gas gas in
if
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
remaining Z.zero then
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Operation_quota_exceeded
else
if
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
block_remaining Z.zero then
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Block_quota_exceeded
else
ok (block_remaining, (Limited {| remaining := remaining |}), rest)
else
ok (block_gas, operation_gas, total_internal_gas)
end.
Definition check_enough
(block_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
(operation_gas : t)
(internal_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
(cost : cost)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
op_gtpipequestion (consume block_gas operation_gas internal_gas cost)
(fun function_parameter =>
let '(_block_remainig, _remaining, _internal_gas) := function_parameter in
tt).
Definition internal_gas_zero : internal_gas := Z.zero.
Definition alloc_cost (n : Z) : cost :=
{| allocations := scale (Z.of_int (op_plus n 1)); steps := Z.zero;
reads := Z.zero; writes := Z.zero; bytes_read := Z.zero;
bytes_written := Z.zero |}.
Definition alloc_bytes_cost (n : Z) : cost :=
alloc_cost (op_div (op_plus n 7) 8).
Definition alloc_bits_cost (n : Z) : cost :=
alloc_cost (op_div (op_plus n 63) 64).
Definition atomic_step_cost (n : Z) : cost :=
{| allocations := Z.zero; steps := Z.of_int (op_star 2 n); reads := Z.zero;
writes := Z.zero; bytes_read := Z.zero; bytes_written := Z.zero |}.
Definition step_cost (n : Z) : cost :=
{| allocations := Z.zero; steps := scale (Z.of_int n); reads := Z.zero;
writes := Z.zero; bytes_read := Z.zero; bytes_written := Z.zero |}.
Definition free : cost :=
{| allocations := Z.zero; steps := Z.zero; reads := Z.zero; writes := Z.zero;
bytes_read := Z.zero; bytes_written := Z.zero |}.
Definition read_bytes_cost
(n : Tezos_protocol_environment_alpha__Environment.Z.t) : cost :=
{| allocations := Z.zero; steps := Z.zero; reads := scale Z.one;
writes := Z.zero; bytes_read := scale n; bytes_written := Z.zero |}.
Definition write_bytes_cost
(n : Tezos_protocol_environment_alpha__Environment.Z.t) : cost :=
{| allocations := Z.zero; steps := Z.zero; reads := Z.zero; writes := Z.one;
bytes_read := Z.zero; bytes_written := scale n |}.
Definition op_plusat (x : cost) (y : cost) : cost :=
{| allocations := Z.add (allocations x) (allocations y);
steps := Z.add (steps x) (steps y); reads := Z.add (reads x) (reads y);
writes := Z.add (writes x) (writes y);
bytes_read := Z.add (bytes_read x) (bytes_read y);
bytes_written := Z.add (bytes_written x) (bytes_written y) |}.
Definition op_starat (x : Z) (y : cost) : cost :=
{| allocations := Z.mul (Z.of_int x) (allocations y);
steps := Z.mul (Z.of_int x) (steps y);
reads := Z.mul (Z.of_int x) (reads y);
writes := Z.mul (Z.of_int x) (writes y);
bytes_read := Z.mul (Z.of_int x) (bytes_read y);
bytes_written := Z.mul (Z.of_int x) (bytes_written y) |}.
Definition alloc_mbytes_cost (n : Z) : cost :=
op_plusat (alloc_cost 12) (alloc_bytes_cost n).
src/proto_alpha/lib_protocol/helpers_services.ml 598 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
type error += Cannot_parse_operation (* `Branch *)
let () =
register_error_kind
`Branch
~id:"operation.cannot_parse"
~title:"Cannot parse operation"
~description:"The operation is ill-formed or for another protocol version"
~pp:(fun ppf () -> Format.fprintf ppf "The operation cannot be parsed")
Data_encoding.unit
(function Cannot_parse_operation -> Some () | _ -> None)
(fun () -> Cannot_parse_operation)
let parse_operation (op : Operation.raw) =
match
Data_encoding.Binary.of_bytes Operation.protocol_data_encoding op.proto
with
| Some protocol_data ->
ok {shell = op.shell; protocol_data}
| None ->
error Cannot_parse_operation
let path = RPC_path.(open_root / "helpers")
module Scripts = struct
module S = struct
open Data_encoding
let path = RPC_path.(path / "scripts")
let run_code_input_encoding =
obj9
(req "script" Script.expr_encoding)
(req "storage" Script.expr_encoding)
(req "input" Script.expr_encoding)
(req "amount" Tez.encoding)
(req "chain_id" Chain_id.encoding)
(opt "source" Contract.encoding)
(opt "payer" Contract.encoding)
(opt "gas" z)
(dft "entrypoint" string "default")
let trace_encoding =
def "scripted.trace" @@ list
@@ obj3
(req "location" Script.location_encoding)
(req "gas" Gas.encoding)
(req
"stack"
(list
(obj2 (req "item" Script.expr_encoding) (opt "annot" string))))
let run_code =
RPC_service.post_service
~description:"Run a piece of code in the current context"
~query:RPC_query.empty
~input:run_code_input_encoding
~output:
(obj3
(req "storage" Script.expr_encoding)
(req "operations" (list Operation.internal_operation_encoding))
(opt "big_map_diff" Contract.big_map_diff_encoding))
RPC_path.(path / "run_code")
let trace_code =
RPC_service.post_service
~description:
"Run a piece of code in the current context, keeping a trace"
~query:RPC_query.empty
~input:run_code_input_encoding
~output:
(obj4
(req "storage" Script.expr_encoding)
(req "operations" (list Operation.internal_operation_encoding))
(req "trace" trace_encoding)
(opt "big_map_diff" Contract.big_map_diff_encoding))
RPC_path.(path / "trace_code")
let typecheck_code =
RPC_service.post_service
~description:"Typecheck a piece of code in the current context"
~query:RPC_query.empty
~input:(obj2 (req "program" Script.expr_encoding) (opt "gas" z))
~output:
(obj2
(req "type_map" Script_tc_errors_registration.type_map_enc)
(req "gas" Gas.encoding))
RPC_path.(path / "typecheck_code")
let typecheck_data =
RPC_service.post_service
~description:
"Check that some data expression is well formed and of a given type \
in the current context"
~query:RPC_query.empty
~input:
(obj3
(req "data" Script.expr_encoding)
(req "type" Script.expr_encoding)
(opt "gas" z))
~output:(obj1 (req "gas" Gas.encoding))
RPC_path.(path / "typecheck_data")
let pack_data =
RPC_service.post_service
~description:
"Computes the serialized version of some data expression using the \
same algorithm as script instruction PACK"
~input:
(obj3
(req "data" Script.expr_encoding)
(req "type" Script.expr_encoding)
(opt "gas" z))
~output:(obj2 (req "packed" bytes) (req "gas" Gas.encoding))
~query:RPC_query.empty
RPC_path.(path / "pack_data")
let run_operation =
RPC_service.post_service
~description:"Run an operation without signature checks"
~query:RPC_query.empty
~input:
(obj2
(req "operation" Operation.encoding)
(req "chain_id" Chain_id.encoding))
~output:Apply_results.operation_data_and_metadata_encoding
RPC_path.(path / "run_operation")
let entrypoint_type =
RPC_service.post_service
~description:"Return the type of the given entrypoint"
~query:RPC_query.empty
~input:
(obj2
(req "script" Script.expr_encoding)
(dft "entrypoint" string "default"))
~output:(obj1 (req "entrypoint_type" Script.expr_encoding))
RPC_path.(path / "entrypoint")
let list_entrypoints =
RPC_service.post_service
~description:"Return the list of entrypoints of the given script"
~query:RPC_query.empty
~input:(obj1 (req "script" Script.expr_encoding))
~output:
(obj2
(dft
"unreachable"
(Data_encoding.list
(obj1
(req
"path"
(Data_encoding.list
Michelson_v1_primitives.prim_encoding))))
[])
(req "entrypoints" (assoc Script.expr_encoding)))
RPC_path.(path / "entrypoints")
end
let register () =
let open Services_registration in
let originate_dummy_contract ctxt script =
let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in
Contract.fresh_contract_from_current_nonce ctxt
>>=? fun (ctxt, dummy_contract) ->
let balance =
match Tez.of_mutez 4_000_000_000_000L with
| Some balance ->
balance
| None ->
assert false
in
Contract.originate
ctxt
dummy_contract
~balance
~delegate:None
~script:(script, None)
>>=? fun ctxt -> return (ctxt, dummy_contract)
in
register0
S.run_code
(fun ctxt
()
( code,
storage,
parameter,
amount,
chain_id,
source,
payer,
gas,
entrypoint )
->
let storage = Script.lazy_expr storage in
let code = Script.lazy_expr code in
originate_dummy_contract ctxt {storage; code}
>>=? fun (ctxt, dummy_contract) ->
let (source, payer) =
match (source, payer) with
| (Some source, Some payer) ->
(source, payer)
| (Some source, None) ->
(source, source)
| (None, Some payer) ->
(payer, payer)
| (None, None) ->
(dummy_contract, dummy_contract)
in
let gas =
match gas with
| Some gas ->
gas
| None ->
Constants.hard_gas_limit_per_operation ctxt
in
let ctxt = Gas.set_limit ctxt gas in
let step_constants =
let open Script_interpreter in
{source; payer; self = dummy_contract; amount; chain_id}
in
Script_interpreter.execute
ctxt
Readable
step_constants
~script:{storage; code}
~entrypoint
~parameter
>>=? fun {Script_interpreter.storage; operations; big_map_diff; _} ->
return (storage, operations, big_map_diff)) ;
register0
S.trace_code
(fun ctxt
()
( code,
storage,
parameter,
amount,
chain_id,
source,
payer,
gas,
entrypoint )
->
let storage = Script.lazy_expr storage in
let code = Script.lazy_expr code in
originate_dummy_contract ctxt {storage; code}
>>=? fun (ctxt, dummy_contract) ->
let (source, payer) =
match (source, payer) with
| (Some source, Some payer) ->
(source, payer)
| (Some source, None) ->
(source, source)
| (None, Some payer) ->
(payer, payer)
| (None, None) ->
(dummy_contract, dummy_contract)
in
let gas =
match gas with
| Some gas ->
gas
| None ->
Constants.hard_gas_limit_per_operation ctxt
in
let ctxt = Gas.set_limit ctxt gas in
let step_constants =
let open Script_interpreter in
{source; payer; self = dummy_contract; amount; chain_id}
in
Script_interpreter.trace
ctxt
Readable
step_constants
~script:{storage; code}
~entrypoint
~parameter
>>=? fun ( {Script_interpreter.storage; operations; big_map_diff; _},
trace ) ->
return (storage, operations, trace, big_map_diff)) ;
register0 S.typecheck_code (fun ctxt () (expr, maybe_gas) ->
let ctxt =
match maybe_gas with
| None ->
Gas.set_unlimited ctxt
| Some gas ->
Gas.set_limit ctxt gas
in
Script_ir_translator.typecheck_code ctxt expr
>>=? fun (res, ctxt) -> return (res, Gas.level ctxt)) ;
register0 S.typecheck_data (fun ctxt () (data, ty, maybe_gas) ->
let ctxt =
match maybe_gas with
| None ->
Gas.set_unlimited ctxt
| Some gas ->
Gas.set_limit ctxt gas
in
Script_ir_translator.typecheck_data ctxt (data, ty)
>>=? fun ctxt -> return (Gas.level ctxt)) ;
register0 S.pack_data (fun ctxt () (expr, typ, maybe_gas) ->
let open Script_ir_translator in
let ctxt =
match maybe_gas with
| None ->
Gas.set_unlimited ctxt
| Some gas ->
Gas.set_limit ctxt gas
in
Lwt.return (parse_packable_ty ctxt ~legacy:true (Micheline.root typ))
>>=? fun (Ex_ty typ, ctxt) ->
parse_data ctxt ~legacy:true typ (Micheline.root expr)
>>=? fun (data, ctxt) ->
Script_ir_translator.pack_data ctxt typ data
>>=? fun (bytes, ctxt) -> return (bytes, Gas.level ctxt)) ;
register0
S.run_operation
(fun ctxt
()
({shell; protocol_data = Operation_data protocol_data}, chain_id)
->
(* this code is a duplicate of Apply without signature check *)
let partial_precheck_manager_contents (type kind) ctxt
(op : kind Kind.manager contents) : context tzresult Lwt.t =
let (Manager_operation
{source; fee; counter; operation; gas_limit; storage_limit}) =
op
in
Lwt.return (Gas.check_limit ctxt gas_limit)
>>=? fun () ->
let ctxt = Gas.set_limit ctxt gas_limit in
Lwt.return (Fees.check_storage_limit ctxt storage_limit)
>>=? fun () ->
Contract.must_be_allocated ctxt (Contract.implicit_contract source)
>>=? fun () ->
Contract.check_counter_increment ctxt source counter
>>=? fun () ->
( match operation with
| Reveal pk ->
Contract.reveal_manager_key ctxt source pk
| Transaction {parameters; _} ->
(* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *)
let arg_bytes =
Data_encoding.Binary.to_bytes_exn
Script.lazy_expr_encoding
parameters
in
let arg =
match
Data_encoding.Binary.of_bytes
Script.lazy_expr_encoding
arg_bytes
with
| Some arg ->
arg
| None ->
assert false
in
(* Fail quickly if not enough gas for minimal deserialization cost *)
Lwt.return
@@ record_trace Apply.Gas_quota_exceeded_init_deserialize
@@ Gas.check_enough ctxt (Script.minimal_deserialize_cost arg)
>>=? fun () ->
(* Fail if not enough gas for complete deserialization cost *)
trace Apply.Gas_quota_exceeded_init_deserialize
@@ Script.force_decode ctxt arg
>>|? fun (_arg, ctxt) -> ctxt
| Origination {script; _} ->
(* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *)
let script_bytes =
Data_encoding.Binary.to_bytes_exn Script.encoding script
in
let script =
match
Data_encoding.Binary.of_bytes Script.encoding script_bytes
with
| Some script ->
script
| None ->
assert false
in
(* Fail quickly if not enough gas for minimal deserialization cost *)
Lwt.return
@@ record_trace Apply.Gas_quota_exceeded_init_deserialize
@@ ( Gas.consume
ctxt
(Script.minimal_deserialize_cost script.code)
>>? fun ctxt ->
Gas.check_enough
ctxt
(Script.minimal_deserialize_cost script.storage) )
>>=? fun () ->
(* Fail if not enough gas for complete deserialization cost *)
trace Apply.Gas_quota_exceeded_init_deserialize
@@ Script.force_decode ctxt script.code
>>=? fun (_code, ctxt) ->
trace Apply.Gas_quota_exceeded_init_deserialize
@@ Script.force_decode ctxt script.storage
>>|? fun (_storage, ctxt) -> ctxt
| _ ->
return ctxt )
>>=? fun ctxt ->
Contract.get_manager_key ctxt source
>>=? fun _public_key ->
(* signature check unplugged from here *)
Contract.increment_counter ctxt source
>>=? fun ctxt ->
Contract.spend ctxt (Contract.implicit_contract source) fee
>>=? fun ctxt -> return ctxt
in
let rec partial_precheck_manager_contents_list :
type kind.
Alpha_context.t ->
kind Kind.manager contents_list ->
context tzresult Lwt.t =
fun ctxt contents_list ->
match contents_list with
| Single (Manager_operation _ as op) ->
partial_precheck_manager_contents ctxt op
| Cons ((Manager_operation _ as op), rest) ->
partial_precheck_manager_contents ctxt op
>>=? fun ctxt -> partial_precheck_manager_contents_list ctxt rest
in
let return contents =
return
( Operation_data protocol_data,
Apply_results.Operation_metadata {contents} )
in
let operation : _ operation = {shell; protocol_data} in
let hash = Operation.hash {shell; protocol_data} in
let ctxt = Contract.init_origination_nonce ctxt hash in
let baker = Signature.Public_key_hash.zero in
match protocol_data.contents with
| Single (Manager_operation _) as op ->
partial_precheck_manager_contents_list ctxt op
>>=? fun ctxt ->
Apply.apply_manager_contents_list ctxt Optimized baker chain_id op
>>= fun (_ctxt, result) -> return result
| Cons (Manager_operation _, _) as op ->
partial_precheck_manager_contents_list ctxt op
>>=? fun ctxt ->
Apply.apply_manager_contents_list ctxt Optimized baker chain_id op
>>= fun (_ctxt, result) -> return result
| _ ->
Apply.apply_contents_list
ctxt
chain_id
Optimized
shell.branch
baker
operation
operation.protocol_data.contents
>>=? fun (_ctxt, result) -> return result) ;
register0 S.entrypoint_type (fun ctxt () (expr, entrypoint) ->
let ctxt = Gas.set_unlimited ctxt in
let legacy = false in
let open Script_ir_translator in
Lwt.return
( parse_toplevel ~legacy expr
>>? fun (arg_type, _, _, root_name) ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:true
arg_type
>>? fun (Ex_ty arg_type, _) ->
Script_ir_translator.find_entrypoint ~root_name arg_type entrypoint
)
>>=? fun (_f, Ex_ty ty) ->
unparse_ty ctxt ty
>>=? fun (ty_node, _) -> return (Micheline.strip_locations ty_node)) ;
register0 S.list_entrypoints (fun ctxt () expr ->
let ctxt = Gas.set_unlimited ctxt in
let legacy = false in
let open Script_ir_translator in
Lwt.return
( parse_toplevel ~legacy expr
>>? fun (arg_type, _, _, root_name) ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:true
arg_type
>>? fun (Ex_ty arg_type, _) ->
Script_ir_translator.list_entrypoints ~root_name arg_type ctxt )
>>=? fun (unreachable_entrypoint, map) ->
return
( unreachable_entrypoint,
Entrypoints_map.fold
(fun entry (_, ty) acc ->
(entry, Micheline.strip_locations ty) :: acc)
map
[] ))
let run_code ctxt block code
(storage, input, amount, chain_id, source, payer, gas, entrypoint) =
RPC_context.make_call0
S.run_code
ctxt
block
()
(code, storage, input, amount, chain_id, source, payer, gas, entrypoint)
let trace_code ctxt block code
(storage, input, amount, chain_id, source, payer, gas, entrypoint) =
RPC_context.make_call0
S.trace_code
ctxt
block
()
(code, storage, input, amount, chain_id, source, payer, gas, entrypoint)
let typecheck_code ctxt block =
RPC_context.make_call0 S.typecheck_code ctxt block ()
let typecheck_data ctxt block =
RPC_context.make_call0 S.typecheck_data ctxt block ()
let pack_data ctxt block = RPC_context.make_call0 S.pack_data ctxt block ()
let run_operation ctxt block =
RPC_context.make_call0 S.run_operation ctxt block ()
let entrypoint_type ctxt block =
RPC_context.make_call0 S.entrypoint_type ctxt block ()
let list_entrypoints ctxt block =
RPC_context.make_call0 S.list_entrypoints ctxt block ()
end
module Forge = struct
module S = struct
open Data_encoding
let path = RPC_path.(path / "forge")
let operations =
RPC_service.post_service
~description:"Forge an operation"
~query:RPC_query.empty
~input:Operation.unsigned_encoding
~output:bytes
RPC_path.(path / "operations")
let empty_proof_of_work_nonce =
MBytes.of_string
(String.make Constants_repr.proof_of_work_nonce_size '\000')
let protocol_data =
RPC_service.post_service
~description:"Forge the protocol-specific part of a block header"
~query:RPC_query.empty
~input:
(obj3
(req "priority" uint16)
(opt "nonce_hash" Nonce_hash.encoding)
(dft
"proof_of_work_nonce"
(Fixed.bytes Alpha_context.Constants.proof_of_work_nonce_size)
empty_proof_of_work_nonce))
~output:(obj1 (req "protocol_data" bytes))
RPC_path.(path / "protocol_data")
end
let register () =
let open Services_registration in
register0_noctxt S.operations (fun () (shell, proto) ->
return
(Data_encoding.Binary.to_bytes_exn
Operation.unsigned_encoding
(shell, proto))) ;
register0_noctxt
S.protocol_data
(fun () (priority, seed_nonce_hash, proof_of_work_nonce) ->
return
(Data_encoding.Binary.to_bytes_exn
Block_header.contents_encoding
{priority; seed_nonce_hash; proof_of_work_nonce}))
module Manager = struct
let operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee
~gas_limit ~storage_limit operations =
Contract_services.manager_key ctxt block source
>>= function
| Error _ as e ->
Lwt.return e
| Ok revealed ->
let ops =
List.map
(fun (Manager operation) ->
Contents
(Manager_operation
{
source;
counter;
operation;
fee;
gas_limit;
storage_limit;
}))
operations
in
let ops =
match (sourcePubKey, revealed) with
| (None, _) | (_, Some _) ->
ops
| (Some pk, None) ->
let operation = Reveal pk in
Contents
(Manager_operation
{
source;
counter;
operation;
fee;
gas_limit;
storage_limit;
})
:: ops
in
RPC_context.make_call0
S.operations
ctxt
block
()
({branch}, Operation.of_list ops)
let reveal ctxt block ~branch ~source ~sourcePubKey ~counter ~fee () =
operations
ctxt
block
~branch
~source
~sourcePubKey
~counter
~fee
~gas_limit:Z.zero
~storage_limit:Z.zero
[]
let transaction ctxt block ~branch ~source ?sourcePubKey ~counter ~amount
~destination ?(entrypoint = "default") ?parameters ~gas_limit
~storage_limit ~fee () =
let parameters =
Option.unopt_map
~f:Script.lazy_expr
~default:Script.unit_parameter
parameters
in
operations
ctxt
block
~branch
~source
?sourcePubKey
~counter
~fee
~gas_limit
~storage_limit
[Manager (Transaction {amount; parameters; destination; entrypoint})]
let origination ctxt block ~branch ~source ?sourcePubKey ~counter ~balance
?delegatePubKey ~script ~gas_limit ~storage_limit ~fee () =
operations
ctxt
block
~branch
~source
?sourcePubKey
~counter
~fee
~gas_limit
~storage_limit
[ Manager
(Origination
{
delegate = delegatePubKey;
script;
credit = balance;
preorigination = None;
}) ]
let delegation ctxt block ~branch ~source ?sourcePubKey ~counter ~fee
delegate =
operations
ctxt
block
~branch
~source
?sourcePubKey
~counter
~fee
~gas_limit:Z.zero
~storage_limit:Z.zero
[Manager (Delegation delegate)]
end
let operation ctxt block ~branch operation =
RPC_context.make_call0
S.operations
ctxt
block
()
({branch}, Contents_list (Single operation))
let endorsement ctxt b ~branch ~level () =
operation ctxt b ~branch (Endorsement {level})
let proposals ctxt b ~branch ~source ~period ~proposals () =
operation ctxt b ~branch (Proposals {source; period; proposals})
let ballot ctxt b ~branch ~source ~period ~proposal ~ballot () =
operation ctxt b ~branch (Ballot {source; period; proposal; ballot})
let seed_nonce_revelation ctxt block ~branch ~level ~nonce () =
operation ctxt block ~branch (Seed_nonce_revelation {level; nonce})
let double_baking_evidence ctxt block ~branch ~bh1 ~bh2 () =
operation ctxt block ~branch (Double_baking_evidence {bh1; bh2})
let double_endorsement_evidence ctxt block ~branch ~op1 ~op2 () =
operation ctxt block ~branch (Double_endorsement_evidence {op1; op2})
let empty_proof_of_work_nonce =
MBytes.of_string
(String.make Constants_repr.proof_of_work_nonce_size '\000')
let protocol_data ctxt block ~priority ?seed_nonce_hash
?(proof_of_work_nonce = empty_proof_of_work_nonce) () =
RPC_context.make_call0
S.protocol_data
ctxt
block
()
(priority, seed_nonce_hash, proof_of_work_nonce)
end
module Parse = struct
module S = struct
open Data_encoding
let path = RPC_path.(path / "parse")
let operations =
RPC_service.post_service
~description:"Parse operations"
~query:RPC_query.empty
~input:
(obj2
(req "operations" (list (dynamic_size Operation.raw_encoding)))
(opt "check_signature" bool))
~output:(list (dynamic_size Operation.encoding))
RPC_path.(path / "operations")
let block =
RPC_service.post_service
~description:"Parse a block"
~query:RPC_query.empty
~input:Block_header.raw_encoding
~output:Block_header.protocol_data_encoding
RPC_path.(path / "block")
end
let parse_protocol_data protocol_data =
match
Data_encoding.Binary.of_bytes
Block_header.protocol_data_encoding
protocol_data
with
| None ->
failwith "Cant_parse_protocol_data"
| Some protocol_data ->
return protocol_data
let register () =
let open Services_registration in
register0 S.operations (fun _ctxt () (operations, check) ->
map_s
(fun raw ->
Lwt.return (parse_operation raw)
>>=? fun op ->
( match check with
| Some true ->
return_unit (* FIXME *)
(* I.check_signature ctxt *)
(* op.protocol_data.signature op.shell op.protocol_data.contents *)
| Some false | None ->
return_unit )
>>|? fun () -> op)
operations) ;
register0_noctxt S.block (fun () raw_block ->
parse_protocol_data raw_block.protocol_data)
let operations ctxt block ?check operations =
RPC_context.make_call0 S.operations ctxt block () (operations, check)
let block ctxt block shell protocol_data =
RPC_context.make_call0
S.block
ctxt
block
()
({shell; protocol_data} : Block_header.raw)
end
module S = struct
open Data_encoding
type level_query = {offset : int32}
let level_query : level_query RPC_query.t =
let open RPC_query in
query (fun offset -> {offset})
|+ field "offset" RPC_arg.int32 0l (fun t -> t.offset)
|> seal
let current_level =
RPC_service.get_service
~description:
"Returns the level of the interrogated block, or the one of a block \
located `offset` blocks after in the chain (or before when \
negative). For instance, the next block if `offset` is 1."
~query:level_query
~output:Level.encoding
RPC_path.(path / "current_level")
let levels_in_current_cycle =
RPC_service.get_service
~description:"Levels of a cycle"
~query:level_query
~output:
(obj2 (req "first" Raw_level.encoding) (req "last" Raw_level.encoding))
RPC_path.(path / "levels_in_current_cycle")
end
let register () =
Scripts.register () ;
Forge.register () ;
Parse.register () ;
let open Services_registration in
register0 S.current_level (fun ctxt q () ->
let level = Level.current ctxt in
return (Level.from_raw ctxt ~offset:q.offset level.level)) ;
register0 S.levels_in_current_cycle (fun ctxt q () ->
let levels = Level.levels_in_current_cycle ctxt ~offset:q.offset () in
match levels with
| [] ->
raise Not_found
| _ ->
let first = List.hd (List.rev levels) in
let last = List.hd levels in
return (first.level, last.level))
let current_level ctxt ?(offset = 0l) block =
RPC_context.make_call0 S.current_level ctxt block {offset} ()
let levels_in_current_cycle ctxt ?(offset = 0l) block =
RPC_context.make_call0 S.levels_in_current_cycle ctxt block {offset} ()
src/proto_alpha/lib_protocol/helpers_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition parse_operation
(op : Tezos_raw_protocol_alpha.Alpha_context.Operation.raw)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Alpha_context.packed_operation :=
match
Data_encoding.Binary.of_bytes Operation.protocol_data_encoding (proto op)
with
| Some protocol_data =>
ok {| shell := shell op; protocol_data := protocol_data |}
| None =>
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_parse_operation
end.
Definition path
: Tezos_protocol_environment_alpha__Environment.RPC_path.path
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
op_div open_root "helpers" % string.
Module Scripts.
Module S.
Import Data_encoding.
Definition path
: Tezos_protocol_environment_alpha__Environment.RPC_path.path
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
op_div path "scripts" % string.
Definition run_code_input_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
* (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
(option Tezos_protocol_environment_alpha__Environment.Z.t) * string) :=
obj9 (req None None "script" % string Script.expr_encoding)
(req None None "storage" % string Script.expr_encoding)
(req None None "input" % string Script.expr_encoding)
(req None None "amount" % string Tez.encoding)
(req None None "chain_id" % string
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding))
(opt None None "source" % string Contract.encoding)
(opt None None "payer" % string Contract.encoding)
(opt None None "gas" % string z)
(dft None None "entrypoint" % string string "default" % string).
Definition trace_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.location *
Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(option string))))) :=
op_atat
(let arg := def "scripted.trace" % string in
fun eta => arg None None eta)
(op_atat
(let arg := list in
fun eta => arg None eta)
(obj3 (req None None "location" % string Script.location_encoding)
(req None None "gas" % string Gas.encoding)
(req None None "stack" % string
(list None
(obj2 (req None None "item" % string Script.expr_encoding)
(opt None None "annot" % string string)))))).
Definition run_code
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
* (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
(option Tezos_protocol_environment_alpha__Environment.Z.t) * string)
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(list
Tezos_raw_protocol_alpha__Alpha_context.packed_internal_operation) *
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff)) :=
RPC_service.post_service
(Some "Run a piece of code in the current context" % string)
RPC_query.empty run_code_input_encoding
(obj3 (req None None "storage" % string Script.expr_encoding)
(req None None "operations" % string
(list None Operation.internal_operation_encoding))
(opt None None "big_map_diff" % string Contract.big_map_diff_encoding))
(op_div path "run_code" % string).
Definition trace_code
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
* (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
(option Tezos_protocol_environment_alpha__Environment.Z.t) * string)
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(list
Tezos_raw_protocol_alpha__Alpha_context.packed_internal_operation) *
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.location *
Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(option string))))) *
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff)) :=
RPC_service.post_service
(Some
"Run a piece of code in the current context, keeping a trace" % string)
RPC_query.empty run_code_input_encoding
(obj4 (req None None "storage" % string Script.expr_encoding)
(req None None "operations" % string
(list None Operation.internal_operation_encoding))
(req None None "trace" % string trace_encoding)
(opt None None "big_map_diff" % string Contract.big_map_diff_encoding))
(op_div path "trace_code" % string).
Definition typecheck_code
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(option Tezos_protocol_environment_alpha__Environment.Z.t))
((list
(Tezos_raw_protocol_alpha.Alpha_context.Script.location *
((list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(list string))) *
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(list string)))))) *
Tezos_raw_protocol_alpha.Alpha_context.Gas.t) :=
RPC_service.post_service
(Some "Typecheck a piece of code in the current context" % string)
RPC_query.empty
(obj2 (req None None "program" % string Script.expr_encoding)
(opt None None "gas" % string z))
(obj2
(req None None "type_map" % string
Script_tc_errors_registration.type_map_enc)
(req None None "gas" % string Gas.encoding))
(op_div path "typecheck_code" % string).
Definition typecheck_data
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(option Tezos_protocol_environment_alpha__Environment.Z.t))
Tezos_raw_protocol_alpha.Alpha_context.Gas.t :=
RPC_service.post_service
(Some
"Check that some data expression is well formed and of a given type in the current context"
% string) RPC_query.empty
(obj3 (req None None "data" % string Script.expr_encoding)
(req None None "type" % string Script.expr_encoding)
(opt None None "gas" % string z))
(obj1 (req None None "gas" % string Gas.encoding))
(op_div path "typecheck_data" % string).
Definition pack_data
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(option Tezos_protocol_environment_alpha__Environment.Z.t))
(Tezos_protocol_environment_alpha__Environment.MBytes.t *
Tezos_raw_protocol_alpha.Alpha_context.Gas.t) :=
RPC_service.post_service
(Some
"Computes the serialized version of some data expression using the same algorithm as script instruction PACK"
% string) RPC_query.empty
(obj3 (req None None "data" % string Script.expr_encoding)
(req None None "type" % string Script.expr_encoding)
(opt None None "gas" % string z))
(obj2 (req None None "packed" % string bytes)
(req None None "gas" % string Gas.encoding))
(op_div path "pack_data" % string).
Definition run_operation
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
(Tezos_raw_protocol_alpha.Alpha_context.Operation.packed *
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(Tezos_raw_protocol_alpha.Alpha_context.Operation.packed_protocol_data *
Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata) :=
RPC_service.post_service
(Some "Run an operation without signature checks" % string)
RPC_query.empty
(obj2 (req None None "operation" % string Operation.encoding)
(req None None "chain_id" % string
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)))
Apply_results.operation_data_and_metadata_encoding
(op_div path "run_operation" % string).
Definition entrypoint_type
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr * string)
Tezos_raw_protocol_alpha.Alpha_context.Script.expr :=
RPC_service.post_service
(Some "Return the type of the given entrypoint" % string)
RPC_query.empty
(obj2 (req None None "script" % string Script.expr_encoding)
(dft None None "entrypoint" % string string "default" % string))
(obj1 (req None None "entrypoint_type" % string Script.expr_encoding))
(op_div path "entrypoint" % string).
Definition list_entrypoints
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
Tezos_raw_protocol_alpha.Alpha_context.Script.expr
((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
(list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr))) :=
RPC_service.post_service
(Some "Return the list of entrypoints of the given script" % string)
RPC_query.empty
(obj1 (req None None "script" % string Script.expr_encoding))
(obj2
(dft None None "unreachable" % string
(Data_encoding.list None
(obj1
(req None None "path" % string
(Data_encoding.list None Michelson_v1_primitives.prim_encoding))))
[])
(req None None "entrypoints" % string (assoc Script.expr_encoding)))
(op_div path "entrypoints" % string).
End S.
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
let originate_dummy_contract
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (script :
Tezos_raw_protocol_alpha__Alpha_context.Script.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha__Alpha_context.context *
Tezos_raw_protocol_alpha.Alpha_context.Contract.t)) :=
let ctxt :=
Contract.init_origination_nonce ctxt
Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
in
op_gtgteqquestion (Contract.fresh_contract_from_current_nonce ctxt)
(fun function_parameter =>
let '(ctxt, dummy_contract) := function_parameter in
let balance :=
match
Tez.of_mutez
(* ❌ Constant of type int64 is converted to int *)
4000000000000 with
| Some balance => balance
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
op_gtgteqquestion
(Contract.originate ctxt dummy_contract balance (script, None) None)
(fun ctxt => _return (ctxt, dummy_contract))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.run_code
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let
'(code, storage, parameter, amount, chain_id, source, payer,
gas, entrypoint) := function_parameter in
let storage := Script.lazy_expr storage in
let code := Script.lazy_expr code in
op_gtgteqquestion
(originate_dummy_contract ctxt
{| code := code; storage := storage |})
(fun function_parameter =>
let '(ctxt, dummy_contract) := function_parameter in
let '(source, payer) :=
match (source, payer) with
| (Some source, Some payer) => (source, payer)
| (Some source, None) => (source, source)
| (None, Some payer) => (payer, payer)
| (None, None) => (dummy_contract, dummy_contract)
end in
let gas :=
match gas with
| Some gas => gas
| None => Constants.hard_gas_limit_per_operation ctxt
end in
let ctxt := Gas.set_limit ctxt gas in
let step_constants :=
{| source := source; payer := payer; self := dummy_contract;
amount := amount; chain_id := chain_id |} in
op_gtgteqquestion
(Script_interpreter.execute ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Readable
step_constants {| code := code; storage := storage |}
entrypoint parameter)
(fun function_parameter =>
let '{|
Script_interpreter.storage := storage;
Script_interpreter.big_map_diff := big_map_diff;
Script_interpreter.operations := operations
|} := function_parameter in
_return (storage, operations, big_map_diff)))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.trace_code
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let
'(code, storage, parameter, amount, chain_id, source, payer,
gas, entrypoint) := function_parameter in
let storage := Script.lazy_expr storage in
let code := Script.lazy_expr code in
op_gtgteqquestion
(originate_dummy_contract ctxt
{| code := code; storage := storage |})
(fun function_parameter =>
let '(ctxt, dummy_contract) := function_parameter in
let '(source, payer) :=
match (source, payer) with
| (Some source, Some payer) => (source, payer)
| (Some source, None) => (source, source)
| (None, Some payer) => (payer, payer)
| (None, None) => (dummy_contract, dummy_contract)
end in
let gas :=
match gas with
| Some gas => gas
| None => Constants.hard_gas_limit_per_operation ctxt
end in
let ctxt := Gas.set_limit ctxt gas in
let step_constants :=
{| source := source; payer := payer; self := dummy_contract;
amount := amount; chain_id := chain_id |} in
op_gtgteqquestion
(Script_interpreter.trace ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Readable
step_constants {| code := code; storage := storage |}
entrypoint parameter)
(fun function_parameter =>
let
'({|
Script_interpreter.storage := storage;
Script_interpreter.big_map_diff := big_map_diff;
Script_interpreter.operations := operations
|}, trace) := function_parameter in
_return (storage, operations, trace, big_map_diff)))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.typecheck_code
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(expr, maybe_gas) := function_parameter in
let ctxt :=
match maybe_gas with
| None => Gas.set_unlimited ctxt
| Some gas => Gas.set_limit ctxt gas
end in
op_gtgteqquestion (Script_ir_translator.typecheck_code ctxt expr)
(fun function_parameter =>
let '(res, ctxt) := function_parameter in
_return (res, (Gas.level ctxt)))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.typecheck_data
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(data, ty, maybe_gas) := function_parameter in
let ctxt :=
match maybe_gas with
| None => Gas.set_unlimited ctxt
| Some gas => Gas.set_limit ctxt gas
end in
op_gtgteqquestion
(Script_ir_translator.typecheck_data None ctxt (data, ty))
(fun ctxt => _return (Gas.level ctxt))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.pack_data
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(expr, typ, maybe_gas) := function_parameter in
let ctxt :=
match maybe_gas with
| None => Gas.set_unlimited ctxt
| Some gas => Gas.set_limit ctxt gas
end in
op_gtgteqquestion
(Lwt._return (parse_packable_ty ctxt true (Micheline.root typ)))
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty typ,
ctxt) := function_parameter in
op_gtgteqquestion
(parse_data None ctxt true typ (Micheline.root expr))
(fun function_parameter =>
let '(data, ctxt) := function_parameter in
op_gtgteqquestion
(Script_ir_translator.pack_data ctxt typ data)
(fun function_parameter =>
let '(bytes, ctxt) := function_parameter in
_return (string, (Gas.level ctxt)))))) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.run_operation
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let
'({|
shell := shell;
protocol_data :=
Tezos_raw_protocol_alpha.Alpha_context.Operation_data
protocol_data
|}, chain_id) := function_parameter in
let partial_precheck_manager_contents {A : Type}
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (op :
Tezos_raw_protocol_alpha.Alpha_context.contents
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Alpha_context.context) :=
let
'Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
source := source;
fee := fee;
counter := counter;
operation := operation;
gas_limit := gas_limit;
storage_limit := storage_limit
|} := op in
op_gtgteqquestion (Lwt._return (Gas.check_limit ctxt gas_limit))
(fun function_parameter =>
let 'tt := function_parameter in
let ctxt := Gas.set_limit ctxt gas_limit in
op_gtgteqquestion
(Lwt._return (Fees.check_storage_limit ctxt storage_limit))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Contract.must_be_allocated ctxt
(Contract.implicit_contract source))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Contract.check_counter_increment ctxt source
counter)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
match operation with
|
Tezos_raw_protocol_alpha.Alpha_context.Reveal
pk =>
Contract.reveal_manager_key ctxt source pk
|
Tezos_raw_protocol_alpha.Alpha_context.Transaction
{| parameters := parameters |} =>
let arg_bytes :=
Data_encoding.Binary.to_bytes_exn
Script.lazy_expr_encoding parameters in
let arg :=
match
Data_encoding.Binary.of_bytes
Script.lazy_expr_encoding arg_bytes
with
| Some arg => arg
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
op_gtgteqquestion
(op_atat Lwt._return
(op_atat
(record_trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
(Gas.check_enough ctxt
(Script.minimal_deserialize_cost arg))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtpipequestion
(op_atat
(trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
(Script.force_decode ctxt arg))
(fun function_parameter =>
let '(_arg, ctxt) :=
function_parameter in
ctxt))
|
Tezos_raw_protocol_alpha.Alpha_context.Origination
{| script := script |} =>
let script_bytes :=
Data_encoding.Binary.to_bytes_exn
Script.encoding script in
let script :=
match
Data_encoding.Binary.of_bytes
Script.encoding script_bytes with
| Some script => script
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
op_gtgteqquestion
(op_atat Lwt._return
(op_atat
(record_trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
(op_gtgtquestion
(Gas.consume ctxt
(Script.minimal_deserialize_cost
(code script)))
(fun ctxt =>
Gas.check_enough ctxt
(Script.minimal_deserialize_cost
(storage script))))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_atat
(trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
(Script.force_decode ctxt
(code script)))
(fun function_parameter =>
let '(_code, ctxt) :=
function_parameter in
op_gtgtpipequestion
(op_atat
(trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
(Script.force_decode ctxt
(storage script)))
(fun function_parameter =>
let '(_storage, ctxt) :=
function_parameter in
ctxt)))
| _ => _return ctxt
end
(fun ctxt =>
op_gtgteqquestion
(Contract.get_manager_key ctxt source)
(fun _public_key =>
op_gtgteqquestion
(Contract.increment_counter ctxt
source)
(fun ctxt =>
op_gtgteqquestion
(Contract.spend ctxt
(Contract.implicit_contract
source) fee)
(fun ctxt => _return ctxt))))))))
in
let fix partial_precheck_manager_contents_list {kind : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.t) (contents_list
:
Tezos_raw_protocol_alpha.Alpha_context.contents_list
(Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Alpha_context.context) :=
match contents_list with
|
Tezos_raw_protocol_alpha.Alpha_context.Single
((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _)
as op) => partial_precheck_manager_contents ctxt op
|
Tezos_raw_protocol_alpha.Alpha_context.Cons
((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _)
as op) rest =>
op_gtgteqquestion (partial_precheck_manager_contents ctxt op)
(fun ctxt =>
partial_precheck_manager_contents_list ctxt rest)
end in
let _return {A : Type}
(contents :
Tezos_raw_protocol_alpha.Apply_results.contents_result_list A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.packed_protocol_data
*
Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata)) :=
_return
((Tezos_raw_protocol_alpha.Alpha_context.Operation_data
protocol_data),
(Tezos_raw_protocol_alpha.Apply_results.Operation_metadata
{| contents := contents |})) in
let operation :=
{| shell := shell; protocol_data := protocol_data |} in
let hash :=
Operation.hash
{| shell := shell; protocol_data := protocol_data |} in
let ctxt := Contract.init_origination_nonce ctxt hash in
let baker := Signature.Public_key_hash.zero in
match contents protocol_data with
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _))
as op =>
op_gtgteqquestion
(partial_precheck_manager_contents_list ctxt op)
(fun ctxt =>
op_gtgteq
(Apply.apply_manager_contents_list ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
baker chain_id op)
(fun function_parameter =>
let '(_ctxt, result) := function_parameter in
_return result))
|
(Tezos_raw_protocol_alpha.Alpha_context.Cons
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _) _)
as op =>
op_gtgteqquestion
(partial_precheck_manager_contents_list ctxt op)
(fun ctxt =>
op_gtgteq
(Apply.apply_manager_contents_list ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
baker chain_id op)
(fun function_parameter =>
let '(_ctxt, result) := function_parameter in
_return result))
| _ =>
op_gtgteqquestion
(Apply.apply_contents_list ctxt chain_id
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
(branch shell) baker operation
(contents (protocol_data operation)))
(fun function_parameter =>
let '(_ctxt, result) := function_parameter in
_return result)
end) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.entrypoint_type
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(expr, entrypoint) := function_parameter in
let ctxt := Gas.set_unlimited ctxt in
let legacy := false in
op_gtgteqquestion
(Lwt._return
(op_gtgtquestion (parse_toplevel legacy expr)
(fun function_parameter =>
let '(arg_type, _, _, root_name) := function_parameter in
op_gtgtquestion
(parse_ty ctxt legacy true false true arg_type)
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty
arg_type, _) := function_parameter in
Script_ir_translator.find_entrypoint arg_type
root_name entrypoint))))
(fun function_parameter =>
let
'(_f, Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty ty) :=
function_parameter in
op_gtgteqquestion (unparse_ty ctxt ty)
(fun function_parameter =>
let '(ty_node, _) := function_parameter in
_return (Micheline.strip_locations ty_node)))) in
register0 S.list_entrypoints
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun expr =>
let ctxt := Gas.set_unlimited ctxt in
let legacy := false in
op_gtgteqquestion
(Lwt._return
(op_gtgtquestion (parse_toplevel legacy expr)
(fun function_parameter =>
let '(arg_type, _, _, root_name) := function_parameter in
op_gtgtquestion
(parse_ty ctxt legacy true false true arg_type)
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty
arg_type, _) := function_parameter in
Script_ir_translator.list_entrypoints arg_type ctxt
root_name))))
(fun function_parameter =>
let '(unreachable_entrypoint, map) := function_parameter in
_return
(unreachable_entrypoint,
(Entrypoints_map.fold
(fun entry =>
fun function_parameter =>
let '(_, ty) := function_parameter in
fun acc =>
cons (entry, (Micheline.strip_locations ty)) acc)
map [])))).
Definition run_code {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D) (code : Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
(function_parameter :
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
* (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
(option Tezos_protocol_environment_alpha__Environment.Z.t) * string)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(list
Tezos_raw_protocol_alpha__Alpha_context.packed_internal_operation) *
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
let '(storage, input, amount, chain_id, source, payer, gas, entrypoint) :=
function_parameter in
RPC_context.make_call0 S.run_code ctxt block tt
(code, storage, input, amount, chain_id, source, payer, gas, entrypoint).
Definition trace_code {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D) (code : Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
(function_parameter :
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
* (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
(option Tezos_protocol_environment_alpha__Environment.Z.t) * string)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(list
Tezos_raw_protocol_alpha__Alpha_context.packed_internal_operation) *
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.location *
Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(option string))))) *
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
let '(storage, input, amount, chain_id, source, payer, gas, entrypoint) :=
function_parameter in
RPC_context.make_call0 S.trace_code ctxt block tt
(code, storage, input, amount, chain_id, source, payer, gas, entrypoint).
Definition typecheck_code {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(option Tezos_protocol_environment_alpha__Environment.Z.t)) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
((list
(Tezos_raw_protocol_alpha.Alpha_context.Script.location *
((list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(list string))) *
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(list string)))))) *
Tezos_raw_protocol_alpha.Alpha_context.Gas.t)) :=
RPC_context.make_call0 S.typecheck_code ctxt block tt.
Definition typecheck_data {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(option Tezos_protocol_environment_alpha__Environment.Z.t)) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Gas.t) :=
RPC_context.make_call0 S.typecheck_data ctxt block tt.
Definition pack_data {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(option Tezos_protocol_environment_alpha__Environment.Z.t)) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(Tezos_protocol_environment_alpha__Environment.MBytes.t *
Tezos_raw_protocol_alpha.Alpha_context.Gas.t)) :=
RPC_context.make_call0 S.pack_data ctxt block tt.
Definition run_operation {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: (Tezos_raw_protocol_alpha.Alpha_context.Operation.packed *
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(Tezos_raw_protocol_alpha.Alpha_context.Operation.packed_protocol_data
* Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata)) :=
RPC_context.make_call0 S.run_operation ctxt block tt.
Definition entrypoint_type {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * string) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
RPC_context.make_call0 S.entrypoint_type ctxt block tt.
Definition list_entrypoints {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: Tezos_raw_protocol_alpha.Alpha_context.Script.expr ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
(list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr)))) :=
RPC_context.make_call0 S.list_entrypoints ctxt block tt.
End Scripts.
Module Forge.
Module S.
Import Data_encoding.
Definition path
: Tezos_protocol_environment_alpha__Environment.RPC_path.path
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
op_div path "forge" % string.
Definition operations
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
(Tezos_protocol_environment_alpha__Environment.Operation.shell_header *
Tezos_raw_protocol_alpha__Alpha_context.packed_contents_list)
Tezos_protocol_environment_alpha__Environment.MBytes.t :=
RPC_service.post_service (Some "Forge an operation" % string)
RPC_query.empty Operation.unsigned_encoding bytes
(op_div path "operations" % string).
Definition empty_proof_of_work_nonce
: Tezos_protocol_environment_alpha__Environment.MBytes.t :=
MBytes.of_string
(String.make Constants_repr.proof_of_work_nonce_size "000" % char).
Definition protocol_data
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
(Z * (option Tezos_raw_protocol_alpha.Nonce_hash.t) *
Tezos_protocol_environment_alpha__Environment.MBytes.t)
Tezos_protocol_environment_alpha__Environment.MBytes.t :=
RPC_service.post_service
(Some "Forge the protocol-specific part of a block header" % string)
RPC_query.empty
(obj3 (req None None "priority" % string uint16)
(opt None None "nonce_hash" % string Nonce_hash.encoding)
(dft None None "proof_of_work_nonce" % string
(Fixed.bytes Alpha_context.Constants.proof_of_work_nonce_size)
empty_proof_of_work_nonce))
(obj1 (req None None "protocol_data" % string bytes))
(op_div path "protocol_data" % string).
End S.
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0_noctxt S.operations
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(shell, proto) := function_parameter in
_return
(Data_encoding.Binary.to_bytes_exn Operation.unsigned_encoding
(shell, proto))) in
register0_noctxt S.protocol_data
(fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(priority, seed_nonce_hash, proof_of_work_nonce) :=
function_parameter in
_return
(Data_encoding.Binary.to_bytes_exn Block_header.contents_encoding
{| priority := priority; seed_nonce_hash := seed_nonce_hash;
proof_of_work_nonce := proof_of_work_nonce |})).
Module Manager.
Definition operations {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
i o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
a) * b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L *
D) (block : D)
(branch :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
(sourcePubKey :
option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
(counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
(fee : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
(gas_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
(storage_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
(operations :
list Tezos_raw_protocol_alpha.Alpha_context.packed_manager_operation)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Pervasives.result
Tezos_protocol_environment_alpha__Environment.MBytes.t
(list
Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
op_gtgteq (Contract_services.manager_key ctxt block source)
(fun function_parameter =>
match function_parameter with
|
(Tezos_protocol_environment_alpha__Environment.Pervasives.Error _)
as e => Lwt._return e
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok revealed
=>
let ops :=
List.map
(fun function_parameter =>
let
'Tezos_raw_protocol_alpha.Alpha_context.Manager operation :=
function_parameter in
Tezos_raw_protocol_alpha.Alpha_context.Contents
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation
{| source := source; fee := fee; counter := counter;
operation := operation; gas_limit := gas_limit;
storage_limit := storage_limit |})) operations in
let ops :=
match (sourcePubKey, revealed) with
| (None, _) | (_, Some _) => ops
| (Some pk, None) =>
let operation :=
Tezos_raw_protocol_alpha.Alpha_context.Reveal pk in
cons
(Tezos_raw_protocol_alpha.Alpha_context.Contents
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation
{| source := source; fee := fee; counter := counter;
operation := operation; gas_limit := gas_limit;
storage_limit := storage_limit |})) ops
end in
RPC_context.make_call0 S.operations ctxt block tt
({| branch := branch |}, (Operation.of_list ops))
end).
Definition reveal {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
i o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
a) * b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L *
D) (block : D)
(branch :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
(sourcePubKey :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
(counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
(fee : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Pervasives.result
Tezos_protocol_environment_alpha__Environment.MBytes.t
(list
Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
let 'tt := function_parameter in
operations ctxt block branch source (Some sourcePubKey) counter fee Z.zero
Z.zero [].
Definition transaction {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
i o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
a) * b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L *
D) (block : D)
(branch :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
(sourcePubKey :
option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
(counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
(amount : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
(destination : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
(op_staroptstar : option string)
: (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr) ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_raw_protocol_alpha.Alpha_context.Tez.tez ->
unit ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Pervasives.result
Tezos_protocol_environment_alpha__Environment.MBytes.t
(list
Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
let entrypoint :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "default" % string
end in
fun parameters =>
fun gas_limit =>
fun storage_limit =>
fun fee =>
fun function_parameter =>
let 'tt := function_parameter in
let parameters :=
Option.unopt_map Script.lazy_expr Script.unit_parameter
parameters in
operations ctxt block branch source sourcePubKey counter fee
gas_limit storage_limit
(cons
(Tezos_raw_protocol_alpha.Alpha_context.Manager
(Tezos_raw_protocol_alpha.Alpha_context.Transaction
{| amount := amount; parameters := parameters;
entrypoint := entrypoint; destination := destination
|})) []).
Definition origination {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
i o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
a) * b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L *
D) (block : D)
(branch :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
(sourcePubKey :
option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
(counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
(balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
(delegatePubKey :
option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(script : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
(gas_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
(storage_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
(fee : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Pervasives.result
Tezos_protocol_environment_alpha__Environment.MBytes.t
(list
Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
let 'tt := function_parameter in
operations ctxt block branch source sourcePubKey counter fee gas_limit
storage_limit
(cons
(Tezos_raw_protocol_alpha.Alpha_context.Manager
(Tezos_raw_protocol_alpha.Alpha_context.Origination
{| delegate := delegatePubKey; script := script;
credit := balance; preorigination := None |})) []).
Definition delegation {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
i o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
a) * b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L *
D) (block : D)
(branch :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
(sourcePubKey :
option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
(counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
(fee : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
(delegate :
option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Pervasives.result
Tezos_protocol_environment_alpha__Environment.MBytes.t
(list
Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
operations ctxt block branch source sourcePubKey counter fee Z.zero Z.zero
(cons
(Tezos_raw_protocol_alpha.Alpha_context.Manager
(Tezos_raw_protocol_alpha.Alpha_context.Delegation delegate)) []).
End Manager.
Definition operation {D E G I K L M a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(branch :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(operation : Tezos_raw_protocol_alpha.Alpha_context.contents M)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
RPC_context.make_call0 S.operations ctxt block tt
({| branch := branch |},
(Tezos_raw_protocol_alpha.Alpha_context.Contents_list
(Tezos_raw_protocol_alpha.Alpha_context.Single operation))).
Definition endorsement {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(b : D)
(branch :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
let 'tt := function_parameter in
operation ctxt b branch
(Tezos_raw_protocol_alpha.Alpha_context.Endorsement {| level := level |}).
Definition proposals {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(b : D)
(branch :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(source :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(period : Tezos_raw_protocol_alpha.Alpha_context.Voting_period.t)
(proposals :
list
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
let 'tt := function_parameter in
operation ctxt b branch
(Tezos_raw_protocol_alpha.Alpha_context.Proposals
{| source := source; period := period; proposals := proposals |}).
Definition ballot {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(b : D)
(branch :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(source :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(period : Tezos_raw_protocol_alpha.Alpha_context.Voting_period.t)
(proposal :
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(ballot : Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot)
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
let 'tt := function_parameter in
operation ctxt b branch
(Tezos_raw_protocol_alpha.Alpha_context.Ballot
{| source := source; period := period; proposal := proposal;
ballot := ballot |}).
Definition seed_nonce_revelation {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(branch :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)
(nonce : Tezos_raw_protocol_alpha.Alpha_context.Nonce.t)
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
let 'tt := function_parameter in
operation ctxt block branch
(Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation
{| level := level; nonce := nonce |}).
Definition double_baking_evidence {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(branch :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(bh1 : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
(bh2 : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
let 'tt := function_parameter in
operation ctxt block branch
(Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence
{| bh1 := bh1; bh2 := bh2 |}).
Definition double_endorsement_evidence {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(branch :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(op1 :
Tezos_raw_protocol_alpha.Alpha_context.operation
Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement)
(op2 :
Tezos_raw_protocol_alpha.Alpha_context.operation
Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement)
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
let 'tt := function_parameter in
operation ctxt block branch
(Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence
{| op1 := op1; op2 := op2 |}).
Definition empty_proof_of_work_nonce
: Tezos_protocol_environment_alpha__Environment.MBytes.t :=
MBytes.of_string
(String.make Constants_repr.proof_of_work_nonce_size "000" % char).
Definition protocol_data {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D) (priority : Z)
(seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
(op_staroptstar :
option Tezos_protocol_environment_alpha__Environment.MBytes.t)
: unit ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
let proof_of_work_nonce :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => empty_proof_of_work_nonce
end in
fun function_parameter =>
let 'tt := function_parameter in
RPC_context.make_call0 S.protocol_data ctxt block tt
(priority, seed_nonce_hash, proof_of_work_nonce).
End Forge.
Module Parse.
Module S.
Import Data_encoding.
Definition path
: Tezos_protocol_environment_alpha__Environment.RPC_path.path
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
op_div path "parse" % string.
Definition operations
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
((list Tezos_raw_protocol_alpha.Alpha_context.Operation.raw) *
(option bool))
(list Tezos_raw_protocol_alpha.Alpha_context.Operation.packed) :=
RPC_service.post_service (Some "Parse operations" % string)
RPC_query.empty
(obj2
(req None None "operations" % string
(list None (dynamic_size None Operation.raw_encoding)))
(opt None None "check_signature" % string bool))
(list None (dynamic_size None Operation.encoding))
(op_div path "operations" % string).
Definition block
: Tezos_protocol_environment_alpha__Environment.RPC_service.service
variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
Tezos_raw_protocol_alpha.Alpha_context.Block_header.raw
Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data :=
RPC_service.post_service (Some "Parse a block" % string) RPC_query.empty
Block_header.raw_encoding Block_header.protocol_data_encoding
(op_div path "block" % string).
End S.
Definition parse_protocol_data
(protocol_data : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data) :=
match
Data_encoding.Binary.of_bytes Block_header.protocol_data_encoding
protocol_data with
| None => failwith "Cant_parse_protocol_data" % string
| Some protocol_data => _return protocol_data
end.
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.operations
(fun _ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let '(operations, check) := function_parameter in
map_s
(fun raw =>
op_gtgteqquestion (Lwt._return (parse_operation raw))
(fun op =>
op_gtgtpipequestion
match check with
| Some true => return_unit
| Some false | None => return_unit
end
(fun function_parameter =>
let 'tt := function_parameter in
op))) operations) in
register0_noctxt S.block
(fun function_parameter =>
let 'tt := function_parameter in
fun raw_block => parse_protocol_data (protocol_data raw_block)).
Definition operations {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D) (check : option bool)
(operations : list Tezos_raw_protocol_alpha.Alpha_context.Operation.raw)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(list Tezos_raw_protocol_alpha.Alpha_context.Operation.packed)) :=
RPC_context.make_call0 S.operations ctxt block tt (operations, check).
Definition block {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
o) ->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
b) q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
(shell :
Tezos_protocol_environment_alpha__Environment.Block_header.shell_header)
(protocol_data : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data) :=
RPC_context.make_call0 S.block ctxt block tt
{| shell := shell; protocol_data := protocol_data |}.
End Parse.
Module S.
Import Data_encoding.
Record level_query := {
offset : int32 }.
Definition level_query
: Tezos_protocol_environment_alpha__Environment.RPC_query.t level_query :=
op_pipegt
(op_pipeplus (query (fun offset => {| offset := offset |}))
(field None "offset" % string RPC_arg.int32
(* ❌ Constant of type int32 is converted to int *)
0 (fun t => offset t))) seal.
Definition current_level
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
level_query unit Tezos_raw_protocol_alpha.Alpha_context.Level.t :=
RPC_service.get_service
(Some
"Returns the level of the interrogated block, or the one of a block located `offset` blocks after in the chain (or before when negative). For instance, the next block if `offset` is 1."
% string) level_query Level.encoding
(op_div path "current_level" % string).
Definition levels_in_current_cycle
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
level_query unit
(Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t *
Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t) :=
RPC_service.get_service (Some "Levels of a cycle" % string) level_query
(obj2 (req None None "first" % string Raw_level.encoding)
(req None None "last" % string Raw_level.encoding))
(op_div path "levels_in_current_cycle" % string).
End S.
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Scripts.register tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Forge.register tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Parse.register tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.current_level
(fun ctxt =>
fun q =>
fun function_parameter =>
let 'tt := function_parameter in
let level := Level.current ctxt in
_return (Level.from_raw ctxt (Some (offset q)) (level level))) in
register0 S.levels_in_current_cycle
(fun ctxt =>
fun q =>
fun function_parameter =>
let 'tt := function_parameter in
let levels := Level.levels_in_current_cycle ctxt (Some (offset q)) tt
in
match levels with
| [] => raise OCaml.Not_found
| _ =>
let first := List.hd (List.rev levels) in
let last := List.hd levels in
_return ((level first), (level last))
end).
Definition current_level {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(op_staroptstar : option int32)
: D ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Level.t) :=
let offset :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Constant of type int32 is converted to int *)
0
end in
fun block =>
RPC_context.make_call0 S.current_level ctxt block {| offset := offset |} tt.
Definition levels_in_current_cycle {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(op_staroptstar : option int32)
: D ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t *
Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)) :=
let offset :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Constant of type int32 is converted to int *)
0
end in
fun block =>
RPC_context.make_call0 S.levels_in_current_cycle ctxt block
{| offset := offset |} tt.
src/proto_alpha/lib_protocol/init_storage.ml 6 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* This is the genesis protocol: initialise the state *)
let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness =
Raw_context.prepare_first_block ~level ~timestamp ~fitness ctxt
>>=? fun (previous_protocol, ctxt) ->
Storage.Big_map.Next.init ctxt
>>=? fun ctxt ->
match previous_protocol with
| Genesis param ->
Commitment_storage.init ctxt param.commitments
>>=? fun ctxt ->
Roll_storage.init ctxt
>>=? fun ctxt ->
Seed_storage.init ctxt
>>=? fun ctxt ->
Contract_storage.init ctxt
>>=? fun ctxt ->
Bootstrap_storage.init
ctxt
~typecheck
?ramp_up_cycles:param.security_deposit_ramp_up_cycles
?no_reward_cycles:param.no_reward_cycles
param.bootstrap_accounts
param.bootstrap_contracts
>>=? fun ctxt ->
Roll_storage.init_first_cycles ctxt
>>=? fun ctxt ->
Vote_storage.init ctxt
>>=? fun ctxt ->
Storage.Block_priority.init ctxt 0
>>=? fun ctxt ->
Vote_storage.freeze_listings ctxt >>=? fun ctxt -> return ctxt
| Alpha_previous ->
return ctxt
let prepare ctxt ~level ~predecessor_timestamp ~timestamp ~fitness =
Raw_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
src/proto_alpha/lib_protocol/init_storage.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition prepare_first_block
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
(typecheck :
Tezos_raw_protocol_alpha.Raw_context.t ->
Tezos_raw_protocol_alpha.Script_repr.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_raw_protocol_alpha.Script_repr.t *
(option Tezos_raw_protocol_alpha.Contract_storage.big_map_diff)) *
Tezos_raw_protocol_alpha.Raw_context.t))) (level : int32)
(timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
(fitness :
Tezos_protocol_environment_alpha__Environment.Fitness.(Tezos_protocol_environment_alpha__Environment.T.S.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteqquestion
(Raw_context.prepare_first_block level timestamp fitness ctxt)
(fun function_parameter =>
let '(previous_protocol, ctxt) := function_parameter in
op_gtgteqquestion (Storage.Big_map.Next.init ctxt)
(fun ctxt =>
match previous_protocol with
| Tezos_raw_protocol_alpha.Raw_context.Genesis param =>
op_gtgteqquestion (Commitment_storage.init ctxt (commitments param))
(fun ctxt =>
op_gtgteqquestion (Roll_storage.init ctxt)
(fun ctxt =>
op_gtgteqquestion (Seed_storage.init ctxt)
(fun ctxt =>
op_gtgteqquestion (Contract_storage.init ctxt)
(fun ctxt =>
op_gtgteqquestion
(Bootstrap_storage.init ctxt typecheck
(security_deposit_ramp_up_cycles param)
(no_reward_cycles param)
(bootstrap_accounts param)
(bootstrap_contracts param))
(fun ctxt =>
op_gtgteqquestion
(Roll_storage.init_first_cycles ctxt)
(fun ctxt =>
op_gtgteqquestion (Vote_storage.init ctxt)
(fun ctxt =>
op_gtgteqquestion
(Storage.Block_priority.init ctxt 0)
(fun ctxt =>
op_gtgteqquestion
(Vote_storage.freeze_listings ctxt)
(fun ctxt => _return ctxt)))))))))
| Tezos_raw_protocol_alpha.Raw_context.Alpha_previous => _return ctxt
end)).
Definition prepare
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
(level : Tezos_protocol_environment_alpha__Environment.Int32.t)
(predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
(timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
(fitness :
Tezos_protocol_environment_alpha__Environment.Fitness.(Tezos_protocol_environment_alpha__Environment.T.S.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.context) :=
Raw_context.prepare level predecessor_timestamp timestamp fitness ctxt.
src/proto_alpha/lib_protocol/legacy_script_support_repr.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* Copyright (c) 2019 Cryptium Labs <contact@cryptium-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let manager_script_code : Script_repr.lazy_expr =
let open Micheline in
let open Michelson_v1_primitives in
Script_repr.lazy_expr @@ strip_locations
@@ Seq
( 0,
[ Prim
( 0,
K_parameter,
[ Prim
( 0,
T_or,
[ Prim
( 0,
T_lambda,
[ Prim (0, T_unit, [], []);
Prim
(0, T_list, [Prim (0, T_operation, [], [])], [])
],
["%do"] );
Prim (0, T_unit, [], ["%default"]) ],
[] ) ],
[] );
Prim (0, K_storage, [Prim (0, T_key_hash, [], [])], []);
Prim
( 0,
K_code,
[ Seq
( 0,
[ Seq
( 0,
[ Seq
( 0,
[ Prim (0, I_DUP, [], []);
Prim (0, I_CAR, [], []);
Prim
( 0,
I_DIP,
[Seq (0, [Prim (0, I_CDR, [], [])])],
[] ) ] ) ] );
Prim
( 0,
I_IF_LEFT,
[ Seq
( 0,
[ Prim
( 0,
I_PUSH,
[ Prim (0, T_mutez, [], []);
Int (0, Z.zero) ],
[] );
Prim (0, I_AMOUNT, [], []);
Seq
( 0,
[ Seq
( 0,
[ Prim (0, I_COMPARE, [], []);
Prim (0, I_EQ, [], []) ] );
Prim
( 0,
I_IF,
[ Seq (0, []);
Seq
( 0,
[ Seq
( 0,
[ Prim
(0, I_UNIT, [], []);
Prim
( 0,
I_FAILWITH,
[],
[] ) ] ) ] ) ],
[] ) ] );
Seq
( 0,
[ Prim
( 0,
I_DIP,
[ Seq
(0, [Prim (0, I_DUP, [], [])])
],
[] );
Prim (0, I_SWAP, [], []) ] );
Prim (0, I_IMPLICIT_ACCOUNT, [], []);
Prim (0, I_ADDRESS, [], []);
Prim (0, I_SENDER, [], []);
Seq
( 0,
[ Seq
( 0,
[ Prim (0, I_COMPARE, [], []);
Prim (0, I_EQ, [], []) ] );
Prim
( 0,
I_IF,
[ Seq (0, []);
Seq
( 0,
[ Seq
( 0,
[ Prim
(0, I_UNIT, [], []);
Prim
( 0,
I_FAILWITH,
[],
[] ) ] ) ] ) ],
[] ) ] );
Prim (0, I_UNIT, [], []);
Prim (0, I_EXEC, [], []);
Prim (0, I_PAIR, [], []) ] );
Seq
( 0,
[ Prim (0, I_DROP, [], []);
Prim
( 0,
I_NIL,
[Prim (0, T_operation, [], [])],
[] );
Prim (0, I_PAIR, [], []) ] ) ],
[] ) ] ) ],
[] ) ] )
(* Find the toplevel expression with a given prim type from list,
because they can be in arbitrary order. *)
let find_toplevel toplevel exprs =
let open Micheline in
let rec iter toplevel = function
| (Prim (_, prim, _, _) as found) :: _
when String.equal toplevel (Michelson_v1_primitives.string_of_prim prim)
->
Some found
| _ :: rest ->
iter toplevel rest
| [] ->
None
in
iter (Michelson_v1_primitives.string_of_prim toplevel) exprs
let add_do :
manager_pkh:Signature.Public_key_hash.t ->
script_code:Script_repr.lazy_expr ->
script_storage:Script_repr.lazy_expr ->
(Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t =
fun ~manager_pkh ~script_code ~script_storage ->
let open Micheline in
let open Michelson_v1_primitives in
Lwt.return (Script_repr.force_decode script_code)
>>=? fun (script_code_expr, _gas_cost) ->
Lwt.return (Script_repr.force_decode script_storage)
>>|? fun (script_storage_expr, _gas_cost) ->
let storage_expr = root script_storage_expr in
match root script_code_expr with
| Seq (_, toplevel) -> (
match
( find_toplevel K_parameter toplevel,
find_toplevel K_storage toplevel,
find_toplevel K_code toplevel )
with
| ( Some
(Prim
( _,
K_parameter,
[Prim (_, parameter_type, parameter_expr, parameter_annot)],
prim_param_annot )),
Some
(Prim
( _,
K_storage,
[ Prim
(_, code_storage_type, code_storage_expr, code_storage_annot)
],
k_storage_annot )),
Some (Prim (_, K_code, [code_expr], code_annot)) ) ->
(* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *)
let migrated_code =
Seq
( 0,
[ Prim
( 0,
K_parameter,
[ Prim
( 0,
T_or,
[ Prim
( 0,
T_lambda,
[ Prim (0, T_unit, [], []);
Prim
( 0,
T_list,
[Prim (0, T_operation, [], [])],
[] ) ],
["%do"] );
Prim
( 0,
parameter_type,
parameter_expr,
"%default" :: parameter_annot ) ],
[] ) ],
prim_param_annot );
Prim
( 0,
K_storage,
[ Prim
( 0,
T_pair,
[ Prim (0, T_key_hash, [], []);
Prim
( 0,
code_storage_type,
code_storage_expr,
code_storage_annot ) ],
[] ) ],
k_storage_annot );
Prim
( 0,
K_code,
[ Seq
( 0,
[ Prim (0, I_DUP, [], []);
Prim (0, I_CAR, [], []);
Prim
( 0,
I_IF_LEFT,
[ Seq
( 0,
[ Prim
( 0,
I_PUSH,
[ Prim (0, T_mutez, [], []);
Int (0, Z.zero) ],
[] );
Prim (0, I_AMOUNT, [], []);
Seq
( 0,
[ Seq
( 0,
[ Prim (0, I_COMPARE, [], []);
Prim (0, I_EQ, [], []) ] );
Prim
( 0,
I_IF,
[ Seq (0, []);
Seq
( 0,
[ Seq
( 0,
[ Prim
( 0,
I_UNIT,
[],
[] );
Prim
( 0,
I_FAILWITH,
[],
[] ) ] ) ]
) ],
[] ) ] );
Seq
( 0,
[ Prim
( 0,
I_DIP,
[ Seq
( 0,
[ Prim
(0, I_DUP, [], [])
] ) ],
[] );
Prim (0, I_SWAP, [], []) ] );
Prim (0, I_CDR, [], []);
Prim (0, I_CAR, [], []);
Prim (0, I_IMPLICIT_ACCOUNT, [], []);
Prim (0, I_ADDRESS, [], []);
Prim (0, I_SENDER, [], []);
Seq
( 0,
[ Prim (0, I_COMPARE, [], []);
Prim (0, I_NEQ, [], []);
Prim
( 0,
I_IF,
[ Seq
( 0,
[ Prim
( 0,
I_SENDER,
[],
[] );
Prim
( 0,
I_PUSH,
[ Prim
( 0,
T_string,
[],
[] );
String
( 0,
"Only the \
owner \
can \
operate."
) ],
[] );
Prim
(0, I_PAIR, [], []);
Prim
( 0,
I_FAILWITH,
[],
[] ) ] );
Seq
( 0,
[ Prim
(0, I_UNIT, [], []);
Prim
(0, I_EXEC, [], []);
Prim
( 0,
I_DIP,
[ Seq
( 0,
[ Prim
( 0,
I_CDR,
[],
[] )
] ) ],
[] );
Prim
(0, I_PAIR, [], [])
] ) ],
[] ) ] ) ] );
Seq
( 0,
[ Prim
( 0,
I_DIP,
[ Seq
( 0,
[ Prim (0, I_CDR, [], []);
Prim (0, I_DUP, [], []);
Prim (0, I_CDR, [], []) ]
) ],
[] );
Prim (0, I_PAIR, [], []);
code_expr;
Prim (0, I_SWAP, [], []);
Prim (0, I_CAR, [], []);
Prim (0, I_SWAP, [], []);
Seq
( 0,
[ Seq
( 0,
[ Prim (0, I_DUP, [], []);
Prim (0, I_CAR, [], []);
Prim
( 0,
I_DIP,
[ Seq
( 0,
[ Prim
( 0,
I_CDR,
[],
[] ) ] ) ],
[] ) ] ) ] );
Prim
( 0,
I_DIP,
[ Seq
( 0,
[ Prim (0, I_SWAP, [], []);
Prim (0, I_PAIR, [], []) ]
) ],
[] );
Prim (0, I_PAIR, [], []) ] ) ],
[] ) ] ) ],
code_annot ) ] )
in
let migrated_storage =
Prim
( 0,
D_Pair,
[ (* Instead of
`String (0, Signature.Public_key_hash.to_b58check manager_pkh)`
the storage is written as unparsed with [Optimized] *)
Bytes
( 0,
Data_encoding.Binary.to_bytes_exn
Signature.Public_key_hash.encoding
manager_pkh );
storage_expr ],
[] )
in
( Script_repr.lazy_expr @@ strip_locations migrated_code,
Script_repr.lazy_expr @@ strip_locations migrated_storage )
| _ ->
(script_code, script_storage) )
| _ ->
(script_code, script_storage)
let add_set_delegate :
manager_pkh:Signature.Public_key_hash.t ->
script_code:Script_repr.lazy_expr ->
script_storage:Script_repr.lazy_expr ->
(Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t =
fun ~manager_pkh ~script_code ~script_storage ->
let open Micheline in
let open Michelson_v1_primitives in
Lwt.return (Script_repr.force_decode script_code)
>>=? fun (script_code_expr, _gas_cost) ->
Lwt.return (Script_repr.force_decode script_storage)
>>|? fun (script_storage_expr, _gas_cost) ->
let storage_expr = root script_storage_expr in
match root script_code_expr with
| Seq (_, toplevel) -> (
match
( find_toplevel K_parameter toplevel,
find_toplevel K_storage toplevel,
find_toplevel K_code toplevel )
with
| ( Some
(Prim
( _,
K_parameter,
[Prim (_, parameter_type, parameter_expr, parameter_annot)],
prim_param_annot )),
Some
(Prim
( _,
K_storage,
[ Prim
(_, code_storage_type, code_storage_expr, code_storage_annot)
],
k_storage_annot )),
Some (Prim (_, K_code, [code_expr], code_annot)) ) ->
(* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *)
let migrated_code =
Seq
( 0,
[ Prim
( 0,
K_parameter,
[ Prim
( 0,
T_or,
[ Prim
( 0,
T_or,
[ Prim (0, T_key_hash, [], ["%set_delegate"]);
Prim (0, T_unit, [], ["%remove_delegate"]) ],
[] );
Prim
( 0,
parameter_type,
parameter_expr,
"%default" :: parameter_annot ) ],
[] ) ],
prim_param_annot );
Prim
( 0,
K_storage,
[ Prim
( 0,
T_pair,
[ Prim (0, T_key_hash, [], []);
Prim
( 0,
code_storage_type,
code_storage_expr,
code_storage_annot ) ],
[] ) ],
k_storage_annot );
Prim
( 0,
K_code,
[ Seq
( 0,
[ Prim (0, I_DUP, [], []);
Prim (0, I_CAR, [], []);
Prim
( 0,
I_IF_LEFT,
[ Seq
( 0,
[ Prim
( 0,
I_PUSH,
[ Prim (0, T_mutez, [], []);
Int (0, Z.zero) ],
[] );
Prim (0, I_AMOUNT, [], []);
Seq
( 0,
[ Seq
( 0,
[ Prim (0, I_COMPARE, [], []);
Prim (0, I_EQ, [], []) ] );
Prim
( 0,
I_IF,
[ Seq (0, []);
Seq
( 0,
[ Seq
( 0,
[ Prim
( 0,
I_UNIT,
[],
[] );
Prim
( 0,
I_FAILWITH,
[],
[] ) ] ) ]
) ],
[] ) ] );
Seq
( 0,
[ Prim
( 0,
I_DIP,
[ Seq
( 0,
[ Prim
(0, I_DUP, [], [])
] ) ],
[] );
Prim (0, I_SWAP, [], []) ] );
Prim (0, I_CDR, [], []);
Prim (0, I_CAR, [], []);
Prim (0, I_IMPLICIT_ACCOUNT, [], []);
Prim (0, I_ADDRESS, [], []);
Prim (0, I_SENDER, [], []);
Seq
( 0,
[ Prim (0, I_COMPARE, [], []);
Prim (0, I_NEQ, [], []);
Prim
( 0,
I_IF,
[ Seq
( 0,
[ Prim
( 0,
I_SENDER,
[],
[] );
Prim
( 0,
I_PUSH,
[ Prim
( 0,
T_string,
[],
[] );
String
( 0,
"Only the \
owner \
can \
operate."
) ],
[] );
Prim
(0, I_PAIR, [], []);
Prim
( 0,
I_FAILWITH,
[],
[] ) ] );
Seq
( 0,
[ Prim
( 0,
I_DIP,
[ Seq
( 0,
[ Prim
( 0,
I_CDR,
[],
[] );
Prim
( 0,
I_NIL,
[ Prim
(
0,
T_operation,
[],
[]
)
],
[] )
] ) ],
[] );
Prim
( 0,
I_IF_LEFT,
[ Seq
( 0,
[ Prim
( 0,
I_SOME,
[],
[] );
Prim
( 0,
I_SET_DELEGATE,
[],
[] );
Prim
( 0,
I_CONS,
[],
[] );
Prim
( 0,
I_PAIR,
[],
[] )
] );
Seq
( 0,
[ Prim
( 0,
I_DROP,
[],
[] );
Prim
( 0,
I_NONE,
[ Prim
(
0,
T_key_hash,
[],
[]
)
],
[] );
Prim
( 0,
I_SET_DELEGATE,
[],
[] );
Prim
( 0,
I_CONS,
[],
[] );
Prim
( 0,
I_PAIR,
[],
[] )
] ) ],
[] ) ] ) ],
[] ) ] ) ] );
Seq
( 0,
[ Prim
( 0,
I_DIP,
[ Seq
( 0,
[ Prim (0, I_CDR, [], []);
Prim (0, I_DUP, [], []);
Prim (0, I_CDR, [], []) ]
) ],
[] );
Prim (0, I_PAIR, [], []);
code_expr;
Prim (0, I_SWAP, [], []);
Prim (0, I_CAR, [], []);
Prim (0, I_SWAP, [], []);
Seq
( 0,
[ Seq
( 0,
[ Prim (0, I_DUP, [], []);
Prim (0, I_CAR, [], []);
Prim
( 0,
I_DIP,
[ Seq
( 0,
[ Prim
( 0,
I_CDR,
[],
[] ) ] ) ],
[] ) ] ) ] );
Prim
( 0,
I_DIP,
[ Seq
( 0,
[ Prim (0, I_SWAP, [], []);
Prim (0, I_PAIR, [], []) ]
) ],
[] );
Prim (0, I_PAIR, [], []) ] ) ],
[] ) ] ) ],
code_annot ) ] )
in
let migrated_storage =
Prim
( 0,
D_Pair,
[ (* Instead of
`String (0, Signature.Public_key_hash.to_b58check manager_pkh)`
the storage is written as unparsed with [Optimized] *)
Bytes
( 0,
Data_encoding.Binary.to_bytes_exn
Signature.Public_key_hash.encoding
manager_pkh );
storage_expr ],
[] )
in
( Script_repr.lazy_expr @@ strip_locations migrated_code,
Script_repr.lazy_expr @@ strip_locations migrated_storage )
| _ ->
(script_code, script_storage) )
| _ ->
(script_code, script_storage)
let has_default_entrypoint expr =
let open Micheline in
let open Michelson_v1_primitives in
match Script_repr.force_decode expr with
| Error _ ->
false
| Ok (expr, _) -> (
match root expr with
| Seq (_, toplevel) -> (
match find_toplevel K_parameter toplevel with
| Some (Prim (_, K_parameter, [_], ["%default"])) ->
false
| Some (Prim (_, K_parameter, [parameter_expr], _)) ->
let rec has_default = function
| Prim (_, T_or, [l; r], annots) ->
List.exists (String.equal "%default") annots
|| has_default l || has_default r
| Prim (_, _, _, annots) ->
List.exists (String.equal "%default") annots
| _ ->
false
in
has_default parameter_expr
| Some _ | None ->
false )
| _ ->
false )
let add_root_entrypoint :
script_code:Script_repr.lazy_expr -> Script_repr.lazy_expr tzresult Lwt.t =
fun ~script_code ->
let open Micheline in
let open Michelson_v1_primitives in
Lwt.return (Script_repr.force_decode script_code)
>>|? fun (script_code_expr, _gas_cost) ->
match root script_code_expr with
| Seq (_, toplevel) ->
let migrated_code =
Seq
( 0,
List.map
(function
| Prim (_, K_parameter, [parameter_expr], _) ->
Prim (0, K_parameter, [parameter_expr], ["%root"])
| Prim (_, K_code, exprs, annots) ->
let rec rewrite_self = function
| ( Int _
| String _
| Bytes _
| Prim (_, I_CREATE_CONTRACT, _, _) ) as leaf ->
leaf
| Prim (_, I_SELF, [], annots) ->
Prim (0, I_SELF, [], "%root" :: annots)
| Prim (_, name, args, annots) ->
Prim (0, name, List.map rewrite_self args, annots)
| Seq (_, args) ->
Seq (0, List.map rewrite_self args)
in
Prim (0, K_code, List.map rewrite_self exprs, annots)
| other ->
other)
toplevel )
in
Script_repr.lazy_expr @@ strip_locations migrated_code
| _ ->
script_code
src/proto_alpha/lib_protocol/legacy_script_support_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition manager_script_code
: Tezos_raw_protocol_alpha.Script_repr.lazy_expr :=
op_atat Script_repr.lazy_expr
(op_atat strip_locations
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq 0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_or
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0 Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_lambda
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_unit
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_list
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_operation
[] []) []) []) [])) (cons "%do" % string []))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0 Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_unit
[] (cons "%default" % string [])) [])) []) []) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_storage
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_key_hash []
[]) []) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq 0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
[] []) [])) []) []) [])))) []))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF_LEFT
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PUSH
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_mutez
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Int
0 Z.zero) [])) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_AMOUNT
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_COMPARE
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_EQ
[] []) [])))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0 [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_UNIT
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_FAILWITH
[] []) []))) [])) []))
[]) [])))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
[] []) [])) []) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
[] []) [])))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IMPLICIT_ACCOUNT
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_ADDRESS
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SENDER
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_COMPARE
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_EQ
[] []) [])))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0 [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_UNIT
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_FAILWITH
[] []) [])))
[])) [])) []) [])))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_UNIT
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_EXEC
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
[] []) []))))))))))))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DROP
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_NIL
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_operation
[] []) []) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
[] []) [])))) [])) []) []))) []) []) []))))).
Definition find_toplevel {A : Type}
(toplevel : Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)
(exprs :
list
(Tezos_protocol_environment_alpha__Environment.Micheline.node A
Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim))
: option
(Tezos_protocol_environment_alpha__Environment.Micheline.node A
Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) :=
let fix iter {B : Type}
(toplevel : Tezos_protocol_environment_alpha__Environment.String.t)
(function_parameter :
list
(Tezos_protocol_environment_alpha__Environment.Micheline.node B
Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim))
: option
(Tezos_protocol_environment_alpha__Environment.Micheline.node B
Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) :=
match function_parameter with
|
cons
((Tezos_protocol_environment_alpha__Environment.Micheline.Prim _ prim _
_) as found) _ => Some found
| cons _ rest => iter toplevel rest
| [] => None
end in
iter (Michelson_v1_primitives.string_of_prim toplevel) exprs.
Definition add_do
(manager_pkh :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(script_code : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
(script_storage : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Script_repr.lazy_expr *
Tezos_raw_protocol_alpha.Script_repr.lazy_expr)) :=
op_gtgteqquestion (Lwt._return (Script_repr.force_decode script_code))
(fun function_parameter =>
let '(script_code_expr, _gas_cost) := function_parameter in
op_gtgtpipequestion
(Lwt._return (Script_repr.force_decode script_storage))
(fun function_parameter =>
let '(script_storage_expr, _gas_cost) := function_parameter in
let storage_expr := root script_storage_expr in
match root script_code_expr with
|
Tezos_protocol_environment_alpha__Environment.Micheline.Seq _
toplevel =>
match
((find_toplevel
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
toplevel),
(find_toplevel
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_storage
toplevel),
(find_toplevel
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
toplevel)) with
|
(Some
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
_ parameter_type parameter_expr parameter_annot) [])
prim_param_annot),
Some
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
_ Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_storage
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
_ code_storage_type code_storage_expr code_storage_annot)
[]) k_storage_annot),
Some
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
_ Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
(cons code_expr []) code_annot)) =>
let migrated_code :=
Tezos_protocol_environment_alpha__Environment.Micheline.Seq 0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_or
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_lambda
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_unit
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_list
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_operation
[] []) []) []) []))
(cons "%do" % string []))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0 parameter_type parameter_expr
(cons "%default" % string parameter_annot)) []))
[]) []) prim_param_annot)
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_storage
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_pair
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_key_hash
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0 code_storage_type code_storage_expr
code_storage_annot) [])) []) [])
k_storage_annot)
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF_LEFT
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PUSH
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_mutez
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Int
0 Z.zero) [])) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_AMOUNT
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_COMPARE
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_EQ
[] []) [])))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0 [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_UNIT
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_FAILWITH
[] [])
[]))) []))
[])) []) [])))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
[] []) [])) [])
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
[] []) [])))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IMPLICIT_ACCOUNT
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_ADDRESS
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SENDER
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_COMPARE
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_NEQ
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SENDER
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PUSH
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_string
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.String
0
"Only the owner can operate."
%
string)
[]))
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_FAILWITH
[]
[])
[])))))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_UNIT
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_EXEC
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
[]
[])
[]))
[])
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
[]
[])
[])))))
[]))
[]) []))))
[])))))))))))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
[] []) [])))) []) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
[] [])
(cons code_expr
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
[]
[])
[]))
[]) [])
[])))) []))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
[] [])
[]))) [])
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
[] []) []))))))))))
[])) []) [])))) []) code_annot) [])))
in
let migrated_storage :=
Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.D_Pair
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
0
(Data_encoding.Binary.to_bytes_exn
Signature.Public_key_hash.encoding manager_pkh))
(cons storage_expr [])) [] in
((op_atat Script_repr.lazy_expr (strip_locations migrated_code)),
(op_atat Script_repr.lazy_expr
(strip_locations migrated_storage)))
| _ => (script_code, script_storage)
end
| _ => (script_code, script_storage)
end)).
Definition add_set_delegate
(manager_pkh :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(script_code : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
(script_storage : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Script_repr.lazy_expr *
Tezos_raw_protocol_alpha.Script_repr.lazy_expr)) :=
op_gtgteqquestion (Lwt._return (Script_repr.force_decode script_code))
(fun function_parameter =>
let '(script_code_expr, _gas_cost) := function_parameter in
op_gtgtpipequestion
(Lwt._return (Script_repr.force_decode script_storage))
(fun function_parameter =>
let '(script_storage_expr, _gas_cost) := function_parameter in
let storage_expr := root script_storage_expr in
match root script_code_expr with
|
Tezos_protocol_environment_alpha__Environment.Micheline.Seq _
toplevel =>
match
((find_toplevel
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
toplevel),
(find_toplevel
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_storage
toplevel),
(find_toplevel
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
toplevel)) with
|
(Some
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
_ parameter_type parameter_expr parameter_annot) [])
prim_param_annot),
Some
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
_ Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_storage
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
_ code_storage_type code_storage_expr code_storage_annot)
[]) k_storage_annot),
Some
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
_ Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
(cons code_expr []) code_annot)) =>
let migrated_code :=
Tezos_protocol_environment_alpha__Environment.Micheline.Seq 0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_or
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_or
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_key_hash
[] (cons "%set_delegate" % string []))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_unit
[] (cons "%remove_delegate" % string [])) []))
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0 parameter_type parameter_expr
(cons "%default" % string parameter_annot)) []))
[]) []) prim_param_annot)
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_storage
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_pair
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_key_hash
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0 code_storage_type code_storage_expr
code_storage_annot) [])) []) [])
k_storage_annot)
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF_LEFT
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PUSH
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_mutez
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Int
0 Z.zero) [])) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_AMOUNT
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_COMPARE
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_EQ
[] []) [])))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0 [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_UNIT
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_FAILWITH
[] [])
[]))) []))
[])) []) [])))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
[] []) [])) [])
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
[] []) [])))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IMPLICIT_ACCOUNT
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_ADDRESS
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SENDER
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_COMPARE
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_NEQ
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SENDER
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PUSH
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_string
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.String
0
"Only the owner can operate."
%
string)
[]))
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_FAILWITH
[]
[])
[])))))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_NIL
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_operation
[]
[])
[])
[])
[])))
[])
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF_LEFT
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SOME
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SET_DELEGATE
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CONS
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
[]
[])
[])))))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DROP
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_NONE
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_key_hash
[]
[])
[])
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SET_DELEGATE
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CONS
[]
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
[]
[])
[]))))))
[]))
[])
[])))
[]))
[]) []))))
[])))))))))))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
[] []) [])))) []) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
[] [])
(cons code_expr
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
[]
[])
[]))
[]) [])
[])))) []))
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
[] [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
[] [])
[]))) [])
[])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
[] []) []))))))))))
[])) []) [])))) []) code_annot) [])))
in
let migrated_storage :=
Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.D_Pair
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
0
(Data_encoding.Binary.to_bytes_exn
Signature.Public_key_hash.encoding manager_pkh))
(cons storage_expr [])) [] in
((op_atat Script_repr.lazy_expr (strip_locations migrated_code)),
(op_atat Script_repr.lazy_expr
(strip_locations migrated_storage)))
| _ => (script_code, script_storage)
end
| _ => (script_code, script_storage)
end)).
Definition has_default_entrypoint
(expr : Tezos_raw_protocol_alpha.Script_repr.lazy_expr) : bool :=
match Script_repr.force_decode expr with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ => false
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok (expr, _) =>
match root expr with
| Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ toplevel =>
match
find_toplevel
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter toplevel
with
|
Some
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
(cons _ []) (cons "%default" % string [])) => false
|
Some
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
(cons parameter_expr []) _) =>
let fix has_default {A : Type}
(function_parameter :
Tezos_protocol_environment_alpha__Environment.Micheline.node A
Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) : bool :=
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_or
(cons l (cons r [])) annots =>
op_pipepipe (List._exists (String.equal "%default" % string) annots)
(op_pipepipe (has_default l) (has_default r))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim _ _ _
annots => List._exists (String.equal "%default" % string) annots
| _ => false
end in
has_default parameter_expr
| Some _ | None => false
end
| _ => false
end
end.
Definition add_root_entrypoint
(script_code : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Script_repr.lazy_expr) :=
op_gtgtpipequestion (Lwt._return (Script_repr.force_decode script_code))
(fun function_parameter =>
let '(script_code_expr, _gas_cost) := function_parameter in
match root script_code_expr with
| Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ toplevel
=>
let migrated_code :=
Tezos_protocol_environment_alpha__Environment.Micheline.Seq 0
(List.map
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
(cons parameter_expr []) _ =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
(cons parameter_expr []) (cons "%root" % string [])
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
exprs annots =>
let fix rewrite_self
(function_parameter :
Tezos_protocol_environment_alpha__Environment.Micheline.node
Z Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)
: Tezos_protocol_environment_alpha__Environment.Micheline.node
Z Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim :=
match function_parameter with
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Int
_ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.String
_ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
_ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Prim
_
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CREATE_CONTRACT
_ _) as leaf => leaf
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim
_
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SELF
[] annots =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SELF
[] (cons "%root" % string annots)
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim
_ name args annots =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0 name (List.map rewrite_self args) annots
|
Tezos_protocol_environment_alpha__Environment.Micheline.Seq
_ args =>
Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0 (List.map rewrite_self args)
end in
Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
(List.map rewrite_self exprs) annots
| other => other
end) toplevel) in
op_atat Script_repr.lazy_expr (strip_locations migrated_code)
| _ => script_code
end).
src/proto_alpha/lib_protocol/level_repr.ml 4 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = {
level : Raw_level_repr.t;
level_position : int32;
cycle : Cycle_repr.t;
cycle_position : int32;
voting_period : Voting_period_repr.t;
voting_period_position : int32;
expected_commitment : bool;
}
include Compare.Make (struct
type nonrec t = t
let compare {level = l1} {level = l2} = Raw_level_repr.compare l1 l2
end)
type level = t
let pp ppf {level} = Raw_level_repr.pp ppf level
let pp_full ppf l =
Format.fprintf
ppf
"%a.%ld (cycle %a.%ld) (vote %a.%ld)"
Raw_level_repr.pp
l.level
l.level_position
Cycle_repr.pp
l.cycle
l.cycle_position
Voting_period_repr.pp
l.voting_period
l.voting_period_position
let encoding =
let open Data_encoding in
conv
(fun { level;
level_position;
cycle;
cycle_position;
voting_period;
voting_period_position;
expected_commitment } ->
( level,
level_position,
cycle,
cycle_position,
voting_period,
voting_period_position,
expected_commitment ))
(fun ( level,
level_position,
cycle,
cycle_position,
voting_period,
voting_period_position,
expected_commitment ) ->
{
level;
level_position;
cycle;
cycle_position;
voting_period;
voting_period_position;
expected_commitment;
})
(obj7
(req
"level"
~description:
"The level of the block relative to genesis. This is also the \
Shell's notion of level"
Raw_level_repr.encoding)
(req
"level_position"
~description:
"The level of the block relative to the block that starts \
protocol alpha. This is specific to the protocol alpha. Other \
protocols might or might not include a similar notion."
int32)
(req
"cycle"
~description:
"The current cycle's number. Note that cycles are a \
protocol-specific notion. As a result, the cycle number starts \
at 0 with the first block of protocol alpha."
Cycle_repr.encoding)
(req
"cycle_position"
~description:
"The current level of the block relative to the first block of \
the current cycle."
int32)
(req
"voting_period"
~description:
"The current voting period's index. Note that cycles are a \
protocol-specific notion. As a result, the voting period index \
starts at 0 with the first block of protocol alpha."
Voting_period_repr.encoding)
(req
"voting_period_position"
~description:
"The current level of the block relative to the first block of \
the current voting period."
int32)
(req
"expected_commitment"
~description:
"Tells wether the baker of this block has to commit a seed nonce \
hash."
bool))
let root first_level =
{
level = first_level;
level_position = 0l;
cycle = Cycle_repr.root;
cycle_position = 0l;
voting_period = Voting_period_repr.root;
voting_period_position = 0l;
expected_commitment = false;
}
let from_raw ~first_level ~blocks_per_cycle ~blocks_per_voting_period
~blocks_per_commitment level =
let raw_level = Raw_level_repr.to_int32 level in
let first_level = Raw_level_repr.to_int32 first_level in
let level_position =
Compare.Int32.max 0l (Int32.sub raw_level first_level)
in
let cycle =
Cycle_repr.of_int32_exn (Int32.div level_position blocks_per_cycle)
in
let cycle_position = Int32.rem level_position blocks_per_cycle in
let voting_period =
Voting_period_repr.of_int32_exn
(Int32.div level_position blocks_per_voting_period)
in
let voting_period_position =
Int32.rem level_position blocks_per_voting_period
in
let expected_commitment =
Compare.Int32.(
Int32.rem cycle_position blocks_per_commitment
= Int32.pred blocks_per_commitment)
in
{
level;
level_position;
cycle;
cycle_position;
voting_period;
voting_period_position;
expected_commitment;
}
let diff {level = l1; _} {level = l2; _} =
Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2)
src/proto_alpha/lib_protocol/level_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record t := {
level : Tezos_raw_protocol_alpha.Raw_level_repr.t;
level_position : int32;
cycle : Tezos_raw_protocol_alpha.Cycle_repr.t;
cycle_position : int32;
voting_period : Tezos_raw_protocol_alpha.Voting_period_repr.t;
voting_period_position : int32;
expected_commitment : bool }.
(* ❌ Structure item `include` not handled. *)
include
Definition level := t.
Definition pp
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
(function_parameter : t) : unit :=
let '{| level := level |} := function_parameter in
Raw_level_repr.pp ppf level.
Definition pp_full
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter) (l : t)
: unit :=
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Alpha
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Char_literal
"." % char
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
" (cycle " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Alpha
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Char_literal
"." % char
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
") (vote " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Alpha
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Char_literal
"." % char
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Char_literal
")" % char
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format))))))))))))
"%a.%ld (cycle %a.%ld) (vote %a.%ld)" % string) Raw_level_repr.pp
(level l) (level_position l) Cycle_repr.pp (cycle l) (cycle_position l)
Voting_period_repr.pp (voting_period l) (voting_period_position l).
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
conv
(fun function_parameter =>
let '{|
level := level;
level_position := level_position;
cycle := cycle;
cycle_position := cycle_position;
voting_period := voting_period;
voting_period_position := voting_period_position;
expected_commitment := expected_commitment
|} := function_parameter in
(level, level_position, cycle, cycle_position, voting_period,
voting_period_position, expected_commitment))
(fun function_parameter =>
let
'(level, level_position, cycle, cycle_position, voting_period,
voting_period_position, expected_commitment) := function_parameter in
{| level := level; level_position := level_position; cycle := cycle;
cycle_position := cycle_position; voting_period := voting_period;
voting_period_position := voting_period_position;
expected_commitment := expected_commitment |}) None
(obj7
(req None
(Some
"The level of the block relative to genesis. This is also the Shell's notion of level"
% string) "level" % string Raw_level_repr.encoding)
(req None
(Some
"The level of the block relative to the block that starts protocol alpha. This is specific to the protocol alpha. Other protocols might or might not include a similar notion."
% string) "level_position" % string int32)
(req None
(Some
"The current cycle's number. Note that cycles are a protocol-specific notion. As a result, the cycle number starts at 0 with the first block of protocol alpha."
% string) "cycle" % string Cycle_repr.encoding)
(req None
(Some
"The current level of the block relative to the first block of the current cycle."
% string) "cycle_position" % string int32)
(req None
(Some
"The current voting period's index. Note that cycles are a protocol-specific notion. As a result, the voting period index starts at 0 with the first block of protocol alpha."
% string) "voting_period" % string Voting_period_repr.encoding)
(req None
(Some
"The current level of the block relative to the first block of the current voting period."
% string) "voting_period_position" % string int32)
(req None
(Some
"Tells wether the baker of this block has to commit a seed nonce hash."
% string) "expected_commitment" % string bool)).
Definition root (first_level : Tezos_raw_protocol_alpha.Raw_level_repr.t) : t :=
{| level := first_level;
level_position :=
(* ❌ Constant of type int32 is converted to int *)
0; cycle := Cycle_repr.root;
cycle_position :=
(* ❌ Constant of type int32 is converted to int *)
0; voting_period := Voting_period_repr.root;
voting_period_position :=
(* ❌ Constant of type int32 is converted to int *)
0; expected_commitment := false |}.
Definition from_raw
(first_level : Tezos_raw_protocol_alpha.Raw_level_repr.raw_level)
(blocks_per_cycle : int32) (blocks_per_voting_period : int32)
(blocks_per_commitment : int32)
(level : Tezos_raw_protocol_alpha.Raw_level_repr.raw_level) : t :=
let raw_level := Raw_level_repr.to_int32 level in
let first_level := Raw_level_repr.to_int32 first_level in
let level_position :=
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
(* ❌ Constant of type int32 is converted to int *)
0 (Int32.sub raw_level first_level) in
let cycle :=
Cycle_repr.of_int32_exn (Int32.div level_position blocks_per_cycle) in
let cycle_position := Int32.rem level_position blocks_per_cycle in
let voting_period :=
Voting_period_repr.of_int32_exn
(Int32.div level_position blocks_per_voting_period) in
let voting_period_position :=
Int32.rem level_position blocks_per_voting_period in
let expected_commitment :=
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(Int32.rem cycle_position blocks_per_commitment)
(Int32.pred blocks_per_commitment) in
{| level := level; level_position := level_position; cycle := cycle;
cycle_position := cycle_position; voting_period := voting_period;
voting_period_position := voting_period_position;
expected_commitment := expected_commitment |}.
Definition diff (function_parameter : t) : t -> int32 :=
let '{| level := l1 |} := function_parameter in
fun function_parameter =>
let '{| level := l2 |} := function_parameter in
Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2).
src/proto_alpha/lib_protocol/level_storage.ml 4 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Level_repr
let from_raw c ?offset l =
let l =
match offset with
| None ->
l
| Some o ->
Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o))
in
let constants = Raw_context.constants c in
let first_level = Raw_context.first_level c in
Level_repr.from_raw
~first_level
~blocks_per_cycle:constants.Constants_repr.blocks_per_cycle
~blocks_per_voting_period:constants.Constants_repr.blocks_per_voting_period
~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment
l
let root c = Level_repr.root (Raw_context.first_level c)
let succ c l = from_raw c (Raw_level_repr.succ l.level)
let pred c l =
match Raw_level_repr.pred l.Level_repr.level with
| None ->
None
| Some l ->
Some (from_raw c l)
let current ctxt = Raw_context.current_level ctxt
let previous ctxt =
let l = current ctxt in
match pred ctxt l with
| None ->
assert false (* We never validate the Genesis... *)
| Some p ->
p
let first_level_in_cycle ctxt c =
let constants = Raw_context.constants ctxt in
let first_level = Raw_context.first_level ctxt in
from_raw
ctxt
(Raw_level_repr.of_int32_exn
(Int32.add
(Raw_level_repr.to_int32 first_level)
(Int32.mul
constants.Constants_repr.blocks_per_cycle
(Cycle_repr.to_int32 c))))
let last_level_in_cycle ctxt c =
match pred ctxt (first_level_in_cycle ctxt (Cycle_repr.succ c)) with
| None ->
assert false
| Some x ->
x
let levels_in_cycle ctxt cycle =
let first = first_level_in_cycle ctxt cycle in
let rec loop n acc =
if Cycle_repr.(n.cycle = first.cycle) then loop (succ ctxt n) (n :: acc)
else acc
in
loop first []
let levels_in_current_cycle ctxt ?(offset = 0l) () =
let current_cycle = Cycle_repr.to_int32 (current ctxt).cycle in
let cycle = Int32.add current_cycle offset in
if Compare.Int32.(cycle < 0l) then []
else
let cycle = Cycle_repr.of_int32_exn cycle in
levels_in_cycle ctxt cycle
let levels_with_commitments_in_cycle ctxt c =
let first = first_level_in_cycle ctxt c in
let rec loop n acc =
if Cycle_repr.(n.cycle = first.cycle) then
if n.expected_commitment then loop (succ ctxt n) (n :: acc)
else loop (succ ctxt n) acc
else acc
in
loop first []
let last_allowed_fork_level c =
let level = Raw_context.current_level c in
let preserved_cycles = Constants_storage.preserved_cycles c in
match Cycle_repr.sub level.cycle preserved_cycles with
| None ->
Raw_level_repr.root
| Some cycle ->
(first_level_in_cycle c cycle).level
src/proto_alpha/lib_protocol/level_storage.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Level_repr.
Definition from_raw
(c : Tezos_raw_protocol_alpha.Raw_context.context) (offset : option int32)
(l : Tezos_raw_protocol_alpha.Raw_level_repr.raw_level)
: Tezos_raw_protocol_alpha.Level_repr.level :=
let l :=
match offset with
| None => l
| Some o => of_int32_exn (Int32.add (to_int32 l) o)
end in
let constants := Raw_context.constants c in
let first_level := Raw_context.first_level c in
Level_repr.from_raw first_level (Constants_repr.blocks_per_cycle constants)
(Constants_repr.blocks_per_voting_period constants)
(Constants_repr.blocks_per_commitment constants) l.
Definition root (c : Tezos_raw_protocol_alpha.Raw_context.context)
: Tezos_raw_protocol_alpha.Level_repr.level :=
Level_repr.root (Raw_context.first_level c).
Definition succ
(c : Tezos_raw_protocol_alpha.Raw_context.context)
(l : Tezos_raw_protocol_alpha.Level_repr.t)
: Tezos_raw_protocol_alpha.Level_repr.level :=
from_raw c None (Raw_level_repr.succ (level l)).
Definition pred
(c : Tezos_raw_protocol_alpha.Raw_context.context)
(l : Tezos_raw_protocol_alpha.Level_repr.t)
: option Tezos_raw_protocol_alpha.Level_repr.level :=
match Raw_level_repr.pred (Level_repr.level l) with
| None => None
| Some l => Some (from_raw c None l)
end.
Definition current (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
: Tezos_raw_protocol_alpha.Level_repr.t := Raw_context.current_level ctxt.
Definition previous (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
: Tezos_raw_protocol_alpha.Level_repr.level :=
let l := current ctxt in
match pred ctxt l with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some p => p
end.
Definition first_level_in_cycle
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
(c : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
: Tezos_raw_protocol_alpha.Level_repr.level :=
let constants := Raw_context.constants ctxt in
let first_level := Raw_context.first_level ctxt in
from_raw ctxt None
(Raw_level_repr.of_int32_exn
(Int32.add (Raw_level_repr.to_int32 first_level)
(Int32.mul (Constants_repr.blocks_per_cycle constants)
(Cycle_repr.to_int32 c)))).
Definition last_level_in_cycle
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
(c : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
: Tezos_raw_protocol_alpha.Level_repr.level :=
match pred ctxt (first_level_in_cycle ctxt (Cycle_repr.succ c)) with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some x => x
end.
Definition levels_in_cycle
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
(cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
: list Tezos_raw_protocol_alpha.Level_repr.t :=
let first := first_level_in_cycle ctxt cycle in
let fix loop
(n : Tezos_raw_protocol_alpha.Level_repr.t) (acc :
list Tezos_raw_protocol_alpha.Level_repr.t)
: list Tezos_raw_protocol_alpha.Level_repr.t :=
if op_eq (cycle n) (cycle first) then
loop (succ ctxt n) (cons n acc)
else
acc in
loop first [].
Definition levels_in_current_cycle
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
(op_staroptstar : option int32)
: unit -> list Tezos_raw_protocol_alpha.Level_repr.t :=
let offset :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None =>
(* ❌ Constant of type int32 is converted to int *)
0
end in
fun function_parameter =>
let 'tt := function_parameter in
let current_cycle := Cycle_repr.to_int32 (cycle (current ctxt)) in
let cycle := Int32.add current_cycle offset in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
cycle
(* ❌ Constant of type int32 is converted to int *)
0 then
[]
else
let cycle := Cycle_repr.of_int32_exn cycle in
levels_in_cycle ctxt cycle.
Definition levels_with_commitments_in_cycle
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
(c : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
: list Tezos_raw_protocol_alpha.Level_repr.t :=
let first := first_level_in_cycle ctxt c in
let fix loop
(n : Tezos_raw_protocol_alpha.Level_repr.t) (acc :
list Tezos_raw_protocol_alpha.Level_repr.t)
: list Tezos_raw_protocol_alpha.Level_repr.t :=
if op_eq (cycle n) (cycle first) then
if expected_commitment n then
loop (succ ctxt n) (cons n acc)
else
loop (succ ctxt n) acc
else
acc in
loop first [].
Definition last_allowed_fork_level
(c : Tezos_raw_protocol_alpha.Raw_context.context)
: Tezos_raw_protocol_alpha.Raw_level_repr.raw_level :=
let level := Raw_context.current_level c in
let preserved_cycles := Constants_storage.preserved_cycles c in
match Cycle_repr.sub (cycle level) preserved_cycles with
| None => Raw_level_repr.root
| Some cycle => level (first_level_in_cycle c cycle)
end.
src/proto_alpha/lib_protocol/main.ml 52 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Tezos Protocol Implementation - Protocol Signature Instance *)
type block_header_data = Alpha_context.Block_header.protocol_data
type block_header = Alpha_context.Block_header.t = {
shell : Block_header.shell_header;
protocol_data : block_header_data;
}
let block_header_data_encoding =
Alpha_context.Block_header.protocol_data_encoding
type block_header_metadata = Apply_results.block_metadata
let block_header_metadata_encoding = Apply_results.block_metadata_encoding
type operation_data = Alpha_context.packed_protocol_data =
| Operation_data :
'kind Alpha_context.Operation.protocol_data
-> operation_data
let operation_data_encoding = Alpha_context.Operation.protocol_data_encoding
type operation_receipt = Apply_results.packed_operation_metadata =
| Operation_metadata :
'kind Apply_results.operation_metadata
-> operation_receipt
| No_operation_metadata : operation_receipt
let operation_receipt_encoding = Apply_results.operation_metadata_encoding
let operation_data_and_receipt_encoding =
Apply_results.operation_data_and_metadata_encoding
type operation = Alpha_context.packed_operation = {
shell : Operation.shell_header;
protocol_data : operation_data;
}
let acceptable_passes = Alpha_context.Operation.acceptable_passes
let max_block_length = Alpha_context.Block_header.max_header_length
let max_operation_data_length =
Alpha_context.Constants.max_operation_data_length
let validation_passes =
let max_anonymous_operations =
Alpha_context.Constants.max_revelations_per_block
+ (* allow 100 wallet activations or denunciations per block *) 100
in
Updater.
[ {max_size = 32 * 1024; max_op = Some 32};
(* 32 endorsements *)
{max_size = 32 * 1024; max_op = None};
(* 32k of voting operations *)
{
max_size = max_anonymous_operations * 1024;
max_op = Some max_anonymous_operations;
};
{max_size = 512 * 1024; max_op = None} ]
(* 512kB *)
let rpc_services =
Alpha_services.register () ;
Services_registration.get_rpc_services ()
type validation_mode =
| Application of {
block_header : Alpha_context.Block_header.t;
baker : Alpha_context.public_key_hash;
block_delay : Alpha_context.Period.t;
}
| Partial_application of {
block_header : Alpha_context.Block_header.t;
baker : Alpha_context.public_key_hash;
block_delay : Alpha_context.Period.t;
}
| Partial_construction of {predecessor : Block_hash.t}
| Full_construction of {
predecessor : Block_hash.t;
protocol_data : Alpha_context.Block_header.contents;
baker : Alpha_context.public_key_hash;
block_delay : Alpha_context.Period.t;
}
type validation_state = {
mode : validation_mode;
chain_id : Chain_id.t;
ctxt : Alpha_context.t;
op_count : int;
}
let current_context {ctxt; _} = return (Alpha_context.finalize ctxt).context
let begin_partial_application ~chain_id ~ancestor_context:ctxt
~predecessor_timestamp ~predecessor_fitness
(block_header : Alpha_context.Block_header.t) =
let level = block_header.shell.level in
let fitness = predecessor_fitness in
let timestamp = block_header.shell.timestamp in
Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
>>=? fun ctxt ->
Apply.begin_application ctxt chain_id block_header predecessor_timestamp
>>=? fun (ctxt, baker, block_delay) ->
let mode =
Partial_application
{block_header; baker = Signature.Public_key.hash baker; block_delay}
in
return {mode; chain_id; ctxt; op_count = 0}
let begin_application ~chain_id ~predecessor_context:ctxt
~predecessor_timestamp ~predecessor_fitness
(block_header : Alpha_context.Block_header.t) =
let level = block_header.shell.level in
let fitness = predecessor_fitness in
let timestamp = block_header.shell.timestamp in
Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
>>=? fun ctxt ->
Apply.begin_application ctxt chain_id block_header predecessor_timestamp
>>=? fun (ctxt, baker, block_delay) ->
let mode =
Application
{block_header; baker = Signature.Public_key.hash baker; block_delay}
in
return {mode; chain_id; ctxt; op_count = 0}
let begin_construction ~chain_id ~predecessor_context:ctxt
~predecessor_timestamp ~predecessor_level:pred_level
~predecessor_fitness:pred_fitness ~predecessor ~timestamp
?(protocol_data : block_header_data option) () =
let level = Int32.succ pred_level in
let fitness = pred_fitness in
Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
>>=? fun ctxt ->
( match protocol_data with
| None ->
Apply.begin_partial_construction ctxt
>>=? fun ctxt ->
let mode = Partial_construction {predecessor} in
return (mode, ctxt)
| Some proto_header ->
Apply.begin_full_construction
ctxt
predecessor_timestamp
proto_header.contents
>>=? fun (ctxt, protocol_data, baker, block_delay) ->
let mode =
let baker = Signature.Public_key.hash baker in
Full_construction {predecessor; baker; protocol_data; block_delay}
in
return (mode, ctxt) )
>>=? fun (mode, ctxt) -> return {mode; chain_id; ctxt; op_count = 0}
let apply_operation ({mode; chain_id; ctxt; op_count; _} as data)
(operation : Alpha_context.packed_operation) =
match mode with
| Partial_application _
when not
(List.exists
(Compare.Int.equal 0)
(Alpha_context.Operation.acceptable_passes operation)) ->
(* Multipass validation only considers operations in pass 0. *)
let op_count = op_count + 1 in
return ({data with ctxt; op_count}, No_operation_metadata)
| _ ->
let {shell; protocol_data = Operation_data protocol_data} = operation in
let operation : _ Alpha_context.operation = {shell; protocol_data} in
let (predecessor, baker) =
match mode with
| Partial_application
{block_header = {shell = {predecessor; _}; _}; baker}
| Application {block_header = {shell = {predecessor; _}; _}; baker}
| Full_construction {predecessor; baker; _} ->
(predecessor, baker)
| Partial_construction {predecessor} ->
(predecessor, Signature.Public_key_hash.zero)
in
Apply.apply_operation
ctxt
chain_id
Optimized
predecessor
baker
(Alpha_context.Operation.hash operation)
operation
>>=? fun (ctxt, result) ->
let op_count = op_count + 1 in
return ({data with ctxt; op_count}, Operation_metadata result)
let finalize_block {mode; ctxt; op_count} =
match mode with
| Partial_construction _ ->
let level = Alpha_context.Level.current ctxt in
Alpha_context.Vote.get_current_period_kind ctxt
>>=? fun voting_period_kind ->
let baker = Signature.Public_key_hash.zero in
Signature.Public_key_hash.Map.fold
(fun delegate deposit ctxt ->
ctxt
>>=? fun ctxt ->
Alpha_context.Delegate.freeze_deposit ctxt delegate deposit)
(Alpha_context.get_deposits ctxt)
(return ctxt)
>>=? fun ctxt ->
let ctxt = Alpha_context.finalize ctxt in
return
( ctxt,
Apply_results.
{
baker;
level;
voting_period_kind;
nonce_hash = None;
consumed_gas = Z.zero;
deactivated = [];
balance_updates = [];
} )
| Partial_application {block_header; baker; block_delay} ->
let level = Alpha_context.Level.current ctxt in
let included_endorsements = Alpha_context.included_endorsements ctxt in
Apply.check_minimum_endorsements
ctxt
block_header.protocol_data.contents
block_delay
included_endorsements
>>=? fun () ->
Alpha_context.Vote.get_current_period_kind ctxt
>>=? fun voting_period_kind ->
let ctxt = Alpha_context.finalize ctxt in
return
( ctxt,
Apply_results.
{
baker;
level;
voting_period_kind;
nonce_hash = None;
consumed_gas = Z.zero;
deactivated = [];
balance_updates = [];
} )
| Application
{ baker;
block_delay;
block_header = {protocol_data = {contents = protocol_data; _}; _} }
| Full_construction {protocol_data; baker; block_delay; _} ->
Apply.finalize_application ctxt protocol_data baker ~block_delay
>>=? fun (ctxt, receipt) ->
let level = Alpha_context.Level.current ctxt in
let priority = protocol_data.priority in
let raw_level = Alpha_context.Raw_level.to_int32 level.level in
let fitness = Alpha_context.Fitness.current ctxt in
let commit_message =
Format.asprintf
"lvl %ld, fit 1:%Ld, prio %d, %d ops"
raw_level
fitness
priority
op_count
in
let ctxt = Alpha_context.finalize ~commit_message ctxt in
return (ctxt, receipt)
let compare_operations op1 op2 =
let open Alpha_context in
let (Operation_data op1) = op1.protocol_data in
let (Operation_data op2) = op2.protocol_data in
match (op1.contents, op2.contents) with
| (Single (Endorsement _), Single (Endorsement _)) ->
0
| (_, Single (Endorsement _)) ->
1
| (Single (Endorsement _), _) ->
-1
| (Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _)) ->
0
| (_, Single (Seed_nonce_revelation _)) ->
1
| (Single (Seed_nonce_revelation _), _) ->
-1
| ( Single (Double_endorsement_evidence _),
Single (Double_endorsement_evidence _) ) ->
0
| (_, Single (Double_endorsement_evidence _)) ->
1
| (Single (Double_endorsement_evidence _), _) ->
-1
| (Single (Double_baking_evidence _), Single (Double_baking_evidence _)) ->
0
| (_, Single (Double_baking_evidence _)) ->
1
| (Single (Double_baking_evidence _), _) ->
-1
| (Single (Activate_account _), Single (Activate_account _)) ->
0
| (_, Single (Activate_account _)) ->
1
| (Single (Activate_account _), _) ->
-1
| (Single (Proposals _), Single (Proposals _)) ->
0
| (_, Single (Proposals _)) ->
1
| (Single (Proposals _), _) ->
-1
| (Single (Ballot _), Single (Ballot _)) ->
0
| (_, Single (Ballot _)) ->
1
| (Single (Ballot _), _) ->
-1
(* Manager operations with smaller counter are pre-validated first. *)
| (Single (Manager_operation op1), Single (Manager_operation op2)) ->
Z.compare op1.counter op2.counter
| (Cons (Manager_operation op1, _), Single (Manager_operation op2)) ->
Z.compare op1.counter op2.counter
| (Single (Manager_operation op1), Cons (Manager_operation op2, _)) ->
Z.compare op1.counter op2.counter
| (Cons (Manager_operation op1, _), Cons (Manager_operation op2, _)) ->
Z.compare op1.counter op2.counter
let init ctxt block_header =
let level = block_header.Block_header.level in
let fitness = block_header.fitness in
let timestamp = block_header.timestamp in
let typecheck (ctxt : Alpha_context.context)
(script : Alpha_context.Script.t) =
Script_ir_translator.parse_script ctxt ~legacy:false script
>>=? fun (Ex_script parsed_script, ctxt) ->
Script_ir_translator.extract_big_map_diff
ctxt
Optimized
parsed_script.storage_type
parsed_script.storage
~to_duplicate:Script_ir_translator.no_big_map_id
~to_update:Script_ir_translator.no_big_map_id
~temporary:false
>>=? fun (storage, big_map_diff, ctxt) ->
Script_ir_translator.unparse_data
ctxt
Optimized
parsed_script.storage_type
storage
>>=? fun (storage, ctxt) ->
let storage =
Alpha_context.Script.lazy_expr (Micheline.strip_locations storage)
in
return (({script with storage}, big_map_diff), ctxt)
in
Alpha_context.prepare_first_block ~typecheck ~level ~timestamp ~fitness ctxt
>>=? fun ctxt -> return (Alpha_context.finalize ctxt)
(* Vanity nonce: 313282890 *)
src/proto_alpha/lib_protocol/main.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition block_header_data :=
Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data.
Record block_header := {
shell :
Tezos_protocol_environment_alpha__Environment.Block_header.shell_header;
protocol_data : block_header_data }.
Definition block_header_data_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data :=
Alpha_context.Block_header.protocol_data_encoding.
Definition block_header_metadata :=
Tezos_raw_protocol_alpha.Apply_results.block_metadata.
Definition block_header_metadata_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
Tezos_raw_protocol_alpha.Apply_results.block_metadata :=
Apply_results.block_metadata_encoding.
Inductive operation_data : Type :=
| Operation_data : forall {kind : Type},
(Tezos_raw_protocol_alpha.Alpha_context.Operation.protocol_data kind) ->
operation_data.
Definition operation_data_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.t
Tezos_raw_protocol_alpha.Alpha_context.Operation.packed_protocol_data :=
Alpha_context.Operation.protocol_data_encoding.
Inductive operation_receipt : Type :=
| Operation_metadata : forall {kind : Type},
(Tezos_raw_protocol_alpha.Apply_results.operation_metadata kind) ->
operation_receipt
| No_operation_metadata : operation_receipt.
Definition operation_receipt_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.t
Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata :=
Apply_results.operation_metadata_encoding.
Definition operation_data_and_receipt_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.t
(Tezos_raw_protocol_alpha.Alpha_context.Operation.packed_protocol_data *
Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata) :=
Apply_results.operation_data_and_metadata_encoding.
Record operation := {
shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
protocol_data : operation_data }.
Definition acceptable_passes
: Tezos_raw_protocol_alpha__Alpha_context.packed_operation -> list Z :=
Alpha_context.Operation.acceptable_passes.
Definition max_block_length : Z := Alpha_context.Block_header.max_header_length.
Definition max_operation_data_length : Z :=
Alpha_context.Constants.max_operation_data_length.
Definition validation_passes
: list Tezos_protocol_environment_alpha__Environment.Updater.quota :=
let max_anonymous_operations :=
op_plus Alpha_context.Constants.max_revelations_per_block 100 in
cons {| max_size := op_star 32 1024; max_op := Some 32 |}
(cons {| max_size := op_star 32 1024; max_op := None |}
(cons
{| max_size := op_star max_anonymous_operations 1024;
max_op := Some max_anonymous_operations |}
(cons {| max_size := op_star 512 1024; max_op := None |} []))).
Definition rpc_services
: Tezos_protocol_environment_alpha__Environment.RPC_directory.directory
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Alpha_services.register tt in
Services_registration.get_rpc_services tt.
Inductive validation_mode : Type :=
| Application : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t ->
Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
Tezos_raw_protocol_alpha.Alpha_context.Period.t -> validation_mode
| Partial_application : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t ->
Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
Tezos_raw_protocol_alpha.Alpha_context.Period.t -> validation_mode
| Partial_construction :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
-> validation_mode
| Full_construction :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
-> Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents ->
Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
Tezos_raw_protocol_alpha.Alpha_context.Period.t -> validation_mode.
Record validation_state := {
mode : validation_mode;
chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t);
ctxt : Tezos_raw_protocol_alpha.Alpha_context.t;
op_count : Z }.
Definition current_context (function_parameter : validation_state)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Context.t) :=
let '{| ctxt := ctxt |} := function_parameter in
_return (context (Alpha_context.finalize None ctxt)).
Definition begin_partial_application
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
(predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
(predecessor_fitness : Tezos_raw_protocol_alpha.Alpha_context.Fitness.t)
(block_header : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
validation_state) :=
let level := level (shell block_header) in
let fitness := predecessor_fitness in
let timestamp := timestamp (shell block_header) in
op_gtgteqquestion
(Alpha_context.prepare ctxt level predecessor_timestamp timestamp fitness)
(fun ctxt =>
op_gtgteqquestion
(Apply.begin_application ctxt chain_id block_header
predecessor_timestamp)
(fun function_parameter =>
let '(ctxt, baker, block_delay) := function_parameter in
let mode :=
Partial_application
{| block_header := block_header;
baker := Signature.Public_key.hash baker;
block_delay := block_delay |} in
_return
{| mode := mode; chain_id := chain_id; ctxt := ctxt; op_count := 0
|})).
Definition begin_application
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
(predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
(predecessor_fitness : Tezos_raw_protocol_alpha.Alpha_context.Fitness.t)
(block_header : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
validation_state) :=
let level := level (shell block_header) in
let fitness := predecessor_fitness in
let timestamp := timestamp (shell block_header) in
op_gtgteqquestion
(Alpha_context.prepare ctxt level predecessor_timestamp timestamp fitness)
(fun ctxt =>
op_gtgteqquestion
(Apply.begin_application ctxt chain_id block_header
predecessor_timestamp)
(fun function_parameter =>
let '(ctxt, baker, block_delay) := function_parameter in
let mode :=
Application
{| block_header := block_header;
baker := Signature.Public_key.hash baker;
block_delay := block_delay |} in
_return
{| mode := mode; chain_id := chain_id; ctxt := ctxt; op_count := 0
|})).
Definition begin_construction
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
(predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
(pred_level : int32)
(pred_fitness : Tezos_raw_protocol_alpha.Alpha_context.Fitness.t)
(predecessor :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
(protocol_data : option block_header_data) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
validation_state) :=
let 'tt := function_parameter in
let level := Int32.succ pred_level in
let fitness := pred_fitness in
op_gtgteqquestion
(Alpha_context.prepare ctxt level predecessor_timestamp timestamp fitness)
(fun ctxt =>
op_gtgteqquestion
match protocol_data with
| None =>
op_gtgteqquestion (Apply.begin_partial_construction ctxt)
(fun ctxt =>
let mode := Partial_construction {| predecessor := predecessor |}
in
_return (mode, ctxt))
| Some proto_header =>
op_gtgteqquestion
(Apply.begin_full_construction ctxt predecessor_timestamp
(contents proto_header))
(fun function_parameter =>
let '(ctxt, protocol_data, baker, block_delay) :=
function_parameter in
let mode :=
let baker := Signature.Public_key.hash baker in
Full_construction
{| predecessor := predecessor; protocol_data := protocol_data;
baker := baker; block_delay := block_delay |} in
_return (mode, ctxt))
end
(fun function_parameter =>
let '(mode, ctxt) := function_parameter in
_return
{| mode := mode; chain_id := chain_id; ctxt := ctxt; op_count := 0
|})).
Definition apply_operation (function_parameter : validation_state)
: Tezos_raw_protocol_alpha.Alpha_context.packed_operation ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(validation_state * operation_receipt)) :=
let
'{|
mode := mode;
chain_id := chain_id;
ctxt := ctxt;
op_count := op_count
|} as data := function_parameter in
fun operation =>
match mode with
| Partial_application _ =>
let op_count := op_plus op_count 1 in
_return
((* ❌ Record substitution not handled *)
record_substitution, No_operation_metadata)
| _ =>
let '{|
shell := shell; protocol_data := Operation_data protocol_data |} :=
operation in
let operation := {| shell := shell; protocol_data := protocol_data |} in
let '(predecessor, baker) :=
match mode with
|
Partial_application {|
block_header := {| shell := {| predecessor := predecessor |} |};
baker := baker
|} |
Application {|
block_header := {| shell := {| predecessor := predecessor |} |};
baker := baker
|} |
Full_construction {| predecessor := predecessor; baker := baker |}
=> (predecessor, baker)
| Partial_construction {| predecessor := predecessor |} =>
(predecessor, Signature.Public_key_hash.zero)
end in
op_gtgteqquestion
(Apply.apply_operation ctxt chain_id
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized predecessor
baker (Alpha_context.Operation.hash operation) operation)
(fun function_parameter =>
let '(ctxt, result) := function_parameter in
let op_count := op_plus op_count 1 in
_return
((* ❌ Record substitution not handled *)
record_substitution, (Operation_metadata result)))
end.
Definition finalize_block (function_parameter : validation_state)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_protocol_environment_alpha__Environment.Updater.validation_result *
Tezos_raw_protocol_alpha.Apply_results.block_metadata)) :=
let '{| mode := mode; ctxt := ctxt; op_count := op_count |} :=
function_parameter in
match mode with
| Partial_construction _ =>
let level := Alpha_context.Level.current ctxt in
op_gtgteqquestion (Alpha_context.Vote.get_current_period_kind ctxt)
(fun voting_period_kind =>
let baker := Signature.Public_key_hash.zero in
op_gtgteqquestion
(Signature.Public_key_hash.Map.fold
(fun delegate =>
fun deposit =>
fun ctxt =>
op_gtgteqquestion ctxt
(fun ctxt =>
Alpha_context.Delegate.freeze_deposit ctxt delegate
deposit)) (Alpha_context.get_deposits ctxt)
(_return ctxt))
(fun ctxt =>
let ctxt := Alpha_context.finalize None ctxt in
_return
(ctxt,
{| baker := baker; level := level;
voting_period_kind := voting_period_kind; nonce_hash := None;
consumed_gas := Z.zero; deactivated := [];
balance_updates := [] |})))
|
Partial_application {|
block_header := block_header;
baker := baker;
block_delay := block_delay
|} =>
let level := Alpha_context.Level.current ctxt in
let included_endorsements := Alpha_context.included_endorsements ctxt in
op_gtgteqquestion
(Apply.check_minimum_endorsements ctxt
(contents (protocol_data block_header)) block_delay
included_endorsements)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (Alpha_context.Vote.get_current_period_kind ctxt)
(fun voting_period_kind =>
let ctxt := Alpha_context.finalize None ctxt in
_return
(ctxt,
{| baker := baker; level := level;
voting_period_kind := voting_period_kind; nonce_hash := None;
consumed_gas := Z.zero; deactivated := [];
balance_updates := [] |})))
|
Application {|
block_header := {| protocol_data := {| contents := protocol_data |} |};
baker := baker;
block_delay := block_delay
|} |
Full_construction {|
protocol_data := protocol_data;
baker := baker;
block_delay := block_delay
|} =>
op_gtgteqquestion
(Apply.finalize_application ctxt protocol_data baker block_delay)
(fun function_parameter =>
let '(ctxt, receipt) := function_parameter in
let level := Alpha_context.Level.current ctxt in
let priority := priority protocol_data in
let raw_level := Alpha_context.Raw_level.to_int32 (level level) in
let fitness := Alpha_context.Fitness.current ctxt in
let commit_message :=
Format.asprintf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"lvl " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
", fit 1:" % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int64
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
", prio " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
", " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
" ops" % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))))))))
"lvl %ld, fit 1:%Ld, prio %d, %d ops" % string) raw_level fitness
priority op_count in
let ctxt := Alpha_context.finalize (Some commit_message) ctxt in
_return (ctxt, receipt))
end.
Definition compare_operations
(op1 : Tezos_raw_protocol_alpha.Alpha_context.packed_operation)
(op2 : Tezos_raw_protocol_alpha.Alpha_context.packed_operation) : Z :=
let 'Tezos_raw_protocol_alpha.Alpha_context.Operation_data op1 :=
protocol_data op1 in
let 'Tezos_raw_protocol_alpha.Alpha_context.Operation_data op2 :=
protocol_data op2 in
match ((contents op1), (contents op2)) with
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Endorsement _),
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Endorsement _)) => 0
|
(_,
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Endorsement _)) => 1
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Endorsement _), _) => (-1)
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation _),
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation _)) => 0
|
(_,
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation _)) => 1
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation _), _) =>
(-1)
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence _),
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence _))
=> 0
|
(_,
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence _))
=> 1
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence _), _)
=> (-1)
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence _),
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence _)) => 0
|
(_,
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence _)) => 1
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence _), _) =>
(-1)
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Activate_account _),
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Activate_account _)) => 0
|
(_,
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Activate_account _)) => 1
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Activate_account _), _) => (-1)
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Proposals _),
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Proposals _)) => 0
|
(_,
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Proposals _)) => 1
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Proposals _), _) => (-1)
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Ballot _),
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Ballot _)) => 0
|
(_,
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Ballot _)) => 1
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Ballot _), _) => (-1)
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op1),
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op2)) =>
Z.compare (counter op1) (counter op2)
|
(Tezos_raw_protocol_alpha.Alpha_context.Cons
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op1) _,
Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op2)) =>
Z.compare (counter op1) (counter op2)
|
(Tezos_raw_protocol_alpha.Alpha_context.Single
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op1),
Tezos_raw_protocol_alpha.Alpha_context.Cons
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op2) _) =>
Z.compare (counter op1) (counter op2)
|
(Tezos_raw_protocol_alpha.Alpha_context.Cons
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op1) _,
Tezos_raw_protocol_alpha.Alpha_context.Cons
(Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op2) _) =>
Z.compare (counter op1) (counter op2)
end.
Definition init
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
(block_header :
Tezos_protocol_environment_alpha__Environment.Block_header.shell_header)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Updater.validation_result) :=
let level := Block_header.level block_header in
let fitness := fitness block_header in
let timestamp := timestamp block_header in
let typecheck
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (script :
Tezos_raw_protocol_alpha.Alpha_context.Script.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_raw_protocol_alpha.Alpha_context.Script.t *
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))
* Tezos_raw_protocol_alpha.Alpha_context.context)) :=
op_gtgteqquestion (Script_ir_translator.parse_script None ctxt false script)
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_script
parsed_script, ctxt) := function_parameter in
op_gtgteqquestion
(Script_ir_translator.extract_big_map_diff ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized false
Script_ir_translator.no_big_map_id
Script_ir_translator.no_big_map_id (storage_type parsed_script)
(storage parsed_script))
(fun function_parameter =>
let '(storage, big_map_diff, ctxt) := function_parameter in
op_gtgteqquestion
(Script_ir_translator.unparse_data ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
(storage_type parsed_script) storage)
(fun function_parameter =>
let '(storage, ctxt) := function_parameter in
let storage :=
Alpha_context.Script.lazy_expr
(Micheline.strip_locations storage) in
_return
(((* ❌ Record substitution not handled *)
record_substitution, big_map_diff), ctxt)))) in
op_gtgteqquestion
(Alpha_context.prepare_first_block ctxt typecheck level timestamp fitness)
(fun ctxt => _return (Alpha_context.finalize None ctxt)).
src/proto_alpha/lib_protocol/manager_repr.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Tezos Protocol Implementation - Low level Repr. of Managers' keys *)
type manager_key =
| Hash of Signature.Public_key_hash.t
| Public_key of Signature.Public_key.t
type t = manager_key
open Data_encoding
let hash_case tag =
case
tag
~title:"Public_key_hash"
Signature.Public_key_hash.encoding
(function Hash hash -> Some hash | _ -> None)
(fun hash -> Hash hash)
let pubkey_case tag =
case
tag
~title:"Public_key"
Signature.Public_key.encoding
(function Public_key hash -> Some hash | _ -> None)
(fun hash -> Public_key hash)
let encoding = union [hash_case (Tag 0); pubkey_case (Tag 1)]
src/proto_alpha/lib_protocol/manager_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive manager_key : Type :=
| Hash :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
manager_key
| Public_key :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t ->
manager_key.
Definition t := manager_key.
Import Data_encoding.
Definition hash_case
(tag : Tezos_protocol_environment_alpha__Environment.Data_encoding.case_tag)
: Tezos_protocol_environment_alpha__Environment.Data_encoding.case manager_key :=
case "Public_key_hash" % string None tag Signature.Public_key_hash.encoding
(fun function_parameter =>
match function_parameter with
| Hash hash => Some hash
| _ => None
end) (fun hash => Hash hash).
Definition pubkey_case
(tag : Tezos_protocol_environment_alpha__Environment.Data_encoding.case_tag)
: Tezos_protocol_environment_alpha__Environment.Data_encoding.case manager_key :=
case "Public_key" % string None tag Signature.Public_key.encoding
(fun function_parameter =>
match function_parameter with
| Public_key hash => Some hash
| _ => None
end) (fun hash => Public_key hash).
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
manager_key :=
union None
(cons
(hash_case
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0))
(cons
(pubkey_case
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1))
[])).
src/proto_alpha/lib_protocol/michelson_v1_gas.ml 489 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
open Gas
module Cost_of = struct
let log2 =
let rec help acc = function 0 -> acc | n -> help (acc + 1) (n / 2) in
help 1
let z_bytes (z : Z.t) =
let bits = Z.numbits z in
(7 + bits) / 8
let int_bytes (z : 'a Script_int.num) = z_bytes (Script_int.to_zint z)
let timestamp_bytes (t : Script_timestamp.t) =
let z = Script_timestamp.to_zint t in
z_bytes z
(* For now, returns size in bytes, but this could get more complicated... *)
let rec size_of_comparable :
type a b. (a, b) Script_typed_ir.comparable_struct -> a -> int =
fun wit v ->
match wit with
| Int_key _ ->
int_bytes v
| Nat_key _ ->
int_bytes v
| String_key _ ->
String.length v
| Bytes_key _ ->
MBytes.length v
| Bool_key _ ->
8
| Key_hash_key _ ->
Signature.Public_key_hash.size
| Timestamp_key _ ->
timestamp_bytes v
| Address_key _ ->
Signature.Public_key_hash.size
| Mutez_key _ ->
8
| Pair_key ((l, _), (r, _), _) ->
let (lval, rval) = v in
size_of_comparable l lval + size_of_comparable r rval
let string length = alloc_bytes_cost length
let bytes length = alloc_mbytes_cost length
let manager_operation = step_cost 10_000
module Legacy = struct
let zint z = alloc_bits_cost (Z.numbits z)
let set_to_list : type item. item Script_typed_ir.set -> cost =
fun (module Box) -> alloc_cost @@ Pervasives.(Box.size * 2)
let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost
=
fun (module Box) ->
let size = snd Box.boxed in
3 *@ alloc_cost size
let z_to_int64 = step_cost 2 +@ alloc_cost 1
let hash data len = (10 *@ step_cost (MBytes.length data)) +@ bytes len
let set_access : type elt. elt -> elt Script_typed_ir.set -> int =
fun _key (module Box) -> log2 @@ Box.size
let set_update key _presence set = set_access key set *@ alloc_cost 3
end
module Interpreter = struct
let cycle = atomic_step_cost 10
let nop = free
let stack_op = atomic_step_cost 10
let push = atomic_step_cost 10
let wrap = atomic_step_cost 10
let variant_no_data = atomic_step_cost 10
let branch = atomic_step_cost 10
let pair = atomic_step_cost 10
let pair_access = atomic_step_cost 10
let cons = atomic_step_cost 10
let loop_size = atomic_step_cost 5
let loop_cycle = atomic_step_cost 10
let loop_iter = atomic_step_cost 20
let loop_map = atomic_step_cost 30
let empty_set = atomic_step_cost 10
let set_to_list : type elt. elt Script_typed_ir.set -> cost =
fun (module Box) -> atomic_step_cost (Box.size * 20)
let set_mem : type elt. elt -> elt Script_typed_ir.set -> cost =
fun elt (module Box) ->
let elt_bytes = size_of_comparable Box.elt_ty elt in
atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size)
let set_update : type elt. elt -> bool -> elt Script_typed_ir.set -> cost =
fun elt _ (module Box) ->
let elt_bytes = size_of_comparable Box.elt_ty elt in
atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size)
let set_size = atomic_step_cost 10
let empty_map = atomic_step_cost 10
let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost
=
fun (module Box) ->
let size = snd Box.boxed in
atomic_step_cost (size * 20)
let map_access :
type key value. key -> (key, value) Script_typed_ir.map -> cost =
fun key (module Box) ->
let map_card = snd Box.boxed in
let key_bytes = size_of_comparable Box.key_ty key in
atomic_step_cost ((1 + (key_bytes / 70)) * log2 map_card)
let map_mem = map_access
let map_get = map_access
let map_update :
type key value.
key -> value option -> (key, value) Script_typed_ir.map -> cost =
fun key _value (module Box) ->
let map_card = snd Box.boxed in
let key_bytes = size_of_comparable Box.key_ty key in
atomic_step_cost ((1 + (key_bytes / 38)) * log2 map_card)
let map_size = atomic_step_cost 10
let add_timestamp (t1 : Script_timestamp.t) (t2 : 'a Script_int.num) =
let bytes1 = timestamp_bytes t1 in
let bytes2 = int_bytes t2 in
atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62))
let sub_timestamp = add_timestamp
let diff_timestamps (t1 : Script_timestamp.t) (t2 : Script_timestamp.t) =
let bytes1 = timestamp_bytes t1 in
let bytes2 = timestamp_bytes t2 in
atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62))
let rec concat_loop l acc =
match l with [] -> 30 | _ :: tl -> concat_loop tl (acc + 30)
let concat_string string_list =
atomic_step_cost (concat_loop string_list 0)
let slice_string string_length =
atomic_step_cost (40 + (string_length / 70))
let concat_bytes bytes_list = atomic_step_cost (concat_loop bytes_list 0)
let int64_op = atomic_step_cost 61
let z_to_int64 = atomic_step_cost 20
let int64_to_z = atomic_step_cost 20
let bool_binop _ _ = atomic_step_cost 10
let bool_unop _ = atomic_step_cost 10
let abs int = atomic_step_cost (61 + (int_bytes int / 70))
let int _int = free
let neg = abs
let add i1 i2 =
atomic_step_cost
(51 + (Compare.Int.max (int_bytes i1) (int_bytes i2) / 62))
let sub = add
let mul i1 i2 =
let bytes = Compare.Int.max (int_bytes i1) (int_bytes i2) in
atomic_step_cost (51 + (bytes / 6 * log2 bytes))
let indic_lt x y = if Compare.Int.(x < y) then 1 else 0
let div i1 i2 =
let bytes1 = int_bytes i1 in
let bytes2 = int_bytes i2 in
let cost = indic_lt bytes2 bytes1 * (bytes1 - bytes2) * bytes2 in
atomic_step_cost (51 + (cost / 3151))
let shift_left _i _shift_bits = atomic_step_cost 30
let shift_right _i _shift_bits = atomic_step_cost 30
let logor i1 i2 =
let bytes1 = int_bytes i1 in
let bytes2 = int_bytes i2 in
atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 70))
let logand i1 i2 =
let bytes1 = int_bytes i1 in
let bytes2 = int_bytes i2 in
atomic_step_cost (51 + (Compare.Int.min bytes1 bytes2 / 70))
let logxor = logor
let lognot i = atomic_step_cost (51 + (int_bytes i / 20))
let exec = atomic_step_cost 10
let compare_bool _ _ = atomic_step_cost 30
let compare_string s1 s2 =
let bytes1 = String.length s1 in
let bytes2 = String.length s2 in
atomic_step_cost (30 + (Compare.Int.min bytes1 bytes2 / 123))
let compare_bytes b1 b2 =
let bytes1 = MBytes.length b1 in
let bytes2 = MBytes.length b2 in
atomic_step_cost (30 + (Compare.Int.min bytes1 bytes2 / 123))
let compare_tez _ _ = atomic_step_cost 30
let compare_zint i1 i2 =
atomic_step_cost
(51 + (Compare.Int.min (int_bytes i1) (int_bytes i2) / 82))
let compare_key_hash _ _ = atomic_step_cost 92
let compare_timestamp t1 t2 =
let bytes1 = timestamp_bytes t1 in
let bytes2 = timestamp_bytes t2 in
atomic_step_cost (51 + (Compare.Int.min bytes1 bytes2 / 82))
let compare_address _ _ = atomic_step_cost 92
let compare_res = atomic_step_cost 30
let unpack_failed bytes =
(* We cannot instrument failed deserialization,
so we take worst case fees: a set of size 1 bytes values. *)
let len = MBytes.length bytes in
(len *@ alloc_mbytes_cost 1)
+@ (len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1)))
let address = atomic_step_cost 10
let contract = step_cost 10000
let transfer = step_cost 10
let create_account = step_cost 10
let create_contract = step_cost 10
let implicit_account = step_cost 10
let set_delegate = step_cost 10 +@ write_bytes_cost (Z.of_int 32)
let balance = atomic_step_cost 10
let now = atomic_step_cost 10
let check_signature_secp256k1 bytes = atomic_step_cost (10342 + (bytes / 5))
let check_signature_ed25519 bytes = atomic_step_cost (36864 + (bytes / 5))
let check_signature_p256 bytes = atomic_step_cost (36864 + (bytes / 5))
let check_signature (pkey : Signature.public_key) bytes =
match pkey with
| Ed25519 _ ->
check_signature_ed25519 (MBytes.length bytes)
| Secp256k1 _ ->
check_signature_secp256k1 (MBytes.length bytes)
| P256 _ ->
check_signature_p256 (MBytes.length bytes)
let hash_key = atomic_step_cost 30
let hash_blake2b b = atomic_step_cost (102 + (MBytes.length b / 5))
let hash_sha256 b = atomic_step_cost (409 + MBytes.length b)
let hash_sha512 b =
let bytes = MBytes.length b in
atomic_step_cost (409 + ((bytes lsr 1) + (bytes lsr 4)))
let steps_to_quota = atomic_step_cost 10
let source = atomic_step_cost 10
let self = atomic_step_cost 10
let amount = atomic_step_cost 10
let chain_id = step_cost 1
let stack_n_op n =
atomic_step_cost (20 + ((n lsr 1) + (n lsr 2) + (n lsr 4)))
let apply = alloc_cost 8 +@ step_cost 1
let rec compare :
type a s. (a, s) Script_typed_ir.comparable_struct -> a -> a -> cost =
fun ty x y ->
match ty with
| Bool_key _ ->
compare_bool x y
| String_key _ ->
compare_string x y
| Bytes_key _ ->
compare_bytes x y
| Mutez_key _ ->
compare_tez x y
| Int_key _ ->
compare_zint x y
| Nat_key _ ->
compare_zint x y
| Key_hash_key _ ->
compare_key_hash x y
| Timestamp_key _ ->
compare_timestamp x y
| Address_key _ ->
compare_address x y
| Pair_key ((tl, _), (tr, _), _) ->
(* Reasonable over-approximation of the cost of lexicographic comparison. *)
let (xl, xr) = x and (yl, yr) = y in
compare tl xl yl +@ compare tr xr yr
end
module Typechecking = struct
let cycle = step_cost 1
let bool = free
let unit = free
let string = string
let bytes = bytes
let z = Legacy.zint
let int_of_string str =
alloc_cost @@ Pervasives.( / ) (String.length str) 5
let tez = step_cost 1 +@ alloc_cost 1
let string_timestamp = step_cost 3 +@ alloc_cost 3
let key = step_cost 3 +@ alloc_cost 3
let key_hash = step_cost 1 +@ alloc_cost 1
let signature = step_cost 1 +@ alloc_cost 1
let chain_id = step_cost 1 +@ alloc_cost 1
let contract = step_cost 5
let get_script = step_cost 20 +@ alloc_cost 5
let contract_exists = step_cost 15 +@ alloc_cost 5
let pair = alloc_cost 2
let union = alloc_cost 1
let lambda = alloc_cost 5 +@ step_cost 3
let some = alloc_cost 1
let none = alloc_cost 0
let list_element = alloc_cost 2 +@ step_cost 1
let set_element size = log2 size *@ (alloc_cost 3 +@ step_cost 2)
let map_element size = log2 size *@ (alloc_cost 4 +@ step_cost 2)
let primitive_type = alloc_cost 1
let one_arg_type = alloc_cost 2
let two_arg_type = alloc_cost 3
let operation b = bytes b
let type_ nb_args = alloc_cost (nb_args + 1)
(* Cost of parsing instruction, is cost of allocation of
constructor + cost of contructor parameters + cost of
allocation on the stack type *)
let instr : type b a. (b, a) Script_typed_ir.instr -> cost =
fun i ->
let open Script_typed_ir in
alloc_cost 1
+@
(* cost of allocation of constructor *)
match i with
| Drop ->
alloc_cost 0
| Dup ->
alloc_cost 1
| Swap ->
alloc_cost 0
| Const _ ->
alloc_cost 1
| Cons_pair ->
alloc_cost 2
| Car ->
alloc_cost 1
| Cdr ->
alloc_cost 1
| Cons_some ->
alloc_cost 2
| Cons_none _ ->
alloc_cost 3
| If_none _ ->
alloc_cost 2
| Left ->
alloc_cost 3
| Right ->
alloc_cost 3
| If_left _ ->
alloc_cost 2
| Cons_list ->
alloc_cost 1
| Nil ->
alloc_cost 1
| If_cons _ ->
alloc_cost 2
| List_map _ ->
alloc_cost 5
| List_iter _ ->
alloc_cost 4
| List_size ->
alloc_cost 1
| Empty_set _ ->
alloc_cost 1
| Set_iter _ ->
alloc_cost 4
| Set_mem ->
alloc_cost 1
| Set_update ->
alloc_cost 1
| Set_size ->
alloc_cost 1
| Empty_map _ ->
alloc_cost 2
| Map_map _ ->
alloc_cost 5
| Map_iter _ ->
alloc_cost 4
| Map_mem ->
alloc_cost 1
| Map_get ->
alloc_cost 1
| Map_update ->
alloc_cost 1
| Map_size ->
alloc_cost 1
| Empty_big_map _ ->
alloc_cost 2
| Big_map_mem ->
alloc_cost 1
| Big_map_get ->
alloc_cost 1
| Big_map_update ->
alloc_cost 1
| Concat_string ->
alloc_cost 1
| Concat_string_pair ->
alloc_cost 1
| Concat_bytes ->
alloc_cost 1
| Concat_bytes_pair ->
alloc_cost 1
| Slice_string ->
alloc_cost 1
| Slice_bytes ->
alloc_cost 1
| String_size ->
alloc_cost 1
| Bytes_size ->
alloc_cost 1
| Add_seconds_to_timestamp ->
alloc_cost 1
| Add_timestamp_to_seconds ->
alloc_cost 1
| Sub_timestamp_seconds ->
alloc_cost 1
| Diff_timestamps ->
alloc_cost 1
| Add_tez ->
alloc_cost 1
| Sub_tez ->
alloc_cost 1
| Mul_teznat ->
alloc_cost 1
| Mul_nattez ->
alloc_cost 1
| Ediv_teznat ->
alloc_cost 1
| Ediv_tez ->
alloc_cost 1
| Or ->
alloc_cost 1
| And ->
alloc_cost 1
| Xor ->
alloc_cost 1
| Not ->
alloc_cost 1
| Is_nat ->
alloc_cost 1
| Neg_nat ->
alloc_cost 1
| Neg_int ->
alloc_cost 1
| Abs_int ->
alloc_cost 1
| Int_nat ->
alloc_cost 1
| Add_intint ->
alloc_cost 1
| Add_intnat ->
alloc_cost 1
| Add_natint ->
alloc_cost 1
| Add_natnat ->
alloc_cost 1
| Sub_int ->
alloc_cost 1
| Mul_intint ->
alloc_cost 1
| Mul_intnat ->
alloc_cost 1
| Mul_natint ->
alloc_cost 1
| Mul_natnat ->
alloc_cost 1
| Ediv_intint ->
alloc_cost 1
| Ediv_intnat ->
alloc_cost 1
| Ediv_natint ->
alloc_cost 1
| Ediv_natnat ->
alloc_cost 1
| Lsl_nat ->
alloc_cost 1
| Lsr_nat ->
alloc_cost 1
| Or_nat ->
alloc_cost 1
| And_nat ->
alloc_cost 1
| And_int_nat ->
alloc_cost 1
| Xor_nat ->
alloc_cost 1
| Not_nat ->
alloc_cost 1
| Not_int ->
alloc_cost 1
| Seq _ ->
alloc_cost 8
| If _ ->
alloc_cost 8
| Loop _ ->
alloc_cost 4
| Loop_left _ ->
alloc_cost 5
| Dip _ ->
alloc_cost 4
| Exec ->
alloc_cost 1
| Apply _ ->
alloc_cost 1
| Lambda _ ->
alloc_cost 2
| Failwith _ ->
alloc_cost 1
| Nop ->
alloc_cost 0
| Compare _ ->
alloc_cost 1
| Eq ->
alloc_cost 1
| Neq ->
alloc_cost 1
| Lt ->
alloc_cost 1
| Gt ->
alloc_cost 1
| Le ->
alloc_cost 1
| Ge ->
alloc_cost 1
| Address ->
alloc_cost 1
| Contract _ ->
alloc_cost 2
| Transfer_tokens ->
alloc_cost 1
| Create_account ->
alloc_cost 2
| Implicit_account ->
alloc_cost 1
| Create_contract _ ->
alloc_cost 8
(* Deducted the cost of removed arguments manager, spendable and delegatable:
- manager: key_hash = 1
- spendable: bool = 0
- delegatable: bool = 0
*)
| Create_contract_2 _ ->
alloc_cost 7
| Set_delegate ->
alloc_cost 1
| Now ->
alloc_cost 1
| Balance ->
alloc_cost 1
| Check_signature ->
alloc_cost 1
| Hash_key ->
alloc_cost 1
| Pack _ ->
alloc_cost 2
| Unpack _ ->
alloc_cost 2
| Blake2b ->
alloc_cost 1
| Sha256 ->
alloc_cost 1
| Sha512 ->
alloc_cost 1
| Steps_to_quota ->
alloc_cost 1
| Source ->
alloc_cost 1
| Sender ->
alloc_cost 1
| Self _ ->
alloc_cost 2
| Amount ->
alloc_cost 1
| Dig (n, _) ->
n *@ alloc_cost 1 (* _ is a unary development of n *)
| Dug (n, _) ->
n *@ alloc_cost 1
| Dipn (n, _, _) ->
n *@ alloc_cost 1
| Dropn (n, _) ->
n *@ alloc_cost 1
| ChainId ->
alloc_cost 1
end
module Unparse = struct
let prim_cost l annot = Script.prim_node_cost_nonrec_of_length l annot
let seq_cost = Script.seq_node_cost_nonrec_of_length
let string_cost length = Script.string_node_cost_of_length length
let cycle = step_cost 1
let bool = prim_cost 0 []
let unit = prim_cost 0 []
(* We count the length of strings and bytes to prevent hidden
miscalculations due to non detectable expansion of sharing. *)
let string s = Script.string_node_cost s
let bytes s = Script.bytes_node_cost s
let z i = Script.int_node_cost i
let int i = Script.int_node_cost (Script_int.to_zint i)
let tez = Script.int_node_cost_of_numbits 60 (* int64 bound *)
let timestamp x = Script_timestamp.to_zint x |> Script_int.of_zint |> int
let operation bytes = Script.bytes_node_cost bytes
let chain_id bytes = Script.bytes_node_cost bytes
let key = string_cost 54
let key_hash = string_cost 36
let signature = string_cost 128
let contract = string_cost 36
let pair = prim_cost 2 []
let union = prim_cost 1 []
let some = prim_cost 1 []
let none = prim_cost 0 []
let list_element = alloc_cost 2
let set_element = alloc_cost 2
let map_element = alloc_cost 2
let one_arg_type = prim_cost 1
let two_arg_type = prim_cost 2
let set_to_list = Legacy.set_to_list
let map_to_list = Legacy.map_to_list
end
end
src/proto_alpha/lib_protocol/michelson_v1_gas.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Import Gas.
Module Cost_of.
Definition log2 : Z -> Z :=
let fix help (acc : Z) (function_parameter : Z) : Z :=
match function_parameter with
| 0 => acc
| n => help (op_plus acc 1) (op_div n 2)
end in
help 1.
Definition z_bytes (z : Tezos_protocol_environment_alpha__Environment.Z.t)
: Z :=
let bits := Z.numbits z in
op_div (op_plus 7 bits) 8.
Definition int_bytes {a : Type}
(z : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num a) : Z :=
z_bytes (Script_int.to_zint z).
Definition timestamp_bytes
(t : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t) : Z :=
let z := Script_timestamp.to_zint t in
z_bytes z.
Fixpoint size_of_comparable {a b : Type}
(wit : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a b)
(v : a) : Z :=
match wit with
| Tezos_raw_protocol_alpha.Script_typed_ir.Int_key _ => int_bytes v
| Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key _ => int_bytes v
| Tezos_raw_protocol_alpha.Script_typed_ir.String_key _ => String.length v
| Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key _ => MBytes.length v
| Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key _ => 8
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key _ =>
Signature.Public_key_hash.size
| Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key _ =>
timestamp_bytes v
| Tezos_raw_protocol_alpha.Script_typed_ir.Address_key _ =>
Signature.Public_key_hash.size
| Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key _ => 8
| Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key (l, _) (r, _) _ =>
let '(lval, rval) := v in
op_plus (size_of_comparable l lval) (size_of_comparable r rval)
end.
Definition string (length : Z)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := alloc_bytes_cost length.
Definition bytes (length : Z)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
alloc_mbytes_cost length.
Definition manager_operation
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := step_cost 10000.
Module Legacy.
Definition zint (z : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
alloc_bits_cost (Z.numbits z).
Definition set_to_list {item : Type}
(Box : Tezos_raw_protocol_alpha.Script_typed_ir.set item)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let Box := projT2 Box in
op_atat alloc_cost
(op_star Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_set.size)
2).
Definition map_to_list {key value : Type}
(Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let Box := projT2 Box in
let size :=
snd Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_map.boxed) in
op_starat 3 (alloc_cost size).
Definition z_to_int64 : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (step_cost 2) (alloc_cost 1).
Definition hash
(data : Tezos_protocol_environment_alpha__Environment.MBytes.t) (len : Z)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (op_starat 10 (step_cost (MBytes.length data))) (string len).
Definition set_access {elt : Type}
(_key : elt) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt)
: Z :=
let Box := projT2 Box in
op_atat log2
Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_set.size).
Definition set_update {A B : Type}
(key : A) (_presence : B)
(set : Tezos_raw_protocol_alpha.Script_typed_ir.set A)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_starat (set_access key set) (alloc_cost 3).
End Legacy.
Module Interpreter.
Definition cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition nop : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := free.
Definition stack_op : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition push : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition wrap : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition variant_no_data
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := atomic_step_cost 10.
Definition branch : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition pair : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition pair_access : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition cons : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition loop_size : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 5.
Definition loop_cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition loop_iter : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 20.
Definition loop_map : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 30.
Definition empty_set : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition set_to_list {elt : Type}
(Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let Box := projT2 Box in
atomic_step_cost
(op_star Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_set.size)
20).
Definition set_mem {elt : Type}
(elt : elt) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let Box := projT2 Box in
let elt_bytes :=
size_of_comparable
Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_set.elt_ty) elt
in
atomic_step_cost
(op_star (op_plus 1 (op_div elt_bytes 82))
(log2 Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_set.size))).
Definition set_update {elt : Type} (elt : elt) (function_parameter : bool)
: (Tezos_raw_protocol_alpha.Script_typed_ir.set elt) ->
Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let '_ := function_parameter in
fun Box =>
let Box := projT2 Box in
let elt_bytes :=
size_of_comparable
Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_set.elt_ty) elt
in
atomic_step_cost
(op_star (op_plus 1 (op_div elt_bytes 82))
(log2 Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_set.size))).
Definition set_size : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition empty_map : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition map_to_list {key value : Type}
(Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let Box := projT2 Box in
let size :=
snd Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_map.boxed) in
atomic_step_cost (op_star size 20).
Definition map_access {key value : Type}
(key : key) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let Box := projT2 Box in
let map_card :=
snd Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_map.boxed) in
let key_bytes :=
size_of_comparable
Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_map.key_ty) key
in
atomic_step_cost
(op_star (op_plus 1 (op_div key_bytes 70)) (log2 map_card)).
Definition map_mem {A B : Type}
: A ->
(Tezos_raw_protocol_alpha.Script_typed_ir.map A B) ->
Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := map_access.
Definition map_get {A B : Type}
: A ->
(Tezos_raw_protocol_alpha.Script_typed_ir.map A B) ->
Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := map_access.
Definition map_update {key value : Type}
(key : key) (_value : option value)
(Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let Box := projT2 Box in
let map_card :=
snd Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_map.boxed) in
let key_bytes :=
size_of_comparable
Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_map.key_ty) key
in
atomic_step_cost
(op_star (op_plus 1 (op_div key_bytes 38)) (log2 map_card)).
Definition map_size : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition add_timestamp {a : Type}
(t1 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
(t2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num a)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let bytes1 := timestamp_bytes t1 in
let bytes2 := int_bytes t2 in
atomic_step_cost
(op_plus 51
(op_div
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
bytes1 bytes2) 62)).
Definition sub_timestamp {A : Type}
: Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t ->
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A) ->
Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := add_timestamp.
Definition diff_timestamps
(t1 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
(t2 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let bytes1 := timestamp_bytes t1 in
let bytes2 := timestamp_bytes t2 in
atomic_step_cost
(op_plus 51
(op_div
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
bytes1 bytes2) 62)).
Fixpoint concat_loop {A : Type} (l : list A) (acc : Z) : Z :=
match l with
| [] => 30
| cons _ tl => concat_loop tl (op_plus acc 30)
end.
Definition concat_string {A : Type} (string_list : list A)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost (concat_loop string_list 0).
Definition slice_string (string_length : Z)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost (op_plus 40 (op_div string_length 70)).
Definition concat_bytes {A : Type} (bytes_list : list A)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost (concat_loop bytes_list 0).
Definition int64_op : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 61.
Definition z_to_int64 : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 20.
Definition int64_to_z : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 20.
Definition bool_binop {A B : Type} (function_parameter : A)
: B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
atomic_step_cost 10.
Definition bool_unop {A : Type} (function_parameter : A)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let '_ := function_parameter in
atomic_step_cost 10.
Definition abs {A : Type}
(int : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost (op_plus 61 (op_div (int_bytes Z) 70)).
Definition int {A : Type} (_int : A)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := free.
Definition neg {A : Type}
: (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A) ->
Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := abs.
Definition add {A B : Type}
(i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
(i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost
(op_plus 51
(op_div
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
(int_bytes i1) (int_bytes i2)) 62)).
Definition sub {A B : Type}
: (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A) ->
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B) ->
Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := add.
Definition mul {A B : Type}
(i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
(i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let bytes :=
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
(int_bytes i1) (int_bytes i2) in
atomic_step_cost (op_plus 51 (op_star (op_div string 6) (log2 string))).
Definition indic_lt
(x :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(y :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Z :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
x y then
1
else
0.
Definition div {A B : Type}
(i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
(i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let bytes1 := int_bytes i1 in
let bytes2 := int_bytes i2 in
let cost :=
op_star (op_star (indic_lt bytes2 bytes1) (op_minus bytes1 bytes2))
bytes2 in
atomic_step_cost (op_plus 51 (op_div cost 3151)).
Definition shift_left {A B : Type} (_i : A) (_shift_bits : B)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := atomic_step_cost 30.
Definition shift_right {A B : Type} (_i : A) (_shift_bits : B)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := atomic_step_cost 30.
Definition logor {A B : Type}
(i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
(i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let bytes1 := int_bytes i1 in
let bytes2 := int_bytes i2 in
atomic_step_cost
(op_plus 51
(op_div
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
bytes1 bytes2) 70)).
Definition logand {A B : Type}
(i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
(i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let bytes1 := int_bytes i1 in
let bytes2 := int_bytes i2 in
atomic_step_cost
(op_plus 51
(op_div
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
bytes1 bytes2) 70)).
Definition logxor {A B : Type}
: (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A) ->
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B) ->
Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := logor.
Definition lognot {A : Type}
(i : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost (op_plus 51 (op_div (int_bytes i) 20)).
Definition exec : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition compare_bool {A B : Type} (function_parameter : A)
: B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
atomic_step_cost 30.
Definition compare_string (s1 : string) (s2 : string)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let bytes1 := String.length s1 in
let bytes2 := String.length s2 in
atomic_step_cost
(op_plus 30
(op_div
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
bytes1 bytes2) 123)).
Definition compare_bytes
(b1 : Tezos_protocol_environment_alpha__Environment.MBytes.t)
(b2 : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let bytes1 := MBytes.length b1 in
let bytes2 := MBytes.length b2 in
atomic_step_cost
(op_plus 30
(op_div
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
bytes1 bytes2) 123)).
Definition compare_tez {A B : Type} (function_parameter : A)
: B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
atomic_step_cost 30.
Definition compare_zint {A B : Type}
(i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
(i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost
(op_plus 51
(op_div
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
(int_bytes i1) (int_bytes i2)) 82)).
Definition compare_key_hash {A B : Type} (function_parameter : A)
: B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
atomic_step_cost 92.
Definition compare_timestamp
(t1 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
(t2 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let bytes1 := timestamp_bytes t1 in
let bytes2 := timestamp_bytes t2 in
atomic_step_cost
(op_plus 51
(op_div
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
bytes1 bytes2) 82)).
Definition compare_address {A B : Type} (function_parameter : A)
: B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
atomic_step_cost 92.
Definition compare_res : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 30.
Definition unpack_failed
(bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let len := MBytes.length string in
op_plusat (op_starat len (alloc_mbytes_cost 1))
(op_starat len
(op_starat (log2 len) (op_plusat (alloc_cost 3) (step_cost 1)))).
Definition address : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition contract : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
step_cost 10000.
Definition transfer : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
step_cost 10.
Definition create_account
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := step_cost 10.
Definition create_contract
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := step_cost 10.
Definition implicit_account
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := step_cost 10.
Definition set_delegate : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (step_cost 10) (write_bytes_cost (Z.of_int 32)).
Definition balance : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition now : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition check_signature_secp256k1 (bytes : Z)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost (op_plus 10342 (op_div string 5)).
Definition check_signature_ed25519 (bytes : Z)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost (op_plus 36864 (op_div string 5)).
Definition check_signature_p256 (bytes : Z)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost (op_plus 36864 (op_div string 5)).
Definition check_signature
(pkey : Tezos_protocol_environment_alpha__Environment.Signature.public_key)
(bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
match pkey with
| Tezos_protocol_environment_alpha__Environment.Signature.Ed25519 _ =>
check_signature_ed25519 (MBytes.length string)
| Tezos_protocol_environment_alpha__Environment.Signature.Secp256k1 _ =>
check_signature_secp256k1 (MBytes.length string)
| Tezos_protocol_environment_alpha__Environment.Signature.P256 _ =>
check_signature_p256 (MBytes.length string)
end.
Definition hash_key : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 30.
Definition hash_blake2b
(b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost (op_plus 102 (op_div (MBytes.length b) 5)).
Definition hash_sha256
(b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost (op_plus 409 (MBytes.length b)).
Definition hash_sha512
(b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
let bytes := MBytes.length b in
atomic_step_cost (op_plus 409 (op_plus (lsr string 1) (lsr string 4))).
Definition steps_to_quota
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := atomic_step_cost 10.
Definition source : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition self : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition amount : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost 10.
Definition chain_id : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
step_cost 1.
Definition stack_n_op (n : Z)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
atomic_step_cost
(op_plus 20 (op_plus (op_plus (lsr n 1) (lsr n 2)) (lsr n 4))).
Definition apply : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (alloc_cost 8) (step_cost 1).
Fixpoint compare {a s : Type}
(ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a s)
(x : a) (y : a) : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
match ty with
| Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key _ => compare_bool x y
| Tezos_raw_protocol_alpha.Script_typed_ir.String_key _ =>
compare_string x y
| Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key _ =>
compare_bytes x y
| Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key _ => compare_tez x y
| Tezos_raw_protocol_alpha.Script_typed_ir.Int_key _ => compare_zint x y
| Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key _ => compare_zint x y
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key _ =>
compare_key_hash x y
| Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key _ =>
compare_timestamp x y
| Tezos_raw_protocol_alpha.Script_typed_ir.Address_key _ =>
compare_address x y
| Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key (tl, _) (tr, _) _ =>
in
op_plusat (compare tl xl yl) (compare tr xr yr)
end.
End Interpreter.
Module Typechecking.
Definition cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
step_cost 1.
Definition bool : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := free.
Definition unit : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := free.
Definition string : Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
string.
Definition bytes : Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
string.
Definition z
: Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := Legacy.zint.
Definition int_of_string (str : string)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_atat alloc_cost (Pervasives.op_div (String.length str) 5).
Definition tez : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (step_cost 1) (alloc_cost 1).
Definition string_timestamp
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (step_cost 3) (alloc_cost 3).
Definition key : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (step_cost 3) (alloc_cost 3).
Definition key_hash : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (step_cost 1) (alloc_cost 1).
Definition signature : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (step_cost 1) (alloc_cost 1).
Definition chain_id : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (step_cost 1) (alloc_cost 1).
Definition contract : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
step_cost 5.
Definition get_script : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (step_cost 20) (alloc_cost 5).
Definition contract_exists
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (step_cost 15) (alloc_cost 5).
Definition pair : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
alloc_cost 2.
Definition union : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
alloc_cost 1.
Definition lambda : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (alloc_cost 5) (step_cost 3).
Definition some : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
alloc_cost 1.
Definition none : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
alloc_cost 0.
Definition list_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (alloc_cost 2) (step_cost 1).
Definition set_element (size : Z)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_starat (log2 size) (op_plusat (alloc_cost 3) (step_cost 2)).
Definition map_element (size : Z)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_starat (log2 size) (op_plusat (alloc_cost 4) (step_cost 2)).
Definition primitive_type
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := alloc_cost 1.
Definition one_arg_type : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
alloc_cost 2.
Definition two_arg_type : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
alloc_cost 3.
Definition operation (b : Z)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := string b.
Definition type_ (nb_args : Z)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
alloc_cost (op_plus nb_args 1).
Definition instr {a b : Type}
(i : Tezos_raw_protocol_alpha.Script_typed_ir.instr b a)
: Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
op_plusat (alloc_cost 1)
match i with
| Tezos_raw_protocol_alpha.Script_typed_ir.Drop => alloc_cost 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Dup => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Swap => alloc_cost 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Const _ => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Cons_pair => alloc_cost 2
| Tezos_raw_protocol_alpha.Script_typed_ir.Car => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Cdr => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Cons_some => alloc_cost 2
| Tezos_raw_protocol_alpha.Script_typed_ir.Cons_none _ => alloc_cost 3
| Tezos_raw_protocol_alpha.Script_typed_ir.If_none _ _ => alloc_cost 2
| Tezos_raw_protocol_alpha.Script_typed_ir.Left => alloc_cost 3
| Tezos_raw_protocol_alpha.Script_typed_ir.Right => alloc_cost 3
| Tezos_raw_protocol_alpha.Script_typed_ir.If_left _ _ => alloc_cost 2
| Tezos_raw_protocol_alpha.Script_typed_ir.Cons_list => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Nil => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.If_cons _ _ => alloc_cost 2
| Tezos_raw_protocol_alpha.Script_typed_ir.List_map _ => alloc_cost 5
| Tezos_raw_protocol_alpha.Script_typed_ir.List_iter _ => alloc_cost 4
| Tezos_raw_protocol_alpha.Script_typed_ir.List_size => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Empty_set _ => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_iter _ => alloc_cost 4
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_mem => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_update => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_size => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Empty_map _ _ => alloc_cost 2
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_map _ => alloc_cost 5
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_iter _ => alloc_cost 4
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_mem => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_get => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_update => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_size => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Empty_big_map _ _ =>
alloc_cost 2
| Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_mem => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_get => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_update =>
alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string_pair =>
alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes_pair =>
alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Slice_string => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Slice_bytes => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.String_size => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_size => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Add_seconds_to_timestamp =>
alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Add_timestamp_to_seconds =>
alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Sub_timestamp_seconds =>
alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Diff_timestamps =>
alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Add_tez => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Sub_tez => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Mul_teznat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Mul_nattez => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_teznat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_tez => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Or => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.And => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Xor => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Not => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Is_nat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Neg_nat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Neg_int => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Abs_int => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Int_nat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Add_intint => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Add_intnat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Add_natint => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Add_natnat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Sub_int => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intint => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intnat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natint => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natnat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intint => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intnat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natint => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natnat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Lsl_nat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Lsr_nat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Or_nat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.And_nat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.And_int_nat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Xor_nat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Not_nat => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Not_int => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Seq _ _ => alloc_cost 8
| Tezos_raw_protocol_alpha.Script_typed_ir.If _ _ => alloc_cost 8
| Tezos_raw_protocol_alpha.Script_typed_ir.Loop _ => alloc_cost 4
| Tezos_raw_protocol_alpha.Script_typed_ir.Loop_left _ => alloc_cost 5
| Tezos_raw_protocol_alpha.Script_typed_ir.Dip _ => alloc_cost 4
| Tezos_raw_protocol_alpha.Script_typed_ir.Exec => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Apply _ => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Lambda _ => alloc_cost 2
| Tezos_raw_protocol_alpha.Script_typed_ir.Failwith _ => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Nop => alloc_cost 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Compare _ => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Eq => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Neq => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Lt => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Gt => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Le => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Ge => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Address => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Contract _ _ => alloc_cost 2
| Tezos_raw_protocol_alpha.Script_typed_ir.Transfer_tokens =>
alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Create_account =>
alloc_cost 2
| Tezos_raw_protocol_alpha.Script_typed_ir.Implicit_account =>
alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract _ _ _ _ =>
alloc_cost 8
| Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract_2 _ _ _ _ =>
alloc_cost 7
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_delegate => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Now => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Balance => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Check_signature =>
alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Hash_key => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Pack _ => alloc_cost 2
| Tezos_raw_protocol_alpha.Script_typed_ir.Unpack _ => alloc_cost 2
| Tezos_raw_protocol_alpha.Script_typed_ir.Blake2b => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Sha256 => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Sha512 => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Steps_to_quota =>
alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Source => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Sender => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Self _ _ => alloc_cost 2
| Tezos_raw_protocol_alpha.Script_typed_ir.Amount => alloc_cost 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Dig n _ =>
op_starat n (alloc_cost 1)
| Tezos_raw_protocol_alpha.Script_typed_ir.Dug n _ =>
op_starat n (alloc_cost 1)
| Tezos_raw_protocol_alpha.Script_typed_ir.Dipn n _ _ =>
op_starat n (alloc_cost 1)
| Tezos_raw_protocol_alpha.Script_typed_ir.Dropn n _ =>
op_starat n (alloc_cost 1)
| Tezos_raw_protocol_alpha.Script_typed_ir.ChainId => alloc_cost 1
end.
End Typechecking.
Module Unparse.
Definition prim_cost
(l : Z) (annot : Tezos_raw_protocol_alpha.Alpha_context.Script.annot)
: Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
Script.prim_node_cost_nonrec_of_length l annot.
Definition seq_cost
: Z -> Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
Script.seq_node_cost_nonrec_of_length.
Definition string_cost (length : Z)
: Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
Script.string_node_cost_of_length length.
Definition cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
step_cost 1.
Definition bool : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
prim_cost 0 [].
Definition unit : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
prim_cost 0 [].
Definition string (s : string)
: Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
Script.string_node_cost s.
Definition bytes
(s : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
Script.bytes_node_cost s.
Definition z (i : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
Script.int_node_cost i.
Definition int {A : Type}
(i : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
: Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
Script.int_node_cost (Script_int.to_zint i).
Definition tez : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
Script.int_node_cost_of_numbits 60.
Definition timestamp
(x : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
: Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
op_pipegt (op_pipegt (Script_timestamp.to_zint x) Script_int.of_zint) Z.
Definition operation
(bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
Script.bytes_node_cost string.
Definition chain_id
(bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
Script.bytes_node_cost string.
Definition key : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
string_cost 54.
Definition key_hash : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
string_cost 36.
Definition signature : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
string_cost 128.
Definition contract : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
string_cost 36.
Definition pair : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
prim_cost 2 [].
Definition union : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
prim_cost 1 [].
Definition some : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
prim_cost 1 [].
Definition none : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
prim_cost 0 [].
Definition list_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
alloc_cost 2.
Definition set_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
alloc_cost 2.
Definition map_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
alloc_cost 2.
Definition one_arg_type
: Tezos_raw_protocol_alpha.Alpha_context.Script.annot ->
Tezos_raw_protocol_alpha__Alpha_context.Gas.cost := prim_cost 1.
Definition two_arg_type
: Tezos_raw_protocol_alpha.Alpha_context.Script.annot ->
Tezos_raw_protocol_alpha__Alpha_context.Gas.cost := prim_cost 2.
Definition set_to_list {A : Type}
: (Tezos_raw_protocol_alpha.Script_typed_ir.set A) ->
Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := Legacy.set_to_list.
Definition map_to_list {A B : Type}
: (Tezos_raw_protocol_alpha.Script_typed_ir.map A B) ->
Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := Legacy.map_to_list.
End Unparse.
End Cost_of.
src/proto_alpha/lib_protocol/michelson_v1_primitives.ml 11 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Micheline
type error += Unknown_primitive_name of string
type error += Invalid_case of string
type error +=
| Invalid_primitive_name of
string Micheline.canonical * Micheline.canonical_location
type prim =
| K_parameter
| K_storage
| K_code
| D_False
| D_Elt
| D_Left
| D_None
| D_Pair
| D_Right
| D_Some
| D_True
| D_Unit
| I_PACK
| I_UNPACK
| I_BLAKE2B
| I_SHA256
| I_SHA512
| I_ABS
| I_ADD
| I_AMOUNT
| I_AND
| I_BALANCE
| I_CAR
| I_CDR
| I_CHAIN_ID
| I_CHECK_SIGNATURE
| I_COMPARE
| I_CONCAT
| I_CONS
| I_CREATE_ACCOUNT
| I_CREATE_CONTRACT
| I_IMPLICIT_ACCOUNT
| I_DIP
| I_DROP
| I_DUP
| I_EDIV
| I_EMPTY_BIG_MAP
| I_EMPTY_MAP
| I_EMPTY_SET
| I_EQ
| I_EXEC
| I_APPLY
| I_FAILWITH
| I_GE
| I_GET
| I_GT
| I_HASH_KEY
| I_IF
| I_IF_CONS
| I_IF_LEFT
| I_IF_NONE
| I_INT
| I_LAMBDA
| I_LE
| I_LEFT
| I_LOOP
| I_LSL
| I_LSR
| I_LT
| I_MAP
| I_MEM
| I_MUL
| I_NEG
| I_NEQ
| I_NIL
| I_NONE
| I_NOT
| I_NOW
| I_OR
| I_PAIR
| I_PUSH
| I_RIGHT
| I_SIZE
| I_SOME
| I_SOURCE
| I_SENDER
| I_SELF
| I_SLICE
| I_STEPS_TO_QUOTA
| I_SUB
| I_SWAP
| I_TRANSFER_TOKENS
| I_SET_DELEGATE
| I_UNIT
| I_UPDATE
| I_XOR
| I_ITER
| I_LOOP_LEFT
| I_ADDRESS
| I_CONTRACT
| I_ISNAT
| I_CAST
| I_RENAME
| I_DIG
| I_DUG
| T_bool
| T_contract
| T_int
| T_key
| T_key_hash
| T_lambda
| T_list
| T_map
| T_big_map
| T_nat
| T_option
| T_or
| T_pair
| T_set
| T_signature
| T_string
| T_bytes
| T_mutez
| T_timestamp
| T_unit
| T_operation
| T_address
| T_chain_id
let valid_case name =
let is_lower = function '_' | 'a' .. 'z' -> true | _ -> false in
let is_upper = function '_' | 'A' .. 'Z' -> true | _ -> false in
let rec for_all a b f =
Compare.Int.(a > b) || (f a && for_all (a + 1) b f)
in
let len = String.length name in
Compare.Int.(len <> 0)
&& Compare.Char.(name.[0] <> '_')
&& ( (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_upper name.[i]))
|| (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i]))
|| (is_lower name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i]))
)
let string_of_prim = function
| K_parameter ->
"parameter"
| K_storage ->
"storage"
| K_code ->
"code"
| D_False ->
"False"
| D_Elt ->
"Elt"
| D_Left ->
"Left"
| D_None ->
"None"
| D_Pair ->
"Pair"
| D_Right ->
"Right"
| D_Some ->
"Some"
| D_True ->
"True"
| D_Unit ->
"Unit"
| I_PACK ->
"PACK"
| I_UNPACK ->
"UNPACK"
| I_BLAKE2B ->
"BLAKE2B"
| I_SHA256 ->
"SHA256"
| I_SHA512 ->
"SHA512"
| I_ABS ->
"ABS"
| I_ADD ->
"ADD"
| I_AMOUNT ->
"AMOUNT"
| I_AND ->
"AND"
| I_BALANCE ->
"BALANCE"
| I_CAR ->
"CAR"
| I_CDR ->
"CDR"
| I_CHAIN_ID ->
"CHAIN_ID"
| I_CHECK_SIGNATURE ->
"CHECK_SIGNATURE"
| I_COMPARE ->
"COMPARE"
| I_CONCAT ->
"CONCAT"
| I_CONS ->
"CONS"
| I_CREATE_ACCOUNT ->
"CREATE_ACCOUNT"
| I_CREATE_CONTRACT ->
"CREATE_CONTRACT"
| I_IMPLICIT_ACCOUNT ->
"IMPLICIT_ACCOUNT"
| I_DIP ->
"DIP"
| I_DROP ->
"DROP"
| I_DUP ->
"DUP"
| I_EDIV ->
"EDIV"
| I_EMPTY_BIG_MAP ->
"EMPTY_BIG_MAP"
| I_EMPTY_MAP ->
"EMPTY_MAP"
| I_EMPTY_SET ->
"EMPTY_SET"
| I_EQ ->
"EQ"
| I_EXEC ->
"EXEC"
| I_APPLY ->
"APPLY"
| I_FAILWITH ->
"FAILWITH"
| I_GE ->
"GE"
| I_GET ->
"GET"
| I_GT ->
"GT"
| I_HASH_KEY ->
"HASH_KEY"
| I_IF ->
"IF"
| I_IF_CONS ->
"IF_CONS"
| I_IF_LEFT ->
"IF_LEFT"
| I_IF_NONE ->
"IF_NONE"
| I_INT ->
"INT"
| I_LAMBDA ->
"LAMBDA"
| I_LE ->
"LE"
| I_LEFT ->
"LEFT"
| I_LOOP ->
"LOOP"
| I_LSL ->
"LSL"
| I_LSR ->
"LSR"
| I_LT ->
"LT"
| I_MAP ->
"MAP"
| I_MEM ->
"MEM"
| I_MUL ->
"MUL"
| I_NEG ->
"NEG"
| I_NEQ ->
"NEQ"
| I_NIL ->
"NIL"
| I_NONE ->
"NONE"
| I_NOT ->
"NOT"
| I_NOW ->
"NOW"
| I_OR ->
"OR"
| I_PAIR ->
"PAIR"
| I_PUSH ->
"PUSH"
| I_RIGHT ->
"RIGHT"
| I_SIZE ->
"SIZE"
| I_SOME ->
"SOME"
| I_SOURCE ->
"SOURCE"
| I_SENDER ->
"SENDER"
| I_SELF ->
"SELF"
| I_SLICE ->
"SLICE"
| I_STEPS_TO_QUOTA ->
"STEPS_TO_QUOTA"
| I_SUB ->
"SUB"
| I_SWAP ->
"SWAP"
| I_TRANSFER_TOKENS ->
"TRANSFER_TOKENS"
| I_SET_DELEGATE ->
"SET_DELEGATE"
| I_UNIT ->
"UNIT"
| I_UPDATE ->
"UPDATE"
| I_XOR ->
"XOR"
| I_ITER ->
"ITER"
| I_LOOP_LEFT ->
"LOOP_LEFT"
| I_ADDRESS ->
"ADDRESS"
| I_CONTRACT ->
"CONTRACT"
| I_ISNAT ->
"ISNAT"
| I_CAST ->
"CAST"
| I_RENAME ->
"RENAME"
| I_DIG ->
"DIG"
| I_DUG ->
"DUG"
| T_bool ->
"bool"
| T_contract ->
"contract"
| T_int ->
"int"
| T_key ->
"key"
| T_key_hash ->
"key_hash"
| T_lambda ->
"lambda"
| T_list ->
"list"
| T_map ->
"map"
| T_big_map ->
"big_map"
| T_nat ->
"nat"
| T_option ->
"option"
| T_or ->
"or"
| T_pair ->
"pair"
| T_set ->
"set"
| T_signature ->
"signature"
| T_string ->
"string"
| T_bytes ->
"bytes"
| T_mutez ->
"mutez"
| T_timestamp ->
"timestamp"
| T_unit ->
"unit"
| T_operation ->
"operation"
| T_address ->
"address"
| T_chain_id ->
"chain_id"
let prim_of_string = function
| "parameter" ->
ok K_parameter
| "storage" ->
ok K_storage
| "code" ->
ok K_code
| "False" ->
ok D_False
| "Elt" ->
ok D_Elt
| "Left" ->
ok D_Left
| "None" ->
ok D_None
| "Pair" ->
ok D_Pair
| "Right" ->
ok D_Right
| "Some" ->
ok D_Some
| "True" ->
ok D_True
| "Unit" ->
ok D_Unit
| "PACK" ->
ok I_PACK
| "UNPACK" ->
ok I_UNPACK
| "BLAKE2B" ->
ok I_BLAKE2B
| "SHA256" ->
ok I_SHA256
| "SHA512" ->
ok I_SHA512
| "ABS" ->
ok I_ABS
| "ADD" ->
ok I_ADD
| "AMOUNT" ->
ok I_AMOUNT
| "AND" ->
ok I_AND
| "BALANCE" ->
ok I_BALANCE
| "CAR" ->
ok I_CAR
| "CDR" ->
ok I_CDR
| "CHAIN_ID" ->
ok I_CHAIN_ID
| "CHECK_SIGNATURE" ->
ok I_CHECK_SIGNATURE
| "COMPARE" ->
ok I_COMPARE
| "CONCAT" ->
ok I_CONCAT
| "CONS" ->
ok I_CONS
| "CREATE_ACCOUNT" ->
ok I_CREATE_ACCOUNT
| "CREATE_CONTRACT" ->
ok I_CREATE_CONTRACT
| "IMPLICIT_ACCOUNT" ->
ok I_IMPLICIT_ACCOUNT
| "DIP" ->
ok I_DIP
| "DROP" ->
ok I_DROP
| "DUP" ->
ok I_DUP
| "EDIV" ->
ok I_EDIV
| "EMPTY_BIG_MAP" ->
ok I_EMPTY_BIG_MAP
| "EMPTY_MAP" ->
ok I_EMPTY_MAP
| "EMPTY_SET" ->
ok I_EMPTY_SET
| "EQ" ->
ok I_EQ
| "EXEC" ->
ok I_EXEC
| "APPLY" ->
ok I_APPLY
| "FAILWITH" ->
ok I_FAILWITH
| "GE" ->
ok I_GE
| "GET" ->
ok I_GET
| "GT" ->
ok I_GT
| "HASH_KEY" ->
ok I_HASH_KEY
| "IF" ->
ok I_IF
| "IF_CONS" ->
ok I_IF_CONS
| "IF_LEFT" ->
ok I_IF_LEFT
| "IF_NONE" ->
ok I_IF_NONE
| "INT" ->
ok I_INT
| "LAMBDA" ->
ok I_LAMBDA
| "LE" ->
ok I_LE
| "LEFT" ->
ok I_LEFT
| "LOOP" ->
ok I_LOOP
| "LSL" ->
ok I_LSL
| "LSR" ->
ok I_LSR
| "LT" ->
ok I_LT
| "MAP" ->
ok I_MAP
| "MEM" ->
ok I_MEM
| "MUL" ->
ok I_MUL
| "NEG" ->
ok I_NEG
| "NEQ" ->
ok I_NEQ
| "NIL" ->
ok I_NIL
| "NONE" ->
ok I_NONE
| "NOT" ->
ok I_NOT
| "NOW" ->
ok I_NOW
| "OR" ->
ok I_OR
| "PAIR" ->
ok I_PAIR
| "PUSH" ->
ok I_PUSH
| "RIGHT" ->
ok I_RIGHT
| "SIZE" ->
ok I_SIZE
| "SOME" ->
ok I_SOME
| "SOURCE" ->
ok I_SOURCE
| "SENDER" ->
ok I_SENDER
| "SELF" ->
ok I_SELF
| "SLICE" ->
ok I_SLICE
| "STEPS_TO_QUOTA" ->
ok I_STEPS_TO_QUOTA
| "SUB" ->
ok I_SUB
| "SWAP" ->
ok I_SWAP
| "TRANSFER_TOKENS" ->
ok I_TRANSFER_TOKENS
| "SET_DELEGATE" ->
ok I_SET_DELEGATE
| "UNIT" ->
ok I_UNIT
| "UPDATE" ->
ok I_UPDATE
| "XOR" ->
ok I_XOR
| "ITER" ->
ok I_ITER
| "LOOP_LEFT" ->
ok I_LOOP_LEFT
| "ADDRESS" ->
ok I_ADDRESS
| "CONTRACT" ->
ok I_CONTRACT
| "ISNAT" ->
ok I_ISNAT
| "CAST" ->
ok I_CAST
| "RENAME" ->
ok I_RENAME
| "DIG" ->
ok I_DIG
| "DUG" ->
ok I_DUG
| "bool" ->
ok T_bool
| "contract" ->
ok T_contract
| "int" ->
ok T_int
| "key" ->
ok T_key
| "key_hash" ->
ok T_key_hash
| "lambda" ->
ok T_lambda
| "list" ->
ok T_list
| "map" ->
ok T_map
| "big_map" ->
ok T_big_map
| "nat" ->
ok T_nat
| "option" ->
ok T_option
| "or" ->
ok T_or
| "pair" ->
ok T_pair
| "set" ->
ok T_set
| "signature" ->
ok T_signature
| "string" ->
ok T_string
| "bytes" ->
ok T_bytes
| "mutez" ->
ok T_mutez
| "timestamp" ->
ok T_timestamp
| "unit" ->
ok T_unit
| "operation" ->
ok T_operation
| "address" ->
ok T_address
| "chain_id" ->
ok T_chain_id
| n ->
if valid_case n then error (Unknown_primitive_name n)
else error (Invalid_case n)
let prims_of_strings expr =
let rec convert = function
| (Int _ | String _ | Bytes _) as expr ->
ok expr
| Prim (loc, prim, args, annot) ->
Error_monad.record_trace
(Invalid_primitive_name (expr, loc))
(prim_of_string prim)
>>? fun prim ->
List.fold_left
(fun acc arg ->
acc >>? fun args -> convert arg >>? fun arg -> ok (arg :: args))
(ok [])
args
>>? fun args -> ok (Prim (0, prim, List.rev args, annot))
| Seq (_, args) ->
List.fold_left
(fun acc arg ->
acc >>? fun args -> convert arg >>? fun arg -> ok (arg :: args))
(ok [])
args
>>? fun args -> ok (Seq (0, List.rev args))
in
convert (root expr) >>? fun expr -> ok (strip_locations expr)
let strings_of_prims expr =
let rec convert = function
| (Int _ | String _ | Bytes _) as expr ->
expr
| Prim (_, prim, args, annot) ->
let prim = string_of_prim prim in
let args = List.map convert args in
Prim (0, prim, args, annot)
| Seq (_, args) ->
let args = List.map convert args in
Seq (0, args)
in
strip_locations (convert (root expr))
let prim_encoding =
let open Data_encoding in
def "michelson.v1.primitives"
@@ string_enum
[ (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("parameter", K_parameter);
("storage", K_storage);
("code", K_code);
("False", D_False);
("Elt", D_Elt);
("Left", D_Left);
("None", D_None);
("Pair", D_Pair);
("Right", D_Right);
("Some", D_Some);
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("True", D_True);
("Unit", D_Unit);
("PACK", I_PACK);
("UNPACK", I_UNPACK);
("BLAKE2B", I_BLAKE2B);
("SHA256", I_SHA256);
("SHA512", I_SHA512);
("ABS", I_ABS);
("ADD", I_ADD);
("AMOUNT", I_AMOUNT);
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("AND", I_AND);
("BALANCE", I_BALANCE);
("CAR", I_CAR);
("CDR", I_CDR);
("CHECK_SIGNATURE", I_CHECK_SIGNATURE);
("COMPARE", I_COMPARE);
("CONCAT", I_CONCAT);
("CONS", I_CONS);
("CREATE_ACCOUNT", I_CREATE_ACCOUNT);
("CREATE_CONTRACT", I_CREATE_CONTRACT);
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT);
("DIP", I_DIP);
("DROP", I_DROP);
("DUP", I_DUP);
("EDIV", I_EDIV);
("EMPTY_MAP", I_EMPTY_MAP);
("EMPTY_SET", I_EMPTY_SET);
("EQ", I_EQ);
("EXEC", I_EXEC);
("FAILWITH", I_FAILWITH);
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("GE", I_GE);
("GET", I_GET);
("GT", I_GT);
("HASH_KEY", I_HASH_KEY);
("IF", I_IF);
("IF_CONS", I_IF_CONS);
("IF_LEFT", I_IF_LEFT);
("IF_NONE", I_IF_NONE);
("INT", I_INT);
("LAMBDA", I_LAMBDA);
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("LE", I_LE);
("LEFT", I_LEFT);
("LOOP", I_LOOP);
("LSL", I_LSL);
("LSR", I_LSR);
("LT", I_LT);
("MAP", I_MAP);
("MEM", I_MEM);
("MUL", I_MUL);
("NEG", I_NEG);
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("NEQ", I_NEQ);
("NIL", I_NIL);
("NONE", I_NONE);
("NOT", I_NOT);
("NOW", I_NOW);
("OR", I_OR);
("PAIR", I_PAIR);
("PUSH", I_PUSH);
("RIGHT", I_RIGHT);
("SIZE", I_SIZE);
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("SOME", I_SOME);
("SOURCE", I_SOURCE);
("SENDER", I_SENDER);
("SELF", I_SELF);
("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA);
("SUB", I_SUB);
("SWAP", I_SWAP);
("TRANSFER_TOKENS", I_TRANSFER_TOKENS);
("SET_DELEGATE", I_SET_DELEGATE);
("UNIT", I_UNIT);
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("UPDATE", I_UPDATE);
("XOR", I_XOR);
("ITER", I_ITER);
("LOOP_LEFT", I_LOOP_LEFT);
("ADDRESS", I_ADDRESS);
("CONTRACT", I_CONTRACT);
("ISNAT", I_ISNAT);
("CAST", I_CAST);
("RENAME", I_RENAME);
("bool", T_bool);
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("contract", T_contract);
("int", T_int);
("key", T_key);
("key_hash", T_key_hash);
("lambda", T_lambda);
("list", T_list);
("map", T_map);
("big_map", T_big_map);
("nat", T_nat);
("option", T_option);
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("or", T_or);
("pair", T_pair);
("set", T_set);
("signature", T_signature);
("string", T_string);
("bytes", T_bytes);
("mutez", T_mutez);
("timestamp", T_timestamp);
("unit", T_unit);
("operation", T_operation);
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("address", T_address);
(* Alpha_002 addition *)
("SLICE", I_SLICE);
(* Alpha_005 addition *)
("DIG", I_DIG);
("DUG", I_DUG);
("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP);
("APPLY", I_APPLY);
("chain_id", T_chain_id);
("CHAIN_ID", I_CHAIN_ID)
(* New instructions must be added here, for backward compatibility of the encoding. *)
]
let () =
register_error_kind
`Permanent
~id:"michelson_v1.unknown_primitive_name"
~title:"Unknown primitive name"
~description:"In a script or data expression, a primitive was unknown."
~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s." n)
Data_encoding.(obj1 (req "wrong_primitive_name" string))
(function Unknown_primitive_name got -> Some got | _ -> None)
(fun got -> Unknown_primitive_name got) ;
register_error_kind
`Permanent
~id:"michelson_v1.invalid_primitive_name_case"
~title:"Invalid primitive name case"
~description:
"In a script or data expression, a primitive name is neither uppercase, \
lowercase or capitalized."
~pp:(fun ppf n -> Format.fprintf ppf "Primitive %s has invalid case." n)
Data_encoding.(obj1 (req "wrong_primitive_name" string))
(function Invalid_case name -> Some name | _ -> None)
(fun name -> Invalid_case name) ;
register_error_kind
`Permanent
~id:"michelson_v1.invalid_primitive_name"
~title:"Invalid primitive name"
~description:
"In a script or data expression, a primitive name is unknown or has a \
wrong case."
~pp:(fun ppf _ -> Format.fprintf ppf "Invalid primitive.")
Data_encoding.(
obj2
(req
"expression"
(Micheline.canonical_encoding ~variant:"generic" string))
(req "location" Micheline.canonical_location_encoding))
(function
| Invalid_primitive_name (expr, loc) -> Some (expr, loc) | _ -> None)
(fun (expr, loc) -> Invalid_primitive_name (expr, loc))
src/proto_alpha/lib_protocol/michelson_v1_primitives.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Micheline.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Inductive prim : Type :=
| K_parameter : prim
| K_storage : prim
| K_code : prim
| D_False : prim
| D_Elt : prim
| D_Left : prim
| D_None : prim
| D_Pair : prim
| D_Right : prim
| D_Some : prim
| D_True : prim
| D_Unit : prim
| I_PACK : prim
| I_UNPACK : prim
| I_BLAKE2B : prim
| I_SHA256 : prim
| I_SHA512 : prim
| I_ABS : prim
| I_ADD : prim
| I_AMOUNT : prim
| I_AND : prim
| I_BALANCE : prim
| I_CAR : prim
| I_CDR : prim
| I_CHAIN_ID : prim
| I_CHECK_SIGNATURE : prim
| I_COMPARE : prim
| I_CONCAT : prim
| I_CONS : prim
| I_CREATE_ACCOUNT : prim
| I_CREATE_CONTRACT : prim
| I_IMPLICIT_ACCOUNT : prim
| I_DIP : prim
| I_DROP : prim
| I_DUP : prim
| I_EDIV : prim
| I_EMPTY_BIG_MAP : prim
| I_EMPTY_MAP : prim
| I_EMPTY_SET : prim
| I_EQ : prim
| I_EXEC : prim
| I_APPLY : prim
| I_FAILWITH : prim
| I_GE : prim
| I_GET : prim
| I_GT : prim
| I_HASH_KEY : prim
| I_IF : prim
| I_IF_CONS : prim
| I_IF_LEFT : prim
| I_IF_NONE : prim
| I_INT : prim
| I_LAMBDA : prim
| I_LE : prim
| I_LEFT : prim
| I_LOOP : prim
| I_LSL : prim
| I_LSR : prim
| I_LT : prim
| I_MAP : prim
| I_MEM : prim
| I_MUL : prim
| I_NEG : prim
| I_NEQ : prim
| I_NIL : prim
| I_NONE : prim
| I_NOT : prim
| I_NOW : prim
| I_OR : prim
| I_PAIR : prim
| I_PUSH : prim
| I_RIGHT : prim
| I_SIZE : prim
| I_SOME : prim
| I_SOURCE : prim
| I_SENDER : prim
| I_SELF : prim
| I_SLICE : prim
| I_STEPS_TO_QUOTA : prim
| I_SUB : prim
| I_SWAP : prim
| I_TRANSFER_TOKENS : prim
| I_SET_DELEGATE : prim
| I_UNIT : prim
| I_UPDATE : prim
| I_XOR : prim
| I_ITER : prim
| I_LOOP_LEFT : prim
| I_ADDRESS : prim
| I_CONTRACT : prim
| I_ISNAT : prim
| I_CAST : prim
| I_RENAME : prim
| I_DIG : prim
| I_DUG : prim
| T_bool : prim
| T_contract : prim
| T_int : prim
| T_key : prim
| T_key_hash : prim
| T_lambda : prim
| T_list : prim
| T_map : prim
| T_big_map : prim
| T_nat : prim
| T_option : prim
| T_or : prim
| T_pair : prim
| T_set : prim
| T_signature : prim
| T_string : prim
| T_bytes : prim
| T_mutez : prim
| T_timestamp : prim
| T_unit : prim
| T_operation : prim
| T_address : prim
| T_chain_id : prim.
Definition valid_case (name : string) : bool :=
let is_lower (function_parameter : ascii) : bool :=
match function_parameter with
|
"_" % char |
"a" % char |
"b" % char |
"c" % char |
"d" % char |
"e" % char |
"f" % char |
"g" % char |
"h" % char |
"i" % char |
"j" % char |
"k" % char |
"l" % char |
"m" % char |
"n" % char |
"o" % char |
"p" % char |
"q" % char |
"r" % char |
"s" % char |
"t" % char |
"u" % char |
"v" % char |
"w" % char |
"x" % char |
"y" % char | "z" % char
=> true
| _ => false
end in
let is_upper (function_parameter : ascii) : bool :=
match function_parameter with
|
"_" % char |
"A" % char |
"B" % char |
"C" % char |
"D" % char |
"E" % char |
"F" % char |
"G" % char |
"H" % char |
"I" % char |
"J" % char |
"K" % char |
"L" % char |
"M" % char |
"N" % char |
"O" % char |
"P" % char |
"Q" % char |
"R" % char |
"S" % char |
"T" % char |
"U" % char |
"V" % char |
"W" % char |
"X" % char |
"Y" % char | "Z" % char
=> true
| _ => false
end in
let fix for_all
(a :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(b :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(f :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
-> bool) : bool :=
op_pipepipe
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
a b) (op_andand (f a) (for_all (op_plus a 1) b f)) in
let len := String.length name in
op_andand
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt)
len 0)
(op_andand
(Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt)
(String.get name 0) "_" % char)
(op_pipepipe
(op_andand (is_upper (String.get name 0))
(for_all 1 (op_minus len 1) (fun i => is_upper (String.get name i))))
(op_pipepipe
(op_andand (is_upper (String.get name 0))
(for_all 1 (op_minus len 1) (fun i => is_lower (String.get name i))))
(op_andand (is_lower (String.get name 0))
(for_all 1 (op_minus len 1) (fun i => is_lower (String.get name i))))))).
Definition string_of_prim (function_parameter : prim) : string :=
match function_parameter with
| K_parameter => "parameter" % string
| K_storage => "storage" % string
| K_code => "code" % string
| D_False => "False" % string
| D_Elt => "Elt" % string
| D_Left => "Left" % string
| D_None => "None" % string
| D_Pair => "Pair" % string
| D_Right => "Right" % string
| D_Some => "Some" % string
| D_True => "True" % string
| D_Unit => "Unit" % string
| I_PACK => "PACK" % string
| I_UNPACK => "UNPACK" % string
| I_BLAKE2B => "BLAKE2B" % string
| I_SHA256 => "SHA256" % string
| I_SHA512 => "SHA512" % string
| I_ABS => "ABS" % string
| I_ADD => "ADD" % string
| I_AMOUNT => "AMOUNT" % string
| I_AND => "AND" % string
| I_BALANCE => "BALANCE" % string
| I_CAR => "CAR" % string
| I_CDR => "CDR" % string
| I_CHAIN_ID => "CHAIN_ID" % string
| I_CHECK_SIGNATURE => "CHECK_SIGNATURE" % string
| I_COMPARE => "COMPARE" % string
| I_CONCAT => "CONCAT" % string
| I_CONS => "CONS" % string
| I_CREATE_ACCOUNT => "CREATE_ACCOUNT" % string
| I_CREATE_CONTRACT => "CREATE_CONTRACT" % string
| I_IMPLICIT_ACCOUNT => "IMPLICIT_ACCOUNT" % string
| I_DIP => "DIP" % string
| I_DROP => "DROP" % string
| I_DUP => "DUP" % string
| I_EDIV => "EDIV" % string
| I_EMPTY_BIG_MAP => "EMPTY_BIG_MAP" % string
| I_EMPTY_MAP => "EMPTY_MAP" % string
| I_EMPTY_SET => "EMPTY_SET" % string
| I_EQ => "EQ" % string
| I_EXEC => "EXEC" % string
| I_APPLY => "APPLY" % string
| I_FAILWITH => "FAILWITH" % string
| I_GE => "GE" % string
| I_GET => "GET" % string
| I_GT => "GT" % string
| I_HASH_KEY => "HASH_KEY" % string
| I_IF => "IF" % string
| I_IF_CONS => "IF_CONS" % string
| I_IF_LEFT => "IF_LEFT" % string
| I_IF_NONE => "IF_NONE" % string
| I_INT => "INT" % string
| I_LAMBDA => "LAMBDA" % string
| I_LE => "LE" % string
| I_LEFT => "LEFT" % string
| I_LOOP => "LOOP" % string
| I_LSL => "LSL" % string
| I_LSR => "LSR" % string
| I_LT => "LT" % string
| I_MAP => "MAP" % string
| I_MEM => "MEM" % string
| I_MUL => "MUL" % string
| I_NEG => "NEG" % string
| I_NEQ => "NEQ" % string
| I_NIL => "NIL" % string
| I_NONE => "NONE" % string
| I_NOT => "NOT" % string
| I_NOW => "NOW" % string
| I_OR => "OR" % string
| I_PAIR => "PAIR" % string
| I_PUSH => "PUSH" % string
| I_RIGHT => "RIGHT" % string
| I_SIZE => "SIZE" % string
| I_SOME => "SOME" % string
| I_SOURCE => "SOURCE" % string
| I_SENDER => "SENDER" % string
| I_SELF => "SELF" % string
| I_SLICE => "SLICE" % string
| I_STEPS_TO_QUOTA => "STEPS_TO_QUOTA" % string
| I_SUB => "SUB" % string
| I_SWAP => "SWAP" % string
| I_TRANSFER_TOKENS => "TRANSFER_TOKENS" % string
| I_SET_DELEGATE => "SET_DELEGATE" % string
| I_UNIT => "UNIT" % string
| I_UPDATE => "UPDATE" % string
| I_XOR => "XOR" % string
| I_ITER => "ITER" % string
| I_LOOP_LEFT => "LOOP_LEFT" % string
| I_ADDRESS => "ADDRESS" % string
| I_CONTRACT => "CONTRACT" % string
| I_ISNAT => "ISNAT" % string
| I_CAST => "CAST" % string
| I_RENAME => "RENAME" % string
| I_DIG => "DIG" % string
| I_DUG => "DUG" % string
| T_bool => "bool" % string
| T_contract => "contract" % string
| T_int => "int" % string
| T_key => "key" % string
| T_key_hash => "key_hash" % string
| T_lambda => "lambda" % string
| T_list => "list" % string
| T_map => "map" % string
| T_big_map => "big_map" % string
| T_nat => "nat" % string
| T_option => "option" % string
| T_or => "or" % string
| T_pair => "pair" % string
| T_set => "set" % string
| T_signature => "signature" % string
| T_string => "string" % string
| T_bytes => "bytes" % string
| T_mutez => "mutez" % string
| T_timestamp => "timestamp" % string
| T_unit => "unit" % string
| T_operation => "operation" % string
| T_address => "address" % string
| T_chain_id => "chain_id" % string
end.
Definition prim_of_string (function_parameter : string)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult prim :=
match function_parameter with
| "parameter" % string => ok K_parameter
| "storage" % string => ok K_storage
| "code" % string => ok K_code
| "False" % string => ok D_False
| "Elt" % string => ok D_Elt
| "Left" % string => ok D_Left
| "None" % string => ok D_None
| "Pair" % string => ok D_Pair
| "Right" % string => ok D_Right
| "Some" % string => ok D_Some
| "True" % string => ok D_True
| "Unit" % string => ok D_Unit
| "PACK" % string => ok I_PACK
| "UNPACK" % string => ok I_UNPACK
| "BLAKE2B" % string => ok I_BLAKE2B
| "SHA256" % string => ok I_SHA256
| "SHA512" % string => ok I_SHA512
| "ABS" % string => ok I_ABS
| "ADD" % string => ok I_ADD
| "AMOUNT" % string => ok I_AMOUNT
| "AND" % string => ok I_AND
| "BALANCE" % string => ok I_BALANCE
| "CAR" % string => ok I_CAR
| "CDR" % string => ok I_CDR
| "CHAIN_ID" % string => ok I_CHAIN_ID
| "CHECK_SIGNATURE" % string => ok I_CHECK_SIGNATURE
| "COMPARE" % string => ok I_COMPARE
| "CONCAT" % string => ok I_CONCAT
| "CONS" % string => ok I_CONS
| "CREATE_ACCOUNT" % string => ok I_CREATE_ACCOUNT
| "CREATE_CONTRACT" % string => ok I_CREATE_CONTRACT
| "IMPLICIT_ACCOUNT" % string => ok I_IMPLICIT_ACCOUNT
| "DIP" % string => ok I_DIP
| "DROP" % string => ok I_DROP
| "DUP" % string => ok I_DUP
| "EDIV" % string => ok I_EDIV
| "EMPTY_BIG_MAP" % string => ok I_EMPTY_BIG_MAP
| "EMPTY_MAP" % string => ok I_EMPTY_MAP
| "EMPTY_SET" % string => ok I_EMPTY_SET
| "EQ" % string => ok I_EQ
| "EXEC" % string => ok I_EXEC
| "APPLY" % string => ok I_APPLY
| "FAILWITH" % string => ok I_FAILWITH
| "GE" % string => ok I_GE
| "GET" % string => ok I_GET
| "GT" % string => ok I_GT
| "HASH_KEY" % string => ok I_HASH_KEY
| "IF" % string => ok I_IF
| "IF_CONS" % string => ok I_IF_CONS
| "IF_LEFT" % string => ok I_IF_LEFT
| "IF_NONE" % string => ok I_IF_NONE
| "INT" % string => ok I_INT
| "LAMBDA" % string => ok I_LAMBDA
| "LE" % string => ok I_LE
| "LEFT" % string => ok I_LEFT
| "LOOP" % string => ok I_LOOP
| "LSL" % string => ok I_LSL
| "LSR" % string => ok I_LSR
| "LT" % string => ok I_LT
| "MAP" % string => ok I_MAP
| "MEM" % string => ok I_MEM
| "MUL" % string => ok I_MUL
| "NEG" % string => ok I_NEG
| "NEQ" % string => ok I_NEQ
| "NIL" % string => ok I_NIL
| "NONE" % string => ok I_NONE
| "NOT" % string => ok I_NOT
| "NOW" % string => ok I_NOW
| "OR" % string => ok I_OR
| "PAIR" % string => ok I_PAIR
| "PUSH" % string => ok I_PUSH
| "RIGHT" % string => ok I_RIGHT
| "SIZE" % string => ok I_SIZE
| "SOME" % string => ok I_SOME
| "SOURCE" % string => ok I_SOURCE
| "SENDER" % string => ok I_SENDER
| "SELF" % string => ok I_SELF
| "SLICE" % string => ok I_SLICE
| "STEPS_TO_QUOTA" % string => ok I_STEPS_TO_QUOTA
| "SUB" % string => ok I_SUB
| "SWAP" % string => ok I_SWAP
| "TRANSFER_TOKENS" % string => ok I_TRANSFER_TOKENS
| "SET_DELEGATE" % string => ok I_SET_DELEGATE
| "UNIT" % string => ok I_UNIT
| "UPDATE" % string => ok I_UPDATE
| "XOR" % string => ok I_XOR
| "ITER" % string => ok I_ITER
| "LOOP_LEFT" % string => ok I_LOOP_LEFT
| "ADDRESS" % string => ok I_ADDRESS
| "CONTRACT" % string => ok I_CONTRACT
| "ISNAT" % string => ok I_ISNAT
| "CAST" % string => ok I_CAST
| "RENAME" % string => ok I_RENAME
| "DIG" % string => ok I_DIG
| "DUG" % string => ok I_DUG
| "bool" % string => ok T_bool
| "contract" % string => ok T_contract
| "int" % string => ok T_int
| "key" % string => ok T_key
| "key_hash" % string => ok T_key_hash
| "lambda" % string => ok T_lambda
| "list" % string => ok T_list
| "map" % string => ok T_map
| "big_map" % string => ok T_big_map
| "nat" % string => ok T_nat
| "option" % string => ok T_option
| "or" % string => ok T_or
| "pair" % string => ok T_pair
| "set" % string => ok T_set
| "signature" % string => ok T_signature
| "string" % string => ok T_string
| "bytes" % string => ok T_bytes
| "mutez" % string => ok T_mutez
| "timestamp" % string => ok T_timestamp
| "unit" % string => ok T_unit
| "operation" % string => ok T_operation
| "address" % string => ok T_address
| "chain_id" % string => ok T_chain_id
| n =>
if valid_case n then
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unknown_primitive_name
n)
else
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_case
n)
end.
Definition prims_of_strings
(expr :
Tezos_protocol_environment_alpha__Environment.Micheline.canonical string)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_protocol_environment_alpha__Environment.Micheline.canonical prim) :=
let fix convert
(function_parameter :
Tezos_protocol_environment_alpha__Environment.Micheline.node
Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location
string)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_protocol_environment_alpha__Environment.Micheline.node
Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location
prim) :=
match function_parameter with
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Int _ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.String _ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ _) as
expr => ok expr
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc prim args
annot =>
op_gtgtquestion
(Error_monad.record_trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive_name
expr loc) (prim_of_string prim))
(fun prim =>
op_gtgtquestion
(List.fold_left
(fun acc =>
fun arg =>
op_gtgtquestion acc
(fun args =>
op_gtgtquestion (convert arg)
(fun arg => ok (cons arg args)))) (ok []) args)
(fun args =>
ok
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
prim (List.rev args) annot)))
| Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ args =>
op_gtgtquestion
(List.fold_left
(fun acc =>
fun arg =>
op_gtgtquestion acc
(fun args =>
op_gtgtquestion (convert arg) (fun arg => ok (cons arg args))))
(ok []) args)
(fun args =>
ok
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq 0
(List.rev args)))
end in
op_gtgtquestion (convert (root expr)) (fun expr => ok (strip_locations expr)).
Definition strings_of_prims
(expr : Tezos_protocol_environment_alpha__Environment.Micheline.canonical prim)
: Tezos_protocol_environment_alpha__Environment.Micheline.canonical string :=
let fix convert
(function_parameter :
Tezos_protocol_environment_alpha__Environment.Micheline.node Z prim)
: Tezos_protocol_environment_alpha__Environment.Micheline.node Z string :=
match function_parameter with
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Int _ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.String _ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ _) as
expr => expr
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim _ prim args
annot =>
let prim := string_of_prim prim in
let args := List.map convert args in
Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0 prim args
annot
| Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ args =>
let args := List.map convert args in
Tezos_protocol_environment_alpha__Environment.Micheline.Seq 0 args
end in
strip_locations (convert (root expr)).
Definition prim_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding prim :=
op_atat
(let arg := def "michelson.v1.primitives" % string in
fun eta => arg None None eta)
(string_enum
(cons ("parameter" % string, K_parameter)
(cons ("storage" % string, K_storage)
(cons ("code" % string, K_code)
(cons ("False" % string, D_False)
(cons ("Elt" % string, D_Elt)
(cons ("Left" % string, D_Left)
(cons ("None" % string, D_None)
(cons ("Pair" % string, D_Pair)
(cons ("Right" % string, D_Right)
(cons ("Some" % string, D_Some)
(cons ("True" % string, D_True)
(cons ("Unit" % string, D_Unit)
(cons ("PACK" % string, I_PACK)
(cons ("UNPACK" % string, I_UNPACK)
(cons ("BLAKE2B" % string, I_BLAKE2B)
(cons ("SHA256" % string, I_SHA256)
(cons ("SHA512" % string, I_SHA512)
(cons ("ABS" % string, I_ABS)
(cons ("ADD" % string, I_ADD)
(cons ("AMOUNT" % string, I_AMOUNT)
(cons ("AND" % string, I_AND)
(cons
("BALANCE" % string, I_BALANCE)
(cons ("CAR" % string, I_CAR)
(cons
("CDR" % string, I_CDR)
(cons
("CHECK_SIGNATURE" %
string,
I_CHECK_SIGNATURE)
(cons
("COMPARE" % string,
I_COMPARE)
(cons
("CONCAT" % string,
I_CONCAT)
(cons
("CONS" % string,
I_CONS)
(cons
("CREATE_ACCOUNT"
% string,
I_CREATE_ACCOUNT)
(cons
("CREATE_CONTRACT"
% string,
I_CREATE_CONTRACT)
(cons
("IMPLICIT_ACCOUNT"
% string,
I_IMPLICIT_ACCOUNT)
(cons
("DIP" %
string,
I_DIP)
(cons
("DROP"
%
string,
I_DROP)
(cons
("DUP"
%
string,
I_DUP)
(cons
("EDIV"
%
string,
I_EDIV)
(cons
("EMPTY_MAP"
%
string,
I_EMPTY_MAP)
(cons
("EMPTY_SET"
%
string,
I_EMPTY_SET)
(cons
("EQ"
%
string,
I_EQ)
(cons
("EXEC"
%
string,
I_EXEC)
(cons
("FAILWITH"
%
string,
I_FAILWITH)
(cons
("GE"
%
string,
I_GE)
(cons
("GET"
%
string,
I_GET)
(cons
("GT"
%
string,
I_GT)
(cons
("HASH_KEY"
%
string,
I_HASH_KEY)
(cons
("IF"
%
string,
I_IF)
(cons
("IF_CONS"
%
string,
I_IF_CONS)
(cons
("IF_LEFT"
%
string,
I_IF_LEFT)
(cons
("IF_NONE"
%
string,
I_IF_NONE)
(cons
("INT"
%
string,
I_INT)
(cons
("LAMBDA"
%
string,
I_LAMBDA)
(cons
("LE"
%
string,
I_LE)
(cons
("LEFT"
%
string,
I_LEFT)
(cons
("LOOP"
%
string,
I_LOOP)
(cons
("LSL"
%
string,
I_LSL)
(cons
("LSR"
%
string,
I_LSR)
(cons
("LT"
%
string,
I_LT)
(cons
("MAP"
%
string,
I_MAP)
(cons
("MEM"
%
string,
I_MEM)
(cons
("MUL"
%
string,
I_MUL)
(cons
("NEG"
%
string,
I_NEG)
(cons
("NEQ"
%
string,
I_NEQ)
(cons
("NIL"
%
string,
I_NIL)
(cons
("NONE"
%
string,
I_NONE)
(cons
("NOT"
%
string,
I_NOT)
(cons
("NOW"
%
string,
I_NOW)
(cons
("OR"
%
string,
I_OR)
(cons
("PAIR"
%
string,
I_PAIR)
(cons
("PUSH"
%
string,
I_PUSH)
(cons
("RIGHT"
%
string,
I_RIGHT)
(cons
("SIZE"
%
string,
I_SIZE)
(cons
("SOME"
%
string,
I_SOME)
(cons
("SOURCE"
%
string,
I_SOURCE)
(cons
("SENDER"
%
string,
I_SENDER)
(cons
("SELF"
%
string,
I_SELF)
(cons
("STEPS_TO_QUOTA"
%
string,
I_STEPS_TO_QUOTA)
(cons
("SUB"
%
string,
I_SUB)
(cons
("SWAP"
%
string,
I_SWAP)
(cons
("TRANSFER_TOKENS"
%
string,
I_TRANSFER_TOKENS)
(cons
("SET_DELEGATE"
%
string,
I_SET_DELEGATE)
(cons
("UNIT"
%
string,
I_UNIT)
(cons
("UPDATE"
%
string,
I_UPDATE)
(cons
("XOR"
%
string,
I_XOR)
(cons
("ITER"
%
string,
I_ITER)
(cons
("LOOP_LEFT"
%
string,
I_LOOP_LEFT)
(cons
("ADDRESS"
%
string,
I_ADDRESS)
(cons
("CONTRACT"
%
string,
I_CONTRACT)
(cons
("ISNAT"
%
string,
I_ISNAT)
(cons
("CAST"
%
string,
I_CAST)
(cons
("RENAME"
%
string,
I_RENAME)
(cons
("bool"
%
string,
T_bool)
(cons
("contract"
%
string,
T_contract)
(cons
("int"
%
string,
T_int)
(cons
("key"
%
string,
T_key)
(cons
("key_hash"
%
string,
T_key_hash)
(cons
("lambda"
%
string,
T_lambda)
(cons
("list"
%
string,
T_list)
(cons
("map"
%
string,
T_map)
(cons
("big_map"
%
string,
T_big_map)
(cons
("nat"
%
string,
T_nat)
(cons
("option"
%
string,
T_option)
(cons
("or"
%
string,
T_or)
(cons
("pair"
%
string,
T_pair)
(cons
("set"
%
string,
T_set)
(cons
("signature"
%
string,
T_signature)
(cons
("string"
%
string,
T_string)
(cons
("bytes"
%
string,
T_bytes)
(cons
("mutez"
%
string,
T_mutez)
(cons
("timestamp"
%
string,
T_timestamp)
(cons
("unit"
%
string,
T_unit)
(cons
("operation"
%
string,
T_operation)
(cons
("address"
%
string,
T_address)
(cons
("SLICE"
%
string,
I_SLICE)
(cons
("DIG"
%
string,
I_DIG)
(cons
("DUG"
%
string,
I_DUG)
(cons
("EMPTY_BIG_MAP"
%
string,
I_EMPTY_BIG_MAP)
(cons
("APPLY"
%
string,
I_APPLY)
(cons
("chain_id"
%
string,
T_chain_id)
(cons
("CHAIN_ID"
%
string,
I_CHAIN_ID)
[]))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))).
src/proto_alpha/lib_protocol/misc.ml 32 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type 'a lazyt = unit -> 'a
type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt
type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t
let rec ( --> ) i j =
(* [i; i+1; ...; j] *)
if Compare.Int.(i > j) then [] else i :: (succ i --> j)
let rec ( ---> ) i j =
(* [i; i+1; ...; j] *)
if Compare.Int32.(i > j) then [] else i :: (Int32.succ i ---> j)
let split delim ?(limit = max_int) path =
let l = String.length path in
let rec do_slashes acc limit i =
if Compare.Int.(i >= l) then List.rev acc
else if Compare.Char.(path.[i] = delim) then do_slashes acc limit (i + 1)
else do_split acc limit i
and do_split acc limit i =
if Compare.Int.(limit <= 0) then
if Compare.Int.(i = l) then List.rev acc
else List.rev (String.sub path i (l - i) :: acc)
else do_component acc (pred limit) i i
and do_component acc limit i j =
if Compare.Int.(j >= l) then
if Compare.Int.(i = j) then List.rev acc
else List.rev (String.sub path i (j - i) :: acc)
else if Compare.Char.(path.[j] = delim) then
do_slashes (String.sub path i (j - i) :: acc) limit j
else do_component acc limit i (j + 1)
in
if Compare.Int.(limit > 0) then do_slashes [] limit 0 else [path]
let pp_print_paragraph ppf description =
Format.fprintf
ppf
"@[%a@]"
Format.(pp_print_list ~pp_sep:pp_print_space pp_print_string)
(split ' ' description)
let take n l =
let rec loop acc n = function
| xs when Compare.Int.(n <= 0) ->
Some (List.rev acc, xs)
| [] ->
None
| x :: xs ->
loop (x :: acc) (n - 1) xs
in
loop [] n l
let remove_prefix ~prefix s =
let x = String.length prefix in
let n = String.length s in
if Compare.Int.(n >= x) && Compare.String.(String.sub s 0 x = prefix) then
Some (String.sub s x (n - x))
else None
let rec remove_elem_from_list nb = function
| [] ->
[]
| l when Compare.Int.(nb <= 0) ->
l
| _ :: tl ->
remove_elem_from_list (nb - 1) tl
src/proto_alpha/lib_protocol/misc.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition lazyt (a : Type) := unit -> a.
Inductive lazy_list_t (a : Type) : Type :=
| LCons : a ->
(lazyt
(Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(lazy_list_t a)))) -> lazy_list_t a.
Arguments LCons {_}.
Definition lazy_list (a : Type) :=
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(lazy_list_t a)).
Fixpoint op_minusminusgt
(i :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(j :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: list
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
i j then
[]
else
cons i (op_minusminusgt (succ i) j).
Fixpoint op_minusminusminusgt
(i :
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(j :
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: list
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
i j then
[]
else
cons i (op_minusminusminusgt (Int32.succ i) j).
Definition split
(delim :
Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(op_staroptstar :
option
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: string -> list string :=
let limit :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => max_int
end in
fun path =>
let l := String.length path in
let fix do_slashes
(acc : list string) (limit :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(i :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: list string :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
i l then
List.rev acc
else
if
Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.get path i) delim then
do_slashes acc limit (op_plus i 1)
else
do_split acc limit i
with do_split
(acc : list string) (limit :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(i :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: list string :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
limit 0 then
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
i l then
List.rev acc
else
List.rev (cons (String.sub path i (op_minus l i)) acc)
else
do_component acc (pred limit) i i
with do_component
(acc : list string) (limit :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(i :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(j :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: list string :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
j l then
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
i j then
List.rev acc
else
List.rev (cons (String.sub path i (op_minus j i)) acc)
else
if
Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.get path j) delim then
do_slashes (cons (String.sub path i (op_minus j i)) acc) limit j
else
do_component acc limit i (op_plus j 1) in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
limit 0 then
do_slashes [] limit 0
else
cons path [].
Definition pp_print_paragraph
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
(description : string) : unit :=
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_gen
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Open_box
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format
"" % string))
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Alpha
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_lit
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Close_box
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
"@[%a@]" % string) (pp_print_list (Some pp_print_space) pp_print_string)
(split " " % char None description).
Definition take {A : Type}
(n :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(l : list A) : option ((list A) * (list A)) :=
let fix loop {B : Type}
(acc : list B) (n :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(function_parameter : list B) : option ((list B) * (list B)) :=
match function_parameter with
| xs => Some ((List.rev acc), xs)
| [] => None
| cons x xs => loop (cons x acc) (op_minus n 1) xs
end in
loop [] n l.
Definition remove_prefix
(prefix :
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(s : string) : option string :=
let x := String.length prefix in
let n := String.length s in
if
op_andand
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
n x)
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.sub s 0 x) prefix) then
Some (String.sub s x (op_minus n x))
else
None.
Fixpoint remove_elem_from_list {A : Type}
(nb :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(function_parameter : list A) : list A :=
match function_parameter with
| [] => []
| l => l
| cons _ tl => remove_elem_from_list (op_minus nb 1) tl
end.
src/proto_alpha/lib_protocol/nonce_hash.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* 32 *)
let nonce_hash = "\069\220\169" (* nce(53) *)
include Blake2B.Make
(Base58)
(struct
let name = "cycle_nonce"
let title = "A nonce hash"
let b58check_prefix = nonce_hash
let size = None
end)
let () = Base58.check_encoded_prefix b58check_encoding "nce" 53
src/proto_alpha/lib_protocol/nonce_hash.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. Definition nonce_hash : string := "Eܩ" % string. (* ❌ Structure item `include` not handled. *) include
src/proto_alpha/lib_protocol/nonce_storage.ml 13 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = Seed_repr.nonce
type nonce = t
let encoding = Seed_repr.nonce_encoding
type error +=
| Too_late_revelation
| Too_early_revelation
| Previously_revealed_nonce
| Unexpected_nonce
let () =
register_error_kind
`Branch
~id:"nonce.too_late_revelation"
~title:"Too late nonce revelation"
~description:"Nonce revelation happens too late"
~pp:(fun ppf () ->
Format.fprintf ppf "This nonce cannot be revealed anymore.")
Data_encoding.unit
(function Too_late_revelation -> Some () | _ -> None)
(fun () -> Too_late_revelation) ;
register_error_kind
`Temporary
~id:"nonce.too_early_revelation"
~title:"Too early nonce revelation"
~description:"Nonce revelation happens before cycle end"
~pp:(fun ppf () ->
Format.fprintf ppf "This nonce should not yet be revealed")
Data_encoding.unit
(function Too_early_revelation -> Some () | _ -> None)
(fun () -> Too_early_revelation) ;
register_error_kind
`Branch
~id:"nonce.previously_revealed"
~title:"Previously revealed nonce"
~description:"Duplicated revelation for a nonce."
~pp:(fun ppf () -> Format.fprintf ppf "This nonce was previously revealed")
Data_encoding.unit
(function Previously_revealed_nonce -> Some () | _ -> None)
(fun () -> Previously_revealed_nonce) ;
register_error_kind
`Branch
~id:"nonce.unexpected"
~title:"Unexpected nonce"
~description:
"The provided nonce is inconsistent with the committed nonce hash."
~pp:(fun ppf () ->
Format.fprintf
ppf
"This nonce revelation is invalid (inconsistent with the committed \
hash)")
Data_encoding.unit
(function Unexpected_nonce -> Some () | _ -> None)
(fun () -> Unexpected_nonce)
(* checks that the level of a revelation is not too early or too late wrt to the
current context and that a nonce has not been already revealed for that level *)
let get_unrevealed ctxt level =
let cur_level = Level_storage.current ctxt in
match Cycle_repr.pred cur_level.cycle with
| None ->
fail Too_early_revelation (* no revelations during cycle 0 *)
| Some revealed_cycle -> (
if Cycle_repr.(revealed_cycle < level.Level_repr.cycle) then
fail Too_early_revelation
else if Cycle_repr.(level.Level_repr.cycle < revealed_cycle) then
fail Too_late_revelation
else
Storage.Seed.Nonce.get ctxt level
>>=? function
| Revealed _ ->
fail Previously_revealed_nonce
| Unrevealed status ->
return status )
let record_hash ctxt unrevealed =
let level = Level_storage.current ctxt in
Storage.Seed.Nonce.init ctxt level (Unrevealed unrevealed)
let reveal ctxt level nonce =
get_unrevealed ctxt level
>>=? fun unrevealed ->
fail_unless
(Seed_repr.check_hash nonce unrevealed.nonce_hash)
Unexpected_nonce
>>=? fun () ->
Storage.Seed.Nonce.set ctxt level (Revealed nonce)
>>=? fun ctxt -> return ctxt
type unrevealed = Storage.Seed.unrevealed_nonce = {
nonce_hash : Nonce_hash.t;
delegate : Signature.Public_key_hash.t;
rewards : Tez_repr.t;
fees : Tez_repr.t;
}
type status = Storage.Seed.nonce_status =
| Unrevealed of unrevealed
| Revealed of Seed_repr.nonce
let get = Storage.Seed.Nonce.get
let of_bytes = Seed_repr.make_nonce
let hash = Seed_repr.hash
let check_hash = Seed_repr.check_hash
src/proto_alpha/lib_protocol/nonce_storage.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := Tezos_raw_protocol_alpha.Seed_repr.nonce.
Definition nonce := t.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.t
Tezos_raw_protocol_alpha.Seed_repr.nonce := Seed_repr.nonce_encoding.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition get_unrevealed
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(level : Tezos_raw_protocol_alpha.Level_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce) :=
let cur_level := Level_storage.current ctxt in
match Cycle_repr.pred (cycle cur_level) with
| None =>
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Too_early_revelation
| Some revealed_cycle =>
if op_lt revealed_cycle (Level_repr.cycle level) then
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Too_early_revelation
else
if op_lt (Level_repr.cycle level) revealed_cycle then
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Too_late_revelation
else
op_gtgteqquestion (Storage.Seed.Nonce.get ctxt level)
(fun function_parameter =>
match function_parameter with
| Tezos_raw_protocol_alpha__Storage.Seed.Revealed _ =>
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.Previously_revealed_nonce
| Tezos_raw_protocol_alpha__Storage.Seed.Unrevealed status =>
_return status
end)
end.
Definition record_hash
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(unrevealed : Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let level := Level_storage.current ctxt in
Storage.Seed.Nonce.init ctxt level
(Tezos_raw_protocol_alpha__Storage.Seed.Unrevealed unrevealed).
Definition reveal
(ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
(level : Tezos_raw_protocol_alpha.Level_repr.t)
(nonce : Tezos_raw_protocol_alpha.Seed_repr.nonce)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteqquestion (get_unrevealed ctxt level)
(fun unrevealed =>
op_gtgteqquestion
(fail_unless (Seed_repr.check_hash nonce (nonce_hash unrevealed))
Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_nonce)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Storage.Seed.Nonce.set ctxt level
(Tezos_raw_protocol_alpha__Storage.Seed.Revealed nonce))
(fun ctxt => _return ctxt))).
Record unrevealed := {
nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t;
delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
rewards : Tezos_raw_protocol_alpha.Tez_repr.t;
fees : Tezos_raw_protocol_alpha.Tez_repr.t }.
Inductive status : Type :=
| Unrevealed : unrevealed -> status
| Revealed : Tezos_raw_protocol_alpha.Seed_repr.nonce -> status.
Definition get
: Tezos_raw_protocol_alpha.Storage.Seed.Nonce.context ->
Tezos_raw_protocol_alpha.Level_repr.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha__Storage.Seed.nonce_status) :=
Storage.Seed.Nonce.get.
Definition of_bytes
: Tezos_protocol_environment_alpha__Environment.MBytes.t ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Seed_repr.nonce := Seed_repr.make_nonce.
Definition hash
: Tezos_raw_protocol_alpha.Seed_repr.nonce ->
Tezos_raw_protocol_alpha.Nonce_hash.t := Seed_repr.hash.
Definition check_hash
: Tezos_raw_protocol_alpha.Seed_repr.nonce ->
Tezos_raw_protocol_alpha.Nonce_hash.t -> bool := Seed_repr.check_hash.
src/proto_alpha/lib_protocol/operation_repr.ml 36 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Tezos Protocol Implementation - Low level Repr. of Operations *)
module Kind = struct
type seed_nonce_revelation = Seed_nonce_revelation_kind
type double_endorsement_evidence = Double_endorsement_evidence_kind
type double_baking_evidence = Double_baking_evidence_kind
type activate_account = Activate_account_kind
type endorsement = Endorsement_kind
type proposals = Proposals_kind
type ballot = Ballot_kind
type reveal = Reveal_kind
type transaction = Transaction_kind
type origination = Origination_kind
type delegation = Delegation_kind
type 'a manager =
| Reveal_manager_kind : reveal manager
| Transaction_manager_kind : transaction manager
| Origination_manager_kind : origination manager
| Delegation_manager_kind : delegation manager
end
type raw = Operation.t = {shell : Operation.shell_header; proto : MBytes.t}
let raw_encoding = Operation.encoding
type 'kind operation = {
shell : Operation.shell_header;
protocol_data : 'kind protocol_data;
}
and 'kind protocol_data = {
contents : 'kind contents_list;
signature : Signature.t option;
}
and _ contents_list =
| Single : 'kind contents -> 'kind contents_list
| Cons :
'kind Kind.manager contents * 'rest Kind.manager contents_list
-> ('kind * 'rest) Kind.manager contents_list
and _ contents =
| Endorsement : {level : Raw_level_repr.t} -> Kind.endorsement contents
| Seed_nonce_revelation : {
level : Raw_level_repr.t;
nonce : Seed_repr.nonce;
}
-> Kind.seed_nonce_revelation contents
| Double_endorsement_evidence : {
op1 : Kind.endorsement operation;
op2 : Kind.endorsement operation;
}
-> Kind.double_endorsement_evidence contents
| Double_baking_evidence : {
bh1 : Block_header_repr.t;
bh2 : Block_header_repr.t;
}
-> Kind.double_baking_evidence contents
| Activate_account : {
id : Ed25519.Public_key_hash.t;
activation_code : Blinded_public_key_hash.activation_code;
}
-> Kind.activate_account contents
| Proposals : {
source : Signature.Public_key_hash.t;
period : Voting_period_repr.t;
proposals : Protocol_hash.t list;
}
-> Kind.proposals contents
| Ballot : {
source : Signature.Public_key_hash.t;
period : Voting_period_repr.t;
proposal : Protocol_hash.t;
ballot : Vote_repr.ballot;
}
-> Kind.ballot contents
| Manager_operation : {
source : Signature.public_key_hash;
fee : Tez_repr.tez;
counter : counter;
operation : 'kind manager_operation;
gas_limit : Z.t;
storage_limit : Z.t;
}
-> 'kind Kind.manager contents
and _ manager_operation =
| Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
| Transaction : {
amount : Tez_repr.tez;
parameters : Script_repr.lazy_expr;
entrypoint : string;
destination : Contract_repr.contract;
}
-> Kind.transaction manager_operation
| Origination : {
delegate : Signature.Public_key_hash.t option;
script : Script_repr.t;
credit : Tez_repr.tez;
preorigination : Contract_repr.t option;
}
-> Kind.origination manager_operation
| Delegation :
Signature.Public_key_hash.t option
-> Kind.delegation manager_operation
and counter = Z.t
let manager_kind : type kind. kind manager_operation -> kind Kind.manager =
function
| Reveal _ ->
Kind.Reveal_manager_kind
| Transaction _ ->
Kind.Transaction_manager_kind
| Origination _ ->
Kind.Origination_manager_kind
| Delegation _ ->
Kind.Delegation_manager_kind
type 'kind internal_operation = {
source : Contract_repr.contract;
operation : 'kind manager_operation;
nonce : int;
}
type packed_manager_operation =
| Manager : 'kind manager_operation -> packed_manager_operation
type packed_contents = Contents : 'kind contents -> packed_contents
type packed_contents_list =
| Contents_list : 'kind contents_list -> packed_contents_list
type packed_protocol_data =
| Operation_data : 'kind protocol_data -> packed_protocol_data
type packed_operation = {
shell : Operation.shell_header;
protocol_data : packed_protocol_data;
}
let pack ({shell; protocol_data} : _ operation) : packed_operation =
{shell; protocol_data = Operation_data protocol_data}
type packed_internal_operation =
| Internal_operation : 'kind internal_operation -> packed_internal_operation
let rec to_list = function
| Contents_list (Single o) ->
[Contents o]
| Contents_list (Cons (o, os)) ->
Contents o :: to_list (Contents_list os)
let rec of_list = function
| [] ->
assert false
| [Contents o] ->
Contents_list (Single o)
| Contents o :: os -> (
let (Contents_list os) = of_list os in
match (o, os) with
| (Manager_operation _, Single (Manager_operation _)) ->
Contents_list (Cons (o, os))
| (Manager_operation _, Cons _) ->
Contents_list (Cons (o, os))
| _ ->
Pervasives.failwith
"Operation list of length > 1 should only contains manager \
operations." )
module Encoding = struct
open Data_encoding
let case tag name args proj inj =
let open Data_encoding in
case
tag
~title:(String.capitalize_ascii name)
(merge_objs (obj1 (req "kind" (constant name))) args)
(fun x -> match proj x with None -> None | Some x -> Some ((), x))
(fun ((), x) -> inj x)
module Manager_operations = struct
type 'kind case =
| MCase : {
tag : int;
name : string;
encoding : 'a Data_encoding.t;
select : packed_manager_operation -> 'kind manager_operation option;
proj : 'kind manager_operation -> 'a;
inj : 'a -> 'kind manager_operation;
}
-> 'kind case
let reveal_case =
MCase
{
tag = 0;
name = "reveal";
encoding = obj1 (req "public_key" Signature.Public_key.encoding);
select = (function Manager (Reveal _ as op) -> Some op | _ -> None);
proj = (function Reveal pkh -> pkh);
inj = (fun pkh -> Reveal pkh);
}
let entrypoint_encoding =
def
~title:"entrypoint"
~description:"Named entrypoint to a Michelson smart contract"
"entrypoint"
@@
let builtin_case tag name =
Data_encoding.case
(Tag tag)
~title:name
(constant name)
(fun n -> if Compare.String.(n = name) then Some () else None)
(fun () -> name)
in
union
[ builtin_case 0 "default";
builtin_case 1 "root";
builtin_case 2 "do";
builtin_case 3 "set_delegate";
builtin_case 4 "remove_delegate";
Data_encoding.case
(Tag 255)
~title:"named"
(Bounded.string 31)
(fun s -> Some s)
(fun s -> s) ]
let transaction_case =
MCase
{
tag = 1;
name = "transaction";
encoding =
obj3
(req "amount" Tez_repr.encoding)
(req "destination" Contract_repr.encoding)
(opt
"parameters"
(obj2
(req "entrypoint" entrypoint_encoding)
(req "value" Script_repr.lazy_expr_encoding)));
select =
(function Manager (Transaction _ as op) -> Some op | _ -> None);
proj =
(function
| Transaction {amount; destination; parameters; entrypoint} ->
let parameters =
if
Script_repr.is_unit_parameter parameters
&& Compare.String.(entrypoint = "default")
then None
else Some (entrypoint, parameters)
in
(amount, destination, parameters));
inj =
(fun (amount, destination, parameters) ->
let (entrypoint, parameters) =
match parameters with
| None ->
("default", Script_repr.unit_parameter)
| Some (entrypoint, value) ->
(entrypoint, value)
in
Transaction {amount; destination; parameters; entrypoint});
}
let origination_case =
MCase
{
tag = 2;
name = "origination";
encoding =
obj3
(req "balance" Tez_repr.encoding)
(opt "delegate" Signature.Public_key_hash.encoding)
(req "script" Script_repr.encoding);
select =
(function Manager (Origination _ as op) -> Some op | _ -> None);
proj =
(function
| Origination
{ credit;
delegate;
script;
preorigination =
_
(* the hash is only used internally
when originating from smart
contracts, don't serialize it *)
} ->
(credit, delegate, script));
inj =
(fun (credit, delegate, script) ->
Origination {credit; delegate; script; preorigination = None});
}
let delegation_case =
MCase
{
tag = 3;
name = "delegation";
encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding);
select =
(function Manager (Delegation _ as op) -> Some op | _ -> None);
proj = (function Delegation key -> key);
inj = (fun key -> Delegation key);
}
let encoding =
let make (MCase {tag; name; encoding; select; proj; inj}) =
case
(Tag tag)
name
encoding
(fun o ->
match select o with None -> None | Some o -> Some (proj o))
(fun x -> Manager (inj x))
in
union
~tag_size:`Uint8
[ make reveal_case;
make transaction_case;
make origination_case;
make delegation_case ]
end
type 'b case =
| Case : {
tag : int;
name : string;
encoding : 'a Data_encoding.t;
select : packed_contents -> 'b contents option;
proj : 'b contents -> 'a;
inj : 'a -> 'b contents;
}
-> 'b case
let endorsement_encoding = obj1 (req "level" Raw_level_repr.encoding)
let endorsement_case =
Case
{
tag = 0;
name = "endorsement";
encoding = endorsement_encoding;
select =
(function Contents (Endorsement _ as op) -> Some op | _ -> None);
proj = (fun (Endorsement {level}) -> level);
inj = (fun level -> Endorsement {level});
}
let endorsement_encoding =
let make (Case {tag; name; encoding; select = _; proj; inj}) =
case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x)
in
let to_list : Kind.endorsement contents_list -> _ = function
| Single o ->
o
in
let of_list : Kind.endorsement contents -> _ = function o -> Single o in
def "inlined.endorsement"
@@ conv
(fun ({shell; protocol_data = {contents; signature}} : _ operation) ->
(shell, (contents, signature)))
(fun (shell, (contents, signature)) ->
({shell; protocol_data = {contents; signature}} : _ operation))
(merge_objs
Operation.shell_header_encoding
(obj2
(req
"operations"
( conv to_list of_list
@@ def "inlined.endorsement.contents"
@@ union [make endorsement_case] ))
(varopt "signature" Signature.encoding)))
let seed_nonce_revelation_case =
Case
{
tag = 1;
name = "seed_nonce_revelation";
encoding =
obj2
(req "level" Raw_level_repr.encoding)
(req "nonce" Seed_repr.nonce_encoding);
select =
(function
| Contents (Seed_nonce_revelation _ as op) -> Some op | _ -> None);
proj = (fun (Seed_nonce_revelation {level; nonce}) -> (level, nonce));
inj = (fun (level, nonce) -> Seed_nonce_revelation {level; nonce});
}
let double_endorsement_evidence_case : Kind.double_endorsement_evidence case
=
Case
{
tag = 2;
name = "double_endorsement_evidence";
encoding =
obj2
(req "op1" (dynamic_size endorsement_encoding))
(req "op2" (dynamic_size endorsement_encoding));
select =
(function
| Contents (Double_endorsement_evidence _ as op) ->
Some op
| _ ->
None);
proj = (fun (Double_endorsement_evidence {op1; op2}) -> (op1, op2));
inj = (fun (op1, op2) -> Double_endorsement_evidence {op1; op2});
}
let double_baking_evidence_case =
Case
{
tag = 3;
name = "double_baking_evidence";
encoding =
obj2
(req "bh1" (dynamic_size Block_header_repr.encoding))
(req "bh2" (dynamic_size Block_header_repr.encoding));
select =
(function
| Contents (Double_baking_evidence _ as op) -> Some op | _ -> None);
proj = (fun (Double_baking_evidence {bh1; bh2}) -> (bh1, bh2));
inj = (fun (bh1, bh2) -> Double_baking_evidence {bh1; bh2});
}
let activate_account_case =
Case
{
tag = 4;
name = "activate_account";
encoding =
obj2
(req "pkh" Ed25519.Public_key_hash.encoding)
(req "secret" Blinded_public_key_hash.activation_code_encoding);
select =
(function
| Contents (Activate_account _ as op) -> Some op | _ -> None);
proj =
(fun (Activate_account {id; activation_code}) ->
(id, activation_code));
inj =
(fun (id, activation_code) -> Activate_account {id; activation_code});
}
let proposals_case =
Case
{
tag = 5;
name = "proposals";
encoding =
obj3
(req "source" Signature.Public_key_hash.encoding)
(req "period" Voting_period_repr.encoding)
(req "proposals" (list Protocol_hash.encoding));
select =
(function Contents (Proposals _ as op) -> Some op | _ -> None);
proj =
(fun (Proposals {source; period; proposals}) ->
(source, period, proposals));
inj =
(fun (source, period, proposals) ->
Proposals {source; period; proposals});
}
let ballot_case =
Case
{
tag = 6;
name = "ballot";
encoding =
obj4
(req "source" Signature.Public_key_hash.encoding)
(req "period" Voting_period_repr.encoding)
(req "proposal" Protocol_hash.encoding)
(req "ballot" Vote_repr.ballot_encoding);
select = (function Contents (Ballot _ as op) -> Some op | _ -> None);
proj =
(function
| Ballot {source; period; proposal; ballot} ->
(source, period, proposal, ballot));
inj =
(fun (source, period, proposal, ballot) ->
Ballot {source; period; proposal; ballot});
}
let manager_encoding =
obj5
(req "source" Signature.Public_key_hash.encoding)
(req "fee" Tez_repr.encoding)
(req "counter" (check_size 10 n))
(req "gas_limit" (check_size 10 n))
(req "storage_limit" (check_size 10 n))
let extract (type kind)
(Manager_operation
{source; fee; counter; gas_limit; storage_limit; operation = _} :
kind Kind.manager contents) =
(source, fee, counter, gas_limit, storage_limit)
let rebuild (source, fee, counter, gas_limit, storage_limit) operation =
Manager_operation
{source; fee; counter; gas_limit; storage_limit; operation}
let make_manager_case tag (type kind)
(Manager_operations.MCase mcase : kind Manager_operations.case) =
Case
{
tag;
name = mcase.name;
encoding = merge_objs manager_encoding mcase.encoding;
select =
(function
| Contents (Manager_operation ({operation; _} as op)) -> (
match mcase.select (Manager operation) with
| None ->
None
| Some operation ->
Some (Manager_operation {op with operation}) )
| _ ->
None);
proj =
(function
| Manager_operation {operation; _} as op ->
(extract op, mcase.proj operation));
inj = (fun (op, contents) -> rebuild op (mcase.inj contents));
}
let reveal_case = make_manager_case 107 Manager_operations.reveal_case
let transaction_case =
make_manager_case 108 Manager_operations.transaction_case
let origination_case =
make_manager_case 109 Manager_operations.origination_case
let delegation_case =
make_manager_case 110 Manager_operations.delegation_case
let contents_encoding =
let make (Case {tag; name; encoding; select; proj; inj}) =
case
(Tag tag)
name
encoding
(fun o -> match select o with None -> None | Some o -> Some (proj o))
(fun x -> Contents (inj x))
in
def "operation.alpha.contents"
@@ union
[ make endorsement_case;
make seed_nonce_revelation_case;
make double_endorsement_evidence_case;
make double_baking_evidence_case;
make activate_account_case;
make proposals_case;
make ballot_case;
make reveal_case;
make transaction_case;
make origination_case;
make delegation_case ]
let contents_list_encoding =
conv to_list of_list (Variable.list contents_encoding)
let optional_signature_encoding =
conv
(function Some s -> s | None -> Signature.zero)
(fun s -> if Signature.equal s Signature.zero then None else Some s)
Signature.encoding
let protocol_data_encoding =
def "operation.alpha.contents_and_signature"
@@ conv
(fun (Operation_data {contents; signature}) ->
(Contents_list contents, signature))
(fun (Contents_list contents, signature) ->
Operation_data {contents; signature})
(obj2
(req "contents" contents_list_encoding)
(req "signature" optional_signature_encoding))
let operation_encoding =
conv
(fun {shell; protocol_data} -> (shell, protocol_data))
(fun (shell, protocol_data) -> {shell; protocol_data})
(merge_objs Operation.shell_header_encoding protocol_data_encoding)
let unsigned_operation_encoding =
def "operation.alpha.unsigned_operation"
@@ merge_objs
Operation.shell_header_encoding
(obj1 (req "contents" contents_list_encoding))
let internal_operation_encoding =
def "operation.alpha.internal_operation"
@@ conv
(fun (Internal_operation {source; operation; nonce}) ->
((source, nonce), Manager operation))
(fun ((source, nonce), Manager operation) ->
Internal_operation {source; operation; nonce})
(merge_objs
(obj2 (req "source" Contract_repr.encoding) (req "nonce" uint16))
Manager_operations.encoding)
end
let encoding = Encoding.operation_encoding
let contents_encoding = Encoding.contents_encoding
let contents_list_encoding = Encoding.contents_list_encoding
let protocol_data_encoding = Encoding.protocol_data_encoding
let unsigned_operation_encoding = Encoding.unsigned_operation_encoding
let internal_operation_encoding = Encoding.internal_operation_encoding
let raw ({shell; protocol_data} : _ operation) =
let proto =
Data_encoding.Binary.to_bytes_exn
protocol_data_encoding
(Operation_data protocol_data)
in
{Operation.shell; proto}
let acceptable_passes (op : packed_operation) =
let (Operation_data protocol_data) = op.protocol_data in
match protocol_data.contents with
| Single (Endorsement _) ->
[0]
| Single (Proposals _) ->
[1]
| Single (Ballot _) ->
[1]
| Single (Seed_nonce_revelation _) ->
[2]
| Single (Double_endorsement_evidence _) ->
[2]
| Single (Double_baking_evidence _) ->
[2]
| Single (Activate_account _) ->
[2]
| Single (Manager_operation _) ->
[3]
| Cons _ ->
[3]
type error += Invalid_signature (* `Permanent *)
type error += Missing_signature (* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"operation.invalid_signature"
~title:"Invalid operation signature"
~description:
"The operation signature is ill-formed or has been made with the wrong \
public key"
~pp:(fun ppf () -> Format.fprintf ppf "The operation signature is invalid")
Data_encoding.unit
(function Invalid_signature -> Some () | _ -> None)
(fun () -> Invalid_signature) ;
register_error_kind
`Permanent
~id:"operation.missing_signature"
~title:"Missing operation signature"
~description:
"The operation is of a kind that must be signed, but the signature is \
missing"
~pp:(fun ppf () -> Format.fprintf ppf "The operation requires a signature")
Data_encoding.unit
(function Missing_signature -> Some () | _ -> None)
(fun () -> Missing_signature)
let check_signature_sync (type kind) key chain_id
({shell; protocol_data} : kind operation) =
let check ~watermark contents signature =
let unsigned_operation =
Data_encoding.Binary.to_bytes_exn
unsigned_operation_encoding
(shell, contents)
in
if Signature.check ~watermark key signature unsigned_operation then Ok ()
else error Invalid_signature
in
match (protocol_data.contents, protocol_data.signature) with
| (Single _, None) ->
error Missing_signature
| (Cons _, None) ->
error Missing_signature
| ((Single (Endorsement _) as contents), Some signature) ->
check
~watermark:(Endorsement chain_id)
(Contents_list contents)
signature
| ((Single _ as contents), Some signature) ->
check ~watermark:Generic_operation (Contents_list contents) signature
| ((Cons _ as contents), Some signature) ->
check ~watermark:Generic_operation (Contents_list contents) signature
let check_signature pk chain_id op =
Lwt.return (check_signature_sync pk chain_id op)
let hash_raw = Operation.hash
let hash (o : _ operation) =
let proto =
Data_encoding.Binary.to_bytes_exn
protocol_data_encoding
(Operation_data o.protocol_data)
in
Operation.hash {shell = o.shell; proto}
let hash_packed (o : packed_operation) =
let proto =
Data_encoding.Binary.to_bytes_exn protocol_data_encoding o.protocol_data
in
Operation.hash {shell = o.shell; proto}
type ('a, 'b) eq = Eq : ('a, 'a) eq
let equal_manager_operation_kind :
type a b. a manager_operation -> b manager_operation -> (a, b) eq option =
fun op1 op2 ->
match (op1, op2) with
| (Reveal _, Reveal _) ->
Some Eq
| (Reveal _, _) ->
None
| (Transaction _, Transaction _) ->
Some Eq
| (Transaction _, _) ->
None
| (Origination _, Origination _) ->
Some Eq
| (Origination _, _) ->
None
| (Delegation _, Delegation _) ->
Some Eq
| (Delegation _, _) ->
None
let equal_contents_kind :
type a b. a contents -> b contents -> (a, b) eq option =
fun op1 op2 ->
match (op1, op2) with
| (Endorsement _, Endorsement _) ->
Some Eq
| (Endorsement _, _) ->
None
| (Seed_nonce_revelation _, Seed_nonce_revelation _) ->
Some Eq
| (Seed_nonce_revelation _, _) ->
None
| (Double_endorsement_evidence _, Double_endorsement_evidence _) ->
Some Eq
| (Double_endorsement_evidence _, _) ->
None
| (Double_baking_evidence _, Double_baking_evidence _) ->
Some Eq
| (Double_baking_evidence _, _) ->
None
| (Activate_account _, Activate_account _) ->
Some Eq
| (Activate_account _, _) ->
None
| (Proposals _, Proposals _) ->
Some Eq
| (Proposals _, _) ->
None
| (Ballot _, Ballot _) ->
Some Eq
| (Ballot _, _) ->
None
| (Manager_operation op1, Manager_operation op2) -> (
match equal_manager_operation_kind op1.operation op2.operation with
| None ->
None
| Some Eq ->
Some Eq )
| (Manager_operation _, _) ->
None
let rec equal_contents_kind_list :
type a b. a contents_list -> b contents_list -> (a, b) eq option =
fun op1 op2 ->
match (op1, op2) with
| (Single op1, Single op2) ->
equal_contents_kind op1 op2
| (Single _, Cons _) ->
None
| (Cons _, Single _) ->
None
| (Cons (op1, ops1), Cons (op2, ops2)) -> (
match equal_contents_kind op1 op2 with
| None ->
None
| Some Eq -> (
match equal_contents_kind_list ops1 ops2 with
| None ->
None
| Some Eq ->
Some Eq ) )
let equal : type a b. a operation -> b operation -> (a, b) eq option =
fun op1 op2 ->
if not (Operation_hash.equal (hash op1) (hash op2)) then None
else
equal_contents_kind_list
op1.protocol_data.contents
op2.protocol_data.contents
src/proto_alpha/lib_protocol/operation_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Kind.
Inductive seed_nonce_revelation : Type :=
| Seed_nonce_revelation_kind : seed_nonce_revelation.
Inductive double_endorsement_evidence : Type :=
| Double_endorsement_evidence_kind : double_endorsement_evidence.
Inductive double_baking_evidence : Type :=
| Double_baking_evidence_kind : double_baking_evidence.
Inductive activate_account : Type :=
| Activate_account_kind : activate_account.
Inductive endorsement : Type :=
| Endorsement_kind : endorsement.
Inductive proposals : Type :=
| Proposals_kind : proposals.
Inductive ballot : Type :=
| Ballot_kind : ballot.
Inductive reveal : Type :=
| Reveal_kind : reveal.
Inductive transaction : Type :=
| Transaction_kind : transaction.
Inductive origination : Type :=
| Origination_kind : origination.
Inductive delegation : Type :=
| Delegation_kind : delegation.
Inductive manager : forall (a : Type), Type :=
| Reveal_manager_kind : manager reveal
| Transaction_manager_kind : manager transaction
| Origination_manager_kind : manager origination
| Delegation_manager_kind : manager delegation.
End Kind.
Record raw := {
shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
proto : Tezos_protocol_environment_alpha__Environment.MBytes.t }.
Definition raw_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.t
Tezos_protocol_environment_alpha__Environment.Operation.t :=
Operation.encoding.
Reserved Notation "'counter".
Inductive contents_list : forall (_ : Type), Type :=
| Single : forall {kind : Type}, (contents kind) -> contents_list kind
| Cons : forall {kind rest : Type}, (contents (Kind.manager kind)) ->
(contents_list (Kind.manager rest)) ->
contents_list (Kind.manager (kind * rest))
with contents : forall (_ : Type), Type :=
| Endorsement : Tezos_raw_protocol_alpha.Raw_level_repr.t ->
contents Kind.endorsement
| Seed_nonce_revelation : Tezos_raw_protocol_alpha.Raw_level_repr.t ->
Tezos_raw_protocol_alpha.Seed_repr.nonce ->
contents Kind.seed_nonce_revelation
| Double_endorsement_evidence : (operation Kind.endorsement) ->
(operation Kind.endorsement) -> contents Kind.double_endorsement_evidence
| Double_baking_evidence : Tezos_raw_protocol_alpha.Block_header_repr.t ->
Tezos_raw_protocol_alpha.Block_header_repr.t ->
contents Kind.double_baking_evidence
| Activate_account :
Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.t ->
Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code ->
contents Kind.activate_account
| Proposals :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
Tezos_raw_protocol_alpha.Voting_period_repr.t ->
(list
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
-> contents Kind.proposals
| Ballot :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
Tezos_raw_protocol_alpha.Voting_period_repr.t ->
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
-> Tezos_raw_protocol_alpha.Vote_repr.ballot -> contents Kind.ballot
| Manager_operation : forall {kind : Type},
Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash ->
Tezos_raw_protocol_alpha.Tez_repr.tez -> 'counter -> (manager_operation kind)
-> Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
contents (Kind.manager kind)
with manager_operation : forall (_ : Type), Type :=
| Reveal : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t
-> manager_operation Kind.reveal
| Transaction : Tezos_raw_protocol_alpha.Tez_repr.tez ->
Tezos_raw_protocol_alpha.Script_repr.lazy_expr -> string ->
Tezos_raw_protocol_alpha.Contract_repr.contract ->
manager_operation Kind.transaction
| Origination :
(option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
-> Tezos_raw_protocol_alpha.Script_repr.t ->
Tezos_raw_protocol_alpha.Tez_repr.tez ->
(option Tezos_raw_protocol_alpha.Contract_repr.t) ->
manager_operation Kind.origination
| Delegation :
(option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
-> manager_operation Kind.delegation
where "'counter" := ( Tezos_protocol_environment_alpha__Environment.Z.t).
Definition counter := 'counter.
Definition manager_kind {kind : Type}
(function_parameter : manager_operation kind) : Kind.manager kind :=
match function_parameter with
| Reveal _ => Kind.Reveal_manager_kind
| Transaction _ => Kind.Transaction_manager_kind
| Origination _ => Kind.Origination_manager_kind
| Delegation _ => Kind.Delegation_manager_kind
end.
Record internal_operation {kind : Type} := {
source : Tezos_raw_protocol_alpha.Contract_repr.contract;
operation : manager_operation kind;
nonce : Z }.
Arguments internal_operation : clear implicits.
Inductive packed_manager_operation : Type :=
| Manager : forall {kind : Type}, (manager_operation kind) ->
packed_manager_operation.
Inductive packed_contents : Type :=
| Contents : forall {kind : Type}, (contents kind) -> packed_contents.
Inductive packed_contents_list : Type :=
| Contents_list : forall {kind : Type}, (contents_list kind) ->
packed_contents_list.
Inductive packed_protocol_data : Type :=
| Operation_data : forall {kind : Type}, (protocol_data kind) ->
packed_protocol_data.
Record packed_operation := {
shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
protocol_data : packed_protocol_data }.
Definition pack {A : Type} (function_parameter : operation A)
: packed_operation :=
let '{| shell := shell; protocol_data := protocol_data |} :=
function_parameter in
{| shell := shell; protocol_data := Operation_data protocol_data |}.
Inductive packed_internal_operation : Type :=
| Internal_operation : forall {kind : Type}, (internal_operation kind) ->
packed_internal_operation.
Fixpoint to_list (function_parameter : packed_contents_list)
: list packed_contents :=
match function_parameter with
| Contents_list (Single o) => cons (Contents o) []
| Contents_list (Cons o os) => cons (Contents o) (to_list (Contents_list os))
end.
Fixpoint of_list (function_parameter : list packed_contents)
: packed_contents_list :=
match function_parameter with
| [] =>
(* ❌ Assert instruction is not handled. *)
assert false
| cons (Contents o) [] => Contents_list (Single o)
| cons (Contents o) os =>
let 'Contents_list os := of_list os in
match (o, os) with
| (Manager_operation _, Single (Manager_operation _)) =>
Contents_list (Cons o os)
| (Manager_operation _, Cons _ _) => Contents_list (Cons o os)
| _ =>
Pervasives.failwith
"Operation list of length > 1 should only contains manager operations."
% string
end
end.
Module Encoding.
Import Data_encoding.
Definition case {A B : Type}
(tag : Tezos_protocol_environment_alpha__Environment.Data_encoding.case_tag)
(name : string)
(args :
Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding A)
(proj : B -> option A) (inj : A -> B)
: Tezos_protocol_environment_alpha__Environment.Data_encoding.case B :=
case (String.capitalize_ascii name) None tag
(merge_objs (obj1 (req None None "kind" % string (constant name))) args)
(fun x =>
match proj x with
| None => None
| Some x => Some (tt, x)
end)
(fun function_parameter =>
let '(tt, x) := function_parameter in
inj x).
Module Manager_operations.
Inductive case (kind : Type) : Type :=
| MCase : forall {a : Type}, Z -> string ->
(Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
(packed_manager_operation -> option (manager_operation kind)) ->
((manager_operation kind) -> a) -> (a -> manager_operation kind) ->
case kind.
Arguments MCase {_}.
Definition reveal_case : case Kind.reveal :=
MCase
{| tag := 0; name := "reveal" % string;
encoding :=
obj1
(req None None "public_key" % string Signature.Public_key.encoding);
select :=
fun function_parameter =>
match function_parameter with
| Manager ((Reveal _) as op) => Some op
| _ => None
end;
proj :=
fun function_parameter =>
let 'Reveal pkh := function_parameter in
pkh; inj := fun pkh => Reveal pkh |}.
Definition entrypoint_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
op_atat
(def "entrypoint" % string (Some "entrypoint" % string)
(Some "Named entrypoint to a Michelson smart contract" % string))
(let builtin_case
(tag : Z) (name :
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Data_encoding.case
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
Data_encoding.case name None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag tag)
(constant name)
(fun n =>
if
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
n name then
Some tt
else
None)
(fun function_parameter =>
let 'tt := function_parameter in
name) in
union None
(cons (builtin_case 0 "default" % string)
(cons (builtin_case 1 "root" % string)
(cons (builtin_case 2 "do" % string)
(cons (builtin_case 3 "set_delegate" % string)
(cons (builtin_case 4 "remove_delegate" % string)
(cons
(Data_encoding.case "named" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag
255) (Bounded.string 31) (fun s => Some s)
(fun s => s)) []))))))).
Definition transaction_case : case Kind.transaction :=
MCase
{| tag := 1; name := "transaction" % string;
encoding :=
obj3 (req None None "amount" % string Tez_repr.encoding)
(req None None "destination" % string Contract_repr.encoding)
(opt None None "parameters" % string
(obj2 (req None None "entrypoint" % string entrypoint_encoding)
(req None None "value" % string Script_repr.lazy_expr_encoding)));
select :=
fun function_parameter =>
match function_parameter with
| Manager ((Transaction _) as op) => Some op
| _ => None
end;
proj :=
fun function_parameter =>
let
'Transaction {|
amount := amount;
parameters := parameters;
entrypoint := entrypoint;
destination := destination
|} := function_parameter in
let parameters :=
if
op_andand (Script_repr.is_unit_parameter parameters)
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
entrypoint "default" % string) then
None
else
Some (entrypoint, parameters) in
(amount, destination, parameters);
inj :=
fun function_parameter =>
let '(amount, destination, parameters) := function_parameter in
let '(entrypoint, parameters) :=
match parameters with
| None => ("default" % string, Script_repr.unit_parameter)
| Some (entrypoint, value) => (entrypoint, value)
end in
Transaction
{| amount := amount; parameters := parameters;
entrypoint := entrypoint; destination := destination |} |}.
Definition origination_case : case Kind.origination :=
MCase
{| tag := 2; name := "origination" % string;
encoding :=
obj3 (req None None "balance" % string Tez_repr.encoding)
(opt None None "delegate" % string
Signature.Public_key_hash.encoding)
(req None None "script" % string Script_repr.encoding);
select :=
fun function_parameter =>
match function_parameter with
| Manager ((Origination _) as op) => Some op
| _ => None
end;
proj :=
fun function_parameter =>
let
'Origination {|
delegate := delegate;
script := script;
credit := credit;
preorigination := _
|} := function_parameter in
(credit, delegate, script);
inj :=
fun function_parameter =>
let '(credit, delegate, script) := function_parameter in
Origination
{| delegate := delegate; script := script; credit := credit;
preorigination := None |} |}.
Definition delegation_case : case Kind.delegation :=
MCase
{| tag := 3; name := "delegation" % string;
encoding :=
obj1
(opt None None "delegate" % string
Signature.Public_key_hash.encoding);
select :=
fun function_parameter =>
match function_parameter with
| Manager ((Delegation _) as op) => Some op
| _ => None
end;
proj :=
fun function_parameter =>
let 'Delegation key := function_parameter in
key; inj := fun key => Delegation key |}.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_manager_operation :=
let make {A : Type} (function_parameter : case A)
: Tezos_protocol_environment_alpha__Environment.Data_encoding.case
packed_manager_operation :=
let
'MCase {|
tag := tag;
name := name;
encoding := encoding;
select := select;
proj := proj;
inj := inj
|} := function_parameter in
case
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag tag)
name encoding
(fun o =>
match select o with
| None => None
| Some o => Some (proj o)
end) (fun x => Manager (inj x)) in
union
(Some
(* ❌ Variants not supported *)
variant)
(cons (make reveal_case)
(cons (make transaction_case)
(cons (make origination_case) (cons (make delegation_case) [])))).
End Manager_operations.
Inductive case (b : Type) : Type :=
| Case : forall {a : Type}, Z -> string ->
(Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
(packed_contents -> option (contents b)) -> ((contents b) -> a) ->
(a -> contents b) -> case b.
Arguments Case {_}.
Definition endorsement_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
Tezos_raw_protocol_alpha.Raw_level_repr.raw_level :=
obj1 (req None None "level" % string Raw_level_repr.encoding).
Definition endorsement_case : case Kind.endorsement :=
Case
{| tag := 0; name := "endorsement" % string;
encoding := endorsement_encoding;
select :=
fun function_parameter =>
match function_parameter with
| Contents ((Endorsement _) as op) => Some op
| _ => None
end;
proj :=
fun function_parameter =>
let 'Endorsement {| level := level |} := function_parameter in
level; inj := fun level => Endorsement {| level := level |} |}.
Definition endorsement_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(operation Kind.endorsement) :=
let make {A : Type} (function_parameter : case A)
: Tezos_protocol_environment_alpha__Environment.Data_encoding.case
(contents A) :=
let
'Case {|
tag := tag;
name := name;
encoding := encoding;
select := _;
proj := proj;
inj := inj
|} := function_parameter in
case (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag tag)
name encoding (fun o => Some (proj o)) (fun x => inj x) in
let to_list (function_parameter : contents_list Kind.endorsement)
: contents Kind.endorsement :=
let 'Single o := function_parameter in
o in
let of_list (o : contents Kind.endorsement)
: contents_list Kind.endorsement :=
Single o in
op_atat
(let arg := def "inlined.endorsement" % string in
fun eta => arg None None eta)
(conv
(fun function_parameter =>
let '{|
shell := shell;
protocol_data := {|
contents := contents;
signature := signature
|}
|} := function_parameter in
(shell, (contents, signature)))
(fun function_parameter =>
let '(shell, (contents, signature)) := function_parameter in
{| shell := shell;
protocol_data := {| contents := contents; signature := signature |}
|}) None
(merge_objs Operation.shell_header_encoding
(obj2
(req None None "operations" % string
(op_atat
(let arg := conv to_list of_list in
fun eta => arg None eta)
(op_atat
(let arg := def "inlined.endorsement.contents" % string in
fun eta => arg None None eta)
(union None (cons (make endorsement_case) [])))))
(varopt None None "signature" % string Signature.encoding)))).
Definition seed_nonce_revelation_case : case Kind.seed_nonce_revelation :=
Case
{| tag := 1; name := "seed_nonce_revelation" % string;
encoding :=
obj2 (req None None "level" % string Raw_level_repr.encoding)
(req None None "nonce" % string Seed_repr.nonce_encoding);
select :=
fun function_parameter =>
match function_parameter with
| Contents ((Seed_nonce_revelation _) as op) => Some op
| _ => None
end;
proj :=
fun function_parameter =>
let 'Seed_nonce_revelation {| level := level; nonce := nonce |} :=
function_parameter in
(level, nonce);
inj :=
fun function_parameter =>
let '(level, nonce) := function_parameter in
Seed_nonce_revelation {| level := level; nonce := nonce |} |}.
Definition double_endorsement_evidence_case
: case Kind.double_endorsement_evidence :=
Case
{| tag := 2; name := "double_endorsement_evidence" % string;
encoding :=
obj2
(req None None "op1" % string
(dynamic_size None endorsement_encoding))
(req None None "op2" % string
(dynamic_size None endorsement_encoding));
select :=
fun function_parameter =>
match function_parameter with
| Contents ((Double_endorsement_evidence _) as op) => Some op
| _ => None
end;
proj :=
fun function_parameter =>
let 'Double_endorsement_evidence {| op1 := op1; op2 := op2 |} :=
function_parameter in
(op1, op2);
inj :=
fun function_parameter =>
let '(op1, op2) := function_parameter in
Double_endorsement_evidence {| op1 := op1; op2 := op2 |} |}.
Definition double_baking_evidence_case : case Kind.double_baking_evidence :=
Case
{| tag := 3; name := "double_baking_evidence" % string;
encoding :=
obj2
(req None None "bh1" % string
(dynamic_size None Block_header_repr.encoding))
(req None None "bh2" % string
(dynamic_size None Block_header_repr.encoding));
select :=
fun function_parameter =>
match function_parameter with
| Contents ((Double_baking_evidence _) as op) => Some op
| _ => None
end;
proj :=
fun function_parameter =>
let 'Double_baking_evidence {| bh1 := bh1; bh2 := bh2 |} :=
function_parameter in
(bh1, bh2);
inj :=
fun function_parameter =>
let '(bh1, bh2) := function_parameter in
Double_baking_evidence {| bh1 := bh1; bh2 := bh2 |} |}.
Definition activate_account_case : case Kind.activate_account :=
Case
{| tag := 4; name := "activate_account" % string;
encoding :=
obj2 (req None None "pkh" % string Ed25519.Public_key_hash.encoding)
(req None None "secret" % string
Blinded_public_key_hash.activation_code_encoding);
select :=
fun function_parameter =>
match function_parameter with
| Contents ((Activate_account _) as op) => Some op
| _ => None
end;
proj :=
fun function_parameter =>
let
'Activate_account {|
id := id; activation_code := activation_code |} :=
function_parameter in
(id, activation_code);
inj :=
fun function_parameter =>
let '(id, activation_code) := function_parameter in
Activate_account {| id := id; activation_code := activation_code |}
|}.
Definition proposals_case : case Kind.proposals :=
Case
{| tag := 5; name := "proposals" % string;
encoding :=
obj3
(req None None "source" % string Signature.Public_key_hash.encoding)
(req None None "period" % string Voting_period_repr.encoding)
(req None None "proposals" % string
(list None
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)));
select :=
fun function_parameter =>
match function_parameter with
| Contents ((Proposals _) as op) => Some op
| _ => None
end;
proj :=
fun function_parameter =>
let
'Proposals {|
source := source;
period := period;
proposals := proposals
|} := function_parameter in
(source, period, proposals);
inj :=
fun function_parameter =>
let '(source, period, proposals) := function_parameter in
Proposals
{| source := source; period := period; proposals := proposals |}
|}.
Definition ballot_case : case Kind.ballot :=
Case
{| tag := 6; name := "ballot" % string;
encoding :=
obj4
(req None None "source" % string Signature.Public_key_hash.encoding)
(req None None "period" % string Voting_period_repr.encoding)
(req None None "proposal" % string
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding))
(req None None "ballot" % string Vote_repr.ballot_encoding);
select :=
fun function_parameter =>
match function_parameter with
| Contents ((Ballot _) as op) => Some op
| _ => None
end;
proj :=
fun function_parameter =>
let
'Ballot {|
source := source;
period := period;
proposal := proposal;
ballot := ballot
|} := function_parameter in
(source, period, proposal, ballot);
inj :=
fun function_parameter =>
let '(source, period, proposal, ballot) := function_parameter in
Ballot
{| source := source; period := period; proposal := proposal;
ballot := ballot |} |}.
Definition manager_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* Tezos_raw_protocol_alpha.Tez_repr.t *
Tezos_protocol_environment_alpha__Environment.Z.t *
Tezos_protocol_environment_alpha__Environment.Z.t *
Tezos_protocol_environment_alpha__Environment.Z.t) :=
obj5 (req None None "source" % string Signature.Public_key_hash.encoding)
(req None None "fee" % string Tez_repr.encoding)
(req None None "counter" % string (check_size 10 n))
(req None None "gas_limit" % string (check_size 10 n))
(req None None "storage_limit" % string (check_size 10 n)).
Definition extract {A : Type} (function_parameter : contents (Kind.manager A))
: Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash *
Tezos_raw_protocol_alpha.Tez_repr.tez * counter *
Tezos_protocol_environment_alpha__Environment.Z.t *
Tezos_protocol_environment_alpha__Environment.Z.t :=
let
'Manager_operation {|
source := source;
fee := fee;
counter := counter;
operation := _;
gas_limit := gas_limit;
storage_limit := storage_limit
|} := function_parameter in
(source, fee, counter, gas_limit, storage_limit).
Definition rebuild {A : Type}
(function_parameter :
Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash *
Tezos_raw_protocol_alpha.Tez_repr.tez * counter *
Tezos_protocol_environment_alpha__Environment.Z.t *
Tezos_protocol_environment_alpha__Environment.Z.t)
: (manager_operation A) -> contents (Kind.manager A) :=
let '(source, fee, counter, gas_limit, storage_limit) := function_parameter
in
fun operation =>
Manager_operation
{| source := source; fee := fee; counter := counter;
operation := operation; gas_limit := gas_limit;
storage_limit := storage_limit |}.
Definition make_manager_case {A : Type}
(tag : Z) (function_parameter : Manager_operations.case A)
: case (Kind.manager A) :=
let 'Manager_operations.MCase mcase := function_parameter in
Case
{| tag := tag; name := name mcase;
encoding := merge_objs manager_encoding (encoding mcase);
select :=
fun function_parameter =>
match function_parameter with
| Contents (Manager_operation ({| operation := operation |} as op))
=>
match (select mcase) (Manager operation) with
| None => None
| Some operation =>
Some
(Manager_operation
(* ❌ Record substitution not handled *)
record_substitution)
end
| _ => None
end;
proj :=
fun function_parameter =>
let '(Manager_operation {| operation := operation |}) as op :=
function_parameter in
((extract op), ((proj mcase) operation));
inj :=
fun function_parameter =>
let '(op, contents) := function_parameter in
rebuild op ((inj mcase) contents) |}.
Definition reveal_case : case (Kind.manager Kind.reveal) :=
make_manager_case 107 Manager_operations.reveal_case.
Definition transaction_case : case (Kind.manager Kind.transaction) :=
make_manager_case 108 Manager_operations.transaction_case.
Definition origination_case : case (Kind.manager Kind.origination) :=
make_manager_case 109 Manager_operations.origination_case.
Definition delegation_case : case (Kind.manager Kind.delegation) :=
make_manager_case 110 Manager_operations.delegation_case.
Definition contents_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_contents :=
let make {A : Type} (function_parameter : case A)
: Tezos_protocol_environment_alpha__Environment.Data_encoding.case
packed_contents :=
let
'Case {|
tag := tag;
name := name;
encoding := encoding;
select := select;
proj := proj;
inj := inj
|} := function_parameter in
case (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag tag)
name encoding
(fun o =>
match select o with
| None => None
| Some o => Some (proj o)
end) (fun x => Contents (inj x)) in
op_atat
(let arg := def "operation.alpha.contents" % string in
fun eta => arg None None eta)
(union None
(cons (make endorsement_case)
(cons (make seed_nonce_revelation_case)
(cons (make double_endorsement_evidence_case)
(cons (make double_baking_evidence_case)
(cons (make activate_account_case)
(cons (make proposals_case)
(cons (make ballot_case)
(cons (make reveal_case)
(cons (make transaction_case)
(cons (make origination_case)
(cons (make delegation_case) [])))))))))))).
Definition contents_list_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_contents_list :=
conv to_list of_list None (Variable.list None contents_encoding).
Definition optional_signature_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(option Tezos_protocol_environment_alpha__Environment.Signature.t) :=
conv
(fun function_parameter =>
match function_parameter with
| Some s => s
| None => Signature.zero
end)
(fun s =>
if Signature.equal s Signature.zero then
None
else
Some s) None Signature.encoding.
Definition protocol_data_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_protocol_data :=
op_atat
(let arg := def "operation.alpha.contents_and_signature" % string in
fun eta => arg None None eta)
(conv
(fun function_parameter =>
let
'Operation_data {| contents := contents; signature := signature |} :=
function_parameter in
((Contents_list contents), signature))
(fun function_parameter =>
let '(Contents_list contents, signature) := function_parameter in
Operation_data {| contents := contents; signature := signature |})
None
(obj2 (req None None "contents" % string contents_list_encoding)
(req None None "signature" % string optional_signature_encoding))).
Definition operation_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_operation :=
conv
(fun function_parameter =>
let '{| shell := shell; protocol_data := protocol_data |} :=
function_parameter in
(shell, protocol_data))
(fun function_parameter =>
let '(shell, protocol_data) := function_parameter in
{| shell := shell; protocol_data := protocol_data |}) None
(merge_objs Operation.shell_header_encoding protocol_data_encoding).
Definition unsigned_operation_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(Tezos_protocol_environment_alpha__Environment.Operation.shell_header *
packed_contents_list) :=
op_atat
(let arg := def "operation.alpha.unsigned_operation" % string in
fun eta => arg None None eta)
(merge_objs Operation.shell_header_encoding
(obj1 (req None None "contents" % string contents_list_encoding))).
Definition internal_operation_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_internal_operation :=
op_atat
(let arg := def "operation.alpha.internal_operation" % string in
fun eta => arg None None eta)
(conv
(fun function_parameter =>
let
'Internal_operation {|
source := source; operation := operation; nonce := nonce |} :=
function_parameter in
((source, nonce), (Manager operation)))
(fun function_parameter =>
let '((source, nonce), Manager operation) := function_parameter in
Internal_operation
{| source := source; operation := operation; nonce := nonce |}) None
(merge_objs
(obj2 (req None None "source" % string Contract_repr.encoding)
(req None None "nonce" % string uint16)) Manager_operations.encoding)).
End Encoding.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_operation := Encoding.operation_encoding.
Definition contents_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_contents := Encoding.contents_encoding.
Definition contents_list_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_contents_list := Encoding.contents_list_encoding.
Definition protocol_data_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_protocol_data := Encoding.protocol_data_encoding.
Definition unsigned_operation_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(Tezos_protocol_environment_alpha__Environment.Operation.shell_header *
packed_contents_list) := Encoding.unsigned_operation_encoding.
Definition internal_operation_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
packed_internal_operation := Encoding.internal_operation_encoding.
Definition raw {A : Type} (function_parameter : operation A)
: Tezos_protocol_environment_alpha__Environment.Operation.t :=
let '{| shell := shell; protocol_data := protocol_data |} :=
function_parameter in
let proto :=
Data_encoding.Binary.to_bytes_exn protocol_data_encoding
(Operation_data protocol_data) in
{| Operation.shell := shell; Operation.proto := proto |}.
Definition acceptable_passes (op : packed_operation) : list Z :=
let 'Operation_data protocol_data := protocol_data op in
match contents protocol_data with
| Single (Endorsement _) => cons 0 []
| Single (Proposals _) => cons 1 []
| Single (Ballot _) => cons 1 []
| Single (Seed_nonce_revelation _) => cons 2 []
| Single (Double_endorsement_evidence _) => cons 2 []
| Single (Double_baking_evidence _) => cons 2 []
| Single (Activate_account _) => cons 2 []
| Single (Manager_operation _) => cons 3 []
| Cons _ _ => cons 3 []
end.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition check_signature_sync {A : Type}
(key : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(function_parameter : operation A)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
let '{| shell := shell; protocol_data := protocol_data |} :=
function_parameter in
let check
(watermark :
Tezos_protocol_environment_alpha__Environment.Signature.watermark) (contents
: packed_contents_list) (signature :
Tezos_protocol_environment_alpha__Environment.Signature.t)
: Tezos_protocol_environment_alpha__Environment.Pervasives.result unit
(list Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
let unsigned_operation :=
Data_encoding.Binary.to_bytes_exn unsigned_operation_encoding
(shell, contents) in
if Signature.check (Some watermark) key signature unsigned_operation then
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok tt
else
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_signature
in
match ((contents protocol_data), (signature protocol_data)) with
| (Single _, None) =>
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Missing_signature
| (Cons _ _, None) =>
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Missing_signature
| ((Single (Endorsement _)) as contents, Some signature) =>
check
(Tezos_protocol_environment_alpha__Environment.Signature.Endorsement
chain_id) (Contents_list contents) signature
| ((Single _) as contents, Some signature) =>
check
Tezos_protocol_environment_alpha__Environment.Signature.Generic_operation
(Contents_list contents) signature
| ((Cons _ _) as contents, Some signature) =>
check
Tezos_protocol_environment_alpha__Environment.Signature.Generic_operation
(Contents_list contents) signature
end.
Definition check_signature {A : Type}
(pk : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
(chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(op : operation A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
Lwt._return (check_signature_sync pk chain_id op).
Definition hash_raw
: Tezos_protocol_environment_alpha__Environment.Operation.t ->
Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
Operation.hash.
Definition hash {A : Type} (o : operation A)
: Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
let proto :=
Data_encoding.Binary.to_bytes_exn protocol_data_encoding
(Operation_data (protocol_data o)) in
Operation.hash {| shell := shell o; proto := proto |}.
Definition hash_packed (o : packed_operation)
: Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
let proto :=
Data_encoding.Binary.to_bytes_exn protocol_data_encoding (protocol_data o)
in
Operation.hash {| shell := shell o; proto := proto |}.
Inductive eq (a : Type) : forall (b : Type), Type :=
| Eq : eq a a.
Arguments Eq {_}.
Definition equal_manager_operation_kind {a b : Type}
(op1 : manager_operation a) (op2 : manager_operation b) : option (eq a b) :=
match (op1, op2) with
| (Reveal _, Reveal _) => Some Eq
| (Reveal _, _) => None
| (Transaction _, Transaction _) => Some Eq
| (Transaction _, _) => None
| (Origination _, Origination _) => Some Eq
| (Origination _, _) => None
| (Delegation _, Delegation _) => Some Eq
| (Delegation _, _) => None
end.
Definition equal_contents_kind {a b : Type}
(op1 : contents a) (op2 : contents b) : option (eq a b) :=
match (op1, op2) with
| (Endorsement _, Endorsement _) => Some Eq
| (Endorsement _, _) => None
| (Seed_nonce_revelation _, Seed_nonce_revelation _) => Some Eq
| (Seed_nonce_revelation _, _) => None
| (Double_endorsement_evidence _, Double_endorsement_evidence _) => Some Eq
| (Double_endorsement_evidence _, _) => None
| (Double_baking_evidence _, Double_baking_evidence _) => Some Eq
| (Double_baking_evidence _, _) => None
| (Activate_account _, Activate_account _) => Some Eq
| (Activate_account _, _) => None
| (Proposals _, Proposals _) => Some Eq
| (Proposals _, _) => None
| (Ballot _, Ballot _) => Some Eq
| (Ballot _, _) => None
| (Manager_operation op1, Manager_operation op2) =>
match equal_manager_operation_kind (operation op1) (operation op2) with
| None => None
| Some Eq => Some Eq
end
| (Manager_operation _, _) => None
end.
Fixpoint equal_contents_kind_list {a b : Type}
(op1 : contents_list a) (op2 : contents_list b) : option (eq a b) :=
match (op1, op2) with
| (Single op1, Single op2) => equal_contents_kind op1 op2
| (Single _, Cons _ _) => None
| (Cons _ _, Single _) => None
| (Cons op1 ops1, Cons op2 ops2) =>
match equal_contents_kind op1 op2 with
| None => None
| Some Eq =>
match equal_contents_kind_list ops1 ops2 with
| None => None
| Some Eq => Some Eq
end
end
end.
Definition equal {a b : Type} (op1 : operation a) (op2 : operation b)
: option (eq a b) :=
if
not
(Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
(hash op1) (hash op2)) then
None
else
equal_contents_kind_list (contents (protocol_data op1))
(contents (protocol_data op2)).
src/proto_alpha/lib_protocol/parameters_repr.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type bootstrap_account = {
public_key_hash : Signature.Public_key_hash.t;
public_key : Signature.Public_key.t option;
amount : Tez_repr.t;
}
type bootstrap_contract = {
delegate : Signature.Public_key_hash.t;
amount : Tez_repr.t;
script : Script_repr.t;
}
type t = {
bootstrap_accounts : bootstrap_account list;
bootstrap_contracts : bootstrap_contract list;
commitments : Commitment_repr.t list;
constants : Constants_repr.parametric;
security_deposit_ramp_up_cycles : int option;
no_reward_cycles : int option;
}
let bootstrap_account_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Public_key_known"
(tup2 Signature.Public_key.encoding Tez_repr.encoding)
(function
| {public_key_hash; public_key = Some public_key; amount} ->
assert (
Signature.Public_key_hash.equal
(Signature.Public_key.hash public_key)
public_key_hash ) ;
Some (public_key, amount)
| {public_key = None} ->
None)
(fun (public_key, amount) ->
{
public_key = Some public_key;
public_key_hash = Signature.Public_key.hash public_key;
amount;
});
case
(Tag 1)
~title:"Public_key_unknown"
(tup2 Signature.Public_key_hash.encoding Tez_repr.encoding)
(function
| {public_key_hash; public_key = None; amount} ->
Some (public_key_hash, amount)
| {public_key = Some _} ->
None)
(fun (public_key_hash, amount) ->
{public_key = None; public_key_hash; amount}) ]
let bootstrap_contract_encoding =
let open Data_encoding in
conv
(fun {delegate; amount; script} -> (delegate, amount, script))
(fun (delegate, amount, script) -> {delegate; amount; script})
(obj3
(req "delegate" Signature.Public_key_hash.encoding)
(req "amount" Tez_repr.encoding)
(req "script" Script_repr.encoding))
let encoding =
let open Data_encoding in
conv
(fun { bootstrap_accounts;
bootstrap_contracts;
commitments;
constants;
security_deposit_ramp_up_cycles;
no_reward_cycles } ->
( ( bootstrap_accounts,
bootstrap_contracts,
commitments,
security_deposit_ramp_up_cycles,
no_reward_cycles ),
constants ))
(fun ( ( bootstrap_accounts,
bootstrap_contracts,
commitments,
security_deposit_ramp_up_cycles,
no_reward_cycles ),
constants ) ->
{
bootstrap_accounts;
bootstrap_contracts;
commitments;
constants;
security_deposit_ramp_up_cycles;
no_reward_cycles;
})
(merge_objs
(obj5
(req "bootstrap_accounts" (list bootstrap_account_encoding))
(dft "bootstrap_contracts" (list bootstrap_contract_encoding) [])
(dft "commitments" (list Commitment_repr.encoding) [])
(opt "security_deposit_ramp_up_cycles" int31)
(opt "no_reward_cycles" int31))
Constants_repr.parametric_encoding)
src/proto_alpha/lib_protocol/parameters_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Record bootstrap_account := {
public_key_hash :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
public_key :
option Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t;
amount : Tezos_raw_protocol_alpha.Tez_repr.t }.
Record bootstrap_contract := {
delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
amount : Tezos_raw_protocol_alpha.Tez_repr.t;
script : Tezos_raw_protocol_alpha.Script_repr.t }.
Record t := {
bootstrap_accounts : list bootstrap_account;
bootstrap_contracts : list bootstrap_contract;
commitments : list Tezos_raw_protocol_alpha.Commitment_repr.t;
constants : Tezos_raw_protocol_alpha.Constants_repr.parametric;
security_deposit_ramp_up_cycles : option Z;
no_reward_cycles : option Z }.
Definition bootstrap_account_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
bootstrap_account :=
union None
(cons
(case "Public_key_known" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
(tup2 Signature.Public_key.encoding Tez_repr.encoding)
(fun function_parameter =>
match function_parameter with
| {|
public_key_hash := public_key_hash;
public_key := Some public_key;
amount := amount
|} =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Signature.Public_key_hash.equal
(Signature.Public_key.hash public_key) public_key_hash) in
Some (public_key, amount)
| {| public_key := None |} => None
end)
(fun function_parameter =>
let '(public_key, amount) := function_parameter in
{| public_key_hash := Signature.Public_key.hash public_key;
public_key := Some public_key; amount := amount |}))
(cons
(case "Public_key_unknown" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
(tup2 Signature.Public_key_hash.encoding Tez_repr.encoding)
(fun function_parameter =>
match function_parameter with
| {|
public_key_hash := public_key_hash;
public_key := None;
amount := amount
|} => Some (public_key_hash, amount)
| {| public_key := Some _ |} => None
end)
(fun function_parameter =>
let '(public_key_hash, amount) := function_parameter in
{| public_key_hash := public_key_hash; public_key := None;
amount := amount |})) [])).
Definition bootstrap_contract_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
bootstrap_contract :=
conv
(fun function_parameter =>
let '{| delegate := delegate; amount := amount; script := script |} :=
function_parameter in
(delegate, amount, script))
(fun function_parameter =>
let '(delegate, amount, script) := function_parameter in
{| delegate := delegate; amount := amount; script := script |}) None
(obj3 (req None None "delegate" % string Signature.Public_key_hash.encoding)
(req None None "amount" % string Tez_repr.encoding)
(req None None "script" % string Script_repr.encoding)).
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
conv
(fun function_parameter =>
let '{|
bootstrap_accounts := bootstrap_accounts;
bootstrap_contracts := bootstrap_contracts;
commitments := commitments;
constants := constants;
security_deposit_ramp_up_cycles := security_deposit_ramp_up_cycles;
no_reward_cycles := no_reward_cycles
|} := function_parameter in
((bootstrap_accounts, bootstrap_contracts, commitments,
security_deposit_ramp_up_cycles, no_reward_cycles), constants))
(fun function_parameter =>
let
'((bootstrap_accounts, bootstrap_contracts, commitments,
security_deposit_ramp_up_cycles, no_reward_cycles), constants) :=
function_parameter in
{| bootstrap_accounts := bootstrap_accounts;
bootstrap_contracts := bootstrap_contracts; commitments := commitments;
constants := constants;
security_deposit_ramp_up_cycles := security_deposit_ramp_up_cycles;
no_reward_cycles := no_reward_cycles |}) None
(merge_objs
(obj5
(req None None "bootstrap_accounts" % string
(list None bootstrap_account_encoding))
(dft None None "bootstrap_contracts" % string
(list None bootstrap_contract_encoding) [])
(dft None None "commitments" % string
(list None Commitment_repr.encoding) [])
(opt None None "security_deposit_ramp_up_cycles" % string int31)
(opt None None "no_reward_cycles" % string int31))
Constants_repr.parametric_encoding).
src/proto_alpha/lib_protocol/period_repr.ml 15 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = Int64.t
type period = t
include (Compare.Int64 : Compare.S with type t := t)
let encoding = Data_encoding.int64
let rpc_arg = RPC_arg.int64
let pp ppf v = Format.fprintf ppf "%Ld" v
type error += (* `Permanent *)
Malformed_period | Invalid_arg
let () =
let open Data_encoding in
(* Malformed period *)
register_error_kind
`Permanent
~id:"malformed_period"
~title:"Malformed period"
~description:"Period is negative."
~pp:(fun ppf () -> Format.fprintf ppf "Malformed period")
empty
(function Malformed_period -> Some () | _ -> None)
(fun () -> Malformed_period) ;
(* Invalid arg *)
register_error_kind
`Permanent
~id:"invalid_arg"
~title:"Invalid arg"
~description:"Negative multiple of periods are not allowed."
~pp:(fun ppf () -> Format.fprintf ppf "Invalid arg")
empty
(function Invalid_arg -> Some () | _ -> None)
(fun () -> Invalid_arg)
let of_seconds t =
if Compare.Int64.(t >= 0L) then ok t else error Malformed_period
let to_seconds t = t
let of_seconds_exn t =
match of_seconds t with
| Ok t ->
t
| _ ->
invalid_arg "Period.of_seconds_exn"
let mult i p =
(* TODO check overflow *)
if Compare.Int32.(i < 0l) then error Invalid_arg
else ok (Int64.mul (Int64.of_int32 i) p)
let zero = of_seconds_exn 0L
let one_second = of_seconds_exn 1L
let one_minute = of_seconds_exn 60L
let one_hour = of_seconds_exn 3600L
src/proto_alpha/lib_protocol/period_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := Tezos_protocol_environment_alpha__Environment.Int64.t.
Definition period := t.
(* ❌ Structure item `include` not handled. *)
include
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int64 :=
Data_encoding.int64.
Definition rpc_arg
: Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int64 :=
RPC_arg.int64.
Definition pp
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
(v : int64) : unit :=
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int64
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
"%Ld" % string) v.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition of_seconds
(t :
Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
t
(* ❌ Constant of type int64 is converted to int *)
0 then
ok t
else
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Malformed_period.
Definition to_seconds {A : Type} (t : A) : A := t.
Definition of_seconds_exn
(t :
Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
match of_seconds t with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok t => t
| _ => invalid_arg "Period.of_seconds_exn" % string
end.
Definition mult
(i :
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(p : int64)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int64 :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
i
(* ❌ Constant of type int32 is converted to int *)
0 then
error Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arg
else
ok (Int64.mul (Int64.of_int32 i) p).
Definition zero
: Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
of_seconds_exn
(* ❌ Constant of type int64 is converted to int *)
0.
Definition one_second
: Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
of_seconds_exn
(* ❌ Constant of type int64 is converted to int *)
1.
Definition one_minute
: Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
of_seconds_exn
(* ❌ Constant of type int64 is converted to int *)
60.
Definition one_hour
: Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
of_seconds_exn
(* ❌ Constant of type int64 is converted to int *)
3600.
src/proto_alpha/lib_protocol/qty_repr.ml 9 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module type QTY = sig
val id : string
end
module type S = sig
type qty
type error +=
| Addition_overflow of qty * qty (* `Temporary *)
| Subtraction_underflow of qty * qty (* `Temporary *)
| Multiplication_overflow of qty * int64 (* `Temporary *)
| Negative_multiplicator of qty * int64 (* `Temporary *)
| Invalid_divisor of qty * int64
(* `Temporary *)
val id : string
val zero : qty
val one_mutez : qty
val one_cent : qty
val fifty_cents : qty
val one : qty
val ( -? ) : qty -> qty -> qty tzresult
val ( +? ) : qty -> qty -> qty tzresult
val ( *? ) : qty -> int64 -> qty tzresult
val ( /? ) : qty -> int64 -> qty tzresult
val to_mutez : qty -> int64
(** [of_mutez n] (micro tez) is None if n is negative *)
val of_mutez : int64 -> qty option
(** [of_mutez_exn n] fails if n is negative.
It should only be used at toplevel for constants. *)
val of_mutez_exn : int64 -> qty
(** It should only be used at toplevel for constants. *)
val add_exn : qty -> qty -> qty
(** It should only be used at toplevel for constants. *)
val mul_exn : qty -> int -> qty
val encoding : qty Data_encoding.t
val to_int64 : qty -> int64
include Compare.S with type t := qty
val pp : Format.formatter -> qty -> unit
val of_string : string -> qty option
val to_string : qty -> string
end
module Make (T : QTY) : S = struct
type qty = int64 (* invariant: positive *)
type error +=
| Addition_overflow of qty * qty (* `Temporary *)
| Subtraction_underflow of qty * qty (* `Temporary *)
| Multiplication_overflow of qty * int64 (* `Temporary *)
| Negative_multiplicator of qty * int64 (* `Temporary *)
| Invalid_divisor of qty * int64
(* `Temporary *)
include Compare.Int64
let zero = 0L
(* all other constant are defined from the value of one micro tez *)
let one_mutez = 1L
let one_cent = Int64.mul one_mutez 10_000L
let fifty_cents = Int64.mul one_cent 50L
(* 1 tez = 100 cents = 1_000_000 mutez *)
let one = Int64.mul one_cent 100L
let id = T.id
let of_string s =
let triplets = function
| hd :: tl ->
let len = String.length hd in
Compare.Int.(
len <= 3 && len > 0
&& List.for_all (fun s -> String.length s = 3) tl)
| [] ->
false
in
let integers s = triplets (String.split_on_char ',' s) in
let decimals s =
let l = String.split_on_char ',' s in
if Compare.Int.(List.length l > 2) then false else triplets (List.rev l)
in
let parse left right =
let remove_commas s = String.concat "" (String.split_on_char ',' s) in
let pad_to_six s =
let len = String.length s in
String.init 6 (fun i -> if Compare.Int.(i < len) then s.[i] else '0')
in
try
Some
(Int64.of_string
(remove_commas left ^ pad_to_six (remove_commas right)))
with _ -> None
in
match String.split_on_char '.' s with
| [left; right] ->
if String.contains s ',' then
if integers left && decimals right then parse left right else None
else if
Compare.Int.(String.length right > 0)
&& Compare.Int.(String.length right <= 6)
then parse left right
else None
| [left] ->
if (not (String.contains s ',')) || integers left then parse left ""
else None
| _ ->
None
let pp ppf amount =
let mult_int = 1_000_000L in
let rec left ppf amount =
let (d, r) = (Int64.(div amount 1000L), Int64.(rem amount 1000L)) in
if d > 0L then Format.fprintf ppf "%a%03Ld" left d r
else Format.fprintf ppf "%Ld" r
in
let right ppf amount =
let triplet ppf v =
if Compare.Int.(v mod 10 > 0) then Format.fprintf ppf "%03d" v
else if Compare.Int.(v mod 100 > 0) then
Format.fprintf ppf "%02d" (v / 10)
else Format.fprintf ppf "%d" (v / 100)
in
let (hi, lo) = (amount / 1000, amount mod 1000) in
if Compare.Int.(lo = 0) then Format.fprintf ppf "%a" triplet hi
else Format.fprintf ppf "%03d%a" hi triplet lo
in
let (ints, decs) =
(Int64.(div amount mult_int), Int64.(to_int (rem amount mult_int)))
in
Format.fprintf ppf "%a" left ints ;
if Compare.Int.(decs > 0) then Format.fprintf ppf ".%a" right decs
let to_string t = Format.asprintf "%a" pp t
let ( - ) t1 t2 = if t2 <= t1 then Some (Int64.sub t1 t2) else None
let ( -? ) t1 t2 =
match t1 - t2 with
| None ->
error (Subtraction_underflow (t1, t2))
| Some v ->
ok v
let ( +? ) t1 t2 =
let t = Int64.add t1 t2 in
if t < t1 then error (Addition_overflow (t1, t2)) else ok t
let ( *? ) t m =
let open Compare.Int64 in
let open Int64 in
let rec step cur pow acc =
if cur = 0L then ok acc
else
pow +? pow
>>? fun npow ->
if logand cur 1L = 1L then
acc +? pow >>? fun nacc -> step (shift_right_logical cur 1) npow nacc
else step (shift_right_logical cur 1) npow acc
in
if m < 0L then error (Negative_multiplicator (t, m))
else
match step m t 0L with
| Ok res ->
Ok res
| Error ([Addition_overflow _] as errs) ->
Error (Multiplication_overflow (t, m) :: errs)
| Error errs ->
Error errs
let ( /? ) t d =
if d <= 0L then error (Invalid_divisor (t, d)) else ok (Int64.div t d)
let add_exn t1 t2 =
let t = Int64.add t1 t2 in
if t <= 0L then invalid_arg "add_exn" else t
let mul_exn t m =
match t *? Int64.(of_int m) with
| Ok v ->
v
| Error _ ->
invalid_arg "mul_exn"
let of_mutez t = if t < 0L then None else Some t
let of_mutez_exn x =
match of_mutez x with None -> invalid_arg "Qty.of_mutez" | Some v -> v
let to_int64 t = t
let to_mutez t = t
let encoding =
let open Data_encoding in
check_size 10 (conv Z.of_int64 (Json.wrap_error Z.to_int64) n)
let () =
let open Data_encoding in
register_error_kind
`Temporary
~id:(T.id ^ ".addition_overflow")
~title:("Overflowing " ^ T.id ^ " addition")
~pp:(fun ppf (opa, opb) ->
Format.fprintf
ppf
"Overflowing addition of %a %s and %a %s"
pp
opa
T.id
pp
opb
T.id)
~description:("An addition of two " ^ T.id ^ " amounts overflowed")
(obj1 (req "amounts" (tup2 encoding encoding)))
(function Addition_overflow (a, b) -> Some (a, b) | _ -> None)
(fun (a, b) -> Addition_overflow (a, b)) ;
register_error_kind
`Temporary
~id:(T.id ^ ".subtraction_underflow")
~title:("Underflowing " ^ T.id ^ " subtraction")
~pp:(fun ppf (opa, opb) ->
Format.fprintf
ppf
"Underflowing subtraction of %a %s and %a %s"
pp
opa
T.id
pp
opb
T.id)
~description:("An subtraction of two " ^ T.id ^ " amounts underflowed")
(obj1 (req "amounts" (tup2 encoding encoding)))
(function Subtraction_underflow (a, b) -> Some (a, b) | _ -> None)
(fun (a, b) -> Subtraction_underflow (a, b)) ;
register_error_kind
`Temporary
~id:(T.id ^ ".multiplication_overflow")
~title:("Overflowing " ^ T.id ^ " multiplication")
~pp:(fun ppf (opa, opb) ->
Format.fprintf
ppf
"Overflowing multiplication of %a %s and %Ld"
pp
opa
T.id
opb)
~description:
("A multiplication of a " ^ T.id ^ " amount by an integer overflowed")
(obj2 (req "amount" encoding) (req "multiplicator" int64))
(function Multiplication_overflow (a, b) -> Some (a, b) | _ -> None)
(fun (a, b) -> Multiplication_overflow (a, b)) ;
register_error_kind
`Temporary
~id:(T.id ^ ".negative_multiplicator")
~title:("Negative " ^ T.id ^ " multiplicator")
~pp:(fun ppf (opa, opb) ->
Format.fprintf
ppf
"Multiplication of %a %s by negative integer %Ld"
pp
opa
T.id
opb)
~description:
("Multiplication of a " ^ T.id ^ " amount by a negative integer")
(obj2 (req "amount" encoding) (req "multiplicator" int64))
(function Negative_multiplicator (a, b) -> Some (a, b) | _ -> None)
(fun (a, b) -> Negative_multiplicator (a, b)) ;
register_error_kind
`Temporary
~id:(T.id ^ ".invalid_divisor")
~title:("Invalid " ^ T.id ^ " divisor")
~pp:(fun ppf (opa, opb) ->
Format.fprintf
ppf
"Division of %a %s by non positive integer %Ld"
pp
opa
T.id
opb)
~description:
("Multiplication of a " ^ T.id ^ " amount by a non positive integer")
(obj2 (req "amount" encoding) (req "divisor" int64))
(function Invalid_divisor (a, b) -> Some (a, b) | _ -> None)
(fun (a, b) -> Invalid_divisor (a, b))
end
src/proto_alpha/lib_protocol/qty_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module QTY.
Record signature := {
id : string;
}.
End QTY.
Module S.
Record signature {qty : Type} := {
qty := qty;
extensible_type;
id : string;
zero : qty;
one_mutez : qty;
one_cent : qty;
fifty_cents : qty;
one : qty;
op_minusquestion : qty ->
qty ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult qty;
op_plusquestion : qty ->
qty ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult qty;
op_starquestion : qty ->
int64 ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult qty;
op_divquestion : qty ->
int64 ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult qty;
to_mutez : qty -> int64;
of_mutez : int64 -> option qty;
of_mutez_exn : int64 -> qty;
add_exn : qty -> qty -> qty;
mul_exn : qty -> Z -> qty;
encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t qty;
to_int64 : qty -> int64;
include;
pp : Tezos_protocol_environment_alpha__Environment.Format.formatter ->
qty -> unit;
of_string : string -> option qty;
to_string : qty -> string;
}.
Arguments signature : clear implicits.
End S.
(* ❌ Functors are not handled. *)
functor
src/proto_alpha/lib_protocol/raw_context.ml 85 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Int_set = Set.Make (Compare.Int)
type t = {
context : Context.t;
constants : Constants_repr.parametric;
first_level : Raw_level_repr.t;
level : Level_repr.t;
predecessor_timestamp : Time.t;
timestamp : Time.t;
fitness : Int64.t;
deposits : Tez_repr.t Signature.Public_key_hash.Map.t;
included_endorsements : int;
allowed_endorsements :
(Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t;
fees : Tez_repr.t;
rewards : Tez_repr.t;
block_gas : Z.t;
operation_gas : Gas_limit_repr.t;
internal_gas : Gas_limit_repr.internal_gas;
storage_space_to_pay : Z.t option;
allocated_contracts : int option;
origination_nonce : Contract_repr.origination_nonce option;
temporary_big_map : Z.t;
internal_nonce : int;
internal_nonces_used : Int_set.t;
}
type context = t
type root_context = t
let current_level ctxt = ctxt.level
let predecessor_timestamp ctxt = ctxt.predecessor_timestamp
let current_timestamp ctxt = ctxt.timestamp
let current_fitness ctxt = ctxt.fitness
let first_level ctxt = ctxt.first_level
let constants ctxt = ctxt.constants
let recover ctxt = ctxt.context
let record_endorsement ctxt k =
match Signature.Public_key_hash.Map.find_opt k ctxt.allowed_endorsements with
| None ->
assert false
| Some (_, _, true) ->
assert false (* right already used *)
| Some (d, s, false) ->
{
ctxt with
included_endorsements = ctxt.included_endorsements + List.length s;
allowed_endorsements =
Signature.Public_key_hash.Map.add
k
(d, s, true)
ctxt.allowed_endorsements;
}
let init_endorsements ctxt allowed_endorsements =
if Signature.Public_key_hash.Map.is_empty allowed_endorsements then
assert false (* can't initialize to empty *)
else if Signature.Public_key_hash.Map.is_empty ctxt.allowed_endorsements then
{ctxt with allowed_endorsements}
else assert false
(* can't initialize twice *)
let allowed_endorsements ctxt = ctxt.allowed_endorsements
let included_endorsements ctxt = ctxt.included_endorsements
type error += Too_many_internal_operations (* `Permanent *)
let () =
let open Data_encoding in
register_error_kind
`Permanent
~id:"too_many_internal_operations"
~title:"Too many internal operations"
~description:
"A transaction exceeded the hard limit of internal operations it can emit"
empty
(function Too_many_internal_operations -> Some () | _ -> None)
(fun () -> Too_many_internal_operations)
let fresh_internal_nonce ctxt =
if Compare.Int.(ctxt.internal_nonce >= 65_535) then
error Too_many_internal_operations
else
ok
( {ctxt with internal_nonce = ctxt.internal_nonce + 1},
ctxt.internal_nonce )
let reset_internal_nonce ctxt =
{ctxt with internal_nonces_used = Int_set.empty; internal_nonce = 0}
let record_internal_nonce ctxt k =
{ctxt with internal_nonces_used = Int_set.add k ctxt.internal_nonces_used}
let internal_nonce_already_recorded ctxt k =
Int_set.mem k ctxt.internal_nonces_used
let set_current_fitness ctxt fitness = {ctxt with fitness}
let add_fees ctxt fees =
Lwt.return Tez_repr.(ctxt.fees +? fees)
>>=? fun fees -> return {ctxt with fees}
let add_rewards ctxt rewards =
Lwt.return Tez_repr.(ctxt.rewards +? rewards)
>>=? fun rewards -> return {ctxt with rewards}
let add_deposit ctxt delegate deposit =
let previous =
match Signature.Public_key_hash.Map.find_opt delegate ctxt.deposits with
| Some tz ->
tz
| None ->
Tez_repr.zero
in
Lwt.return Tez_repr.(previous +? deposit)
>>=? fun deposit ->
let deposits =
Signature.Public_key_hash.Map.add delegate deposit ctxt.deposits
in
return {ctxt with deposits}
let get_deposits ctxt = ctxt.deposits
let get_rewards ctxt = ctxt.rewards
let get_fees ctxt = ctxt.fees
type error += Undefined_operation_nonce (* `Permanent *)
let () =
let open Data_encoding in
register_error_kind
`Permanent
~id:"undefined_operation_nonce"
~title:"Ill timed access to the origination nonce"
~description:
"An origination was attemped out of the scope of a manager operation"
empty
(function Undefined_operation_nonce -> Some () | _ -> None)
(fun () -> Undefined_operation_nonce)
let init_origination_nonce ctxt operation_hash =
let origination_nonce =
Some (Contract_repr.initial_origination_nonce operation_hash)
in
{ctxt with origination_nonce}
let origination_nonce ctxt =
match ctxt.origination_nonce with
| None ->
error Undefined_operation_nonce
| Some origination_nonce ->
ok origination_nonce
let increment_origination_nonce ctxt =
match ctxt.origination_nonce with
| None ->
error Undefined_operation_nonce
| Some cur_origination_nonce ->
let origination_nonce =
Some (Contract_repr.incr_origination_nonce cur_origination_nonce)
in
ok ({ctxt with origination_nonce}, cur_origination_nonce)
let unset_origination_nonce ctxt = {ctxt with origination_nonce = None}
type error += Gas_limit_too_high (* `Permanent *)
let () =
let open Data_encoding in
register_error_kind
`Permanent
~id:"gas_limit_too_high"
~title:"Gas limit out of protocol hard bounds"
~description:"A transaction tried to exceed the hard limit on gas"
empty
(function Gas_limit_too_high -> Some () | _ -> None)
(fun () -> Gas_limit_too_high)
let check_gas_limit ctxt remaining =
if
Compare.Z.(remaining > ctxt.constants.hard_gas_limit_per_operation)
|| Compare.Z.(remaining < Z.zero)
then error Gas_limit_too_high
else ok ()
let set_gas_limit ctxt remaining =
{
ctxt with
operation_gas = Limited {remaining};
internal_gas = Gas_limit_repr.internal_gas_zero;
}
let set_gas_unlimited ctxt = {ctxt with operation_gas = Unaccounted}
let consume_gas ctxt cost =
Gas_limit_repr.consume
ctxt.block_gas
ctxt.operation_gas
ctxt.internal_gas
cost
>>? fun (block_gas, operation_gas, internal_gas) ->
ok {ctxt with block_gas; operation_gas; internal_gas}
let check_enough_gas ctxt cost =
Gas_limit_repr.check_enough
ctxt.block_gas
ctxt.operation_gas
ctxt.internal_gas
cost
let gas_level ctxt = ctxt.operation_gas
let block_gas_level ctxt = ctxt.block_gas
let gas_consumed ~since ~until =
match (gas_level since, gas_level until) with
| (Limited {remaining = before}, Limited {remaining = after}) ->
Z.sub before after
| (_, _) ->
Z.zero
let init_storage_space_to_pay ctxt =
match ctxt.storage_space_to_pay with
| Some _ ->
assert false
| None ->
{
ctxt with
storage_space_to_pay = Some Z.zero;
allocated_contracts = Some 0;
}
let update_storage_space_to_pay ctxt n =
match ctxt.storage_space_to_pay with
| None ->
assert false
| Some storage_space_to_pay ->
{ctxt with storage_space_to_pay = Some (Z.add n storage_space_to_pay)}
let update_allocated_contracts_count ctxt =
match ctxt.allocated_contracts with
| None ->
assert false
| Some allocated_contracts ->
{ctxt with allocated_contracts = Some (succ allocated_contracts)}
let clear_storage_space_to_pay ctxt =
match (ctxt.storage_space_to_pay, ctxt.allocated_contracts) with
| (None, _) | (_, None) ->
assert false
| (Some storage_space_to_pay, Some allocated_contracts) ->
( {ctxt with storage_space_to_pay = None; allocated_contracts = None},
storage_space_to_pay,
allocated_contracts )
type storage_error =
| Incompatible_protocol_version of string
| Missing_key of string list * [`Get | `Set | `Del | `Copy]
| Existing_key of string list
| Corrupted_data of string list
let storage_error_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Incompatible_protocol_version"
(obj1 (req "incompatible_protocol_version" string))
(function Incompatible_protocol_version arg -> Some arg | _ -> None)
(fun arg -> Incompatible_protocol_version arg);
case
(Tag 1)
~title:"Missing_key"
(obj2
(req "missing_key" (list string))
(req
"function"
(string_enum
[("get", `Get); ("set", `Set); ("del", `Del); ("copy", `Copy)])))
(function Missing_key (key, f) -> Some (key, f) | _ -> None)
(fun (key, f) -> Missing_key (key, f));
case
(Tag 2)
~title:"Existing_key"
(obj1 (req "existing_key" (list string)))
(function Existing_key key -> Some key | _ -> None)
(fun key -> Existing_key key);
case
(Tag 3)
~title:"Corrupted_data"
(obj1 (req "corrupted_data" (list string)))
(function Corrupted_data key -> Some key | _ -> None)
(fun key -> Corrupted_data key) ]
let pp_storage_error ppf = function
| Incompatible_protocol_version version ->
Format.fprintf
ppf
"Found a context with an unexpected version '%s'."
version
| Missing_key (key, `Get) ->
Format.fprintf ppf "Missing key '%s'." (String.concat "/" key)
| Missing_key (key, `Set) ->
Format.fprintf
ppf
"Cannot set undefined key '%s'."
(String.concat "/" key)
| Missing_key (key, `Del) ->
Format.fprintf
ppf
"Cannot delete undefined key '%s'."
(String.concat "/" key)
| Missing_key (key, `Copy) ->
Format.fprintf
ppf
"Cannot copy undefined key '%s'."
(String.concat "/" key)
| Existing_key key ->
Format.fprintf
ppf
"Cannot initialize defined key '%s'."
(String.concat "/" key)
| Corrupted_data key ->
Format.fprintf
ppf
"Failed to parse the data at '%s'."
(String.concat "/" key)
type error += Storage_error of storage_error
let () =
register_error_kind
`Permanent
~id:"context.storage_error"
~title:"Storage error (fatal internal error)"
~description:
"An error that should never happen unless something has been deleted or \
corrupted in the database."
~pp:(fun ppf err ->
Format.fprintf ppf "@[<v 2>Storage error:@ %a@]" pp_storage_error err)
storage_error_encoding
(function Storage_error err -> Some err | _ -> None)
(fun err -> Storage_error err)
let storage_error err = fail (Storage_error err)
(* Initialization *********************************************************)
(* This key should always be populated for every version of the
protocol. It's absence meaning that the context is empty. *)
let version_key = ["version"]
let version_value = "alpha_current"
let version = "v1"
let first_level_key = [version; "first_level"]
let constants_key = [version; "constants"]
let protocol_param_key = ["protocol_parameters"]
let get_first_level ctxt =
Context.get ctxt first_level_key
>>= function
| None ->
storage_error (Missing_key (first_level_key, `Get))
| Some bytes -> (
match Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes with
| None ->
storage_error (Corrupted_data first_level_key)
| Some level ->
return level )
let set_first_level ctxt level =
let bytes =
Data_encoding.Binary.to_bytes_exn Raw_level_repr.encoding level
in
Context.set ctxt first_level_key bytes >>= fun ctxt -> return ctxt
type error += Failed_to_parse_parameter of MBytes.t
type error += Failed_to_decode_parameter of Data_encoding.json * string
let () =
register_error_kind
`Temporary
~id:"context.failed_to_parse_parameter"
~title:"Failed to parse parameter"
~description:"The protocol parameters are not valid JSON."
~pp:(fun ppf bytes ->
Format.fprintf
ppf
"@[<v 2>Cannot parse the protocol parameter:@ %s@]"
(MBytes.to_string bytes))
Data_encoding.(obj1 (req "contents" bytes))
(function Failed_to_parse_parameter data -> Some data | _ -> None)
(fun data -> Failed_to_parse_parameter data) ;
register_error_kind
`Temporary
~id:"context.failed_to_decode_parameter"
~title:"Failed to decode parameter"
~description:"Unexpected JSON object."
~pp:(fun ppf (json, msg) ->
Format.fprintf
ppf
"@[<v 2>Cannot decode the protocol parameter:@ %s@ %a@]"
msg
Data_encoding.Json.pp
json)
Data_encoding.(obj2 (req "contents" json) (req "error" string))
(function
| Failed_to_decode_parameter (json, msg) -> Some (json, msg) | _ -> None)
(fun (json, msg) -> Failed_to_decode_parameter (json, msg))
let get_proto_param ctxt =
Context.get ctxt protocol_param_key
>>= function
| None ->
failwith "Missing protocol parameters."
| Some bytes -> (
match Data_encoding.Binary.of_bytes Data_encoding.json bytes with
| None ->
fail (Failed_to_parse_parameter bytes)
| Some json -> (
Context.del ctxt protocol_param_key
>>= fun ctxt ->
match Data_encoding.Json.destruct Parameters_repr.encoding json with
| exception (Data_encoding.Json.Cannot_destruct _ as exn) ->
Format.kasprintf
failwith
"Invalid protocol_parameters: %a %a"
(fun ppf -> Data_encoding.Json.print_error ppf)
exn
Data_encoding.Json.pp
json
| param ->
return (param, ctxt) ) )
let set_constants ctxt constants =
let bytes =
Data_encoding.Binary.to_bytes_exn
Constants_repr.parametric_encoding
constants
in
Context.set ctxt constants_key bytes
let get_constants ctxt =
Context.get ctxt constants_key
>>= function
| None ->
failwith "Internal error: cannot read constants in context."
| Some bytes -> (
match
Data_encoding.Binary.of_bytes Constants_repr.parametric_encoding bytes
with
| None ->
failwith "Internal error: cannot parse constants in context."
| Some constants ->
return constants )
let patch_constants ctxt f =
let constants = f ctxt.constants in
set_constants ctxt.context constants
>>= fun context -> Lwt.return {ctxt with context; constants}
let check_inited ctxt =
Context.get ctxt version_key
>>= function
| None ->
failwith "Internal error: un-initialized context."
| Some bytes ->
let s = MBytes.to_string bytes in
if Compare.String.(s = version_value) then return_unit
else storage_error (Incompatible_protocol_version s)
let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt =
Lwt.return (Raw_level_repr.of_int32 level)
>>=? fun level ->
Lwt.return (Fitness_repr.to_int64 fitness)
>>=? fun fitness ->
check_inited ctxt
>>=? fun () ->
get_constants ctxt
>>=? fun constants ->
get_first_level ctxt
>>=? fun first_level ->
let level =
Level_repr.from_raw
~first_level
~blocks_per_cycle:constants.Constants_repr.blocks_per_cycle
~blocks_per_voting_period:
constants.Constants_repr.blocks_per_voting_period
~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment
level
in
return
{
context = ctxt;
constants;
level;
predecessor_timestamp;
timestamp;
fitness;
first_level;
allowed_endorsements = Signature.Public_key_hash.Map.empty;
included_endorsements = 0;
fees = Tez_repr.zero;
rewards = Tez_repr.zero;
deposits = Signature.Public_key_hash.Map.empty;
operation_gas = Unaccounted;
internal_gas = Gas_limit_repr.internal_gas_zero;
storage_space_to_pay = None;
allocated_contracts = None;
block_gas = constants.Constants_repr.hard_gas_limit_per_block;
origination_nonce = None;
temporary_big_map = Z.sub Z.zero Z.one;
internal_nonce = 0;
internal_nonces_used = Int_set.empty;
}
type previous_protocol = Genesis of Parameters_repr.t | Alpha_previous
let check_and_update_protocol_version ctxt =
Context.get ctxt version_key
>>= (function
| None ->
failwith
"Internal error: un-initialized context in check_first_block."
| Some bytes ->
let s = MBytes.to_string bytes in
if Compare.String.(s = version_value) then
failwith "Internal error: previously initialized context."
else if Compare.String.(s = "genesis") then
get_proto_param ctxt
>>=? fun (param, ctxt) -> return (Genesis param, ctxt)
else if Compare.String.(s = "alpha_previous") then
return (Alpha_previous, ctxt)
else storage_error (Incompatible_protocol_version s))
>>=? fun (previous_proto, ctxt) ->
Context.set ctxt version_key (MBytes.of_string version_value)
>>= fun ctxt -> return (previous_proto, ctxt)
let prepare_first_block ~level ~timestamp ~fitness ctxt =
check_and_update_protocol_version ctxt
>>=? fun (previous_proto, ctxt) ->
( match previous_proto with
| Genesis param ->
Lwt.return (Raw_level_repr.of_int32 level)
>>=? fun first_level ->
set_first_level ctxt first_level
>>=? fun ctxt ->
set_constants ctxt param.constants >>= fun ctxt -> return ctxt
| Alpha_previous ->
return ctxt )
>>=? fun ctxt ->
prepare ctxt ~level ~predecessor_timestamp:timestamp ~timestamp ~fitness
>>=? fun ctxt -> return (previous_proto, ctxt)
let activate ({context = c; _} as s) h =
Updater.activate c h >>= fun c -> Lwt.return {s with context = c}
let fork_test_chain ({context = c; _} as s) protocol expiration =
Updater.fork_test_chain c ~protocol ~expiration
>>= fun c -> Lwt.return {s with context = c}
(* Generic context ********************************************************)
type key = string list
type value = MBytes.t
module type T = sig
type t
type context = t
val mem : context -> key -> bool Lwt.t
val dir_mem : context -> key -> bool Lwt.t
val get : context -> key -> value tzresult Lwt.t
val get_option : context -> key -> value option Lwt.t
val init : context -> key -> value -> context tzresult Lwt.t
val set : context -> key -> value -> context tzresult Lwt.t
val init_set : context -> key -> value -> context Lwt.t
val set_option : context -> key -> value option -> context Lwt.t
val delete : context -> key -> context tzresult Lwt.t
val remove : context -> key -> context Lwt.t
val remove_rec : context -> key -> context Lwt.t
val copy : context -> from:key -> to_:key -> context tzresult Lwt.t
val fold :
context ->
key ->
init:'a ->
f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
'a Lwt.t
val keys : context -> key -> key list Lwt.t
val fold_keys :
context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
val project : context -> root_context
val absolute_key : context -> key -> key
val consume_gas : context -> Gas_limit_repr.cost -> context tzresult
val check_enough_gas : context -> Gas_limit_repr.cost -> unit tzresult
val description : context Storage_description.t
end
let mem ctxt k = Context.mem ctxt.context k
let dir_mem ctxt k = Context.dir_mem ctxt.context k
let get ctxt k =
Context.get ctxt.context k
>>= function
| None -> storage_error (Missing_key (k, `Get)) | Some v -> return v
let get_option ctxt k = Context.get ctxt.context k
(* Verify that the k is present before modifying *)
let set ctxt k v =
Context.mem ctxt.context k
>>= function
| false ->
storage_error (Missing_key (k, `Set))
| true ->
Context.set ctxt.context k v
>>= fun context -> return {ctxt with context}
(* Verify that the k is not present before inserting *)
let init ctxt k v =
Context.mem ctxt.context k
>>= function
| true ->
storage_error (Existing_key k)
| false ->
Context.set ctxt.context k v
>>= fun context -> return {ctxt with context}
(* Does not verify that the key is present or not *)
let init_set ctxt k v =
Context.set ctxt.context k v
>>= fun context -> Lwt.return {ctxt with context}
(* Verify that the key is present before deleting *)
let delete ctxt k =
Context.mem ctxt.context k
>>= function
| false ->
storage_error (Missing_key (k, `Del))
| true ->
Context.del ctxt.context k >>= fun context -> return {ctxt with context}
(* Do not verify before deleting *)
let remove ctxt k =
Context.del ctxt.context k >>= fun context -> Lwt.return {ctxt with context}
let set_option ctxt k = function
| None ->
remove ctxt k
| Some v ->
init_set ctxt k v
let remove_rec ctxt k =
Context.remove_rec ctxt.context k
>>= fun context -> Lwt.return {ctxt with context}
let copy ctxt ~from ~to_ =
Context.copy ctxt.context ~from ~to_
>>= function
| None ->
storage_error (Missing_key (from, `Copy))
| Some context ->
return {ctxt with context}
let fold ctxt k ~init ~f = Context.fold ctxt.context k ~init ~f
let keys ctxt k = Context.keys ctxt.context k
let fold_keys ctxt k ~init ~f = Context.fold_keys ctxt.context k ~init ~f
let project x = x
let absolute_key _ k = k
let description = Storage_description.create ()
let fresh_temporary_big_map ctxt =
( {ctxt with temporary_big_map = Z.sub ctxt.temporary_big_map Z.one},
ctxt.temporary_big_map )
let reset_temporary_big_map ctxt =
{ctxt with temporary_big_map = Z.sub Z.zero Z.one}
let temporary_big_maps ctxt f acc =
let rec iter acc id =
if Z.equal id ctxt.temporary_big_map then Lwt.return acc
else f acc id >>= fun acc -> iter acc (Z.sub id Z.one)
in
iter acc (Z.sub Z.zero Z.one)
src/proto_alpha/lib_protocol/raw_context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
Record t := {
context : Tezos_protocol_environment_alpha__Environment.Context.t;
constants : Tezos_raw_protocol_alpha.Constants_repr.parametric;
first_level : Tezos_raw_protocol_alpha.Raw_level_repr.t;
level : Tezos_raw_protocol_alpha.Level_repr.t;
predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t;
timestamp : Tezos_protocol_environment_alpha__Environment.Time.t;
fitness : Tezos_protocol_environment_alpha__Environment.Int64.t;
deposits :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
Tezos_raw_protocol_alpha.Tez_repr.t;
included_endorsements : Z;
allowed_endorsements :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
(list Z) * bool);
fees : Tezos_raw_protocol_alpha.Tez_repr.t;
rewards : Tezos_raw_protocol_alpha.Tez_repr.t;
block_gas : Tezos_protocol_environment_alpha__Environment.Z.t;
operation_gas : Tezos_raw_protocol_alpha.Gas_limit_repr.t;
internal_gas : Tezos_raw_protocol_alpha.Gas_limit_repr.internal_gas;
storage_space_to_pay :
option Tezos_protocol_environment_alpha__Environment.Z.t;
allocated_contracts : option Z;
origination_nonce :
option Tezos_raw_protocol_alpha.Contract_repr.origination_nonce;
temporary_big_map : Tezos_protocol_environment_alpha__Environment.Z.t;
internal_nonce : Z;
internal_nonces_used :
Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.t) }.
Definition context := t.
Definition root_context := t.
Definition current_level (ctxt : t) : Tezos_raw_protocol_alpha.Level_repr.t :=
level ctxt.
Definition predecessor_timestamp (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Time.t :=
predecessor_timestamp ctxt.
Definition current_timestamp (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Time.t := timestamp ctxt.
Definition current_fitness (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Int64.t := fitness ctxt.
Definition first_level (ctxt : t) : Tezos_raw_protocol_alpha.Raw_level_repr.t :=
first_level ctxt.
Definition constants (ctxt : t)
: Tezos_raw_protocol_alpha.Constants_repr.parametric := constants ctxt.
Definition recover (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Context.t := context ctxt.
Definition record_endorsement
(ctxt : t)
(k :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.key)
: t :=
match Signature.Public_key_hash.Map.find_opt k (allowed_endorsements ctxt)
with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some (_, _, true) =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some (d, s, false) =>
(* ❌ Record substitution not handled *)
record_substitution
end.
Definition init_endorsements
(ctxt : t)
(allowed_endorsements :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
(list Z) * bool)) : t :=
if Signature.Public_key_hash.Map.is_empty allowed_endorsements then
(* ❌ Assert instruction is not handled. *)
assert false
else
if Signature.Public_key_hash.Map.is_empty (allowed_endorsements ctxt) then
(* ❌ Record substitution not handled *)
record_substitution
else
(* ❌ Assert instruction is not handled. *)
assert false.
Definition allowed_endorsements (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
(list Z) * bool) := allowed_endorsements ctxt.
Definition included_endorsements (ctxt : t) : Z := included_endorsements ctxt.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition fresh_internal_nonce (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (t * Z) :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
(internal_nonce ctxt) 65535 then
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Too_many_internal_operations
else
ok
((* ❌ Record substitution not handled *)
record_substitution, (internal_nonce ctxt)).
Definition reset_internal_nonce (ctxt : t) : t :=
(* ❌ Record substitution not handled *)
record_substitution.
Definition record_internal_nonce
(ctxt : t)
(k : Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.elt)) : t :=
(* ❌ Record substitution not handled *)
record_substitution.
Definition internal_nonce_already_recorded
(ctxt : t)
(k : Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.elt))
: bool :=
Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.mem) k
(internal_nonces_used ctxt).
Definition set_current_fitness
(ctxt : t) (fitness : Tezos_protocol_environment_alpha__Environment.Int64.t)
: t :=
(* ❌ Record substitution not handled *)
record_substitution.
Definition add_fees (ctxt : t) (fees : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
op_gtgteqquestion (Lwt._return (op_plusquestion (fees ctxt) fees))
(fun fees =>
_return
(* ❌ Record substitution not handled *)
record_substitution).
Definition add_rewards
(ctxt : t) (rewards : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
op_gtgteqquestion (Lwt._return (op_plusquestion (rewards ctxt) rewards))
(fun rewards =>
_return
(* ❌ Record substitution not handled *)
record_substitution).
Definition add_deposit
(ctxt : t)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.key)
(deposit : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
let previous :=
match Signature.Public_key_hash.Map.find_opt delegate (deposits ctxt) with
| Some tz => tz
| None => Tez_repr.zero
end in
op_gtgteqquestion (Lwt._return (op_plusquestion previous deposit))
(fun deposit =>
let deposits :=
Signature.Public_key_hash.Map.add delegate deposit (deposits ctxt) in
_return
(* ❌ Record substitution not handled *)
record_substitution).
Definition get_deposits (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
Tezos_raw_protocol_alpha.Tez_repr.t := deposits ctxt.
Definition get_rewards (ctxt : t) : Tezos_raw_protocol_alpha.Tez_repr.t :=
rewards ctxt.
Definition get_fees (ctxt : t) : Tezos_raw_protocol_alpha.Tez_repr.t :=
fees ctxt.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition init_origination_nonce
(ctxt : t)
(operation_hash :
Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
: t :=
let origination_nonce :=
Some (Contract_repr.initial_origination_nonce operation_hash) in
(* ❌ Record substitution not handled *)
record_substitution.
Definition origination_nonce (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Contract_repr.origination_nonce :=
match origination_nonce ctxt with
| None =>
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_operation_nonce
| Some origination_nonce => ok origination_nonce
end.
Definition increment_origination_nonce (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(t * Tezos_raw_protocol_alpha.Contract_repr.origination_nonce) :=
match origination_nonce ctxt with
| None =>
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_operation_nonce
| Some cur_origination_nonce =>
let origination_nonce :=
Some (Contract_repr.incr_origination_nonce cur_origination_nonce) in
ok
((* ❌ Record substitution not handled *)
record_substitution, cur_origination_nonce)
end.
Definition unset_origination_nonce (ctxt : t) : t :=
(* ❌ Record substitution not handled *)
record_substitution.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition check_gas_limit
(ctxt : t)
(remaining :
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
if
op_pipepipe
(Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
remaining (hard_gas_limit_per_operation (constants ctxt)))
(Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
remaining Z.zero) then
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_limit_too_high
else
ok tt.
Definition set_gas_limit
(ctxt : t) (remaining : Tezos_protocol_environment_alpha__Environment.Z.t)
: t :=
(* ❌ Record substitution not handled *)
record_substitution.
Definition set_gas_unlimited (ctxt : t) : t :=
(* ❌ Record substitution not handled *)
record_substitution.
Definition consume_gas
(ctxt : t) (cost : Tezos_raw_protocol_alpha.Gas_limit_repr.cost)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t :=
op_gtgtquestion
(Gas_limit_repr.consume (block_gas ctxt) (operation_gas ctxt)
(internal_gas ctxt) cost)
(fun function_parameter =>
let '(block_gas, operation_gas, internal_gas) := function_parameter in
ok
(* ❌ Record substitution not handled *)
record_substitution).
Definition check_enough_gas
(ctxt : t) (cost : Tezos_raw_protocol_alpha.Gas_limit_repr.cost)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
Gas_limit_repr.check_enough (block_gas ctxt) (operation_gas ctxt)
(internal_gas ctxt) cost.
Definition gas_level (ctxt : t) : Tezos_raw_protocol_alpha.Gas_limit_repr.t :=
operation_gas ctxt.
Definition block_gas_level (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Z.t := block_gas ctxt.
Definition gas_consumed (since : t) (until : t)
: Tezos_protocol_environment_alpha__Environment.Z.t :=
match ((gas_level since), (gas_level until)) with
|
(Tezos_raw_protocol_alpha.Gas_limit_repr.Limited {| remaining := before |},
Tezos_raw_protocol_alpha.Gas_limit_repr.Limited {| remaining := after |})
=> Z.sub before after
| (_, _) => Z.zero
end.
Definition init_storage_space_to_pay (ctxt : t) : t :=
match storage_space_to_pay ctxt with
| Some _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| None =>
(* ❌ Record substitution not handled *)
record_substitution
end.
Definition update_storage_space_to_pay
(ctxt : t) (n : Tezos_protocol_environment_alpha__Environment.Z.t) : t :=
match storage_space_to_pay ctxt with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some storage_space_to_pay =>
(* ❌ Record substitution not handled *)
record_substitution
end.
Definition update_allocated_contracts_count (ctxt : t) : t :=
match allocated_contracts ctxt with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some allocated_contracts =>
(* ❌ Record substitution not handled *)
record_substitution
end.
Definition clear_storage_space_to_pay (ctxt : t)
: t * Tezos_protocol_environment_alpha__Environment.Z.t * Z :=
match ((storage_space_to_pay ctxt), (allocated_contracts ctxt)) with
| (None, _) | (_, None) =>
(* ❌ Assert instruction is not handled. *)
assert false
| (Some storage_space_to_pay, Some allocated_contracts) =>
((* ❌ Record substitution not handled *)
record_substitution, storage_space_to_pay, allocated_contracts)
end.
Inductive storage_error : Type :=
| Incompatible_protocol_version : string -> storage_error
| Missing_key : (list string) -> variant -> storage_error
| Existing_key : (list string) -> storage_error
| Corrupted_data : (list string) -> storage_error.
Definition storage_error_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
storage_error :=
union None
(cons
(case "Incompatible_protocol_version" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
(obj1 (req None None "incompatible_protocol_version" % string string))
(fun function_parameter =>
match function_parameter with
| Incompatible_protocol_version arg => Some arg
| _ => None
end) (fun arg => Incompatible_protocol_version arg))
(cons
(case "Missing_key" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
(obj2 (req None None "missing_key" % string (list None string))
(req None None "function" % string
(string_enum
(cons
("get" % string,
(* ❌ Variants not supported *)
variant)
(cons
("set" % string,
(* ❌ Variants not supported *)
variant)
(cons
("del" % string,
(* ❌ Variants not supported *)
variant)
(cons
("copy" % string,
(* ❌ Variants not supported *)
variant) [])))))))
(fun function_parameter =>
match function_parameter with
| Missing_key key f => Some (key, f)
| _ => None
end)
(fun function_parameter =>
let '(key, f) := function_parameter in
Missing_key key f))
(cons
(case "Existing_key" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 2)
(obj1 (req None None "existing_key" % string (list None string)))
(fun function_parameter =>
match function_parameter with
| Existing_key key => Some key
| _ => None
end) (fun key => Existing_key key))
(cons
(case "Corrupted_data" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 3)
(obj1 (req None None "corrupted_data" % string (list None string)))
(fun function_parameter =>
match function_parameter with
| Corrupted_data key => Some key
| _ => None
end) (fun key => Corrupted_data key)) [])))).
Definition pp_storage_error
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
(function_parameter : storage_error) : unit :=
match function_parameter with
| Incompatible_protocol_version version =>
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"Found a context with an unexpected version '" % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"'." % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
"Found a context with an unexpected version '%s'." % string) version
| Missing_key key Get =>
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"Missing key '" % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"'." % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
"Missing key '%s'." % string) (String.concat "/" % string key)
| Missing_key key Set =>
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"Cannot set undefined key '" % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"'." % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
"Cannot set undefined key '%s'." % string)
(String.concat "/" % string key)
| Missing_key key Del =>
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"Cannot delete undefined key '" % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"'." % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
"Cannot delete undefined key '%s'." % string)
(String.concat "/" % string key)
| Missing_key key Copy =>
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"Cannot copy undefined key '" % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"'." % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
"Cannot copy undefined key '%s'." % string)
(String.concat "/" % string key)
| Existing_key key =>
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"Cannot initialize defined key '" % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"'." % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
"Cannot initialize defined key '%s'." % string)
(String.concat "/" % string key)
| Corrupted_data key =>
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"Failed to parse the data at '" % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"'." % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
"Failed to parse the data at '%s'." % string)
(String.concat "/" % string key)
end.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition storage_error {A : Type} (err : storage_error)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Storage_error err).
Definition version_key : list string := cons "version" % string [].
Definition version_value : string := "alpha_current" % string.
Definition version : string := "v1" % string.
Definition first_level_key : list string :=
cons version (cons "first_level" % string []).
Definition constants_key : list string :=
cons version (cons "constants" % string []).
Definition protocol_param_key : list string :=
cons "protocol_parameters" % string [].
Definition get_first_level
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_level_repr.raw_level) :=
op_gtgteq (Context.get ctxt first_level_key)
(fun function_parameter =>
match function_parameter with
| None =>
storage_error
(Missing_key first_level_key
(* ❌ Variants not supported *)
variant)
| Some bytes =>
match Data_encoding.Binary.of_bytes Raw_level_repr.encoding string with
| None => storage_error (Corrupted_data first_level_key)
| Some level => _return level
end
end).
Definition set_first_level
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
(level : Tezos_raw_protocol_alpha.Raw_level_repr.raw_level)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Context.t) :=
let bytes := Data_encoding.Binary.to_bytes_exn Raw_level_repr.encoding level
in
op_gtgteq (Context.set ctxt first_level_key string) (fun ctxt => _return ctxt).
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition get_proto_param
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Parameters_repr.t *
Tezos_protocol_environment_alpha__Environment.Context.t)) :=
op_gtgteq (Context.get ctxt protocol_param_key)
(fun function_parameter =>
match function_parameter with
| None => failwith "Missing protocol parameters." % string
| Some bytes =>
match Data_encoding.Binary.of_bytes Data_encoding.json string with
| None =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Failed_to_parse_parameter
string)
| Some json =>
op_gtgteq (Context.del ctxt protocol_param_key)
(fun ctxt =>
let 'param :=
Data_encoding.Json.destruct Parameters_repr.encoding json in
_return (param, ctxt))
end
end).
Definition set_constants
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
(constants : Tezos_raw_protocol_alpha.Constants_repr.parametric)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_protocol_environment_alpha__Environment.Context.t :=
let bytes :=
Data_encoding.Binary.to_bytes_exn Constants_repr.parametric_encoding
constants in
Context.set ctxt constants_key string.
Definition get_constants
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Constants_repr.parametric) :=
op_gtgteq (Context.get ctxt constants_key)
(fun function_parameter =>
match function_parameter with
| None =>
failwith "Internal error: cannot read constants in context." % string
| Some bytes =>
match
Data_encoding.Binary.of_bytes Constants_repr.parametric_encoding
string with
| None =>
failwith "Internal error: cannot parse constants in context." % string
| Some constants => _return constants
end
end).
Definition patch_constants
(ctxt : t)
(f :
Tezos_raw_protocol_alpha.Constants_repr.parametric ->
Tezos_raw_protocol_alpha.Constants_repr.parametric)
: Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
let constants := f (constants ctxt) in
op_gtgteq (set_constants (context ctxt) constants)
(fun context =>
Lwt._return
(* ❌ Record substitution not handled *)
record_substitution).
Definition check_inited
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
op_gtgteq (Context.get ctxt version_key)
(fun function_parameter =>
match function_parameter with
| None => failwith "Internal error: un-initialized context." % string
| Some bytes =>
let s := MBytes.to_string string in
if
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
s version_value then
return_unit
else
storage_error (Incompatible_protocol_version s)
end).
Definition prepare
(level : int32)
(predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
(timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
(fitness : list Tezos_protocol_environment_alpha__Environment.MBytes.t)
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
op_gtgteqquestion (Lwt._return (Raw_level_repr.of_int32 level))
(fun level =>
op_gtgteqquestion (Lwt._return (Fitness_repr.to_int64 fitness))
(fun fitness =>
op_gtgteqquestion (check_inited ctxt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (get_constants ctxt)
(fun constants =>
op_gtgteqquestion (get_first_level ctxt)
(fun first_level =>
let level :=
Level_repr.from_raw first_level
(Constants_repr.blocks_per_cycle constants)
(Constants_repr.blocks_per_voting_period constants)
(Constants_repr.blocks_per_commitment constants) level
in
_return
{| context := ctxt; constants := constants;
first_level := first_level; level := level;
predecessor_timestamp := predecessor_timestamp;
timestamp := timestamp; fitness := fitness;
deposits := Signature.Public_key_hash.Map.empty;
included_endorsements := 0;
allowed_endorsements :=
Signature.Public_key_hash.Map.empty;
fees := Tez_repr.zero; rewards := Tez_repr.zero;
block_gas :=
Constants_repr.hard_gas_limit_per_block constants;
operation_gas :=
Tezos_raw_protocol_alpha.Gas_limit_repr.Unaccounted;
internal_gas := Gas_limit_repr.internal_gas_zero;
storage_space_to_pay := None;
allocated_contracts := None;
origination_nonce := None;
temporary_big_map := Z.sub Z.zero Z.one;
internal_nonce := 0;
internal_nonces_used :=
Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.empty)
|}))))).
Inductive previous_protocol : Type :=
| Genesis : Tezos_raw_protocol_alpha.Parameters_repr.t -> previous_protocol
| Alpha_previous : previous_protocol.
Definition check_and_update_protocol_version
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(previous_protocol *
Tezos_protocol_environment_alpha__Environment.Context.t)) :=
op_gtgteqquestion
(op_gtgteq (Context.get ctxt version_key)
(fun function_parameter =>
match function_parameter with
| None =>
failwith
"Internal error: un-initialized context in check_first_block." %
string
| Some bytes =>
let s := MBytes.to_string string in
if
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
s version_value then
failwith "Internal error: previously initialized context." % string
else
if
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
s "genesis" % string then
op_gtgteqquestion (get_proto_param ctxt)
(fun function_parameter =>
let '(param, ctxt) := function_parameter in
_return ((Genesis param), ctxt))
else
if
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
s "alpha_previous" % string then
_return (Alpha_previous, ctxt)
else
storage_error (Incompatible_protocol_version s)
end))
(fun function_parameter =>
let '(previous_proto, ctxt) := function_parameter in
op_gtgteq (Context.set ctxt version_key (MBytes.of_string version_value))
(fun ctxt => _return (previous_proto, ctxt))).
Definition prepare_first_block
(level : int32)
(timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
(fitness : list Tezos_protocol_environment_alpha__Environment.MBytes.t)
(ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(previous_protocol * t)) :=
op_gtgteqquestion (check_and_update_protocol_version ctxt)
(fun function_parameter =>
let '(previous_proto, ctxt) := function_parameter in
op_gtgteqquestion
match previous_proto with
| Genesis param =>
op_gtgteqquestion (Lwt._return (Raw_level_repr.of_int32 level))
(fun first_level =>
op_gtgteqquestion (set_first_level ctxt first_level)
(fun ctxt =>
op_gtgteq (set_constants ctxt (constants param))
(fun ctxt => _return ctxt)))
| Alpha_previous => _return ctxt
end
(fun ctxt =>
op_gtgteqquestion (prepare level timestamp timestamp fitness ctxt)
(fun ctxt => _return (previous_proto, ctxt)))).
Definition activate (function_parameter : t)
: Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
-> Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
let '{| context := c |} as s := function_parameter in
fun h =>
op_gtgteq (Updater.activate c h)
(fun c =>
Lwt._return
(* ❌ Record substitution not handled *)
record_substitution).
Definition fork_test_chain (function_parameter : t)
: Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
->
Tezos_protocol_environment_alpha__Environment.Time.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
let '{| context := c |} as s := function_parameter in
fun protocol =>
fun expiration =>
op_gtgteq (Updater.fork_test_chain c protocol expiration)
(fun c =>
Lwt._return
(* ❌ Record substitution not handled *)
record_substitution).
Definition key := list string.
Definition value := Tezos_protocol_environment_alpha__Environment.MBytes.t.
Module T.
Record signature {t : Type} := {
t := t;
context := t;
mem : context ->
key -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
dir_mem : context ->
key -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
get : context ->
key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
value);
get_option : context ->
key -> Tezos_protocol_environment_alpha__Environment.Lwt.t (option value);
init : context ->
key ->
value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
context);
set : context ->
key ->
value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
context);
init_set : context ->
key ->
value -> Tezos_protocol_environment_alpha__Environment.Lwt.t context;
set_option : context ->
key ->
(option value) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t context;
delete : context ->
key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
context);
remove : context ->
key -> Tezos_protocol_environment_alpha__Environment.Lwt.t context;
remove_rec : context ->
key -> Tezos_protocol_environment_alpha__Environment.Lwt.t context;
copy : context ->
key ->
key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
context);
fold : forall {a variant : Type}, context ->
key ->
a ->
(variant -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a)
-> Tezos_protocol_environment_alpha__Environment.Lwt.t a;
keys : context ->
key -> Tezos_protocol_environment_alpha__Environment.Lwt.t (list key);
fold_keys : forall {a : Type}, context ->
key ->
a ->
(key -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t a;
project : context -> root_context;
absolute_key : context -> key -> key;
consume_gas : context ->
Tezos_raw_protocol_alpha.Gas_limit_repr.cost ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
context;
check_enough_gas : context ->
Tezos_raw_protocol_alpha.Gas_limit_repr.cost ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit;
description : Tezos_raw_protocol_alpha.Storage_description.t context;
}.
Arguments signature : clear implicits.
End T.
Definition mem
(ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
Context.mem (context ctxt) k.
Definition dir_mem
(ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
Context.dir_mem (context ctxt) k.
Definition get
(ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Context.value) :=
op_gtgteq (Context.get (context ctxt) k)
(fun function_parameter =>
match function_parameter with
| None =>
storage_error
(Missing_key k
(* ❌ Variants not supported *)
variant)
| Some v => _return v
end).
Definition get_option
(ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(option Tezos_protocol_environment_alpha__Environment.Context.value) :=
Context.get (context ctxt) k.
Definition set
(ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
(v : Tezos_protocol_environment_alpha__Environment.Context.value)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
op_gtgteq (Context.mem (context ctxt) k)
(fun function_parameter =>
match function_parameter with
| false =>
storage_error
(Missing_key k
(* ❌ Variants not supported *)
variant)
| true =>
op_gtgteq (Context.set (context ctxt) k v)
(fun context =>
_return
(* ❌ Record substitution not handled *)
record_substitution)
end).
Definition init
(ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
(v : Tezos_protocol_environment_alpha__Environment.Context.value)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
op_gtgteq (Context.mem (context ctxt) k)
(fun function_parameter =>
match function_parameter with
| true => storage_error (Existing_key k)
| false =>
op_gtgteq (Context.set (context ctxt) k v)
(fun context =>
_return
(* ❌ Record substitution not handled *)
record_substitution)
end).
Definition init_set
(ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
(v : Tezos_protocol_environment_alpha__Environment.Context.value)
: Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
op_gtgteq (Context.set (context ctxt) k v)
(fun context =>
Lwt._return
(* ❌ Record substitution not handled *)
record_substitution).
Definition delete
(ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
op_gtgteq (Context.mem (context ctxt) k)
(fun function_parameter =>
match function_parameter with
| false =>
storage_error
(Missing_key k
(* ❌ Variants not supported *)
variant)
| true =>
op_gtgteq (Context.del (context ctxt) k)
(fun context =>
_return
(* ❌ Record substitution not handled *)
record_substitution)
end).
Definition remove
(ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
op_gtgteq (Context.del (context ctxt) k)
(fun context =>
Lwt._return
(* ❌ Record substitution not handled *)
record_substitution).
Definition set_option
(ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
(function_parameter :
option Tezos_protocol_environment_alpha__Environment.Context.value)
: Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
match function_parameter with
| None => remove ctxt k
| Some v => init_set ctxt k v
end.
Definition remove_rec
(ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
op_gtgteq (Context.remove_rec (context ctxt) k)
(fun context =>
Lwt._return
(* ❌ Record substitution not handled *)
record_substitution).
Definition copy
(ctxt : t) (from : Tezos_protocol_environment_alpha__Environment.Context.key)
(to_ : Tezos_protocol_environment_alpha__Environment.Context.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
op_gtgteq (Context.copy (context ctxt) from to_)
(fun function_parameter =>
match function_parameter with
| None =>
storage_error
(Missing_key from
(* ❌ Variants not supported *)
variant)
| Some context =>
_return
(* ❌ Record substitution not handled *)
record_substitution
end).
Definition fold {A : Type}
(ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
(init : A)
(f : variant -> A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
Context.fold (context ctxt) k init f.
Definition keys
(ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(list Tezos_protocol_environment_alpha__Environment.Context.key) :=
Context.keys (context ctxt) k.
Definition fold_keys {A : Type}
(ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
(init : A)
(f :
Tezos_protocol_environment_alpha__Environment.Context.key ->
A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
Context.fold_keys (context ctxt) k init f.
Definition project {A : Type} (x : A) : A := x.
Definition absolute_key {A B : Type} (function_parameter : A) : B -> B :=
let '_ := function_parameter in
fun k => k.
Definition description {A : Type}
: Tezos_raw_protocol_alpha.Storage_description.t A :=
Storage_description.create tt.
Definition fresh_temporary_big_map (ctxt : t)
: t * Tezos_protocol_environment_alpha__Environment.Z.t :=
((* ❌ Record substitution not handled *)
record_substitution, (temporary_big_map ctxt)).
Definition reset_temporary_big_map (ctxt : t) : t :=
(* ❌ Record substitution not handled *)
record_substitution.
Definition temporary_big_maps {A : Type}
(ctxt : t)
(f :
A ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t A) (acc : A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
let fix iter
(acc : A) (id : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
if Z.equal id (temporary_big_map ctxt) then
Lwt._return acc
else
op_gtgteq (f acc id) (fun acc => iter acc (Z.sub id Z.one)) in
iter acc (Z.sub Z.zero Z.one).
src/proto_alpha/lib_protocol/raw_level_repr.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = int32
type raw_level = t
include (Compare.Int32 : Compare.S with type t := t)
let encoding = Data_encoding.int32
let pp ppf level = Format.fprintf ppf "%ld" level
let rpc_arg =
let construct raw_level = Int32.to_string raw_level in
let destruct str =
match Int32.of_string str with
| exception _ ->
Error "Cannot parse level"
| raw_level ->
Ok raw_level
in
RPC_arg.make
~descr:"A level integer"
~name:"block_level"
~construct
~destruct
()
let root = 0l
let succ = Int32.succ
let pred l = if l = 0l then None else Some (Int32.pred l)
let diff = Int32.sub
let to_int32 l = l
let of_int32_exn l =
if Compare.Int32.(l >= 0l) then l else invalid_arg "Level_repr.of_int32"
type error += Unexpected_level of Int32.t (* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"unexpected_level"
~title:"Unexpected level"
~description:"Level must be non-negative."
~pp:(fun ppf l ->
Format.fprintf
ppf
"The level is %s but should be non-negative."
(Int32.to_string l))
Data_encoding.(obj1 (req "level" int32))
(function Unexpected_level l -> Some l | _ -> None)
(fun l -> Unexpected_level l)
let of_int32 l = try Ok (of_int32_exn l) with _ -> error (Unexpected_level l)
module Index = struct
type t = raw_level
let path_length = 1
let to_path level l = Int32.to_string level :: l
let of_path = function
| [s] -> (
try Some (Int32.of_string s) with _ -> None )
| _ ->
None
let rpc_arg = rpc_arg
let encoding = encoding
let compare = compare
end
src/proto_alpha/lib_protocol/raw_level_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := int32.
Definition raw_level := t.
(* ❌ Structure item `include` not handled. *)
include
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
Data_encoding.int32.
Definition pp
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
(level : int32) : unit :=
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
"%ld" % string) level.
Definition rpc_arg
: Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 :=
let construct (raw_level : int32) : string :=
Int32.to_string raw_level in
let destruct (str : string)
: Tezos_protocol_environment_alpha__Environment.Pervasives.result int32
string :=
let 'raw_level := Int32.of_string str in
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok raw_level in
RPC_arg.make (Some "A level integer" % string) "block_level" % string destruct
construct tt.
Definition root : int32 :=
(* ❌ Constant of type int32 is converted to int *)
0.
Definition succ : int32 -> int32 := Int32.succ.
Definition pred (l : t) : option int32 :=
if
op_eq l
(* ❌ Constant of type int32 is converted to int *)
0 then
None
else
Some (Int32.pred l).
Definition diff : int32 -> int32 -> int32 := Int32.sub.
Definition to_int32 {A : Type} (l : A) : A := l.
Definition of_int32_exn
(l :
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
l
(* ❌ Constant of type int32 is converted to int *)
0 then
l
else
invalid_arg "Level_repr.of_int32" % string.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition of_int32
(l :
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Pervasives.result
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
(list Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
(* ❌ Try-with are not handled *)
try
(Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
(of_int32_exn l)).
Module Index.
Definition t := raw_level.
Definition path_length : Z := 1.
Definition to_path (level : int32) (l : list string) : list string :=
cons (Int32.to_string level) l.
Definition of_path (function_parameter : list string) : option int32 :=
match function_parameter with
| cons s [] =>
(* ❌ Try-with are not handled *)
try (Some (Int32.of_string s))
| _ => None
end.
Definition rpc_arg
: Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 := rpc_arg.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
encoding.
Definition compare : t -> t -> Z := compare.
End Index.
src/proto_alpha/lib_protocol/roll_repr.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Compare.Int32
type roll = t
let encoding = Data_encoding.int32
let first = 0l
let succ i = Int32.succ i
let random sequence ~bound = Seed_repr.take_int32 sequence bound
let rpc_arg = RPC_arg.like RPC_arg.int32 "roll"
let to_int32 v = v
module Index = struct
type t = roll
let path_length = 3
let to_path roll l =
(Int32.to_string @@ Int32.logand roll (Int32.of_int 0xff))
:: ( Int32.to_string
@@ Int32.logand (Int32.shift_right_logical roll 8) (Int32.of_int 0xff)
)
:: Int32.to_string roll :: l
let of_path = function
| _ :: _ :: s :: _ -> (
try Some (Int32.of_string s) with _ -> None )
| _ ->
None
let rpc_arg = rpc_arg
let encoding = encoding
let compare = compare
end
src/proto_alpha/lib_protocol/roll_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition roll := t.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
Data_encoding.int32.
Definition first : int32 :=
(* ❌ Constant of type int32 is converted to int *)
0.
Definition succ (i : int32) : int32 := Int32.succ i.
Definition random
(sequence : Tezos_raw_protocol_alpha.Seed_repr.sequence) (bound : int32)
: int32 * Tezos_raw_protocol_alpha.Seed_repr.sequence :=
Seed_repr.take_int32 sequence bound.
Definition rpc_arg
: Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 :=
RPC_arg.like RPC_arg.int32 None "roll" % string.
Definition to_int32 {A : Type} (v : A) : A := v.
Module Index.
Definition t := roll.
Definition path_length : Z := 3.
Definition to_path (roll : int32) (l : list string) : list string :=
cons (op_atat Int32.to_string (Int32.logand roll (Int32.of_int 255)))
(cons
(op_atat Int32.to_string
(Int32.logand (Int32.shift_right_logical roll 8) (Int32.of_int 255)))
(cons (Int32.to_string roll) l)).
Definition of_path (function_parameter : list string) : option int32 :=
match function_parameter with
| cons _ (cons _ (cons s _)) =>
(* ❌ Try-with are not handled *)
try (Some (Int32.of_string s))
| _ => None
end.
Definition rpc_arg
: Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 := rpc_arg.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
encoding.
Definition compare : t -> t -> Z := compare.
End Index.
src/proto_alpha/lib_protocol/roll_storage.ml 282 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Misc
type error +=
| Consume_roll_change (* `Permanent *)
| No_roll_for_delegate (* `Permanent *)
| No_roll_snapshot_for_cycle of Cycle_repr.t (* `Permanent *)
| Unregistered_delegate of Signature.Public_key_hash.t
(* `Permanent *)
let () =
let open Data_encoding in
(* Consume roll change *)
register_error_kind
`Permanent
~id:"contract.manager.consume_roll_change"
~title:"Consume roll change"
~description:"Change is not enough to consume a roll."
~pp:(fun ppf () ->
Format.fprintf ppf "Not enough change to consume a roll.")
empty
(function Consume_roll_change -> Some () | _ -> None)
(fun () -> Consume_roll_change) ;
(* No roll for delegate *)
register_error_kind
`Permanent
~id:"contract.manager.no_roll_for_delegate"
~title:"No roll for delegate"
~description:"Delegate has no roll."
~pp:(fun ppf () -> Format.fprintf ppf "Delegate has no roll.")
empty
(function No_roll_for_delegate -> Some () | _ -> None)
(fun () -> No_roll_for_delegate) ;
(* No roll snapshot for cycle *)
register_error_kind
`Permanent
~id:"contract.manager.no_roll_snapshot_for_cycle"
~title:"No roll snapshot for cycle"
~description:
"A snapshot of the rolls distribution does not exist for this cycle."
~pp:(fun ppf c ->
Format.fprintf
ppf
"A snapshot of the rolls distribution does not exist for cycle %a"
Cycle_repr.pp
c)
(obj1 (req "cycle" Cycle_repr.encoding))
(function No_roll_snapshot_for_cycle c -> Some c | _ -> None)
(fun c -> No_roll_snapshot_for_cycle c) ;
(* Unregistered delegate *)
register_error_kind
`Permanent
~id:"contract.manager.unregistered_delegate"
~title:"Unregistered delegate"
~description:"A contract cannot be delegated to an unregistered delegate"
~pp:(fun ppf k ->
Format.fprintf
ppf
"The provided public key (with hash %a) is not registered as valid \
delegate key."
Signature.Public_key_hash.pp
k)
(obj1 (req "hash" Signature.Public_key_hash.encoding))
(function Unregistered_delegate k -> Some k | _ -> None)
(fun k -> Unregistered_delegate k)
let get_contract_delegate c contract =
Storage.Contract.Delegate.get_option c contract
let delegate_pubkey ctxt delegate =
Storage.Contract.Manager.get_option
ctxt
(Contract_repr.implicit_contract delegate)
>>=? function
| None | Some (Manager_repr.Hash _) ->
fail (Unregistered_delegate delegate)
| Some (Manager_repr.Public_key pk) ->
return pk
let clear_cycle c cycle =
Storage.Roll.Snapshot_for_cycle.get c cycle
>>=? fun index ->
Storage.Roll.Snapshot_for_cycle.delete c cycle
>>=? fun c ->
Storage.Roll.Last_for_snapshot.delete (c, cycle) index
>>=? fun c ->
Storage.Roll.Owner.delete_snapshot c (cycle, index) >>= fun c -> return c
let fold ctxt ~f init =
Storage.Roll.Next.get ctxt
>>=? fun last ->
let rec loop ctxt roll acc =
acc
>>=? fun acc ->
if Roll_repr.(roll = last) then return acc
else
Storage.Roll.Owner.get_option ctxt roll
>>=? function
| None ->
loop ctxt (Roll_repr.succ roll) (return acc)
| Some delegate ->
loop ctxt (Roll_repr.succ roll) (f roll delegate acc)
in
loop ctxt Roll_repr.first (return init)
let snapshot_rolls_for_cycle ctxt cycle =
Storage.Roll.Snapshot_for_cycle.get ctxt cycle
>>=? fun index ->
Storage.Roll.Snapshot_for_cycle.set ctxt cycle (index + 1)
>>=? fun ctxt ->
Storage.Roll.Owner.snapshot ctxt (cycle, index)
>>=? fun ctxt ->
Storage.Roll.Next.get ctxt
>>=? fun last ->
Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index last
>>=? fun ctxt -> return ctxt
let freeze_rolls_for_cycle ctxt cycle =
Storage.Roll.Snapshot_for_cycle.get ctxt cycle
>>=? fun max_index ->
Storage.Seed.For_cycle.get ctxt cycle
>>=? fun seed ->
let rd = Seed_repr.initialize_new seed [MBytes.of_string "roll_snapshot"] in
let seq = Seed_repr.sequence rd 0l in
let selected_index =
Seed_repr.take_int32 seq (Int32.of_int max_index) |> fst |> Int32.to_int
in
Storage.Roll.Snapshot_for_cycle.set ctxt cycle selected_index
>>=? fun ctxt ->
fold_left_s
(fun ctxt index ->
if Compare.Int.(index = selected_index) then return ctxt
else
Storage.Roll.Owner.delete_snapshot ctxt (cycle, index)
>>= fun ctxt ->
Storage.Roll.Last_for_snapshot.delete (ctxt, cycle) index
>>=? fun ctxt -> return ctxt)
ctxt
Misc.(0 --> (max_index - 1))
>>=? fun ctxt -> return ctxt
(* Roll selection *)
module Random = struct
let int32_to_bytes i =
let b = MBytes.create 4 in
MBytes.set_int32 b 0 i ; b
let level_random seed use level =
let position = level.Level_repr.cycle_position in
Seed_repr.initialize_new
seed
[MBytes.of_string ("level " ^ use ^ ":"); int32_to_bytes position]
let owner c kind level offset =
let cycle = level.Level_repr.cycle in
Seed_storage.for_cycle c cycle
>>=? fun random_seed ->
let rd = level_random random_seed kind level in
let sequence = Seed_repr.sequence rd (Int32.of_int offset) in
Storage.Roll.Snapshot_for_cycle.get c cycle
>>=? fun index ->
Storage.Roll.Last_for_snapshot.get (c, cycle) index
>>=? fun bound ->
let rec loop sequence =
let (roll, sequence) = Roll_repr.random sequence ~bound in
Storage.Roll.Owner.Snapshot.get_option c ((cycle, index), roll)
>>=? function None -> loop sequence | Some delegate -> return delegate
in
Storage.Roll.Owner.snapshot_exists c (cycle, index)
>>= fun snapshot_exists ->
fail_unless snapshot_exists (No_roll_snapshot_for_cycle cycle)
>>=? fun () -> loop sequence
end
let baking_rights_owner c level ~priority =
Random.owner c "baking" level priority
let endorsement_rights_owner c level ~slot =
Random.owner c "endorsement" level slot
let traverse_rolls ctxt head =
let rec loop acc roll =
Storage.Roll.Successor.get_option ctxt roll
>>=? function
| None -> return (List.rev acc) | Some next -> loop (next :: acc) next
in
loop [head] head
let get_rolls ctxt delegate =
Storage.Roll.Delegate_roll_list.get_option ctxt delegate
>>=? function
| None -> return_nil | Some head_roll -> traverse_rolls ctxt head_roll
let count_rolls ctxt delegate =
Storage.Roll.Delegate_roll_list.get_option ctxt delegate
>>=? function
| None ->
return 0
| Some head_roll ->
let rec loop acc roll =
Storage.Roll.Successor.get_option ctxt roll
>>=? function None -> return acc | Some next -> loop (succ acc) next
in
loop 1 head_roll
let get_change c delegate =
Storage.Roll.Delegate_change.get_option c delegate
>>=? function None -> return Tez_repr.zero | Some change -> return change
module Delegate = struct
let fresh_roll c =
Storage.Roll.Next.get c
>>=? fun roll ->
Storage.Roll.Next.set c (Roll_repr.succ roll) >>=? fun c -> return (roll, c)
let get_limbo_roll c =
Storage.Roll.Limbo.get_option c
>>=? function
| None ->
fresh_roll c
>>=? fun (roll, c) ->
Storage.Roll.Limbo.init c roll >>=? fun c -> return (roll, c)
| Some roll ->
return (roll, c)
let consume_roll_change c delegate =
let tokens_per_roll = Constants_storage.tokens_per_roll c in
Storage.Roll.Delegate_change.get c delegate
>>=? fun change ->
trace Consume_roll_change (Lwt.return Tez_repr.(change -? tokens_per_roll))
>>=? fun new_change ->
Storage.Roll.Delegate_change.set c delegate new_change
let recover_roll_change c delegate =
let tokens_per_roll = Constants_storage.tokens_per_roll c in
Storage.Roll.Delegate_change.get c delegate
>>=? fun change ->
Lwt.return Tez_repr.(change +? tokens_per_roll)
>>=? fun new_change ->
Storage.Roll.Delegate_change.set c delegate new_change
let pop_roll_from_delegate c delegate =
recover_roll_change c delegate
>>=? fun c ->
(* beginning:
delegate : roll -> successor_roll -> ...
limbo : limbo_head -> ...
*)
Storage.Roll.Limbo.get_option c
>>=? fun limbo_head ->
Storage.Roll.Delegate_roll_list.get_option c delegate
>>=? function
| None ->
fail No_roll_for_delegate
| Some roll ->
Storage.Roll.Owner.delete c roll
>>=? fun c ->
Storage.Roll.Successor.get_option c roll
>>=? fun successor_roll ->
Storage.Roll.Delegate_roll_list.set_option c delegate successor_roll
>>= fun c ->
(* delegate : successor_roll -> ...
roll ------^
limbo : limbo_head -> ... *)
Storage.Roll.Successor.set_option c roll limbo_head
>>= fun c ->
(* delegate : successor_roll -> ...
roll ------v
limbo : limbo_head -> ... *)
Storage.Roll.Limbo.init_set c roll
>>= fun c ->
(* delegate : successor_roll -> ...
limbo : roll -> limbo_head -> ... *)
return (roll, c)
let create_roll_in_delegate c delegate delegate_pk =
consume_roll_change c delegate
>>=? fun c ->
(* beginning:
delegate : delegate_head -> ...
limbo : roll -> limbo_successor -> ...
*)
Storage.Roll.Delegate_roll_list.get_option c delegate
>>=? fun delegate_head ->
get_limbo_roll c
>>=? fun (roll, c) ->
Storage.Roll.Owner.init c roll delegate_pk
>>=? fun c ->
Storage.Roll.Successor.get_option c roll
>>=? fun limbo_successor ->
Storage.Roll.Limbo.set_option c limbo_successor
>>= fun c ->
(* delegate : delegate_head -> ...
roll ------v
limbo : limbo_successor -> ... *)
Storage.Roll.Successor.set_option c roll delegate_head
>>= fun c ->
(* delegate : delegate_head -> ...
roll ------^
limbo : limbo_successor -> ... *)
Storage.Roll.Delegate_roll_list.init_set c delegate roll
>>= fun c ->
(* delegate : roll -> delegate_head -> ...
limbo : limbo_successor -> ... *)
return c
let ensure_inited c delegate =
Storage.Roll.Delegate_change.mem c delegate
>>= function
| true ->
return c
| false ->
Storage.Roll.Delegate_change.init c delegate Tez_repr.zero
let is_inactive c delegate =
Storage.Contract.Inactive_delegate.mem
c
(Contract_repr.implicit_contract delegate)
>>= fun inactive ->
if inactive then return inactive
else
Storage.Contract.Delegate_desactivation.get_option
c
(Contract_repr.implicit_contract delegate)
>>=? function
| Some last_active_cycle ->
let {Level_repr.cycle = current_cycle} =
Raw_context.current_level c
in
return Cycle_repr.(last_active_cycle < current_cycle)
| None ->
(* This case is only when called from `set_active`, when creating
a contract. *)
return_false
let add_amount c delegate amount =
ensure_inited c delegate
>>=? fun c ->
let tokens_per_roll = Constants_storage.tokens_per_roll c in
Storage.Roll.Delegate_change.get c delegate
>>=? fun change ->
Lwt.return Tez_repr.(amount +? change)
>>=? fun change ->
Storage.Roll.Delegate_change.set c delegate change
>>=? fun c ->
delegate_pubkey c delegate
>>=? fun delegate_pk ->
let rec loop c change =
if Tez_repr.(change < tokens_per_roll) then return c
else
Lwt.return Tez_repr.(change -? tokens_per_roll)
>>=? fun change ->
create_roll_in_delegate c delegate delegate_pk
>>=? fun c -> loop c change
in
is_inactive c delegate
>>=? fun inactive ->
if inactive then return c
else
loop c change
>>=? fun c ->
Storage.Roll.Delegate_roll_list.get_option c delegate
>>=? fun rolls ->
match rolls with
| None ->
return c
| Some _ ->
Storage.Active_delegates_with_rolls.add c delegate
>>= fun c -> return c
let remove_amount c delegate amount =
let tokens_per_roll = Constants_storage.tokens_per_roll c in
let rec loop c change =
if Tez_repr.(amount <= change) then return (c, change)
else
pop_roll_from_delegate c delegate
>>=? fun (_, c) ->
Lwt.return Tez_repr.(change +? tokens_per_roll)
>>=? fun change -> loop c change
in
Storage.Roll.Delegate_change.get c delegate
>>=? fun change ->
is_inactive c delegate
>>=? fun inactive ->
( if inactive then return (c, change)
else
loop c change
>>=? fun (c, change) ->
Storage.Roll.Delegate_roll_list.get_option c delegate
>>=? fun rolls ->
match rolls with
| None ->
Storage.Active_delegates_with_rolls.del c delegate
>>= fun c -> return (c, change)
| Some _ ->
return (c, change) )
>>=? fun (c, change) ->
Lwt.return Tez_repr.(change -? amount)
>>=? fun change -> Storage.Roll.Delegate_change.set c delegate change
let set_inactive ctxt delegate =
ensure_inited ctxt delegate
>>=? fun ctxt ->
let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in
Storage.Roll.Delegate_change.get ctxt delegate
>>=? fun change ->
Storage.Contract.Inactive_delegate.add
ctxt
(Contract_repr.implicit_contract delegate)
>>= fun ctxt ->
Storage.Active_delegates_with_rolls.del ctxt delegate
>>= fun ctxt ->
let rec loop ctxt change =
Storage.Roll.Delegate_roll_list.get_option ctxt delegate
>>=? function
| None ->
return (ctxt, change)
| Some _roll ->
pop_roll_from_delegate ctxt delegate
>>=? fun (_, ctxt) ->
Lwt.return Tez_repr.(change +? tokens_per_roll)
>>=? fun change -> loop ctxt change
in
loop ctxt change
>>=? fun (ctxt, change) ->
Storage.Roll.Delegate_change.set ctxt delegate change
>>=? fun ctxt -> return ctxt
let set_active ctxt delegate =
is_inactive ctxt delegate
>>=? fun inactive ->
let current_cycle = (Raw_context.current_level ctxt).cycle in
let preserved_cycles = Constants_storage.preserved_cycles ctxt in
(* When the delegate is new or inactive, she will become active in
`1+preserved_cycles`, and we allow `preserved_cycles` for the
delegate to start baking. When the delegate is active, we only
give her at least `preserved_cycles` after the current cycle
before to be deactivated. *)
Storage.Contract.Delegate_desactivation.get_option
ctxt
(Contract_repr.implicit_contract delegate)
>>=? fun current_expiration ->
let expiration =
match current_expiration with
| None ->
Cycle_repr.add current_cycle (1 + (2 * preserved_cycles))
| Some current_expiration ->
let delay =
if inactive then 1 + (2 * preserved_cycles)
else 1 + preserved_cycles
in
let updated = Cycle_repr.add current_cycle delay in
Cycle_repr.max current_expiration updated
in
Storage.Contract.Delegate_desactivation.init_set
ctxt
(Contract_repr.implicit_contract delegate)
expiration
>>= fun ctxt ->
if not inactive then return ctxt
else
ensure_inited ctxt delegate
>>=? fun ctxt ->
let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in
Storage.Roll.Delegate_change.get ctxt delegate
>>=? fun change ->
Storage.Contract.Inactive_delegate.del
ctxt
(Contract_repr.implicit_contract delegate)
>>= fun ctxt ->
delegate_pubkey ctxt delegate
>>=? fun delegate_pk ->
let rec loop ctxt change =
if Tez_repr.(change < tokens_per_roll) then return ctxt
else
Lwt.return Tez_repr.(change -? tokens_per_roll)
>>=? fun change ->
create_roll_in_delegate ctxt delegate delegate_pk
>>=? fun ctxt -> loop ctxt change
in
loop ctxt change
>>=? fun ctxt ->
Storage.Roll.Delegate_roll_list.get_option ctxt delegate
>>=? fun rolls ->
match rolls with
| None ->
return ctxt
| Some _ ->
Storage.Active_delegates_with_rolls.add ctxt delegate
>>= fun ctxt -> return ctxt
end
module Contract = struct
let add_amount c contract amount =
get_contract_delegate c contract
>>=? function
| None -> return c | Some delegate -> Delegate.add_amount c delegate amount
let remove_amount c contract amount =
get_contract_delegate c contract
>>=? function
| None ->
return c
| Some delegate ->
Delegate.remove_amount c delegate amount
end
let init ctxt = Storage.Roll.Next.init ctxt Roll_repr.first
let init_first_cycles ctxt =
let preserved = Constants_storage.preserved_cycles ctxt in
(* Precompute rolls for cycle (0 --> preserved_cycles) *)
List.fold_left
(fun ctxt c ->
ctxt
>>=? fun ctxt ->
let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in
Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
>>=? fun ctxt ->
snapshot_rolls_for_cycle ctxt cycle
>>=? fun ctxt -> freeze_rolls_for_cycle ctxt cycle)
(return ctxt)
(0 --> preserved)
>>=? fun ctxt ->
let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 1)) in
(* Precomputed a snapshot for cycle (preserved_cycles + 1) *)
Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
>>=? fun ctxt ->
snapshot_rolls_for_cycle ctxt cycle
>>=? fun ctxt ->
(* Prepare storage for storing snapshots for cycle (preserved_cycles+2) *)
let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 2)) in
Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
>>=? fun ctxt -> return ctxt
let snapshot_rolls ctxt =
let current_level = Raw_context.current_level ctxt in
let preserved = Constants_storage.preserved_cycles ctxt in
let cycle = Cycle_repr.add current_level.cycle (preserved + 2) in
snapshot_rolls_for_cycle ctxt cycle
let cycle_end ctxt last_cycle =
let preserved = Constants_storage.preserved_cycles ctxt in
( match Cycle_repr.sub last_cycle preserved with
| None ->
return ctxt
| Some cleared_cycle ->
clear_cycle ctxt cleared_cycle )
>>=? fun ctxt ->
let frozen_roll_cycle = Cycle_repr.add last_cycle (preserved + 1) in
freeze_rolls_for_cycle ctxt frozen_roll_cycle
>>=? fun ctxt ->
Storage.Roll.Snapshot_for_cycle.init
ctxt
(Cycle_repr.succ (Cycle_repr.succ frozen_roll_cycle))
0
>>=? fun ctxt -> return ctxt
let update_tokens_per_roll ctxt new_tokens_per_roll =
let constants = Raw_context.constants ctxt in
let old_tokens_per_roll = constants.tokens_per_roll in
Raw_context.patch_constants ctxt (fun constants ->
{constants with Constants_repr.tokens_per_roll = new_tokens_per_roll})
>>= fun ctxt ->
let decrease = Tez_repr.(new_tokens_per_roll < old_tokens_per_roll) in
( if decrease then
Lwt.return Tez_repr.(old_tokens_per_roll -? new_tokens_per_roll)
else Lwt.return Tez_repr.(new_tokens_per_roll -? old_tokens_per_roll) )
>>=? fun abs_diff ->
Storage.Delegates.fold ctxt (Ok ctxt) (fun pkh ctxt ->
Lwt.return ctxt
>>=? fun ctxt ->
count_rolls ctxt pkh
>>=? fun rolls ->
Lwt.return Tez_repr.(abs_diff *? Int64.of_int rolls)
>>=? fun amount ->
if decrease then Delegate.add_amount ctxt pkh amount
else Delegate.remove_amount ctxt pkh amount)
src/proto_alpha/lib_protocol/roll_storage.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Misc.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition get_contract_delegate
(c : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option Tezos_raw_protocol_alpha.Storage.Contract.Delegate.value)) :=
Storage.Contract.Delegate.get_option c contract.
Definition delegate_pubkey
(ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t) :=
op_gtgteqquestion
(Storage.Contract.Manager.get_option ctxt
(Contract_repr.implicit_contract delegate))
(fun function_parameter =>
match function_parameter with
| None | Some (Tezos_raw_protocol_alpha.Manager_repr.Hash _) =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unregistered_delegate
delegate)
| Some (Tezos_raw_protocol_alpha.Manager_repr.Public_key pk) => _return pk
end).
Definition clear_cycle
(c : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.context)
(cycle : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.get c cycle)
(fun index =>
op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.delete c cycle)
(fun c =>
op_gtgteqquestion
(Storage.Roll.Last_for_snapshot.delete (c, cycle) index)
(fun c =>
op_gtgteq (Storage.Roll.Owner.delete_snapshot c (cycle, index))
(fun c => _return c)))).
Definition fold {A : Type}
(ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Next.context)
(f :
Tezos_raw_protocol_alpha.Roll_repr.roll ->
Tezos_raw_protocol_alpha.Storage.Roll.Owner.value ->
A ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
A)) (init : A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
op_gtgteqquestion (Storage.Roll.Next.get ctxt)
(fun last =>
let fix loop
(ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Owner.context) (roll :
Tezos_raw_protocol_alpha.Roll_repr.roll) (acc :
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
op_gtgteqquestion acc
(fun acc =>
if op_eq roll last then
_return acc
else
op_gtgteqquestion (Storage.Roll.Owner.get_option ctxt roll)
(fun function_parameter =>
match function_parameter with
| None => loop ctxt (Roll_repr.succ roll) (_return acc)
| Some delegate =>
loop ctxt (Roll_repr.succ roll) (f roll delegate acc)
end)) in
loop ctxt Roll_repr.first (_return init)).
Definition snapshot_rolls_for_cycle
(ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.context)
(cycle : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.get ctxt cycle)
(fun index =>
op_gtgteqquestion
(Storage.Roll.Snapshot_for_cycle.set ctxt cycle (op_plus index 1))
(fun ctxt =>
op_gtgteqquestion (Storage.Roll.Owner.snapshot ctxt (cycle, index))
(fun ctxt =>
op_gtgteqquestion (Storage.Roll.Next.get ctxt)
(fun last =>
op_gtgteqquestion
(Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index
last) (fun ctxt => _return ctxt))))).
Definition freeze_rolls_for_cycle
(ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.context)
(cycle : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Roll.Owner.context) :=
op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.get ctxt cycle)
(fun max_index =>
op_gtgteqquestion (Storage.Seed.For_cycle.get ctxt cycle)
(fun seed =>
let rd :=
Seed_repr.initialize_new seed
(cons (MBytes.of_string "roll_snapshot" % string) []) in
let seq :=
Seed_repr.sequence rd
(* ❌ Constant of type int32 is converted to int *)
0 in
let selected_index :=
op_pipegt
(op_pipegt (Seed_repr.take_int32 seq (Int32.of_int max_index)) fst)
Int32.to_int in
op_gtgteqquestion
(Storage.Roll.Snapshot_for_cycle.set ctxt cycle selected_index)
(fun ctxt =>
op_gtgteqquestion
(fold_left_s
(fun ctxt =>
fun index =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
index selected_index then
_return ctxt
else
op_gtgteq
(Storage.Roll.Owner.delete_snapshot ctxt
(cycle, index))
(fun ctxt =>
op_gtgteqquestion
(Storage.Roll.Last_for_snapshot.delete
(ctxt, cycle) index) (fun ctxt => _return ctxt)))
ctxt (op_minusminusgt 0 (op_minus max_index 1)))
(fun ctxt => _return ctxt)))).
Module Random.
Definition int32_to_bytes (i : int32)
: Tezos_protocol_environment_alpha__Environment.MBytes.t :=
let b := MBytes.create 4 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := MBytes.set_int32 b 0 i in
b.
Definition level_random
(seed : Tezos_raw_protocol_alpha.Seed_repr.seed) (use : string)
(level : Tezos_raw_protocol_alpha.Level_repr.t)
: Tezos_raw_protocol_alpha.Seed_repr.t :=
let position := Level_repr.cycle_position level in
Seed_repr.initialize_new seed
(cons
(MBytes.of_string
(op_caret "level " % string (op_caret use ":" % string)))
(cons (int32_to_bytes position) [])).
Definition owner
(c : Tezos_raw_protocol_alpha.Raw_context.t) (kind : string)
(level : Tezos_raw_protocol_alpha.Level_repr.t) (offset : Z)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Roll.Owner.Snapshot.value) :=
let cycle := Level_repr.cycle level in
op_gtgteqquestion (Seed_storage.for_cycle c cycle)
(fun random_seed =>
let rd := level_random random_seed kind level in
let sequence := Seed_repr.sequence rd (Int32.of_int offset) in
op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.get c cycle)
(fun index =>
op_gtgteqquestion
(Storage.Roll.Last_for_snapshot.get (c, cycle) index)
(fun bound =>
let fix loop
(sequence : Tezos_raw_protocol_alpha.Seed_repr.sequence)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Roll.Owner.Snapshot.value) :=
let '(roll, sequence) := Roll_repr.random sequence bound in
op_gtgteqquestion
(Storage.Roll.Owner.Snapshot.get_option c
((cycle, index), roll))
(fun function_parameter =>
match function_parameter with
| None => loop sequence
| Some delegate => _return delegate
end) in
op_gtgteq (Storage.Roll.Owner.snapshot_exists c (cycle, index))
(fun snapshot_exists =>
op_gtgteqquestion
(fail_unless snapshot_exists
(Tezos_protocol_environment_alpha__Environment.Error_monad.No_roll_snapshot_for_cycle
cycle))
(fun function_parameter =>
let 'tt := function_parameter in
loop sequence))))).
End Random.
Definition baking_rights_owner
(c : Tezos_raw_protocol_alpha.Raw_context.t)
(level : Tezos_raw_protocol_alpha.Level_repr.t) (priority : Z)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Roll.Owner.Snapshot.value) :=
Random.owner c "baking" % string level priority.
Definition endorsement_rights_owner
(c : Tezos_raw_protocol_alpha.Raw_context.t)
(level : Tezos_raw_protocol_alpha.Level_repr.t) (slot : Z)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Roll.Owner.Snapshot.value) :=
Random.owner c "endorsement" % string level slot.
Definition traverse_rolls
(ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Successor.context)
(head : Tezos_raw_protocol_alpha.Storage.Roll.Successor.value)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list Tezos_raw_protocol_alpha.Storage.Roll.Successor.value)) :=
let fix loop
(acc : list Tezos_raw_protocol_alpha.Storage.Roll.Successor.value) (roll :
Tezos_raw_protocol_alpha.Storage.Roll.Successor.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list Tezos_raw_protocol_alpha.Storage.Roll.Successor.value)) :=
op_gtgteqquestion (Storage.Roll.Successor.get_option ctxt roll)
(fun function_parameter =>
match function_parameter with
| None => _return (List.rev acc)
| Some next => loop (cons next acc) next
end) in
loop (cons head []) head.
Definition get_rolls
(ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.context)
(delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list Tezos_raw_protocol_alpha.Storage.Roll.Successor.value)) :=
op_gtgteqquestion (Storage.Roll.Delegate_roll_list.get_option ctxt delegate)
(fun function_parameter =>
match function_parameter with
| None => return_nil
| Some head_roll => traverse_rolls ctxt head_roll
end).
Definition count_rolls
(ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.context)
(delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
op_gtgteqquestion (Storage.Roll.Delegate_roll_list.get_option ctxt delegate)
(fun function_parameter =>
match function_parameter with
| None => _return 0
| Some head_roll =>
let fix loop
(acc : Z) (roll : Tezos_raw_protocol_alpha.Storage.Roll.Successor.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Z) :=
op_gtgteqquestion (Storage.Roll.Successor.get_option ctxt roll)
(fun function_parameter =>
match function_parameter with
| None => _return acc
| Some next => loop (succ acc) next
end) in
loop 1 head_roll
end).
Definition get_change
(c : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context)
(delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Tez_repr.t) :=
op_gtgteqquestion (Storage.Roll.Delegate_change.get_option c delegate)
(fun function_parameter =>
match function_parameter with
| None => _return Tez_repr.zero
| Some change => _return change
end).
Module Delegate.
Definition fresh_roll (c : Tezos_raw_protocol_alpha.Storage.Roll.Next.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Storage.Roll.Next.value *
Tezos_raw_protocol_alpha.Raw_context.t)) :=
op_gtgteqquestion (Storage.Roll.Next.get c)
(fun roll =>
op_gtgteqquestion (Storage.Roll.Next.set c (Roll_repr.succ roll))
(fun c => _return (roll, c))).
Definition get_limbo_roll
(c : Tezos_raw_protocol_alpha.Storage.Roll.Limbo.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Storage.Roll.Next.value *
Tezos_raw_protocol_alpha.Raw_context.t)) :=
op_gtgteqquestion (Storage.Roll.Limbo.get_option c)
(fun function_parameter =>
match function_parameter with
| None =>
op_gtgteqquestion (fresh_roll c)
(fun function_parameter =>
let '(roll, c) := function_parameter in
op_gtgteqquestion (Storage.Roll.Limbo.init c roll)
(fun c => _return (roll, c)))
| Some roll => _return (roll, c)
end).
Definition consume_roll_change
(c : Tezos_raw_protocol_alpha.Raw_context.context)
(delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let tokens_per_roll := Constants_storage.tokens_per_roll c in
op_gtgteqquestion (Storage.Roll.Delegate_change.get c delegate)
(fun change =>
op_gtgteqquestion
(trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Consume_roll_change
(Lwt._return (op_minusquestion change tokens_per_roll)))
(fun new_change =>
Storage.Roll.Delegate_change.set c delegate new_change)).
Definition recover_roll_change
(c : Tezos_raw_protocol_alpha.Raw_context.context)
(delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let tokens_per_roll := Constants_storage.tokens_per_roll c in
op_gtgteqquestion (Storage.Roll.Delegate_change.get c delegate)
(fun change =>
op_gtgteqquestion (Lwt._return (op_plusquestion change tokens_per_roll))
(fun new_change =>
Storage.Roll.Delegate_change.set c delegate new_change)).
Definition pop_roll_from_delegate
(c : Tezos_raw_protocol_alpha.Raw_context.context)
(delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.value *
Tezos_raw_protocol_alpha.Raw_context.t)) :=
op_gtgteqquestion (recover_roll_change c delegate)
(fun c =>
op_gtgteqquestion (Storage.Roll.Limbo.get_option c)
(fun limbo_head =>
op_gtgteqquestion
(Storage.Roll.Delegate_roll_list.get_option c delegate)
(fun function_parameter =>
match function_parameter with
| None =>
fail
Tezos_protocol_environment_alpha__Environment.Error_monad.No_roll_for_delegate
| Some roll =>
op_gtgteqquestion (Storage.Roll.Owner.delete c roll)
(fun c =>
op_gtgteqquestion
(Storage.Roll.Successor.get_option c roll)
(fun successor_roll =>
op_gtgteq
(Storage.Roll.Delegate_roll_list.set_option c
delegate successor_roll)
(fun c =>
op_gtgteq
(Storage.Roll.Successor.set_option c roll
limbo_head)
(fun c =>
op_gtgteq (Storage.Roll.Limbo.init_set c roll)
(fun c => _return (roll, c))))))
end))).
Definition create_roll_in_delegate
(c : Tezos_raw_protocol_alpha.Raw_context.context)
(delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
(delegate_pk : Tezos_raw_protocol_alpha.Storage.Roll.Owner.value)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteqquestion (consume_roll_change c delegate)
(fun c =>
op_gtgteqquestion
(Storage.Roll.Delegate_roll_list.get_option c delegate)
(fun delegate_head =>
op_gtgteqquestion (get_limbo_roll c)
(fun function_parameter =>
let '(roll, c) := function_parameter in
op_gtgteqquestion (Storage.Roll.Owner.init c roll delegate_pk)
(fun c =>
op_gtgteqquestion (Storage.Roll.Successor.get_option c roll)
(fun limbo_successor =>
op_gtgteq
(Storage.Roll.Limbo.set_option c limbo_successor)
(fun c =>
op_gtgteq
(Storage.Roll.Successor.set_option c roll
delegate_head)
(fun c =>
op_gtgteq
(Storage.Roll.Delegate_roll_list.init_set c
delegate roll) (fun c => _return c)))))))).
Definition ensure_inited
(c : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context)
(delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context) :=
op_gtgteq (Storage.Roll.Delegate_change.mem c delegate)
(fun function_parameter =>
match function_parameter with
| true => _return c
| false => Storage.Roll.Delegate_change.init c delegate Tez_repr.zero
end).
Definition is_inactive
(c : Tezos_raw_protocol_alpha.Storage.Contract.Inactive_delegate.context)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
op_gtgteq
(Storage.Contract.Inactive_delegate.mem c
(Contract_repr.implicit_contract delegate))
(fun inactive =>
if inactive then
_return inactive
else
op_gtgteqquestion
(Storage.Contract.Delegate_desactivation.get_option c
(Contract_repr.implicit_contract delegate))
(fun function_parameter =>
match function_parameter with
| Some last_active_cycle =>
let '{| Level_repr.cycle := current_cycle |} :=
Raw_context.current_level c in
_return (op_lt last_active_cycle current_cycle)
| None => return_false
end)).
Definition add_amount
(c : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context)
(delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
(amount : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteqquestion (ensure_inited c delegate)
(fun c =>
let tokens_per_roll := Constants_storage.tokens_per_roll c in
op_gtgteqquestion (Storage.Roll.Delegate_change.get c delegate)
(fun change =>
op_gtgteqquestion (Lwt._return (op_plusquestion amount change))
(fun change =>
op_gtgteqquestion
(Storage.Roll.Delegate_change.set c delegate change)
(fun c =>
op_gtgteqquestion (delegate_pubkey c delegate)
(fun delegate_pk =>
let fix loop
(c : Tezos_raw_protocol_alpha.Raw_context.context)
(change : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.context) :=
if op_lt change tokens_per_roll then
_return c
else
op_gtgteqquestion
(Lwt._return
(op_minusquestion change tokens_per_roll))
(fun change =>
op_gtgteqquestion
(create_roll_in_delegate c delegate
delegate_pk) (fun c => loop c change)) in
op_gtgteqquestion (is_inactive c delegate)
(fun inactive =>
if inactive then
_return c
else
op_gtgteqquestion (loop c change)
(fun c =>
op_gtgteqquestion
(Storage.Roll.Delegate_roll_list.get_option
c delegate)
(fun rolls =>
match rolls with
| None => _return c
| Some _ =>
op_gtgteq
(Storage.Active_delegates_with_rolls.add
c delegate) (fun c => _return c)
end)))))))).
Definition remove_amount
(c : Tezos_raw_protocol_alpha.Raw_context.context)
(delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
(amount : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let tokens_per_roll := Constants_storage.tokens_per_roll c in
let fix loop
(c : Tezos_raw_protocol_alpha.Raw_context.context) (change :
Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.context *
Tezos_raw_protocol_alpha.Tez_repr.t)) :=
if op_lteq amount change then
_return (c, change)
else
op_gtgteqquestion (pop_roll_from_delegate c delegate)
(fun function_parameter =>
let '(_, c) := function_parameter in
op_gtgteqquestion
(Lwt._return (op_plusquestion change tokens_per_roll))
(fun change => loop c change)) in
op_gtgteqquestion (Storage.Roll.Delegate_change.get c delegate)
(fun change =>
op_gtgteqquestion (is_inactive c delegate)
(fun inactive =>
op_gtgteqquestion
(if inactive then
_return (c, change)
else
op_gtgteqquestion (loop c change)
(fun function_parameter =>
let '(c, change) := function_parameter in
op_gtgteqquestion
(Storage.Roll.Delegate_roll_list.get_option c delegate)
(fun rolls =>
match rolls with
| None =>
op_gtgteq
(Storage.Active_delegates_with_rolls.del c delegate)
(fun c => _return (c, change))
| Some _ => _return (c, change)
end)))
(fun function_parameter =>
let '(c, change) := function_parameter in
op_gtgteqquestion (Lwt._return (op_minusquestion change amount))
(fun change =>
Storage.Roll.Delegate_change.set c delegate change)))).
Definition set_inactive
(ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context)
(delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteqquestion (ensure_inited ctxt delegate)
(fun ctxt =>
let tokens_per_roll := Constants_storage.tokens_per_roll ctxt in
op_gtgteqquestion (Storage.Roll.Delegate_change.get ctxt delegate)
(fun change =>
op_gtgteq
(Storage.Contract.Inactive_delegate.add ctxt
(Contract_repr.implicit_contract delegate))
(fun ctxt =>
op_gtgteq
(Storage.Active_delegates_with_rolls.del ctxt delegate)
(fun ctxt =>
let fix loop
(ctxt :
Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.context)
(change : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.context
* Tezos_raw_protocol_alpha.Tez_repr.t)) :=
op_gtgteqquestion
(Storage.Roll.Delegate_roll_list.get_option ctxt
delegate)
(fun function_parameter =>
match function_parameter with
| None => _return (ctxt, change)
| Some _roll =>
op_gtgteqquestion
(pop_roll_from_delegate ctxt delegate)
(fun function_parameter =>
let '(_, ctxt) := function_parameter in
op_gtgteqquestion
(Lwt._return
(op_plusquestion change tokens_per_roll))
(fun change => loop ctxt change))
end) in
op_gtgteqquestion (loop ctxt change)
(fun function_parameter =>
let '(ctxt, change) := function_parameter in
op_gtgteqquestion
(Storage.Roll.Delegate_change.set ctxt delegate change)
(fun ctxt => _return ctxt)))))).
Definition set_active
(ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Inactive_delegate.context)
(delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteqquestion (is_inactive ctxt delegate)
(fun inactive =>
let current_cycle := cycle (Raw_context.current_level ctxt) in
let preserved_cycles := Constants_storage.preserved_cycles ctxt in
op_gtgteqquestion
(Storage.Contract.Delegate_desactivation.get_option ctxt
(Contract_repr.implicit_contract delegate))
(fun current_expiration =>
let expiration :=
match current_expiration with
| None =>
Cycle_repr.add current_cycle
(op_plus 1 (op_star 2 preserved_cycles))
| Some current_expiration =>
let delay :=
if inactive then
op_plus 1 (op_star 2 preserved_cycles)
else
op_plus 1 preserved_cycles in
let updated := Cycle_repr.add current_cycle delay in
Cycle_repr.max current_expiration updated
end in
op_gtgteq
(Storage.Contract.Delegate_desactivation.init_set ctxt
(Contract_repr.implicit_contract delegate) expiration)
(fun ctxt =>
if not inactive then
_return ctxt
else
op_gtgteqquestion (ensure_inited ctxt delegate)
(fun ctxt =>
let tokens_per_roll :=
Constants_storage.tokens_per_roll ctxt in
op_gtgteqquestion
(Storage.Roll.Delegate_change.get ctxt delegate)
(fun change =>
op_gtgteq
(Storage.Contract.Inactive_delegate.del ctxt
(Contract_repr.implicit_contract delegate))
(fun ctxt =>
op_gtgteqquestion (delegate_pubkey ctxt delegate)
(fun delegate_pk =>
let fix loop
(ctxt :
Tezos_raw_protocol_alpha.Raw_context.context)
(change :
Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.context) :=
if op_lt change tokens_per_roll then
_return ctxt
else
op_gtgteqquestion
(Lwt._return
(op_minusquestion change
tokens_per_roll))
(fun change =>
op_gtgteqquestion
(create_roll_in_delegate ctxt
delegate delegate_pk)
(fun ctxt => loop ctxt change)) in
op_gtgteqquestion (loop ctxt change)
(fun ctxt =>
op_gtgteqquestion
(Storage.Roll.Delegate_roll_list.get_option
ctxt delegate)
(fun rolls =>
match rolls with
| None => _return ctxt
| Some _ =>
op_gtgteq
(Storage.Active_delegates_with_rolls.add
ctxt delegate)
(fun ctxt => _return ctxt)
end))))))))).
End Delegate.
Module Contract.
Definition add_amount
(c : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.key)
(amount : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context) :=
op_gtgteqquestion (get_contract_delegate c contract)
(fun function_parameter =>
match function_parameter with
| None => _return c
| Some delegate => Delegate.add_amount c delegate amount
end).
Definition remove_amount
(c : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context)
(contract : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.key)
(amount : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context) :=
op_gtgteqquestion (get_contract_delegate c contract)
(fun function_parameter =>
match function_parameter with
| None => _return c
| Some delegate => Delegate.remove_amount c delegate amount
end).
End Contract.
Definition init (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Next.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
Storage.Roll.Next.init ctxt Roll_repr.first.
Definition init_first_cycles
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let preserved := Constants_storage.preserved_cycles ctxt in
op_gtgteqquestion
(List.fold_left
(fun ctxt =>
fun c =>
op_gtgteqquestion ctxt
(fun ctxt =>
let cycle := Cycle_repr.of_int32_exn (Int32.of_int c) in
op_gtgteqquestion
(Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0)
(fun ctxt =>
op_gtgteqquestion (snapshot_rolls_for_cycle ctxt cycle)
(fun ctxt => freeze_rolls_for_cycle ctxt cycle))))
(_return ctxt) (op_minusminusgt 0 preserved))
(fun ctxt =>
let cycle := Cycle_repr.of_int32_exn (Int32.of_int (op_plus preserved 1))
in
op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0)
(fun ctxt =>
op_gtgteqquestion (snapshot_rolls_for_cycle ctxt cycle)
(fun ctxt =>
let cycle :=
Cycle_repr.of_int32_exn (Int32.of_int (op_plus preserved 2)) in
op_gtgteqquestion
(Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0)
(fun ctxt => _return ctxt)))).
Definition snapshot_rolls (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let current_level := Raw_context.current_level ctxt in
let preserved := Constants_storage.preserved_cycles ctxt in
let cycle := Cycle_repr.add (cycle current_level) (op_plus preserved 2) in
snapshot_rolls_for_cycle ctxt cycle.
Definition cycle_end
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
(last_cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let preserved := Constants_storage.preserved_cycles ctxt in
op_gtgteqquestion
match Cycle_repr.sub last_cycle preserved with
| None => _return ctxt
| Some cleared_cycle => clear_cycle ctxt cleared_cycle
end
(fun ctxt =>
let frozen_roll_cycle := Cycle_repr.add last_cycle (op_plus preserved 1)
in
op_gtgteqquestion (freeze_rolls_for_cycle ctxt frozen_roll_cycle)
(fun ctxt =>
op_gtgteqquestion
(Storage.Roll.Snapshot_for_cycle.init ctxt
(Cycle_repr.succ (Cycle_repr.succ frozen_roll_cycle)) 0)
(fun ctxt => _return ctxt))).
Definition update_tokens_per_roll
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
(new_tokens_per_roll : Tezos_raw_protocol_alpha.Tez_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.context) :=
let constants := Raw_context.constants ctxt in
let old_tokens_per_roll := tokens_per_roll constants in
op_gtgteq
(Raw_context.patch_constants ctxt
(fun constants =>
(* ❌ Record substitution not handled *)
record_substitution))
(fun ctxt =>
let decrease := op_lt new_tokens_per_roll old_tokens_per_roll in
op_gtgteqquestion
(if decrease then
Lwt._return (op_minusquestion old_tokens_per_roll new_tokens_per_roll)
else
Lwt._return (op_minusquestion new_tokens_per_roll old_tokens_per_roll))
(fun abs_diff =>
Storage.Delegates.fold ctxt
(Tezos_protocol_environment_alpha__Environment.Pervasives.Ok ctxt)
(fun pkh =>
fun ctxt =>
op_gtgteqquestion (Lwt._return ctxt)
(fun ctxt =>
op_gtgteqquestion (count_rolls ctxt pkh)
(fun rolls =>
op_gtgteqquestion
(Lwt._return
(op_starquestion abs_diff (Int64.of_int rolls)))
(fun amount =>
if decrease then
Delegate.add_amount ctxt pkh amount
else
Delegate.remove_amount ctxt pkh amount)))))).
src/proto_alpha/lib_protocol/script_expr_hash.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let script_expr_hash = "\013\044\064\027" (* expr(54) *)
include Blake2B.Make
(Base58)
(struct
let name = "script_expr"
let title = "A script expression ID"
let b58check_prefix = script_expr_hash
let size = None
end)
let () = Base58.check_encoded_prefix b58check_encoding "expr" 54
src/proto_alpha/lib_protocol/script_expr_hash.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. Definition script_expr_hash : string := " ,@" % string. (* ❌ Structure item `include` not handled. *) include
src/proto_alpha/lib_protocol/script_int_repr.ml 10 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type n = Natural_tag
type z = Integer_tag
type 't num = Z.t
let compare x y = Z.compare x y
let zero = Z.zero
let zero_n = Z.zero
let to_string x = Z.to_string x
let of_string s = try Some (Z.of_string s) with _ -> None
let to_int64 x = try Some (Z.to_int64 x) with _ -> None
let of_int64 n = Z.of_int64 n
let to_int x = try Some (Z.to_int x) with _ -> None
let of_int n = Z.of_int n
let of_zint x = x
let to_zint x = x
let add x y = Z.add x y
let sub x y = Z.sub x y
let mul x y = Z.mul x y
let ediv x y =
try
let (q, r) = Z.ediv_rem x y in
Some (q, r)
with _ -> None
let add_n = add
let mul_n = mul
let ediv_n = ediv
let abs x = Z.abs x
let is_nat x = if Compare.Z.(x < Z.zero) then None else Some x
let neg x = Z.neg x
let int x = x
let shift_left x y =
if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None
else
let y = Z.to_int y in
Some (Z.shift_left x y)
let shift_right x y =
if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None
else
let y = Z.to_int y in
Some (Z.shift_right x y)
let shift_left_n = shift_left
let shift_right_n = shift_right
let logor x y = Z.logor x y
let logxor x y = Z.logxor x y
let logand x y = Z.logand x y
let lognot x = Z.lognot x
src/proto_alpha/lib_protocol/script_int_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive n : Type :=
| Natural_tag : n.
Inductive z : Type :=
| Integer_tag : z.
Definition num (t : Type) := Tezos_protocol_environment_alpha__Environment.Z.t.
Definition compare
(x : Tezos_protocol_environment_alpha__Environment.Z.t)
(y : Tezos_protocol_environment_alpha__Environment.Z.t) : Z := Z.compare x y.
Definition zero : Tezos_protocol_environment_alpha__Environment.Z.t := Z.zero.
Definition zero_n : Tezos_protocol_environment_alpha__Environment.Z.t := Z.zero.
Definition to_string (x : Tezos_protocol_environment_alpha__Environment.Z.t)
: string := Z.to_string x.
Definition of_string (s : string)
: option Tezos_protocol_environment_alpha__Environment.Z.t :=
(* ❌ Try-with are not handled *)
try (Some (Z.of_string s)).
Definition to_int64 (x : Tezos_protocol_environment_alpha__Environment.Z.t)
: option int64 :=
(* ❌ Try-with are not handled *)
try (Some (Z.to_int64 x)).
Definition of_int64 (n : int64)
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.of_int64 n.
Definition to_int (x : Tezos_protocol_environment_alpha__Environment.Z.t)
: option Z :=
(* ❌ Try-with are not handled *)
try (Some (Z.to_int x)).
Definition of_int (n : Z) : Tezos_protocol_environment_alpha__Environment.Z.t :=
Z.of_int n.
Definition of_zint {A : Type} (x : A) : A := x.
Definition to_zint {A : Type} (x : A) : A := x.
Definition add
(x : Tezos_protocol_environment_alpha__Environment.Z.t)
(y : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.add x y.
Definition sub
(x : Tezos_protocol_environment_alpha__Environment.Z.t)
(y : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.sub x y.
Definition mul
(x : Tezos_protocol_environment_alpha__Environment.Z.t)
(y : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.mul x y.
Definition ediv
(x : Tezos_protocol_environment_alpha__Environment.Z.t)
(y : Tezos_protocol_environment_alpha__Environment.Z.t)
: option
(Tezos_protocol_environment_alpha__Environment.Z.t *
Tezos_protocol_environment_alpha__Environment.Z.t) :=
(* ❌ Try-with are not handled *)
try
(let '(q, r) := Z.ediv_rem x y in
Some (q, r)).
Definition add_n
: Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t := add.
Definition mul_n
: Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t := mul.
Definition ediv_n
: Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
option
(Tezos_protocol_environment_alpha__Environment.Z.t *
Tezos_protocol_environment_alpha__Environment.Z.t) := ediv.
Definition abs (x : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.abs x.
Definition is_nat
(x :
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: option
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
x Z.zero then
None
else
Some x.
Definition neg (x : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.neg x.
Definition int {A : Type} (x : A) : A := x.
Definition shift_left
(x : Tezos_protocol_environment_alpha__Environment.Z.t)
(y : Tezos_protocol_environment_alpha__Environment.Z.t)
: option Tezos_protocol_environment_alpha__Environment.Z.t :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
(Z.compare y (Z.of_int 256)) 0 then
None
else
let y := Z.to_int y in
Some (Z.shift_left x y).
Definition shift_right
(x : Tezos_protocol_environment_alpha__Environment.Z.t)
(y : Tezos_protocol_environment_alpha__Environment.Z.t)
: option Tezos_protocol_environment_alpha__Environment.Z.t :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
(Z.compare y (Z.of_int 256)) 0 then
None
else
let y := Z.to_int y in
Some (Z.shift_right x y).
Definition shift_left_n
: Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
option Tezos_protocol_environment_alpha__Environment.Z.t := shift_left.
Definition shift_right_n
: Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t ->
option Tezos_protocol_environment_alpha__Environment.Z.t := shift_right.
Definition logor
(x : Tezos_protocol_environment_alpha__Environment.Z.t)
(y : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.logor x y.
Definition logxor
(x : Tezos_protocol_environment_alpha__Environment.Z.t)
(y : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.logxor x y.
Definition logand
(x : Tezos_protocol_environment_alpha__Environment.Z.t)
(y : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.logand x y.
Definition lognot (x : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_protocol_environment_alpha__Environment.Z.t := Z.lognot x.
src/proto_alpha/lib_protocol/script_interpreter.ml 272 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
open Script
open Script_typed_ir
open Script_ir_translator
(* ---- Run-time errors -----------------------------------------------------*)
type execution_trace =
(Script.location * Gas.t * (Script.expr * string option) list) list
type error +=
| Reject of Script.location * Script.expr * execution_trace option
type error += Overflow of Script.location * execution_trace option
type error += Runtime_contract_error : Contract.t * Script.expr -> error
type error += Bad_contract_parameter of Contract.t (* `Permanent *)
type error += Cannot_serialize_log
type error += Cannot_serialize_failure
type error += Cannot_serialize_storage
let () =
let open Data_encoding in
let trace_encoding =
list
@@ obj3
(req "location" Script.location_encoding)
(req "gas" Gas.encoding)
(req
"stack"
(list (obj2 (req "item" Script.expr_encoding) (opt "annot" string))))
in
(* Reject *)
register_error_kind
`Temporary
~id:"michelson_v1.script_rejected"
~title:"Script failed"
~description:"A FAILWITH instruction was reached"
(obj3
(req "location" Script.location_encoding)
(req "with" Script.expr_encoding)
(opt "trace" trace_encoding))
(function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None)
(fun (loc, v, trace) -> Reject (loc, v, trace)) ;
(* Overflow *)
register_error_kind
`Temporary
~id:"michelson_v1.script_overflow"
~title:"Script failed (overflow error)"
~description:
"A FAIL instruction was reached due to the detection of an overflow"
(obj2
(req "location" Script.location_encoding)
(opt "trace" trace_encoding))
(function Overflow (loc, trace) -> Some (loc, trace) | _ -> None)
(fun (loc, trace) -> Overflow (loc, trace)) ;
(* Runtime contract error *)
register_error_kind
`Temporary
~id:"michelson_v1.runtime_error"
~title:"Script runtime error"
~description:"Toplevel error for all runtime script errors"
(obj2
(req "contract_handle" Contract.encoding)
(req "contract_code" Script.expr_encoding))
(function
| Runtime_contract_error (contract, expr) ->
Some (contract, expr)
| _ ->
None)
(fun (contract, expr) -> Runtime_contract_error (contract, expr)) ;
(* Bad contract parameter *)
register_error_kind
`Permanent
~id:"michelson_v1.bad_contract_parameter"
~title:"Contract supplied an invalid parameter"
~description:
"Either no parameter was supplied to a contract with a non-unit \
parameter type, a non-unit parameter was passed to an account, or a \
parameter was supplied of the wrong type"
Data_encoding.(obj1 (req "contract" Contract.encoding))
(function Bad_contract_parameter c -> Some c | _ -> None)
(fun c -> Bad_contract_parameter c) ;
(* Cannot serialize log *)
register_error_kind
`Temporary
~id:"michelson_v1.cannot_serialize_log"
~title:"Not enough gas to serialize execution trace"
~description:
"Execution trace with stacks was to big to be serialized with the \
provided gas"
Data_encoding.empty
(function Cannot_serialize_log -> Some () | _ -> None)
(fun () -> Cannot_serialize_log) ;
(* Cannot serialize failure *)
register_error_kind
`Temporary
~id:"michelson_v1.cannot_serialize_failure"
~title:"Not enough gas to serialize argument of FAILWITH"
~description:
"Argument of FAILWITH was too big to be serialized with the provided gas"
Data_encoding.empty
(function Cannot_serialize_failure -> Some () | _ -> None)
(fun () -> Cannot_serialize_failure) ;
(* Cannot serialize storage *)
register_error_kind
`Temporary
~id:"michelson_v1.cannot_serialize_storage"
~title:"Not enough gas to serialize execution storage"
~description:
"The returned storage was too big to be serialized with the provided gas"
Data_encoding.empty
(function Cannot_serialize_storage -> Some () | _ -> None)
(fun () -> Cannot_serialize_storage)
(* ---- interpreter ---------------------------------------------------------*)
type 'tys stack =
| Item : 'ty * 'rest stack -> ('ty * 'rest) stack
| Empty : end_of_stack stack
let unparse_stack ctxt (stack, stack_ty) =
(* We drop the gas limit as this function is only used for debugging/errors. *)
let ctxt = Gas.set_unlimited ctxt in
let rec unparse_stack :
type a.
a stack * a stack_ty -> (Script.expr * string option) list tzresult Lwt.t
= function
| (Empty, Empty_t) ->
return_nil
| (Item (v, rest), Item_t (ty, rest_ty, annot)) ->
unparse_data ctxt Readable ty v
>>=? fun (data, _ctxt) ->
unparse_stack (rest, rest_ty)
>>=? fun rest ->
let annot =
match Script_ir_annot.unparse_var_annot annot with
| [] ->
None
| [a] ->
Some a
| _ ->
assert false
in
let data = Micheline.strip_locations data in
return ((data, annot) :: rest)
in
unparse_stack (stack, stack_ty)
module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter
let rec interp_stack_prefix_preserving_operation :
type fbef bef faft aft result.
(fbef stack -> (faft stack * result) tzresult Lwt.t) ->
(fbef, faft, bef, aft) stack_prefix_preservation_witness ->
bef stack ->
(aft stack * result) tzresult Lwt.t =
fun f n stk ->
match (n, stk) with
| ( Prefix
(Prefix
(Prefix
(Prefix
(Prefix
(Prefix
(Prefix
(Prefix
(Prefix
(Prefix
(Prefix
(Prefix (Prefix (Prefix (Prefix (Prefix n))))))))))))))),
Item
( v0,
Item
( v1,
Item
( v2,
Item
( v3,
Item
( v4,
Item
( v5,
Item
( v6,
Item
( v7,
Item
( v8,
Item
( v9,
Item
( va,
Item
( vb,
Item
( vc,
Item
( vd,
Item
( ve,
Item
(vf, rest)
) ) ) ) ) ) )
) ) ) ) ) ) ) ) ) ->
interp_stack_prefix_preserving_operation f n rest
>>=? fun (rest', result) ->
return
( Item
( v0,
Item
( v1,
Item
( v2,
Item
( v3,
Item
( v4,
Item
( v5,
Item
( v6,
Item
( v7,
Item
( v8,
Item
( v9,
Item
( va,
Item
( vb,
Item
( vc,
Item
( vd,
Item
( ve,
Item
( vf,
rest'
) ) )
) ) ) ) ) ) ) ) )
) ) ) ),
result )
| ( Prefix (Prefix (Prefix (Prefix n))),
Item (v0, Item (v1, Item (v2, Item (v3, rest)))) ) ->
interp_stack_prefix_preserving_operation f n rest
>>=? fun (rest', result) ->
return (Item (v0, Item (v1, Item (v2, Item (v3, rest')))), result)
| (Prefix n, Item (v, rest)) ->
interp_stack_prefix_preserving_operation f n rest
>>=? fun (rest', result) -> return (Item (v, rest'), result)
| (Rest, v) ->
f v
type step_constants = {
source : Contract.t;
payer : Contract.t;
self : Contract.t;
amount : Tez.t;
chain_id : Chain_id.t;
}
let rec step :
type b a.
?log:execution_trace ref ->
context ->
step_constants ->
(b, a) descr ->
b stack ->
(a stack * context) tzresult Lwt.t =
fun ?log ctxt step_constants ({instr; loc; _} as descr) stack ->
Lwt.return (Gas.consume ctxt Interp_costs.cycle)
>>=? fun ctxt ->
let logged_return :
type a b.
(b, a) descr -> a stack * context -> (a stack * context) tzresult Lwt.t =
fun descr (ret, ctxt) ->
match log with
| None ->
return (ret, ctxt)
| Some log ->
trace Cannot_serialize_log (unparse_stack ctxt (ret, descr.aft))
>>=? fun stack ->
log := (descr.loc, Gas.level ctxt, stack) :: !log ;
return (ret, ctxt)
in
let get_log (log : execution_trace ref option) =
Option.map ~f:(fun l -> List.rev !l) log
in
let consume_gas_terop :
type ret arg1 arg2 arg3 rest.
(_ * (_ * (_ * rest)), ret * rest) descr ->
(arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3 ->
(arg1 -> arg2 -> arg3 -> Gas.cost) ->
rest stack ->
((ret * rest) stack * context) tzresult Lwt.t =
fun descr (op, x1, x2, x3) cost_func rest ->
Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3))
>>=? fun ctxt -> logged_return descr (Item (op x1 x2 x3, rest), ctxt)
in
let consume_gas_binop :
type ret arg1 arg2 rest.
(_ * (_ * rest), ret * rest) descr ->
(arg1 -> arg2 -> ret) * arg1 * arg2 ->
(arg1 -> arg2 -> Gas.cost) ->
rest stack ->
context ->
((ret * rest) stack * context) tzresult Lwt.t =
fun descr (op, x1, x2) cost_func rest ctxt ->
Lwt.return (Gas.consume ctxt (cost_func x1 x2))
>>=? fun ctxt -> logged_return descr (Item (op x1 x2, rest), ctxt)
in
let consume_gas_unop :
type ret arg rest.
(_ * rest, ret * rest) descr ->
(arg -> ret) * arg ->
(arg -> Gas.cost) ->
rest stack ->
context ->
((ret * rest) stack * context) tzresult Lwt.t =
fun descr (op, arg) cost_func rest ctxt ->
Lwt.return (Gas.consume ctxt (cost_func arg))
>>=? fun ctxt -> logged_return descr (Item (op arg, rest), ctxt)
in
let logged_return : a stack * context -> (a stack * context) tzresult Lwt.t =
logged_return descr
in
match (instr, stack) with
(* stack ops *)
| (Drop, Item (_, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
>>=? fun ctxt -> logged_return (rest, ctxt)
| (Dup, Item (v, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
>>=? fun ctxt -> logged_return (Item (v, Item (v, rest)), ctxt)
| (Swap, Item (vi, Item (vo, rest))) ->
Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
>>=? fun ctxt -> logged_return (Item (vo, Item (vi, rest)), ctxt)
| (Const v, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.push)
>>=? fun ctxt -> logged_return (Item (v, rest), ctxt)
(* options *)
| (Cons_some, Item (v, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.wrap)
>>=? fun ctxt -> logged_return (Item (Some v, rest), ctxt)
| (Cons_none _, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data)
>>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
| (If_none (bt, _), Item (None, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch)
>>=? fun ctxt -> step ?log ctxt step_constants bt rest
| (If_none (_, bf), Item (Some v, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch)
>>=? fun ctxt -> step ?log ctxt step_constants bf (Item (v, rest))
(* pairs *)
| (Cons_pair, Item (a, Item (b, rest))) ->
Lwt.return (Gas.consume ctxt Interp_costs.pair)
>>=? fun ctxt -> logged_return (Item ((a, b), rest), ctxt)
(* Peephole optimization for UNPAIR *)
| ( Seq
( {instr = Dup; _},
{ instr =
Seq
( {instr = Car; _},
{ instr = Seq ({instr = Dip {instr = Cdr}}, {instr = Nop; _});
_ } );
_ } ),
Item ((a, b), rest) ) ->
Lwt.return (Gas.consume ctxt Interp_costs.pair_access)
>>=? fun ctxt -> logged_return (Item (a, Item (b, rest)), ctxt)
| (Car, Item ((a, _), rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.pair_access)
>>=? fun ctxt -> logged_return (Item (a, rest), ctxt)
| (Cdr, Item ((_, b), rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.pair_access)
>>=? fun ctxt -> logged_return (Item (b, rest), ctxt)
(* unions *)
| (Left, Item (v, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.wrap)
>>=? fun ctxt -> logged_return (Item (L v, rest), ctxt)
| (Right, Item (v, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.wrap)
>>=? fun ctxt -> logged_return (Item (R v, rest), ctxt)
| (If_left (bt, _), Item (L v, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch)
>>=? fun ctxt -> step ?log ctxt step_constants bt (Item (v, rest))
| (If_left (_, bf), Item (R v, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch)
>>=? fun ctxt -> step ?log ctxt step_constants bf (Item (v, rest))
(* lists *)
| (Cons_list, Item (hd, Item (tl, rest))) ->
Lwt.return (Gas.consume ctxt Interp_costs.cons)
>>=? fun ctxt -> logged_return (Item (hd :: tl, rest), ctxt)
| (Nil, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data)
>>=? fun ctxt -> logged_return (Item ([], rest), ctxt)
| (If_cons (_, bf), Item ([], rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch)
>>=? fun ctxt -> step ?log ctxt step_constants bf rest
| (If_cons (bt, _), Item (hd :: tl, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch)
>>=? fun ctxt ->
step ?log ctxt step_constants bt (Item (hd, Item (tl, rest)))
| (List_map body, Item (l, rest)) ->
let rec loop rest ctxt l acc =
Lwt.return (Gas.consume ctxt Interp_costs.loop_map)
>>=? fun ctxt ->
match l with
| [] ->
return (Item (List.rev acc, rest), ctxt)
| hd :: tl ->
step ?log ctxt step_constants body (Item (hd, rest))
>>=? fun (Item (hd, rest), ctxt) -> loop rest ctxt tl (hd :: acc)
in
loop rest ctxt l [] >>=? fun (res, ctxt) -> logged_return (res, ctxt)
| (List_size, Item (list, rest)) ->
Lwt.return
(List.fold_left
(fun acc _ ->
acc
>>? fun (size, ctxt) ->
Gas.consume ctxt Interp_costs.loop_size
>>? fun ctxt -> ok (size + 1 (* FIXME: overflow *), ctxt))
(ok (0, ctxt))
list)
>>=? fun (len, ctxt) ->
logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt)
| (List_iter body, Item (l, init)) ->
let rec loop ctxt l stack =
Lwt.return (Gas.consume ctxt Interp_costs.loop_iter)
>>=? fun ctxt ->
match l with
| [] ->
return (stack, ctxt)
| hd :: tl ->
step ?log ctxt step_constants body (Item (hd, stack))
>>=? fun (stack, ctxt) -> loop ctxt tl stack
in
loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt)
(* sets *)
| (Empty_set t, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.empty_set)
>>=? fun ctxt -> logged_return (Item (empty_set t, rest), ctxt)
| (Set_iter body, Item (set, init)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set))
>>=? fun ctxt ->
let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in
let rec loop ctxt l stack =
Lwt.return (Gas.consume ctxt Interp_costs.loop_iter)
>>=? fun ctxt ->
match l with
| [] ->
return (stack, ctxt)
| hd :: tl ->
step ?log ctxt step_constants body (Item (hd, stack))
>>=? fun (stack, ctxt) -> loop ctxt tl stack
in
loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt)
| (Set_mem, Item (v, Item (set, rest))) ->
consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt
| (Set_update, Item (v, Item (presence, Item (set, rest)))) ->
consume_gas_terop
descr
(set_update, v, presence, set)
Interp_costs.set_update
rest
| (Set_size, Item (set, rest)) ->
consume_gas_unop
descr
(set_size, set)
(fun _ -> Interp_costs.set_size)
rest
ctxt
(* maps *)
| (Empty_map (t, _), rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.empty_map)
>>=? fun ctxt -> logged_return (Item (empty_map t, rest), ctxt)
| (Map_map body, Item (map, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map))
>>=? fun ctxt ->
let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
let rec loop rest ctxt l acc =
Lwt.return (Gas.consume ctxt Interp_costs.loop_map)
>>=? fun ctxt ->
match l with
| [] ->
return (acc, ctxt)
| ((k, _) as hd) :: tl ->
step ?log ctxt step_constants body (Item (hd, rest))
>>=? fun (Item (hd, rest), ctxt) ->
loop rest ctxt tl (map_update k (Some hd) acc)
in
loop rest ctxt l (empty_map (map_key_ty map))
>>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
| (Map_iter body, Item (map, init)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map))
>>=? fun ctxt ->
let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
let rec loop ctxt l stack =
Lwt.return (Gas.consume ctxt Interp_costs.loop_iter)
>>=? fun ctxt ->
match l with
| [] ->
return (stack, ctxt)
| hd :: tl ->
step ?log ctxt step_constants body (Item (hd, stack))
>>=? fun (stack, ctxt) -> loop ctxt tl stack
in
loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt)
| (Map_mem, Item (v, Item (map, rest))) ->
consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt
| (Map_get, Item (v, Item (map, rest))) ->
consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt
| (Map_update, Item (k, Item (v, Item (map, rest)))) ->
consume_gas_terop
descr
(map_update, k, v, map)
Interp_costs.map_update
rest
| (Map_size, Item (map, rest)) ->
consume_gas_unop
descr
(map_size, map)
(fun _ -> Interp_costs.map_size)
rest
ctxt
(* Big map operations *)
| (Empty_big_map (tk, tv), rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.empty_map)
>>=? fun ctxt ->
logged_return
(Item (Script_ir_translator.empty_big_map tk tv, rest), ctxt)
| (Big_map_mem, Item (key, Item (map, rest))) ->
Lwt.return (Gas.consume ctxt (Interp_costs.map_mem key map.diff))
>>=? fun ctxt ->
Script_ir_translator.big_map_mem ctxt key map
>>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
| (Big_map_get, Item (key, Item (map, rest))) ->
Lwt.return (Gas.consume ctxt (Interp_costs.map_get key map.diff))
>>=? fun ctxt ->
Script_ir_translator.big_map_get ctxt key map
>>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
| (Big_map_update, Item (key, Item (maybe_value, Item (map, rest)))) ->
consume_gas_terop
descr
(Script_ir_translator.big_map_update, key, maybe_value, map)
(fun k v m -> Interp_costs.map_update k (Some v) m.diff)
rest
(* timestamp operations *)
| (Add_seconds_to_timestamp, Item (n, Item (t, rest))) ->
consume_gas_binop
descr
(Script_timestamp.add_delta, t, n)
Interp_costs.add_timestamp
rest
ctxt
| (Add_timestamp_to_seconds, Item (t, Item (n, rest))) ->
consume_gas_binop
descr
(Script_timestamp.add_delta, t, n)
Interp_costs.add_timestamp
rest
ctxt
| (Sub_timestamp_seconds, Item (t, Item (s, rest))) ->
consume_gas_binop
descr
(Script_timestamp.sub_delta, t, s)
Interp_costs.sub_timestamp
rest
ctxt
| (Diff_timestamps, Item (t1, Item (t2, rest))) ->
consume_gas_binop
descr
(Script_timestamp.diff, t1, t2)
Interp_costs.diff_timestamps
rest
ctxt
(* string operations *)
| (Concat_string_pair, Item (x, Item (y, rest))) ->
Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y]))
>>=? fun ctxt ->
let s = String.concat "" [x; y] in
logged_return (Item (s, rest), ctxt)
| (Concat_string, Item (ss, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss))
>>=? fun ctxt ->
let s = String.concat "" ss in
logged_return (Item (s, rest), ctxt)
| (Slice_string, Item (offset, Item (length, Item (s, rest)))) ->
let s_length = Z.of_int (String.length s) in
let offset = Script_int.to_zint offset in
let length = Script_int.to_zint length in
if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then
Lwt.return
(Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length)))
>>=? fun ctxt ->
logged_return
( Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest),
ctxt )
else
Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0))
>>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
| (String_size, Item (s, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.push)
>>=? fun ctxt ->
logged_return
(Item (Script_int.(abs (of_int (String.length s))), rest), ctxt)
(* bytes operations *)
| (Concat_bytes_pair, Item (x, Item (y, rest))) ->
Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y]))
>>=? fun ctxt ->
let s = MBytes.concat "" [x; y] in
logged_return (Item (s, rest), ctxt)
| (Concat_bytes, Item (ss, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss))
>>=? fun ctxt ->
let s = MBytes.concat "" ss in
logged_return (Item (s, rest), ctxt)
| (Slice_bytes, Item (offset, Item (length, Item (s, rest)))) ->
let s_length = Z.of_int (MBytes.length s) in
let offset = Script_int.to_zint offset in
let length = Script_int.to_zint length in
if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then
Lwt.return
(Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length)))
>>=? fun ctxt ->
logged_return
( Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest),
ctxt )
else
Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0))
>>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
| (Bytes_size, Item (s, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.push)
>>=? fun ctxt ->
logged_return
(Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt)
(* currency operations *)
| (Add_tez, Item (x, Item (y, rest))) ->
Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
>>=? fun ctxt ->
Lwt.return Tez.(x +? y)
>>=? fun res -> logged_return (Item (res, rest), ctxt)
| (Sub_tez, Item (x, Item (y, rest))) ->
Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
>>=? fun ctxt ->
Lwt.return Tez.(x -? y)
>>=? fun res -> logged_return (Item (res, rest), ctxt)
| (Mul_teznat, Item (x, Item (y, rest))) -> (
Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
>>=? fun ctxt ->
Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64)
>>=? fun ctxt ->
match Script_int.to_int64 y with
| None ->
fail (Overflow (loc, get_log log))
| Some y ->
Lwt.return Tez.(x *? y)
>>=? fun res -> logged_return (Item (res, rest), ctxt) )
| (Mul_nattez, Item (y, Item (x, rest))) -> (
Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
>>=? fun ctxt ->
Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64)
>>=? fun ctxt ->
match Script_int.to_int64 y with
| None ->
fail (Overflow (loc, get_log log))
| Some y ->
Lwt.return Tez.(x *? y)
>>=? fun res -> logged_return (Item (res, rest), ctxt) )
(* boolean operations *)
| (Or, Item (x, Item (y, rest))) ->
consume_gas_binop descr (( || ), x, y) Interp_costs.bool_binop rest ctxt
| (And, Item (x, Item (y, rest))) ->
consume_gas_binop descr (( && ), x, y) Interp_costs.bool_binop rest ctxt
| (Xor, Item (x, Item (y, rest))) ->
consume_gas_binop
descr
(Compare.Bool.( <> ), x, y)
Interp_costs.bool_binop
rest
ctxt
| (Not, Item (x, rest)) ->
consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt
(* integer operations *)
| (Is_nat, Item (x, rest)) ->
consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt
| (Abs_int, Item (x, rest)) ->
consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt
| (Int_nat, Item (x, rest)) ->
consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt
| (Neg_int, Item (x, rest)) ->
consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
| (Neg_nat, Item (x, rest)) ->
consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
| (Add_intint, Item (x, Item (y, rest))) ->
consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
| (Add_intnat, Item (x, Item (y, rest))) ->
consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
| (Add_natint, Item (x, Item (y, rest))) ->
consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
| (Add_natnat, Item (x, Item (y, rest))) ->
consume_gas_binop
descr
(Script_int.add_n, x, y)
Interp_costs.add
rest
ctxt
| (Sub_int, Item (x, Item (y, rest))) ->
consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt
| (Mul_intint, Item (x, Item (y, rest))) ->
consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
| (Mul_intnat, Item (x, Item (y, rest))) ->
consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
| (Mul_natint, Item (x, Item (y, rest))) ->
consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
| (Mul_natnat, Item (x, Item (y, rest))) ->
consume_gas_binop
descr
(Script_int.mul_n, x, y)
Interp_costs.mul
rest
ctxt
| (Ediv_teznat, Item (x, Item (y, rest))) ->
Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z)
>>=? fun ctxt ->
let x = Script_int.of_int64 (Tez.to_mutez x) in
consume_gas_binop
descr
( (fun x y ->
match Script_int.ediv x y with
| None ->
None
| Some (q, r) -> (
match (Script_int.to_int64 q, Script_int.to_int64 r) with
| (Some q, Some r) -> (
match (Tez.of_mutez q, Tez.of_mutez r) with
| (Some q, Some r) ->
Some (q, r)
(* Cannot overflow *)
| _ ->
assert false )
(* Cannot overflow *)
| _ ->
assert false )),
x,
y )
Interp_costs.div
rest
ctxt
| (Ediv_tez, Item (x, Item (y, rest))) ->
Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z)
>>=? fun ctxt ->
Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z)
>>=? fun ctxt ->
let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in
let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in
consume_gas_binop
descr
( (fun x y ->
match Script_int.ediv_n x y with
| None ->
None
| Some (q, r) -> (
match Script_int.to_int64 r with
| None ->
assert false (* Cannot overflow *)
| Some r -> (
match Tez.of_mutez r with
| None ->
assert false (* Cannot overflow *)
| Some r ->
Some (q, r) ) )),
x,
y )
Interp_costs.div
rest
ctxt
| (Ediv_intint, Item (x, Item (y, rest))) ->
consume_gas_binop
descr
(Script_int.ediv, x, y)
Interp_costs.div
rest
ctxt
| (Ediv_intnat, Item (x, Item (y, rest))) ->
consume_gas_binop
descr
(Script_int.ediv, x, y)
Interp_costs.div
rest
ctxt
| (Ediv_natint, Item (x, Item (y, rest))) ->
consume_gas_binop
descr
(Script_int.ediv, x, y)
Interp_costs.div
rest
ctxt
| (Ediv_natnat, Item (x, Item (y, rest))) ->
consume_gas_binop
descr
(Script_int.ediv_n, x, y)
Interp_costs.div
rest
ctxt
| (Lsl_nat, Item (x, Item (y, rest))) -> (
Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y))
>>=? fun ctxt ->
match Script_int.shift_left_n x y with
| None ->
fail (Overflow (loc, get_log log))
| Some x ->
logged_return (Item (x, rest), ctxt) )
| (Lsr_nat, Item (x, Item (y, rest))) -> (
Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y))
>>=? fun ctxt ->
match Script_int.shift_right_n x y with
| None ->
fail (Overflow (loc, get_log log))
| Some r ->
logged_return (Item (r, rest), ctxt) )
| (Or_nat, Item (x, Item (y, rest))) ->
consume_gas_binop
descr
(Script_int.logor, x, y)
Interp_costs.logor
rest
ctxt
| (And_nat, Item (x, Item (y, rest))) ->
consume_gas_binop
descr
(Script_int.logand, x, y)
Interp_costs.logand
rest
ctxt
| (And_int_nat, Item (x, Item (y, rest))) ->
consume_gas_binop
descr
(Script_int.logand, x, y)
Interp_costs.logand
rest
ctxt
| (Xor_nat, Item (x, Item (y, rest))) ->
consume_gas_binop
descr
(Script_int.logxor, x, y)
Interp_costs.logxor
rest
ctxt
| (Not_int, Item (x, rest)) ->
consume_gas_unop
descr
(Script_int.lognot, x)
Interp_costs.lognot
rest
ctxt
| (Not_nat, Item (x, rest)) ->
consume_gas_unop
descr
(Script_int.lognot, x)
Interp_costs.lognot
rest
ctxt
(* control *)
| (Seq (hd, tl), stack) ->
step ?log ctxt step_constants hd stack
>>=? fun (trans, ctxt) -> step ?log ctxt step_constants tl trans
| (If (bt, _), Item (true, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch)
>>=? fun ctxt -> step ?log ctxt step_constants bt rest
| (If (_, bf), Item (false, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.branch)
>>=? fun ctxt -> step ?log ctxt step_constants bf rest
| (Loop body, Item (true, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle)
>>=? fun ctxt ->
step ?log ctxt step_constants body rest
>>=? fun (trans, ctxt) -> step ?log ctxt step_constants descr trans
| (Loop _, Item (false, rest)) ->
logged_return (rest, ctxt)
| (Loop_left body, Item (L v, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle)
>>=? fun ctxt ->
step ?log ctxt step_constants body (Item (v, rest))
>>=? fun (trans, ctxt) -> step ?log ctxt step_constants descr trans
| (Loop_left _, Item (R v, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle)
>>=? fun ctxt -> logged_return (Item (v, rest), ctxt)
| (Dip b, Item (ign, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
>>=? fun ctxt ->
step ?log ctxt step_constants b rest
>>=? fun (res, ctxt) -> logged_return (Item (ign, res), ctxt)
| (Exec, Item (arg, Item (lam, rest))) ->
Lwt.return (Gas.consume ctxt Interp_costs.exec)
>>=? fun ctxt ->
interp ?log ctxt step_constants lam arg
>>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
| (Apply capture_ty, Item (capture, Item (lam, rest))) -> (
Lwt.return (Gas.consume ctxt Interp_costs.apply)
>>=? fun ctxt ->
let (Lam (descr, expr)) = lam in
let (Item_t (full_arg_ty, _, _)) = descr.bef in
unparse_data ctxt Optimized capture_ty capture
>>=? fun (const_expr, ctxt) ->
unparse_ty ctxt capture_ty
>>=? fun (ty_expr, ctxt) ->
match full_arg_ty with
| Pair_t ((capture_ty, _, _), (arg_ty, _, _), _, _) ->
let arg_stack_ty = Item_t (arg_ty, Empty_t, None) in
let const_descr =
( {
loc = descr.loc;
bef = arg_stack_ty;
aft = Item_t (capture_ty, arg_stack_ty, None);
instr = Const capture;
}
: (_, _) descr )
in
let pair_descr =
( {
loc = descr.loc;
bef = Item_t (capture_ty, arg_stack_ty, None);
aft = Item_t (full_arg_ty, Empty_t, None);
instr = Cons_pair;
}
: (_, _) descr )
in
let seq_descr =
( {
loc = descr.loc;
bef = arg_stack_ty;
aft = Item_t (full_arg_ty, Empty_t, None);
instr = Seq (const_descr, pair_descr);
}
: (_, _) descr )
in
let full_descr =
( {
loc = descr.loc;
bef = arg_stack_ty;
aft = descr.aft;
instr = Seq (seq_descr, descr);
}
: (_, _) descr )
in
let full_expr =
Micheline.Seq
( 0,
[ Prim (0, I_PUSH, [ty_expr; const_expr], []);
Prim (0, I_PAIR, [], []);
expr ] )
in
let lam' = Lam (full_descr, full_expr) in
logged_return (Item (lam', rest), ctxt)
| _ ->
assert false )
| (Lambda lam, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.push)
>>=? fun ctxt -> logged_return (Item (lam, rest), ctxt)
| (Failwith tv, Item (v, _)) ->
trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v)
>>=? fun (v, _ctxt) ->
let v = Micheline.strip_locations v in
fail (Reject (loc, v, get_log log))
| (Nop, stack) ->
logged_return (stack, ctxt)
(* comparison *)
| (Compare ty, Item (a, Item (b, rest))) ->
Lwt.return (Gas.consume ctxt (Interp_costs.compare ty a b))
>>=? fun ctxt ->
logged_return
( Item
( Script_int.of_int
@@ Script_ir_translator.compare_comparable ty a b,
rest ),
ctxt )
(* comparators *)
| (Eq, Item (cmpres, rest)) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres = 0) in
Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
>>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
| (Neq, Item (cmpres, rest)) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres <> 0) in
Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
>>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
| (Lt, Item (cmpres, rest)) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres < 0) in
Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
>>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
| (Le, Item (cmpres, rest)) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres <= 0) in
Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
>>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
| (Gt, Item (cmpres, rest)) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres > 0) in
Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
>>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
| (Ge, Item (cmpres, rest)) ->
let cmpres = Script_int.compare cmpres Script_int.zero in
let cmpres = Compare.Int.(cmpres >= 0) in
Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
>>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
(* packing *)
| (Pack t, Item (value, rest)) ->
Script_ir_translator.pack_data ctxt t value
>>=? fun (bytes, ctxt) -> logged_return (Item (bytes, rest), ctxt)
| (Unpack t, Item (bytes, rest)) ->
Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes))
>>=? fun () ->
if
Compare.Int.(MBytes.length bytes >= 1)
&& Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05)
then
let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in
match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
| None ->
Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes))
>>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
| Some expr -> (
Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr))
>>=? fun ctxt ->
parse_data ctxt ~legacy:false t (Micheline.root expr)
>>= function
| Ok (value, ctxt) ->
logged_return (Item (Some value, rest), ctxt)
| Error _ignored ->
Lwt.return
(Gas.consume ctxt (Interp_costs.unpack_failed bytes))
>>=? fun ctxt -> logged_return (Item (None, rest), ctxt) )
else logged_return (Item (None, rest), ctxt)
(* protocol *)
| (Address, Item ((_, address), rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.address)
>>=? fun ctxt -> logged_return (Item (address, rest), ctxt)
| (Contract (t, entrypoint), Item (contract, rest)) -> (
Lwt.return (Gas.consume ctxt Interp_costs.contract)
>>=? fun ctxt ->
match (contract, entrypoint) with
| ((contract, "default"), entrypoint)
| ((contract, entrypoint), "default") ->
Script_ir_translator.parse_contract_for_script
~legacy:false
ctxt
loc
t
contract
~entrypoint
>>=? fun (ctxt, maybe_contract) ->
logged_return (Item (maybe_contract, rest), ctxt)
| _ ->
logged_return (Item (None, rest), ctxt) )
| ( Transfer_tokens,
Item (p, Item (amount, Item ((tp, (destination, entrypoint)), rest))) )
->
Lwt.return (Gas.consume ctxt Interp_costs.transfer)
>>=? fun ctxt ->
collect_big_maps ctxt tp p
>>=? fun (to_duplicate, ctxt) ->
let to_update = no_big_map_id in
extract_big_map_diff
ctxt
Optimized
tp
p
~to_duplicate
~to_update
~temporary:true
>>=? fun (p, big_map_diff, ctxt) ->
unparse_data ctxt Optimized tp p
>>=? fun (p, ctxt) ->
let operation =
Transaction
{
amount;
destination;
entrypoint;
parameters = Script.lazy_expr (Micheline.strip_locations p);
}
in
Lwt.return (fresh_internal_nonce ctxt)
>>=? fun (ctxt, nonce) ->
logged_return
( Item
( ( Internal_operation
{source = step_constants.self; operation; nonce},
big_map_diff ),
rest ),
ctxt )
| ( Create_account,
Item (manager, Item (delegate, Item (_delegatable, Item (credit, rest))))
) ->
Lwt.return (Gas.consume ctxt Interp_costs.create_account)
>>=? fun ctxt ->
Contract.fresh_contract_from_current_nonce ctxt
>>=? fun (ctxt, contract) ->
(* store in optimized binary representation - as unparsed with [Optimized]. *)
let manager_bytes =
Data_encoding.Binary.to_bytes_exn
Signature.Public_key_hash.encoding
manager
in
let storage =
Script_repr.lazy_expr @@ Micheline.strip_locations
@@ Micheline.Bytes (0, manager_bytes)
in
let script = {code = Legacy_support.manager_script_code; storage} in
let operation =
Origination {credit; delegate; preorigination = Some contract; script}
in
Lwt.return (fresh_internal_nonce ctxt)
>>=? fun (ctxt, nonce) ->
logged_return
( Item
( ( Internal_operation
{source = step_constants.self; operation; nonce},
None ),
Item ((contract, "default"), rest) ),
ctxt )
| (Implicit_account, Item (key, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.implicit_account)
>>=? fun ctxt ->
let contract = Contract.implicit_contract key in
logged_return (Item ((Unit_t None, (contract, "default")), rest), ctxt)
| ( Create_contract (storage_type, param_type, Lam (_, code), root_name),
Item
( manager,
Item
( delegate,
Item
( spendable,
Item (delegatable, Item (credit, Item (init, rest))) ) ) ) )
->
Lwt.return (Gas.consume ctxt Interp_costs.create_contract)
>>=? fun ctxt ->
unparse_ty ctxt param_type
>>=? fun (unparsed_param_type, ctxt) ->
let unparsed_param_type =
Script_ir_translator.add_field_annot
(Option.map ~f:(fun n -> `Field_annot n) root_name)
None
unparsed_param_type
in
unparse_ty ctxt storage_type
>>=? fun (unparsed_storage_type, ctxt) ->
let code =
Script.lazy_expr
@@ Micheline.strip_locations
(Seq
( 0,
[ Prim (0, K_parameter, [unparsed_param_type], []);
Prim (0, K_storage, [unparsed_storage_type], []);
Prim (0, K_code, [code], []) ] ))
in
collect_big_maps ctxt storage_type init
>>=? fun (to_duplicate, ctxt) ->
let to_update = no_big_map_id in
extract_big_map_diff
ctxt
Optimized
storage_type
init
~to_duplicate
~to_update
~temporary:true
>>=? fun (init, big_map_diff, ctxt) ->
unparse_data ctxt Optimized storage_type init
>>=? fun (storage, ctxt) ->
let storage = Script.lazy_expr @@ Micheline.strip_locations storage in
( if spendable then
Legacy_support.add_do
~manager_pkh:manager
~script_code:code
~script_storage:storage
else if delegatable then
Legacy_support.add_set_delegate
~manager_pkh:manager
~script_code:code
~script_storage:storage
else if Legacy_support.has_default_entrypoint code then
Legacy_support.add_root_entrypoint code
>>=? fun code -> return (code, storage)
else return (code, storage) )
>>=? fun (code, storage) ->
Contract.fresh_contract_from_current_nonce ctxt
>>=? fun (ctxt, contract) ->
let operation =
Origination
{
credit;
delegate;
preorigination = Some contract;
script = {code; storage};
}
in
Lwt.return (fresh_internal_nonce ctxt)
>>=? fun (ctxt, nonce) ->
logged_return
( Item
( ( Internal_operation
{source = step_constants.self; operation; nonce},
big_map_diff ),
Item ((contract, "default"), rest) ),
ctxt )
| ( Create_contract_2 (storage_type, param_type, Lam (_, code), root_name),
(* Removed the instruction's arguments manager, spendable and delegatable *)
Item (delegate, Item (credit, Item (init, rest))) ) ->
Lwt.return (Gas.consume ctxt Interp_costs.create_contract)
>>=? fun ctxt ->
unparse_ty ctxt param_type
>>=? fun (unparsed_param_type, ctxt) ->
let unparsed_param_type =
Script_ir_translator.add_field_annot
(Option.map ~f:(fun n -> `Field_annot n) root_name)
None
unparsed_param_type
in
unparse_ty ctxt storage_type
>>=? fun (unparsed_storage_type, ctxt) ->
let code =
Micheline.strip_locations
(Seq
( 0,
[ Prim (0, K_parameter, [unparsed_param_type], []);
Prim (0, K_storage, [unparsed_storage_type], []);
Prim (0, K_code, [code], []) ] ))
in
collect_big_maps ctxt storage_type init
>>=? fun (to_duplicate, ctxt) ->
let to_update = no_big_map_id in
extract_big_map_diff
ctxt
Optimized
storage_type
init
~to_duplicate
~to_update
~temporary:true
>>=? fun (init, big_map_diff, ctxt) ->
unparse_data ctxt Optimized storage_type init
>>=? fun (storage, ctxt) ->
let storage = Micheline.strip_locations storage in
Contract.fresh_contract_from_current_nonce ctxt
>>=? fun (ctxt, contract) ->
let operation =
Origination
{
credit;
delegate;
preorigination = Some contract;
script =
{
code = Script.lazy_expr code;
storage = Script.lazy_expr storage;
};
}
in
Lwt.return (fresh_internal_nonce ctxt)
>>=? fun (ctxt, nonce) ->
logged_return
( Item
( ( Internal_operation
{source = step_constants.self; operation; nonce},
big_map_diff ),
Item ((contract, "default"), rest) ),
ctxt )
| (Set_delegate, Item (delegate, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.create_account)
>>=? fun ctxt ->
let operation = Delegation delegate in
Lwt.return (fresh_internal_nonce ctxt)
>>=? fun (ctxt, nonce) ->
logged_return
( Item
( ( Internal_operation
{source = step_constants.self; operation; nonce},
None ),
rest ),
ctxt )
| (Balance, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.balance)
>>=? fun ctxt ->
Contract.get_balance ctxt step_constants.self
>>=? fun balance -> logged_return (Item (balance, rest), ctxt)
| (Now, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.now)
>>=? fun ctxt ->
let now = Script_timestamp.now ctxt in
logged_return (Item (now, rest), ctxt)
| (Check_signature, Item (key, Item (signature, Item (message, rest)))) ->
Lwt.return (Gas.consume ctxt (Interp_costs.check_signature key message))
>>=? fun ctxt ->
let res = Signature.check key signature message in
logged_return (Item (res, rest), ctxt)
| (Hash_key, Item (key, rest)) ->
Lwt.return (Gas.consume ctxt Interp_costs.hash_key)
>>=? fun ctxt ->
logged_return (Item (Signature.Public_key.hash key, rest), ctxt)
| (Blake2b, Item (bytes, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.hash_blake2b bytes))
>>=? fun ctxt ->
let hash = Raw_hashes.blake2b bytes in
logged_return (Item (hash, rest), ctxt)
| (Sha256, Item (bytes, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha256 bytes))
>>=? fun ctxt ->
let hash = Raw_hashes.sha256 bytes in
logged_return (Item (hash, rest), ctxt)
| (Sha512, Item (bytes, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha512 bytes))
>>=? fun ctxt ->
let hash = Raw_hashes.sha512 bytes in
logged_return (Item (hash, rest), ctxt)
| (Steps_to_quota, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota)
>>=? fun ctxt ->
let steps =
match Gas.level ctxt with
| Limited {remaining} ->
remaining
| Unaccounted ->
Z.of_string "99999999"
in
logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt)
| (Source, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.source)
>>=? fun ctxt ->
logged_return (Item ((step_constants.payer, "default"), rest), ctxt)
| (Sender, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.source)
>>=? fun ctxt ->
logged_return (Item ((step_constants.source, "default"), rest), ctxt)
| (Self (t, entrypoint), rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.self)
>>=? fun ctxt ->
logged_return (Item ((t, (step_constants.self, entrypoint)), rest), ctxt)
| (Amount, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.amount)
>>=? fun ctxt -> logged_return (Item (step_constants.amount, rest), ctxt)
| (Dig (n, n'), stack) ->
Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
>>=? fun ctxt ->
interp_stack_prefix_preserving_operation
(fun (Item (v, rest)) -> return (rest, v))
n'
stack
>>=? fun (aft, x) -> logged_return (Item (x, aft), ctxt)
| (Dug (n, n'), Item (v, rest)) ->
Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
>>=? fun ctxt ->
interp_stack_prefix_preserving_operation
(fun stk -> return (Item (v, stk), ()))
n'
rest
>>=? fun (aft, ()) -> logged_return (aft, ctxt)
| (Dipn (n, n', b), stack) ->
Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
>>=? fun ctxt ->
interp_stack_prefix_preserving_operation
(fun stk ->
step ?log ctxt step_constants b stk
>>=? fun (res, ctxt') -> return (res, ctxt'))
n'
stack
>>=? fun (aft, ctxt') -> logged_return (aft, ctxt')
| (Dropn (n, n'), stack) ->
Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
>>=? fun ctxt ->
interp_stack_prefix_preserving_operation
(fun stk -> return (stk, stk))
n'
stack
>>=? fun (_, rest) -> logged_return (rest, ctxt)
| (ChainId, rest) ->
Lwt.return (Gas.consume ctxt Interp_costs.chain_id)
>>=? fun ctxt ->
logged_return (Item (step_constants.chain_id, rest), ctxt)
and interp :
type p r.
?log:execution_trace ref ->
context ->
step_constants ->
(p, r) lambda ->
p ->
(r * context) tzresult Lwt.t =
fun ?log ctxt step_constants (Lam (code, _)) arg ->
let stack = Item (arg, Empty) in
( match log with
| None ->
return_unit
| Some log ->
trace Cannot_serialize_log (unparse_stack ctxt (stack, code.bef))
>>=? fun stack ->
log := (code.loc, Gas.level ctxt, stack) :: !log ;
return_unit )
>>=? fun () ->
step ?log ctxt step_constants code stack
>>=? fun (Item (ret, Empty), ctxt) -> return (ret, ctxt)
(* ---- contract handling ---------------------------------------------------*)
and execute ?log ctxt mode step_constants ~entrypoint unparsed_script arg :
( Script.expr
* packed_internal_operation list
* context
* Contract.big_map_diff option )
tzresult
Lwt.t =
parse_script ctxt unparsed_script ~legacy:true
>>=? fun (Ex_script {code; arg_type; storage; storage_type; root_name}, ctxt) ->
trace
(Bad_contract_parameter step_constants.self)
(Lwt.return (find_entrypoint arg_type ~root_name entrypoint))
>>=? fun (box, _) ->
trace
(Bad_contract_parameter step_constants.self)
(parse_data ctxt ~legacy:false arg_type (box arg))
>>=? fun (arg, ctxt) ->
Script.force_decode ctxt unparsed_script.code
>>=? fun (script_code, ctxt) ->
Script_ir_translator.collect_big_maps ctxt arg_type arg
>>=? fun (to_duplicate, ctxt) ->
Script_ir_translator.collect_big_maps ctxt storage_type storage
>>=? fun (to_update, ctxt) ->
trace
(Runtime_contract_error (step_constants.self, script_code))
(interp ?log ctxt step_constants code (arg, storage))
>>=? fun ((ops, storage), ctxt) ->
Script_ir_translator.extract_big_map_diff
ctxt
mode
~temporary:false
~to_duplicate
~to_update
storage_type
storage
>>=? fun (storage, big_map_diff, ctxt) ->
trace Cannot_serialize_storage (unparse_data ctxt mode storage_type storage)
>>=? fun (storage, ctxt) ->
let (ops, op_diffs) = List.split ops in
let big_map_diff =
match
List.flatten
(List.map (Option.unopt ~default:[]) (op_diffs @ [big_map_diff]))
with
| [] ->
None
| diff ->
Some diff
in
return (Micheline.strip_locations storage, ops, ctxt, big_map_diff)
type execution_result = {
ctxt : context;
storage : Script.expr;
big_map_diff : Contract.big_map_diff option;
operations : packed_internal_operation list;
}
let trace ctxt mode step_constants ~script ~entrypoint ~parameter =
let log = ref [] in
execute
~log
ctxt
mode
step_constants
~entrypoint
script
(Micheline.root parameter)
>>=? fun (storage, operations, ctxt, big_map_diff) ->
let trace = List.rev !log in
return ({ctxt; storage; big_map_diff; operations}, trace)
let execute ctxt mode step_constants ~script ~entrypoint ~parameter =
execute
ctxt
mode
step_constants
~entrypoint
script
(Micheline.root parameter)
>>=? fun (storage, operations, ctxt, big_map_diff) ->
return {ctxt; storage; big_map_diff; operations}
src/proto_alpha/lib_protocol/script_interpreter.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Import Script.
Import Script_typed_ir.
Import Script_ir_translator.
Definition execution_trace :=
list
(Tezos_raw_protocol_alpha.Alpha_context.Script.location *
Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (option string)))).
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Inductive stack : forall (tys : Type), Type :=
| Item : forall {rest ty : Type}, ty -> (stack rest) -> stack (ty * rest)
| Empty : stack Tezos_raw_protocol_alpha.Script_typed_ir.end_of_stack.
Definition unparse_stack {A : Type}
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(function_parameter :
(stack A) * (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty A))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (option string)))) :=
let '(stack, stack_ty) := function_parameter in
let ctxt := Gas.set_unlimited ctxt in
let fix unparse_stack {a : Type}
(function_parameter :
(stack a) * (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (option string)))) :=
match function_parameter with
| (Empty, Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t) => return_nil
|
(Item v rest,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ty rest_ty annot) =>
op_gtgteqquestion
(unparse_data ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Readable ty v)
(fun function_parameter =>
let '(data, _ctxt) := function_parameter in
op_gtgteqquestion (unparse_stack (rest, rest_ty))
(fun rest =>
let annot :=
match Script_ir_annot.unparse_var_annot annot with
| [] => None
| cons a [] => Some a
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
let data := Micheline.strip_locations data in
_return (cons (data, annot) rest)))
end in
unparse_stack (stack, stack_ty).
(* ❌ This kind of module is not handled. *)
unhandled_module
Fixpoint interp_stack_prefix_preserving_operation
{aft bef faft fbef result : Type}
(f :
(stack fbef) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((stack faft) * result)))
(n :
Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
fbef faft bef aft) (stk : stack bef)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((stack aft) * result)) :=
match (n, stk) with
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
n))))))))))))))),
Item v0
(Item v1
(Item v2
(Item v3
(Item v4
(Item v5
(Item v6
(Item v7
(Item v8
(Item v9
(Item va
(Item vb
(Item vc (Item vd (Item ve (Item vf rest))))))))))))))))
=>
op_gtgteqquestion (interp_stack_prefix_preserving_operation f n rest)
(fun function_parameter =>
let '(rest', result) := function_parameter in
_return
((Item v0
(Item v1
(Item v2
(Item v3
(Item v4
(Item v5
(Item v6
(Item v7
(Item v8
(Item v9
(Item va
(Item vb
(Item vc (Item vd (Item ve (Item vf rest')))))))))))))))),
result))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
(Tezos_raw_protocol_alpha.Script_typed_ir.Prefix n))),
Item v0 (Item v1 (Item v2 (Item v3 rest)))) =>
op_gtgteqquestion (interp_stack_prefix_preserving_operation f n rest)
(fun function_parameter =>
let '(rest', result) := function_parameter in
_return ((Item v0 (Item v1 (Item v2 (Item v3 rest')))), result))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix n, Item v rest) =>
op_gtgteqquestion (interp_stack_prefix_preserving_operation f n rest)
(fun function_parameter =>
let '(rest', result) := function_parameter in
_return ((Item v rest'), result))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Rest, v) => f v
end.
Record step_constants := {
source : Tezos_raw_protocol_alpha.Alpha_context.Contract.t;
payer : Tezos_raw_protocol_alpha.Alpha_context.Contract.t;
self : Tezos_raw_protocol_alpha.Alpha_context.Contract.t;
amount : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
chain_id :
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
}.
Fixpoint step {a b : Type}
(log :
option
(Tezos_protocol_environment_alpha__Environment.Pervasives.ref
execution_trace))
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(step_constants : step_constants)
(function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.descr b a)
: (stack b) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((stack a) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let '{| loc := loc; instr := instr |} as descr := function_parameter in
fun stack =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.cycle))
(fun ctxt =>
let logged_return
(descr : Tezos_raw_protocol_alpha.Script_typed_ir.descr b a)
(function_parameter :
(stack a) * Tezos_raw_protocol_alpha.Alpha_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((stack a) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let '(ret, ctxt) := function_parameter in
match log with
| None => _return (ret, ctxt)
| Some log =>
op_gtgteqquestion
(trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_log
(unparse_stack ctxt (ret, (aft descr))))
(fun stack =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_coloneq log
(cons ((loc descr), (Gas.level ctxt), stack)
(op_exclamation log)) in
_return (ret, ctxt))
end in
let get_log
(log :
option
(Tezos_protocol_environment_alpha__Environment.Pervasives.ref
execution_trace))
: option
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.location *
Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(option string))))) :=
Option.map (fun l => List.rev (op_exclamation l)) log in
let consume_gas_terop {C D E arg1 arg2 arg3 rest ret : Type}
(descr :
Tezos_raw_protocol_alpha.Script_typed_ir.descr (C * (D * (E * rest)))
(ret * rest)) (function_parameter :
(arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3)
: (arg1 ->
arg2 -> arg3 -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost) ->
(stack rest) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((stack (ret * rest)) *
Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let '(op, x1, x2, x3) := function_parameter in
fun cost_func =>
fun rest =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (cost_func x1 x2 x3)))
(fun ctxt =>
logged_return descr ((Item (op x1 x2 x3) rest), ctxt)) in
let consume_gas_binop {C D arg1 arg2 rest ret : Type}
(descr :
Tezos_raw_protocol_alpha.Script_typed_ir.descr (C * (D * rest))
(ret * rest)) (function_parameter :
(arg1 -> arg2 -> ret) * arg1 * arg2)
: (arg1 -> arg2 -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost) ->
(stack rest) ->
Tezos_raw_protocol_alpha.Alpha_context.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((stack (ret * rest)) *
Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let '(op, x1, x2) := function_parameter in
fun cost_func =>
fun rest =>
fun ctxt =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (cost_func x1 x2)))
(fun ctxt =>
logged_return descr ((Item (op x1 x2) rest), ctxt)) in
let consume_gas_unop {C arg rest ret : Type}
(descr :
Tezos_raw_protocol_alpha.Script_typed_ir.descr (C * rest) (ret * rest))
(function_parameter : (arg -> ret) * arg)
: (arg -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost) ->
(stack rest) ->
Tezos_raw_protocol_alpha.Alpha_context.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((stack (ret * rest)) *
Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let '(op, arg) := function_parameter in
fun cost_func =>
fun rest =>
fun ctxt =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (cost_func arg)))
(fun ctxt => logged_return descr ((Item (op arg) rest), ctxt))
in
let logged_return := logged_return descr in
match (instr, stack) with
| (Tezos_raw_protocol_alpha.Script_typed_ir.Drop, Item _ rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.stack_op))
(fun ctxt => logged_return (rest, ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Dup, Item v rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.stack_op))
(fun ctxt => logged_return ((Item v (Item v rest)), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Swap, Item vi (Item vo rest))
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.stack_op))
(fun ctxt => logged_return ((Item vo (Item vi rest)), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Const v, rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.push))
(fun ctxt => logged_return ((Item v rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Cons_some, Item v rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.wrap))
(fun ctxt => logged_return ((Item (Some v) rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Cons_none _, rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.variant_no_data))
(fun ctxt => logged_return ((Item None rest), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.If_none bt _, Item None rest)
=>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
(fun ctxt => step log ctxt step_constants bt rest)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.If_none _ bf,
Item (Some v) rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
(fun ctxt => step log ctxt step_constants bf (Item v rest))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Cons_pair,
Item a (Item b rest)) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.pair))
(fun ctxt => logged_return ((Item (a, b) rest), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Seq {|
instr := Tezos_raw_protocol_alpha.Script_typed_ir.Dup |} {|
instr :=
Tezos_raw_protocol_alpha.Script_typed_ir.Seq {|
instr := Tezos_raw_protocol_alpha.Script_typed_ir.Car
|} {|
instr :=
Tezos_raw_protocol_alpha.Script_typed_ir.Seq
{|
instr :=
Tezos_raw_protocol_alpha.Script_typed_ir.Dip
{|
instr :=
Tezos_raw_protocol_alpha.Script_typed_ir.Cdr
|}
|}
{|
instr := Tezos_raw_protocol_alpha.Script_typed_ir.Nop
|}
|}
|}, Item (a, b) rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.pair_access))
(fun ctxt => logged_return ((Item a (Item b rest)), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Car, Item (a, _) rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.pair_access))
(fun ctxt => logged_return ((Item a rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Cdr, Item (_, b) rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.pair_access))
(fun ctxt => logged_return ((Item b rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Left, Item v rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.wrap))
(fun ctxt =>
logged_return
((Item (Tezos_raw_protocol_alpha.Script_typed_ir.L v) rest),
ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Right, Item v rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.wrap))
(fun ctxt =>
logged_return
((Item (Tezos_raw_protocol_alpha.Script_typed_ir.R v) rest),
ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.If_left bt _,
Item (Tezos_raw_protocol_alpha.Script_typed_ir.L v) rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
(fun ctxt => step log ctxt step_constants bt (Item v rest))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.If_left _ bf,
Item (Tezos_raw_protocol_alpha.Script_typed_ir.R v) rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
(fun ctxt => step log ctxt step_constants bf (Item v rest))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Cons_list,
Item hd (Item tl rest)) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.cons))
(fun ctxt => logged_return ((Item (cons hd tl) rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Nil, rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.variant_no_data))
(fun ctxt => logged_return ((Item [] rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.If_cons _ bf, Item [] rest)
=>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
(fun ctxt => step log ctxt step_constants bf rest)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.If_cons bt _,
Item (cons hd tl) rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
(fun ctxt =>
step log ctxt step_constants bt (Item hd (Item tl rest)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.List_map body, Item l rest)
=>
let fix loop
(rest : stack op_dollar49) (ctxt :
Tezos_raw_protocol_alpha__Alpha_context.context) (l :
list op_dollar48) (acc : list op_dollar50)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((stack ((list op_dollar50) * op_dollar49)) *
Tezos_raw_protocol_alpha__Alpha_context.context)) :=
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.loop_map))
(fun ctxt =>
match l with
| [] => _return ((Item (List.rev acc) rest), ctxt)
| cons hd tl =>
op_gtgteqquestion
(step log ctxt step_constants body (Item hd rest))
(fun function_parameter =>
let '(Item hd rest, ctxt) := function_parameter in
loop rest ctxt tl (cons hd acc))
end) in
op_gtgteqquestion (loop rest ctxt l [])
(fun function_parameter =>
let '(res, ctxt) := function_parameter in
logged_return (res, ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.List_size, Item list rest)
=>
op_gtgteqquestion
(Lwt._return
(List.fold_left
(fun acc =>
fun function_parameter =>
let '_ := function_parameter in
op_gtgtquestion acc
(fun function_parameter =>
let '(size, ctxt) := function_parameter in
op_gtgtquestion
(Gas.consume ctxt Interp_costs.loop_size)
(fun ctxt => ok ((op_plus size 1), ctxt))))
(ok (0, ctxt)) list))
(fun function_parameter =>
let '(len, ctxt) := function_parameter in
logged_return ((Item (abs (of_int len)) rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.List_iter body, Item l init)
=>
let fix loop
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (l :
list op_dollar53) (stack : stack op_dollar54)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((stack op_dollar54) *
Tezos_raw_protocol_alpha__Alpha_context.context)) :=
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.loop_iter))
(fun ctxt =>
match l with
| [] => _return (stack, ctxt)
| cons hd tl =>
op_gtgteqquestion
(step log ctxt step_constants body (Item hd stack))
(fun function_parameter =>
let '(stack, ctxt) := function_parameter in
loop ctxt tl stack)
end) in
op_gtgteqquestion (loop ctxt l init)
(fun function_parameter =>
let '(res, ctxt) := function_parameter in
logged_return (res, ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Empty_set t, rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.empty_set))
(fun ctxt => logged_return ((Item (empty_set t) rest), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_iter body, Item set init)
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.set_to_list set)))
(fun ctxt =>
let l :=
List.rev (set_fold (fun e => fun acc => cons e acc) set []) in
let fix loop
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (l :
list op_dollar56) (stack : stack op_dollar57)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((stack op_dollar57) *
Tezos_raw_protocol_alpha__Alpha_context.context)) :=
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.loop_iter))
(fun ctxt =>
match l with
| [] => _return (stack, ctxt)
| cons hd tl =>
op_gtgteqquestion
(step log ctxt step_constants body (Item hd stack))
(fun function_parameter =>
let '(stack, ctxt) := function_parameter in
loop ctxt tl stack)
end) in
op_gtgteqquestion (loop ctxt l init)
(fun function_parameter =>
let '(res, ctxt) := function_parameter in
logged_return (res, ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_mem,
Item v (Item set rest)) =>
consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_update,
Item v (Item presence (Item set rest))) =>
consume_gas_terop descr (set_update, v, presence, set)
Interp_costs.set_update rest
| (Tezos_raw_protocol_alpha.Script_typed_ir.Set_size, Item set rest) =>
consume_gas_unop descr (set_size, set)
(fun function_parameter =>
let '_ := function_parameter in
Interp_costs.set_size) rest ctxt
| (Tezos_raw_protocol_alpha.Script_typed_ir.Empty_map t _, rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.empty_map))
(fun ctxt => logged_return ((Item (empty_map t) rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Map_map body, Item map rest)
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.map_to_list map)))
(fun ctxt =>
let l :=
List.rev
(map_fold (fun k => fun v => fun acc => cons (k, v) acc) map
[]) in
let fix loop
(rest : stack op_dollar68) (ctxt :
Tezos_raw_protocol_alpha__Alpha_context.context) (l :
list (op_dollar66 * op_dollar67)) (acc :
Tezos_raw_protocol_alpha.Script_typed_ir.map op_dollar66
op_dollar69)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_raw_protocol_alpha.Script_typed_ir.map op_dollar66
op_dollar69) *
Tezos_raw_protocol_alpha__Alpha_context.context)) :=
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.loop_map))
(fun ctxt =>
match l with
| [] => _return (acc, ctxt)
| cons ((k, _) as hd) tl =>
op_gtgteqquestion
(step log ctxt step_constants body (Item hd rest))
(fun function_parameter =>
let '(Item hd rest, ctxt) := function_parameter in
loop rest ctxt tl (map_update k (Some hd) acc))
end) in
op_gtgteqquestion (loop rest ctxt l (empty_map (map_key_ty map)))
(fun function_parameter =>
let '(res, ctxt) := function_parameter in
logged_return ((Item res rest), ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_iter body, Item map init)
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.map_to_list map)))
(fun ctxt =>
let l :=
List.rev
(map_fold (fun k => fun v => fun acc => cons (k, v) acc) map
[]) in
let fix loop
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (l :
list (op_dollar70 * op_dollar71)) (stack : stack op_dollar72)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((stack op_dollar72) *
Tezos_raw_protocol_alpha__Alpha_context.context)) :=
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.loop_iter))
(fun ctxt =>
match l with
| [] => _return (stack, ctxt)
| cons hd tl =>
op_gtgteqquestion
(step log ctxt step_constants body (Item hd stack))
(fun function_parameter =>
let '(stack, ctxt) := function_parameter in
loop ctxt tl stack)
end) in
op_gtgteqquestion (loop ctxt l init)
(fun function_parameter =>
let '(res, ctxt) := function_parameter in
logged_return (res, ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_mem,
Item v (Item map rest)) =>
consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_get,
Item v (Item map rest)) =>
consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_update,
Item k (Item v (Item map rest))) =>
consume_gas_terop descr (map_update, k, v, map)
Interp_costs.map_update rest
| (Tezos_raw_protocol_alpha.Script_typed_ir.Map_size, Item map rest) =>
consume_gas_unop descr (map_size, map)
(fun function_parameter =>
let '_ := function_parameter in
Interp_costs.map_size) rest ctxt
| (Tezos_raw_protocol_alpha.Script_typed_ir.Empty_big_map tk tv, rest)
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.empty_map))
(fun ctxt =>
logged_return
((Item (Script_ir_translator.empty_big_map tk tv) rest), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_mem,
Item key (Item map rest)) =>
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Interp_costs.map_mem key (diff map))))
(fun ctxt =>
op_gtgteqquestion (Script_ir_translator.big_map_mem ctxt key map)
(fun function_parameter =>
let '(res, ctxt) := function_parameter in
logged_return ((Item res rest), ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_get,
Item key (Item map rest)) =>
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Interp_costs.map_get key (diff map))))
(fun ctxt =>
op_gtgteqquestion (Script_ir_translator.big_map_get ctxt key map)
(fun function_parameter =>
let '(res, ctxt) := function_parameter in
logged_return ((Item res rest), ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_update,
Item key (Item maybe_value (Item map rest))) =>
consume_gas_terop descr
(Script_ir_translator.big_map_update, key, maybe_value, map)
(fun k =>
fun v => fun m => Interp_costs.map_update k (Some v) (diff m))
rest
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Add_seconds_to_timestamp,
Item n (Item t rest)) =>
consume_gas_binop descr (Script_timestamp.add_delta, t, n)
Interp_costs.add_timestamp rest ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Add_timestamp_to_seconds,
Item t (Item n rest)) =>
consume_gas_binop descr (Script_timestamp.add_delta, t, n)
Interp_costs.add_timestamp rest ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Sub_timestamp_seconds,
Item t (Item s rest)) =>
consume_gas_binop descr (Script_timestamp.sub_delta, t, s)
Interp_costs.sub_timestamp rest ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Diff_timestamps,
Item t1 (Item t2 rest)) =>
consume_gas_binop descr (Script_timestamp.diff, t1, t2)
Interp_costs.diff_timestamps rest ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string_pair,
Item x (Item y rest)) =>
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt
(Interp_costs.concat_string (cons x (cons y [])))))
(fun ctxt =>
let s := String.concat "" % string (cons x (cons y [])) in
logged_return ((Item s rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string, Item ss rest)
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.concat_string ss)))
(fun ctxt =>
let s := String.concat "" % string ss in
logged_return ((Item s rest), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Slice_string,
Item offset (Item length (Item s rest))) =>
let s_length := Z.of_int (String.length s) in
let offset := Script_int.to_zint offset in
let length := Script_int.to_zint length in
if
op_andand
(Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
offset s_length)
(Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
(Z.add offset length) s_length) then
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))))
(fun ctxt =>
logged_return
((Item
(Some (String.sub s (Z.to_int offset) (Z.to_int length)))
rest), ctxt))
else
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.slice_string 0)))
(fun ctxt => logged_return ((Item None rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.String_size, Item s rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.push))
(fun ctxt =>
logged_return ((Item (abs (of_int (String.length s))) rest), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes_pair,
Item x (Item y rest)) =>
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Interp_costs.concat_bytes (cons x (cons y [])))))
(fun ctxt =>
let s := MBytes.concat "" % string (cons x (cons y [])) in
logged_return ((Item s rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes, Item ss rest)
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.concat_bytes ss)))
(fun ctxt =>
let s := MBytes.concat "" % string ss in
logged_return ((Item s rest), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Slice_bytes,
Item offset (Item length (Item s rest))) =>
let s_length := Z.of_int (MBytes.length s) in
let offset := Script_int.to_zint offset in
let length := Script_int.to_zint length in
if
op_andand
(Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
offset s_length)
(Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
(Z.add offset length) s_length) then
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))))
(fun ctxt =>
logged_return
((Item
(Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)))
rest), ctxt))
else
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.slice_string 0)))
(fun ctxt => logged_return ((Item None rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_size, Item s rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.push))
(fun ctxt =>
logged_return ((Item (abs (of_int (MBytes.length s))) rest), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Add_tez,
Item x (Item y rest)) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.int64_op))
(fun ctxt =>
op_gtgteqquestion (Lwt._return (op_plusquestion x y))
(fun res => logged_return ((Item res rest), ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Sub_tez,
Item x (Item y rest)) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.int64_op))
(fun ctxt =>
op_gtgteqquestion (Lwt._return (op_minusquestion x y))
(fun res => logged_return ((Item res rest), ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Mul_teznat,
Item x (Item y rest)) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.int64_op))
(fun ctxt =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.z_to_int64))
(fun ctxt =>
match Script_int.to_int64 y with
| None =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Overflow
loc (get_log log))
| Some y =>
op_gtgteqquestion (Lwt._return (op_starquestion x y))
(fun res => logged_return ((Item res rest), ctxt))
end))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Mul_nattez,
Item y (Item x rest)) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.int64_op))
(fun ctxt =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.z_to_int64))
(fun ctxt =>
match Script_int.to_int64 y with
| None =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Overflow
loc (get_log log))
| Some y =>
op_gtgteqquestion (Lwt._return (op_starquestion x y))
(fun res => logged_return ((Item res rest), ctxt))
end))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Or, Item x (Item y rest)) =>
consume_gas_binop descr (op_pipepipe, x, y) Interp_costs.bool_binop
rest ctxt
| (Tezos_raw_protocol_alpha.Script_typed_ir.And, Item x (Item y rest))
=>
consume_gas_binop descr (op_andand, x, y) Interp_costs.bool_binop rest
ctxt
| (Tezos_raw_protocol_alpha.Script_typed_ir.Xor, Item x (Item y rest))
=>
consume_gas_binop descr
(Tezos_protocol_environment_alpha__Environment.Compare.Bool.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt),
x, y) Interp_costs.bool_binop rest ctxt
| (Tezos_raw_protocol_alpha.Script_typed_ir.Not, Item x rest) =>
consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt
| (Tezos_raw_protocol_alpha.Script_typed_ir.Is_nat, Item x rest) =>
consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest
ctxt
| (Tezos_raw_protocol_alpha.Script_typed_ir.Abs_int, Item x rest) =>
consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt
| (Tezos_raw_protocol_alpha.Script_typed_ir.Int_nat, Item x rest) =>
consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt
| (Tezos_raw_protocol_alpha.Script_typed_ir.Neg_int, Item x rest) =>
consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
| (Tezos_raw_protocol_alpha.Script_typed_ir.Neg_nat, Item x rest) =>
consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Add_intint,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Add_intnat,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Add_natint,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Add_natnat,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Sub_int,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intint,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intnat,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natint,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natnat,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_teznat,
Item x (Item y rest)) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.int64_to_z))
(fun ctxt =>
let x := Script_int.of_int64 (Tez.to_mutez x) in
consume_gas_binop descr
((fun x =>
fun y =>
match Script_int.ediv x y with
| None => None
| Some (q, r) =>
match ((Script_int.to_int64 q), (Script_int.to_int64 r))
with
| (Some q, Some r) =>
match ((Tez.of_mutez q), (Tez.of_mutez r)) with
| (Some q, Some r) => Some (q, r)
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end
end), x, y) Interp_costs.div rest ctxt)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_tez,
Item x (Item y rest)) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.int64_to_z))
(fun ctxt =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.int64_to_z))
(fun ctxt =>
let x := Script_int.abs (Script_int.of_int64 (Tez.to_mutez x))
in
let y := Script_int.abs (Script_int.of_int64 (Tez.to_mutez y))
in
consume_gas_binop descr
((fun x =>
fun y =>
match Script_int.ediv_n x y with
| None => None
| Some (q, r) =>
match Script_int.to_int64 r with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some r =>
match Tez.of_mutez r with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some r => Some (q, r)
end
end
end), x, y) Interp_costs.div rest ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intint,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intnat,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natint,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest
ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natnat,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div
rest ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Lsl_nat,
Item x (Item y rest)) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.shift_left x y)))
(fun ctxt =>
match Script_int.shift_left_n x y with
| None =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Overflow
loc (get_log log))
| Some x => logged_return ((Item x rest), ctxt)
end)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Lsr_nat,
Item x (Item y rest)) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.shift_right x y)))
(fun ctxt =>
match Script_int.shift_right_n x y with
| None =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Overflow
loc (get_log log))
| Some r => logged_return ((Item r rest), ctxt)
end)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Or_nat, Item x (Item y rest))
=>
consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor
rest ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.And_nat,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand
rest ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.And_int_nat,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand
rest ctxt
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Xor_nat,
Item x (Item y rest)) =>
consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor
rest ctxt
| (Tezos_raw_protocol_alpha.Script_typed_ir.Not_int, Item x rest) =>
consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest
ctxt
| (Tezos_raw_protocol_alpha.Script_typed_ir.Not_nat, Item x rest) =>
consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest
ctxt
| (Tezos_raw_protocol_alpha.Script_typed_ir.Seq hd tl, stack) =>
op_gtgteqquestion (step log ctxt step_constants hd stack)
(fun function_parameter =>
let '(trans, ctxt) := function_parameter in
step log ctxt step_constants tl trans)
| (Tezos_raw_protocol_alpha.Script_typed_ir.If bt _, Item true rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
(fun ctxt => step log ctxt step_constants bt rest)
| (Tezos_raw_protocol_alpha.Script_typed_ir.If _ bf, Item false rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
(fun ctxt => step log ctxt step_constants bf rest)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Loop body, Item true rest)
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.loop_cycle))
(fun ctxt =>
op_gtgteqquestion (step log ctxt step_constants body rest)
(fun function_parameter =>
let '(trans, ctxt) := function_parameter in
step log ctxt step_constants descr trans))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Loop _, Item false rest) =>
logged_return (rest, ctxt)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Loop_left body,
Item (Tezos_raw_protocol_alpha.Script_typed_ir.L v) rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.loop_cycle))
(fun ctxt =>
op_gtgteqquestion
(step log ctxt step_constants body (Item v rest))
(fun function_parameter =>
let '(trans, ctxt) := function_parameter in
step log ctxt step_constants descr trans))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Loop_left _,
Item (Tezos_raw_protocol_alpha.Script_typed_ir.R v) rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.loop_cycle))
(fun ctxt => logged_return ((Item v rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Dip b, Item ign rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.stack_op))
(fun ctxt =>
op_gtgteqquestion (step log ctxt step_constants b rest)
(fun function_parameter =>
let '(res, ctxt) := function_parameter in
logged_return ((Item ign res), ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Exec,
Item arg (Item lam rest)) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.exec))
(fun ctxt =>
op_gtgteqquestion (interp log ctxt step_constants lam arg)
(fun function_parameter =>
let '(res, ctxt) := function_parameter in
logged_return ((Item res rest), ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Apply capture_ty,
Item capture (Item lam rest)) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.apply))
(fun ctxt =>
let 'Tezos_raw_protocol_alpha.Script_typed_ir.Lam descr expr :=
lam in
let
'Tezos_raw_protocol_alpha.Script_typed_ir.Item_t full_arg_ty _ _ :=
bef descr in
op_gtgteqquestion
(unparse_data ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
capture_ty capture)
(fun function_parameter =>
let '(const_expr, ctxt) := function_parameter in
op_gtgteqquestion (unparse_ty ctxt capture_ty)
(fun function_parameter =>
let '(ty_expr, ctxt) := function_parameter in
match full_arg_ty with
|
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
(capture_ty, _, _) (arg_ty, _, _) _ _ =>
let arg_stack_ty :=
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t arg_ty
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
None in
let const_descr :=
{| loc := loc descr; bef := arg_stack_ty;
aft :=
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
capture_ty arg_stack_ty None;
instr :=
Tezos_raw_protocol_alpha.Script_typed_ir.Const
capture |} in
let pair_descr :=
{| loc := loc descr;
bef :=
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
capture_ty arg_stack_ty None;
aft :=
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
full_arg_ty
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
None;
instr :=
Tezos_raw_protocol_alpha.Script_typed_ir.Cons_pair
|} in
let seq_descr :=
{| loc := loc descr; bef := arg_stack_ty;
aft :=
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
full_arg_ty
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
None;
instr :=
Tezos_raw_protocol_alpha.Script_typed_ir.Seq
const_descr pair_descr |} in
let full_descr :=
{| loc := loc descr; bef := arg_stack_ty;
aft := aft descr;
instr :=
Tezos_raw_protocol_alpha.Script_typed_ir.Seq
seq_descr descr |} in
let full_expr :=
Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Alpha_context.Script.I_PUSH
(cons ty_expr (cons const_expr [])) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Alpha_context.Script.I_PAIR
[] []) (cons expr []))) in
let lam' :=
Tezos_raw_protocol_alpha.Script_typed_ir.Lam
full_descr full_expr in
logged_return ((Item lam' rest), ctxt)
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda lam, rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.push))
(fun ctxt => logged_return ((Item lam rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Failwith tv, Item v _) =>
op_gtgteqquestion
(trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_failure
(unparse_data ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized tv v))
(fun function_parameter =>
let '(v, _ctxt) := function_parameter in
let v := Micheline.strip_locations v in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Reject
loc v (get_log log)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Nop, stack) =>
logged_return (stack, ctxt)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Compare ty,
Item a (Item b rest)) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.compare ty a b)))
(fun ctxt =>
logged_return
((Item
(op_atat Script_int.of_int
(Script_ir_translator.compare_comparable ty a b)) rest),
ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Eq, Item cmpres rest) =>
let cmpres := Script_int.compare cmpres Script_int.zero in
let cmpres :=
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
cmpres 0 in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.compare_res))
(fun ctxt => logged_return ((Item cmpres rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Neq, Item cmpres rest) =>
let cmpres := Script_int.compare cmpres Script_int.zero in
let cmpres :=
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt)
cmpres 0 in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.compare_res))
(fun ctxt => logged_return ((Item cmpres rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Lt, Item cmpres rest) =>
let cmpres := Script_int.compare cmpres Script_int.zero in
let cmpres :=
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
cmpres 0 in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.compare_res))
(fun ctxt => logged_return ((Item cmpres rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Le, Item cmpres rest) =>
let cmpres := Script_int.compare cmpres Script_int.zero in
let cmpres :=
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
cmpres 0 in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.compare_res))
(fun ctxt => logged_return ((Item cmpres rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Gt, Item cmpres rest) =>
let cmpres := Script_int.compare cmpres Script_int.zero in
let cmpres :=
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
cmpres 0 in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.compare_res))
(fun ctxt => logged_return ((Item cmpres rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Ge, Item cmpres rest) =>
let cmpres := Script_int.compare cmpres Script_int.zero in
let cmpres :=
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
cmpres 0 in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.compare_res))
(fun ctxt => logged_return ((Item cmpres rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Pack t, Item value rest) =>
op_gtgteqquestion (Script_ir_translator.pack_data ctxt t value)
(fun function_parameter =>
let '(bytes, ctxt) := function_parameter in
logged_return ((Item string rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Unpack t, Item bytes rest)
=>
op_gtgteqquestion
(Lwt._return (Gas.check_enough ctxt (Script.serialized_cost string)))
(fun function_parameter =>
let 'tt := function_parameter in
if
op_andand
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
(MBytes.length string) 1)
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(MBytes.get_uint8 string 0) 5) then
let bytes :=
MBytes.sub string 1 (op_minus (MBytes.length string) 1) in
match Data_encoding.Binary.of_bytes Script.expr_encoding string
with
| None =>
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Interp_costs.unpack_failed string)))
(fun ctxt => logged_return ((Item None rest), ctxt))
| Some expr =>
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Script.deserialized_cost expr)))
(fun ctxt =>
op_gtgteq
(parse_data None ctxt false t (Micheline.root expr))
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
(value, ctxt) =>
logged_return ((Item (Some value) rest), ctxt)
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ignored =>
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt
(Interp_costs.unpack_failed string)))
(fun ctxt =>
logged_return ((Item None rest), ctxt))
end))
end
else
logged_return ((Item None rest), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Address,
Item (_, address) rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.address))
(fun ctxt => logged_return ((Item address rest), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Contract t entrypoint,
Item contract rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.contract))
(fun ctxt =>
match (contract, entrypoint) with
|
((contract, "default" % string), entrypoint) |
((contract, entrypoint), "default" % string) =>
op_gtgteqquestion
(Script_ir_translator.parse_contract_for_script false ctxt loc
t contract entrypoint)
(fun function_parameter =>
let '(ctxt, maybe_contract) := function_parameter in
logged_return ((Item maybe_contract rest), ctxt))
| _ => logged_return ((Item None rest), ctxt)
end)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Transfer_tokens,
Item p (Item amount (Item (tp, (destination, entrypoint)) rest))) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.transfer))
(fun ctxt =>
op_gtgteqquestion (collect_big_maps ctxt tp p)
(fun function_parameter =>
let '(to_duplicate, ctxt) := function_parameter in
let to_update := no_big_map_id in
op_gtgteqquestion
(extract_big_map_diff ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
true to_duplicate to_update tp p)
(fun function_parameter =>
let '(p, big_map_diff, ctxt) := function_parameter in
op_gtgteqquestion
(unparse_data ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
tp p)
(fun function_parameter =>
let '(p, ctxt) := function_parameter in
let operation :=
Tezos_raw_protocol_alpha.Alpha_context.Transaction
{| amount := amount;
parameters :=
Script.lazy_expr (Micheline.strip_locations p);
entrypoint := entrypoint;
destination := destination |} in
op_gtgteqquestion
(Lwt._return (fresh_internal_nonce ctxt))
(fun function_parameter =>
let '(ctxt, nonce) := function_parameter in
logged_return
((Item
((Tezos_raw_protocol_alpha.Alpha_context.Internal_operation
{| source := self step_constants;
operation := operation; nonce := nonce |}),
big_map_diff) rest), ctxt))))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Create_account,
Item manager (Item delegate (Item _delegatable (Item credit rest))))
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.create_account))
(fun ctxt =>
op_gtgteqquestion
(Contract.fresh_contract_from_current_nonce ctxt)
(fun function_parameter =>
let '(ctxt, contract) := function_parameter in
let manager_bytes :=
Data_encoding.Binary.to_bytes_exn
Signature.Public_key_hash.encoding manager in
let storage :=
op_atat Script_repr.lazy_expr
(op_atat Micheline.strip_locations
(Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
0 manager_bytes)) in
let script :=
{| code := Legacy_support.manager_script_code;
storage := storage |} in
let operation :=
Tezos_raw_protocol_alpha.Alpha_context.Origination
{| delegate := delegate; script := script;
credit := credit; preorigination := Some contract |} in
op_gtgteqquestion (Lwt._return (fresh_internal_nonce ctxt))
(fun function_parameter =>
let '(ctxt, nonce) := function_parameter in
logged_return
((Item
((Tezos_raw_protocol_alpha.Alpha_context.Internal_operation
{| source := self step_constants;
operation := operation; nonce := nonce |}), None)
(Item (contract, "default" % string) rest)), ctxt))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Implicit_account,
Item key rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.implicit_account))
(fun ctxt =>
let contract := Contract.implicit_contract key in
logged_return
((Item
((Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t None),
(contract, "default" % string)) rest), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract storage_type
param_type (Tezos_raw_protocol_alpha.Script_typed_ir.Lam _ code)
root_name,
Item manager
(Item delegate
(Item spendable
(Item delegatable (Item credit (Item init rest)))))) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.create_contract))
(fun ctxt =>
op_gtgteqquestion (unparse_ty ctxt param_type)
(fun function_parameter =>
let '(unparsed_param_type, ctxt) := function_parameter in
let unparsed_param_type :=
Script_ir_translator.add_field_annot
(Option.map
(fun n =>
(* ❌ Variants not supported *)
variant) root_name) None unparsed_param_type in
op_gtgteqquestion (unparse_ty ctxt storage_type)
(fun function_parameter =>
let '(unparsed_storage_type, ctxt) := function_parameter
in
let code :=
op_atat Script.lazy_expr
(Micheline.strip_locations
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter
(cons unparsed_param_type []) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage
(cons unparsed_storage_type []) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Alpha_context.Script.K_code
(cons code []) []) []))))) in
op_gtgteqquestion
(collect_big_maps ctxt storage_type init)
(fun function_parameter =>
let '(to_duplicate, ctxt) := function_parameter in
let to_update := no_big_map_id in
op_gtgteqquestion
(extract_big_map_diff ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
true to_duplicate to_update storage_type init)
(fun function_parameter =>
let '(init, big_map_diff, ctxt) :=
function_parameter in
op_gtgteqquestion
(unparse_data ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
storage_type init)
(fun function_parameter =>
let '(storage, ctxt) := function_parameter in
let storage :=
op_atat Script.lazy_expr
(Micheline.strip_locations storage) in
op_gtgteqquestion
(if spendable then
Legacy_support.add_do manager code storage
else
if delegatable then
Legacy_support.add_set_delegate manager
code storage
else
if
Legacy_support.has_default_entrypoint
code then
op_gtgteqquestion
(Legacy_support.add_root_entrypoint
code)
(fun code => _return (code, storage))
else
_return (code, storage))
(fun function_parameter =>
let '(code, storage) := function_parameter
in
op_gtgteqquestion
(Contract.fresh_contract_from_current_nonce
ctxt)
(fun function_parameter =>
let '(ctxt, contract) :=
function_parameter in
let operation :=
Tezos_raw_protocol_alpha.Alpha_context.Origination
{| delegate := delegate;
script :=
{| code := code;
storage := storage |};
credit := credit;
preorigination := Some contract
|} in
op_gtgteqquestion
(Lwt._return
(fresh_internal_nonce ctxt))
(fun function_parameter =>
let '(ctxt, nonce) :=
function_parameter in
logged_return
((Item
((Tezos_raw_protocol_alpha.Alpha_context.Internal_operation
{|
source :=
self step_constants;
operation := operation;
nonce := nonce |}),
big_map_diff)
(Item
(contract,
"default" % string) rest)),
ctxt))))))))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract_2
storage_type param_type
(Tezos_raw_protocol_alpha.Script_typed_ir.Lam _ code) root_name,
Item delegate (Item credit (Item init rest))) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.create_contract))
(fun ctxt =>
op_gtgteqquestion (unparse_ty ctxt param_type)
(fun function_parameter =>
let '(unparsed_param_type, ctxt) := function_parameter in
let unparsed_param_type :=
Script_ir_translator.add_field_annot
(Option.map
(fun n =>
(* ❌ Variants not supported *)
variant) root_name) None unparsed_param_type in
op_gtgteqquestion (unparse_ty ctxt storage_type)
(fun function_parameter =>
let '(unparsed_storage_type, ctxt) := function_parameter
in
let code :=
Micheline.strip_locations
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
0
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter
(cons unparsed_param_type []) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage
(cons unparsed_storage_type []) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
0
Tezos_raw_protocol_alpha.Alpha_context.Script.K_code
(cons code []) []) [])))) in
op_gtgteqquestion
(collect_big_maps ctxt storage_type init)
(fun function_parameter =>
let '(to_duplicate, ctxt) := function_parameter in
let to_update := no_big_map_id in
op_gtgteqquestion
(extract_big_map_diff ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
true to_duplicate to_update storage_type init)
(fun function_parameter =>
let '(init, big_map_diff, ctxt) :=
function_parameter in
op_gtgteqquestion
(unparse_data ctxt
Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
storage_type init)
(fun function_parameter =>
let '(storage, ctxt) := function_parameter in
let storage :=
Micheline.strip_locations storage in
op_gtgteqquestion
(Contract.fresh_contract_from_current_nonce
ctxt)
(fun function_parameter =>
let '(ctxt, contract) :=
function_parameter in
let operation :=
Tezos_raw_protocol_alpha.Alpha_context.Origination
{| delegate := delegate;
script :=
{| code := Script.lazy_expr code;
storage :=
Script.lazy_expr storage |};
credit := credit;
preorigination := Some contract |}
in
op_gtgteqquestion
(Lwt._return (fresh_internal_nonce ctxt))
(fun function_parameter =>
let '(ctxt, nonce) :=
function_parameter in
logged_return
((Item
((Tezos_raw_protocol_alpha.Alpha_context.Internal_operation
{|
source := self step_constants;
operation := operation;
nonce := nonce |}),
big_map_diff)
(Item
(contract, "default" % string)
rest)), ctxt)))))))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_delegate,
Item delegate rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.create_account))
(fun ctxt =>
let operation :=
Tezos_raw_protocol_alpha.Alpha_context.Delegation delegate in
op_gtgteqquestion (Lwt._return (fresh_internal_nonce ctxt))
(fun function_parameter =>
let '(ctxt, nonce) := function_parameter in
logged_return
((Item
((Tezos_raw_protocol_alpha.Alpha_context.Internal_operation
{| source := self step_constants;
operation := operation; nonce := nonce |}), None) rest),
ctxt)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Balance, rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.balance))
(fun ctxt =>
op_gtgteqquestion
(Contract.get_balance ctxt (self step_constants))
(fun balance => logged_return ((Item balance rest), ctxt)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Now, rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.now))
(fun ctxt =>
let now := Script_timestamp.now ctxt in
logged_return ((Item now rest), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Check_signature,
Item key (Item signature (Item message rest))) =>
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Interp_costs.check_signature key message)))
(fun ctxt =>
let res := Signature.check None key signature message in
logged_return ((Item res rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Hash_key, Item key rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.hash_key))
(fun ctxt =>
logged_return ((Item (Signature.Public_key.hash key) rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Blake2b, Item bytes rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.hash_blake2b string)))
(fun ctxt =>
let hash := Raw_hashes.blake2b string in
logged_return ((Item hash rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Sha256, Item bytes rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.hash_sha256 string)))
(fun ctxt =>
let hash := Raw_hashes.sha256 string in
logged_return ((Item hash rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Sha512, Item bytes rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.hash_sha512 string)))
(fun ctxt =>
let hash := Raw_hashes.sha512 string in
logged_return ((Item hash rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Steps_to_quota, rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.steps_to_quota))
(fun ctxt =>
let steps :=
match Gas.level ctxt with
|
Tezos_raw_protocol_alpha.Alpha_context.Gas.Limited {|
remaining := remaining |} => remaining
| Tezos_raw_protocol_alpha.Alpha_context.Gas.Unaccounted =>
Z.of_string "99999999" % string
end in
logged_return ((Item (abs (of_zint steps)) rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Source, rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.source))
(fun ctxt =>
logged_return
((Item ((payer step_constants), "default" % string) rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Sender, rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.source))
(fun ctxt =>
logged_return
((Item ((source step_constants), "default" % string) rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Self t entrypoint, rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.self))
(fun ctxt =>
logged_return
((Item (t, ((self step_constants), entrypoint)) rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Amount, rest) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.amount))
(fun ctxt =>
logged_return ((Item (amount step_constants) rest), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Dig n n', stack) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.stack_n_op n)))
(fun ctxt =>
op_gtgteqquestion
(interp_stack_prefix_preserving_operation
(fun function_parameter =>
let 'Item v rest := function_parameter in
_return (rest, v)) n' stack)
(fun function_parameter =>
let '(aft, x) := function_parameter in
logged_return ((Item x aft), ctxt)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Dug n n', Item v rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.stack_n_op n)))
(fun ctxt =>
op_gtgteqquestion
(interp_stack_prefix_preserving_operation
(fun stk => _return ((Item v stk), tt)) n' rest)
(fun function_parameter =>
let '(aft, tt) := function_parameter in
logged_return (aft, ctxt)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Dipn n n' b, stack) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.stack_n_op n)))
(fun ctxt =>
op_gtgteqquestion
(interp_stack_prefix_preserving_operation
(fun stk =>
op_gtgteqquestion (step log ctxt step_constants b stk)
(fun function_parameter =>
let '(res, ctxt') := function_parameter in
_return (res, ctxt'))) n' stack)
(fun function_parameter =>
let '(aft, ctxt') := function_parameter in
logged_return (aft, ctxt')))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Dropn n n', stack) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Interp_costs.stack_n_op n)))
(fun ctxt =>
op_gtgteqquestion
(interp_stack_prefix_preserving_operation
(fun stk => _return (stk, stk)) n' stack)
(fun function_parameter =>
let '(_, rest) := function_parameter in
logged_return (rest, ctxt)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.ChainId, rest) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Interp_costs.chain_id))
(fun ctxt =>
logged_return ((Item (chain_id step_constants) rest), ctxt))
end)
with interp {p r : Type}
(log :
option
(Tezos_protocol_environment_alpha__Environment.Pervasives.ref
execution_trace))
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(step_constants : step_constants)
(function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.lambda p r)
: p ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(r * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let 'Tezos_raw_protocol_alpha.Script_typed_ir.Lam code _ := function_parameter
in
fun arg =>
let stack := Item arg Empty in
op_gtgteqquestion
match log with
| None => return_unit
| Some log =>
op_gtgteqquestion
(trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_log
(unparse_stack ctxt (stack, (bef code))))
(fun stack =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_coloneq log
(cons ((loc code), (Gas.level ctxt), stack) (op_exclamation log))
in
return_unit)
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (step log ctxt step_constants code stack)
(fun function_parameter =>
let '(Item ret Empty, ctxt) := function_parameter in
_return (ret, ctxt)))
with execute
(log :
option
(Tezos_protocol_environment_alpha__Environment.Pervasives.ref
execution_trace))
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
(step_constants : step_constants) (entrypoint : string)
(unparsed_script : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
(arg : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
* Tezos_raw_protocol_alpha.Alpha_context.context *
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
op_gtgteqquestion (parse_script None ctxt true unparsed_script)
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_script {|
code := code;
arg_type := arg_type;
storage := storage;
storage_type := storage_type;
root_name := root_name
|}, ctxt) := function_parameter in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_contract_parameter
(self step_constants))
(Lwt._return (find_entrypoint arg_type root_name entrypoint)))
(fun function_parameter =>
let '(box, _) := function_parameter in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_contract_parameter
(self step_constants))
(parse_data None ctxt false arg_type (box arg)))
(fun function_parameter =>
let '(arg, ctxt) := function_parameter in
op_gtgteqquestion
(Script.force_decode ctxt (code unparsed_script))
(fun function_parameter =>
let '(script_code, ctxt) := function_parameter in
op_gtgteqquestion
(Script_ir_translator.collect_big_maps ctxt arg_type arg)
(fun function_parameter =>
let '(to_duplicate, ctxt) := function_parameter in
op_gtgteqquestion
(Script_ir_translator.collect_big_maps ctxt storage_type
storage)
(fun function_parameter =>
let '(to_update, ctxt) := function_parameter in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Runtime_contract_error
(self step_constants) script_code)
(interp log ctxt step_constants code
(arg, storage)))
(fun function_parameter =>
let '((ops, storage), ctxt) := function_parameter
in
op_gtgteqquestion
(Script_ir_translator.extract_big_map_diff ctxt
mode false to_duplicate to_update storage_type
storage)
(fun function_parameter =>
let '(storage, big_map_diff, ctxt) :=
function_parameter in
op_gtgteqquestion
(trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_storage
(unparse_data ctxt mode storage_type
storage))
(fun function_parameter =>
let '(storage, ctxt) := function_parameter
in
let '(ops, op_diffs) := List.split ops in
let big_map_diff :=
match
List.flatten
(List.map (Option.unopt [])
(op_at op_diffs
(cons big_map_diff []))) with
| [] => None
| diff => Some diff
end in
_return
((Micheline.strip_locations storage),
ops, ctxt, big_map_diff)))))))))).
Record execution_result := {
ctxt : Tezos_raw_protocol_alpha.Alpha_context.context;
storage : Tezos_raw_protocol_alpha.Alpha_context.Script.expr;
big_map_diff :
option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff;
operations :
list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation }.
Definition trace
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
(step_constants : step_constants)
(script : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
(entrypoint : string)
(parameter :
Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(execution_result *
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.location *
Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
(option string))))))) :=
let log := ref [] in
op_gtgteqquestion
(execute (Some log) ctxt mode step_constants entrypoint script
(Micheline.root parameter))
(fun function_parameter =>
let '(storage, operations, ctxt, big_map_diff) := function_parameter in
let trace := List.rev (op_exclamation log) in
_return
({| ctxt := ctxt; storage := storage; big_map_diff := big_map_diff;
operations := operations |}, trace)).
Definition execute
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
(step_constants : step_constants)
(script : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
(entrypoint : string)
(parameter :
Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
execution_result) :=
op_gtgteqquestion
(execute None ctxt mode step_constants entrypoint script
(Micheline.root parameter))
(fun function_parameter =>
let '(storage, operations, ctxt, big_map_diff) := function_parameter in
_return
{| ctxt := ctxt; storage := storage; big_map_diff := big_map_diff;
operations := operations |}).
src/proto_alpha/lib_protocol/script_ir_annot.ml 146 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
open Micheline
open Script_tc_errors
open Script_typed_ir
let default_now_annot = Some (`Var_annot "now")
let default_amount_annot = Some (`Var_annot "amount")
let default_balance_annot = Some (`Var_annot "balance")
let default_steps_annot = Some (`Var_annot "steps")
let default_source_annot = Some (`Var_annot "source")
let default_sender_annot = Some (`Var_annot "sender")
let default_self_annot = Some (`Var_annot "self")
let default_arg_annot = Some (`Var_annot "arg")
let default_param_annot = Some (`Var_annot "parameter")
let default_storage_annot = Some (`Var_annot "storage")
let default_car_annot = Some (`Field_annot "car")
let default_cdr_annot = Some (`Field_annot "cdr")
let default_contract_annot = Some (`Field_annot "contract")
let default_addr_annot = Some (`Field_annot "address")
let default_manager_annot = Some (`Field_annot "manager")
let default_pack_annot = Some (`Field_annot "packed")
let default_unpack_annot = Some (`Field_annot "unpacked")
let default_slice_annot = Some (`Field_annot "slice")
let default_elt_annot = Some (`Field_annot "elt")
let default_key_annot = Some (`Field_annot "key")
let default_hd_annot = Some (`Field_annot "hd")
let default_tl_annot = Some (`Field_annot "tl")
let default_some_annot = Some (`Field_annot "some")
let default_left_annot = Some (`Field_annot "left")
let default_right_annot = Some (`Field_annot "right")
let default_binding_annot = Some (`Field_annot "bnd")
let unparse_type_annot : type_annot option -> string list = function
| None ->
[]
| Some (`Type_annot a) ->
[":" ^ a]
let unparse_var_annot : var_annot option -> string list = function
| None ->
[]
| Some (`Var_annot a) ->
["@" ^ a]
let unparse_field_annot : field_annot option -> string list = function
| None ->
[]
| Some (`Field_annot a) ->
["%" ^ a]
let field_to_var_annot : field_annot option -> var_annot option = function
| None ->
None
| Some (`Field_annot s) ->
Some (`Var_annot s)
let type_to_var_annot : type_annot option -> var_annot option = function
| None ->
None
| Some (`Type_annot s) ->
Some (`Var_annot s)
let var_to_field_annot : var_annot option -> field_annot option = function
| None ->
None
| Some (`Var_annot s) ->
Some (`Field_annot s)
let default_annot ~default = function None -> default | annot -> annot
let gen_access_annot :
var_annot option ->
?default:field_annot option ->
field_annot option ->
var_annot option =
fun value_annot ?(default = None) field_annot ->
match (value_annot, field_annot, default) with
| (None, None, _) | (Some _, None, None) | (None, Some (`Field_annot ""), _)
->
None
| (None, Some (`Field_annot f), _) ->
Some (`Var_annot f)
| ( Some (`Var_annot v),
(None | Some (`Field_annot "")),
Some (`Field_annot f) ) ->
Some (`Var_annot (String.concat "." [v; f]))
| (Some (`Var_annot v), Some (`Field_annot f), _) ->
Some (`Var_annot (String.concat "." [v; f]))
let merge_type_annot :
legacy:bool ->
type_annot option ->
type_annot option ->
type_annot option tzresult =
fun ~legacy annot1 annot2 ->
match (annot1, annot2) with
| (None, None) | (Some _, None) | (None, Some _) ->
ok None
| (Some (`Type_annot a1), Some (`Type_annot a2)) ->
if legacy || String.equal a1 a2 then ok annot1
else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2))
let merge_field_annot :
legacy:bool ->
field_annot option ->
field_annot option ->
field_annot option tzresult =
fun ~legacy annot1 annot2 ->
match (annot1, annot2) with
| (None, None) | (Some _, None) | (None, Some _) ->
ok None
| (Some (`Field_annot a1), Some (`Field_annot a2)) ->
if legacy || String.equal a1 a2 then ok annot1
else error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2))
let merge_var_annot : var_annot option -> var_annot option -> var_annot option
=
fun annot1 annot2 ->
match (annot1, annot2) with
| (None, None) | (Some _, None) | (None, Some _) ->
None
| (Some (`Var_annot a1), Some (`Var_annot a2)) ->
if String.equal a1 a2 then annot1 else None
let error_unexpected_annot loc annot =
match annot with [] -> ok () | _ :: _ -> error (Unexpected_annotation loc)
let fail_unexpected_annot loc annot =
Lwt.return (error_unexpected_annot loc annot)
let parse_annots loc ?(allow_special_var = false)
?(allow_special_field = false) l =
(* allow emtpty annotations as wildcards but otherwise only accept
annotations that start with [a-zA-Z_] *)
let sub_or_wildcard ~specials wrap s acc =
let len = String.length s in
if Compare.Int.(len = 1) then ok @@ (wrap None :: acc)
else
match s.[1] with
| 'a' .. 'z' | 'A' .. 'Z' | '_' ->
ok @@ (wrap (Some (String.sub s 1 (len - 1))) :: acc)
| '@' when Compare.Int.(len = 2) && List.mem '@' specials ->
ok @@ (wrap (Some "@") :: acc)
| '%' when List.mem '%' specials ->
if Compare.Int.(len = 2) then ok @@ (wrap (Some "%") :: acc)
else if Compare.Int.(len = 3) && Compare.Char.(s.[2] = '%') then
ok @@ (wrap (Some "%%") :: acc)
else error (Unexpected_annotation loc)
| _ ->
error (Unexpected_annotation loc)
in
List.fold_left
(fun acc s ->
acc
>>? fun acc ->
if Compare.Int.(String.length s = 0) then
error (Unexpected_annotation loc)
else
match s.[0] with
| ':' ->
sub_or_wildcard ~specials:[] (fun a -> `Type_annot a) s acc
| '@' ->
sub_or_wildcard
~specials:(if allow_special_var then ['%'] else [])
(fun a -> `Var_annot a)
s
acc
| '%' ->
sub_or_wildcard
~specials:(if allow_special_field then ['@'] else [])
(fun a -> `Field_annot a)
s
acc
| _ ->
error (Unexpected_annotation loc))
(ok [])
l
>|? List.rev
let opt_var_of_var_opt = function
| `Var_annot None ->
None
| `Var_annot (Some a) ->
Some (`Var_annot a)
let opt_field_of_field_opt = function
| `Field_annot None ->
None
| `Field_annot (Some a) ->
Some (`Field_annot a)
let opt_type_of_type_opt = function
| `Type_annot None ->
None
| `Type_annot (Some a) ->
Some (`Type_annot a)
let classify_annot loc l :
(var_annot option list * type_annot option list * field_annot option list)
tzresult =
try
let (_, rv, _, rt, _, rf) =
List.fold_left
(fun (in_v, rv, in_t, rt, in_f, rf) a ->
match (a, in_v, rv, in_t, rt, in_f, rf) with
| ((`Var_annot _ as a), true, _, _, _, _, _)
| ((`Var_annot _ as a), false, [], _, _, _, _) ->
(true, opt_var_of_var_opt a :: rv, false, rt, false, rf)
| ((`Type_annot _ as a), _, _, true, _, _, _)
| ((`Type_annot _ as a), _, _, false, [], _, _) ->
(false, rv, true, opt_type_of_type_opt a :: rt, false, rf)
| ((`Field_annot _ as a), _, _, _, _, true, _)
| ((`Field_annot _ as a), _, _, _, _, false, []) ->
(false, rv, false, rt, true, opt_field_of_field_opt a :: rf)
| _ ->
raise Exit)
(false, [], false, [], false, [])
l
in
ok (List.rev rv, List.rev rt, List.rev rf)
with Exit -> error (Ungrouped_annotations loc)
let get_one_annot loc = function
| [] ->
ok None
| [a] ->
ok a
| _ ->
error (Unexpected_annotation loc)
let get_two_annot loc = function
| [] ->
ok (None, None)
| [a] ->
ok (a, None)
| [a; b] ->
ok (a, b)
| _ ->
error (Unexpected_annotation loc)
let parse_type_annot : int -> string list -> type_annot option tzresult =
fun loc annot ->
parse_annots loc annot >>? classify_annot loc
>>? fun (vars, types, fields) ->
error_unexpected_annot loc vars
>>? fun () ->
error_unexpected_annot loc fields >>? fun () -> get_one_annot loc types
let parse_type_field_annot :
int -> string list -> (type_annot option * field_annot option) tzresult =
fun loc annot ->
parse_annots loc annot >>? classify_annot loc
>>? fun (vars, types, fields) ->
error_unexpected_annot loc vars
>>? fun () ->
get_one_annot loc types
>>? fun t -> get_one_annot loc fields >|? fun f -> (t, f)
let parse_composed_type_annot :
int ->
string list ->
(type_annot option * field_annot option * field_annot option) tzresult =
fun loc annot ->
parse_annots loc annot >>? classify_annot loc
>>? fun (vars, types, fields) ->
error_unexpected_annot loc vars
>>? fun () ->
get_one_annot loc types
>>? fun t -> get_two_annot loc fields >|? fun (f1, f2) -> (t, f1, f2)
let parse_field_annot : int -> string list -> field_annot option tzresult =
fun loc annot ->
parse_annots loc annot >>? classify_annot loc
>>? fun (vars, types, fields) ->
error_unexpected_annot loc vars
>>? fun () ->
error_unexpected_annot loc types >>? fun () -> get_one_annot loc fields
let extract_field_annot :
Script.node -> (Script.node * field_annot option) tzresult = function
| Prim (loc, prim, args, annot) ->
let rec extract_first acc = function
| [] ->
(None, annot)
| s :: rest ->
if Compare.Int.(String.length s > 0) && Compare.Char.(s.[0] = '%')
then (Some s, List.rev_append acc rest)
else extract_first (s :: acc) rest
in
let (field_annot, annot) = extract_first [] annot in
let field_annot =
match field_annot with
| None ->
None
| Some field_annot ->
Some
(`Field_annot
(String.sub field_annot 1 (String.length field_annot - 1)))
in
ok (Prim (loc, prim, args, annot), field_annot)
| expr ->
ok (expr, None)
let check_correct_field :
field_annot option -> field_annot option -> unit tzresult =
fun f1 f2 ->
match (f1, f2) with
| (None, _) | (_, None) ->
ok ()
| (Some (`Field_annot s1), Some (`Field_annot s2)) ->
if String.equal s1 s2 then ok ()
else error (Inconsistent_field_annotations ("%" ^ s1, "%" ^ s2))
let parse_var_annot :
int ->
?default:var_annot option ->
string list ->
var_annot option tzresult =
fun loc ?default annot ->
parse_annots loc annot >>? classify_annot loc
>>? fun (vars, types, fields) ->
error_unexpected_annot loc types
>>? fun () ->
error_unexpected_annot loc fields
>>? fun () ->
get_one_annot loc vars
>|? function
| Some _ as a ->
a
| None -> (
match default with Some a -> a | None -> None )
let split_last_dot = function
| None ->
(None, None)
| Some (`Field_annot s) -> (
match String.rindex_opt s '.' with
| None ->
(None, Some (`Field_annot s))
| Some i ->
let s1 = String.sub s 0 i in
let s2 = String.sub s (i + 1) (String.length s - i - 1) in
let f =
if Compare.String.equal s2 "car" || Compare.String.equal s2 "cdr"
then None
else Some (`Field_annot s2)
in
(Some (`Var_annot s1), f) )
let common_prefix v1 v2 =
match (v1, v2) with
| (Some (`Var_annot s1), Some (`Var_annot s2))
when Compare.String.equal s1 s2 ->
v1
| (Some _, None) ->
v1
| (None, Some _) ->
v2
| (_, _) ->
None
let parse_constr_annot :
int ->
?if_special_first:field_annot option ->
?if_special_second:field_annot option ->
string list ->
( var_annot option
* type_annot option
* field_annot option
* field_annot option )
tzresult =
fun loc ?if_special_first ?if_special_second annot ->
parse_annots ~allow_special_field:true loc annot
>>? classify_annot loc
>>? fun (vars, types, fields) ->
get_one_annot loc vars
>>? fun v ->
get_one_annot loc types
>>? fun t ->
get_two_annot loc fields
>>? fun (f1, f2) ->
( match (if_special_first, f1) with
| (Some special_var, Some (`Field_annot "@")) ->
ok (split_last_dot special_var)
| (None, Some (`Field_annot "@")) ->
error (Unexpected_annotation loc)
| (_, _) ->
ok (v, f1) )
>>? fun (v1, f1) ->
( match (if_special_second, f2) with
| (Some special_var, Some (`Field_annot "@")) ->
ok (split_last_dot special_var)
| (None, Some (`Field_annot "@")) ->
error (Unexpected_annotation loc)
| (_, _) ->
ok (v, f2) )
>|? fun (v2, f2) ->
let v = match v with None -> common_prefix v1 v2 | Some _ -> v in
(v, t, f1, f2)
let parse_two_var_annot :
int -> string list -> (var_annot option * var_annot option) tzresult =
fun loc annot ->
parse_annots loc annot >>? classify_annot loc
>>? fun (vars, types, fields) ->
error_unexpected_annot loc types
>>? fun () ->
error_unexpected_annot loc fields >>? fun () -> get_two_annot loc vars
let parse_destr_annot :
int ->
string list ->
default_accessor:field_annot option ->
field_name:field_annot option ->
pair_annot:var_annot option ->
value_annot:var_annot option ->
(var_annot option * field_annot option) tzresult =
fun loc annot ~default_accessor ~field_name ~pair_annot ~value_annot ->
parse_annots loc ~allow_special_var:true annot
>>? classify_annot loc
>>? fun (vars, types, fields) ->
error_unexpected_annot loc types
>>? fun () ->
get_one_annot loc vars
>>? fun v ->
get_one_annot loc fields
>|? fun f ->
let default =
gen_access_annot pair_annot field_name ~default:default_accessor
in
let v =
match v with
| Some (`Var_annot "%") ->
field_to_var_annot field_name
| Some (`Var_annot "%%") ->
default
| Some _ ->
v
| None ->
value_annot
in
(v, f)
let parse_entrypoint_annot :
int ->
?default:var_annot option ->
string list ->
(var_annot option * field_annot option) tzresult =
fun loc ?default annot ->
parse_annots loc annot >>? classify_annot loc
>>? fun (vars, types, fields) ->
error_unexpected_annot loc types
>>? fun () ->
get_one_annot loc fields
>>? fun f ->
get_one_annot loc vars
>|? function
| Some _ as a ->
(a, f)
| None -> (
match default with Some a -> (a, f) | None -> (None, f) )
let parse_var_type_annot :
int -> string list -> (var_annot option * type_annot option) tzresult =
fun loc annot ->
parse_annots loc annot >>? classify_annot loc
>>? fun (vars, types, fields) ->
error_unexpected_annot loc fields
>>? fun () ->
get_one_annot loc vars
>>? fun v -> get_one_annot loc types >|? fun t -> (v, t)
src/proto_alpha/lib_protocol/script_ir_annot.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Import Micheline.
Import Script_tc_errors.
Import Script_typed_ir.
Definition default_now_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_amount_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_balance_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_steps_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_source_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_sender_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_self_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_arg_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_param_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_storage_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_car_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_cdr_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_contract_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_addr_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_manager_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_pack_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_unpack_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_slice_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_elt_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_key_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_hd_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_tl_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_some_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_left_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_right_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition default_binding_annot : option variant :=
Some
(* ❌ Variants not supported *)
variant.
Definition unparse_type_annot
(function_parameter :
option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) : list string :=
match function_parameter with
| None => []
| Some (Type_annot a) => cons (op_caret ":" % string a) []
end.
Definition unparse_var_annot
(function_parameter :
option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) : list string :=
match function_parameter with
| None => []
| Some (Var_annot a) => cons (op_caret "@" % string a) []
end.
Definition unparse_field_annot
(function_parameter :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
: list string :=
match function_parameter with
| None => []
| Some (Field_annot a) => cons (op_caret "%" % string a) []
end.
Definition field_to_var_annot
(function_parameter :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
: option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot :=
match function_parameter with
| None => None
| Some (Field_annot s) =>
Some
(* ❌ Variants not supported *)
variant
end.
Definition type_to_var_annot
(function_parameter :
option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)
: option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot :=
match function_parameter with
| None => None
| Some (Type_annot s) =>
Some
(* ❌ Variants not supported *)
variant
end.
Definition var_to_field_annot
(function_parameter :
option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
: option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot :=
match function_parameter with
| None => None
| Some (Var_annot s) =>
Some
(* ❌ Variants not supported *)
variant
end.
Definition default_annot {A : Type}
(default : option A) (function_parameter : option A) : option A :=
match function_parameter with
| None => default
| annot => annot
end.
Definition gen_access_annot
(value_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
(op_staroptstar :
option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
: (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) ->
option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot :=
let default :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => None
end in
fun field_annot =>
match (value_annot, field_annot, default) with
|
(None, None, _) | (Some _, None, None) |
(None, Some (Field_annot "" % string), _) => None
| (None, Some (Field_annot f), _) =>
Some
(* ❌ Variants not supported *)
variant
|
(Some (Var_annot v), None | Some (Field_annot "" % string),
Some (Field_annot f)) =>
Some
(* ❌ Variants not supported *)
variant
| (Some (Var_annot v), Some (Field_annot f), _) =>
Some
(* ❌ Variants not supported *)
variant
end.
Definition merge_type_annot
(legacy : bool)
(annot1 : option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)
(annot2 : option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) :=
match (annot1, annot2) with
| (None, None) | (Some _, None) | (None, Some _) => ok None
| (Some (Type_annot a1), Some (Type_annot a2)) =>
if op_pipepipe legacy (String.equal a1 a2) then
ok annot1
else
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_annotations
(op_caret ":" % string a1) (op_caret ":" % string a2))
end.
Definition merge_field_annot
(legacy : bool)
(annot1 : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
(annot2 : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) :=
match (annot1, annot2) with
| (None, None) | (Some _, None) | (None, Some _) => ok None
| (Some (Field_annot a1), Some (Field_annot a2)) =>
if op_pipepipe legacy (String.equal a1 a2) then
ok annot1
else
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_annotations
(op_caret "%" % string a1) (op_caret "%" % string a2))
end.
Definition merge_var_annot
(annot1 : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
(annot2 : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
: option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot :=
match (annot1, annot2) with
| (None, None) | (Some _, None) | (None, Some _) => None
| (Some (Var_annot a1), Some (Var_annot a2)) =>
if String.equal a1 a2 then
annot1
else
None
end.
Definition error_unexpected_annot {A : Type}
(loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
(annot : list A)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
match annot with
| [] => ok tt
| cons _ _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc)
end.
Definition fail_unexpected_annot {A : Type}
(loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
(annot : list A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
Lwt._return (error_unexpected_annot loc annot).
Definition parse_annots
(loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
(op_staroptstar : option bool)
: (option bool) ->
(list string) ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list variant) :=
let allow_special_var :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun op_staroptstar =>
let allow_special_field :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun l =>
let sub_or_wildcard {A : Type}
(specials : list ascii) (wrap : (option string) -> A) (s : string) (acc
: list A)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list A) :=
let len := String.length s in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
len 1 then
op_atat ok (cons (wrap None) acc)
else
match String.get s 1 with
|
"a" % char |
"b" % char |
"c" % char |
"d" % char |
"e" % char |
"f" % char |
"g" % char |
"h" % char |
"i" % char |
"j" % char |
"k" % char |
"l" % char |
"m" % char |
"n" % char |
"o" % char |
"p" % char |
"q" % char |
"r" % char |
"s" % char |
"t" % char |
"u" % char |
"v" % char |
"w" % char |
"x" % char |
"y" % char |
"z" % char |
"A" % char |
"B" % char |
"C" % char |
"D" % char |
"E" % char |
"F" % char |
"G" % char |
"H" % char |
"I" % char |
"J" % char |
"K" % char |
"L" % char |
"M" % char |
"N" % char |
"O" % char |
"P" % char |
"Q" % char |
"R" % char |
"S" % char |
"T" % char |
"U" % char |
"V" % char |
"W" % char |
"X" % char |
"Y" % char |
"Z" % char |
"_" % char =>
op_atat ok
(cons (wrap (Some (String.sub s 1 (op_minus len 1)))) acc)
| "@" % char => op_atat ok (cons (wrap (Some "@" % string)) acc)
| "%" % char =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
len 2 then
op_atat ok (cons (wrap (Some "%" % string)) acc)
else
if
op_andand
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
len 3)
(Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.get s 2) "%" % char) then
op_atat ok (cons (wrap (Some "%%" % string)) acc)
else
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc)
| _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc)
end in
op_gtpipequestion
(List.fold_left
(fun acc =>
fun s =>
op_gtgtquestion acc
(fun acc =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.length s) 0 then
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc)
else
match String.get s 0 with
| ":" % char =>
sub_or_wildcard []
(fun a =>
(* ❌ Variants not supported *)
variant) s acc
| "@" % char =>
sub_or_wildcard
(if allow_special_var then
cons "%" % char []
else
[])
(fun a =>
(* ❌ Variants not supported *)
variant) s acc
| "%" % char =>
sub_or_wildcard
(if allow_special_field then
cons "@" % char []
else
[])
(fun a =>
(* ❌ Variants not supported *)
variant) s acc
| _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc)
end)) (ok []) l) List.rev.
Definition opt_var_of_var_opt (function_parameter : variant) : option variant :=
match function_parameter with
| Var_annot None => None
| Var_annot (Some a) =>
Some
(* ❌ Variants not supported *)
variant
end.
Definition opt_field_of_field_opt (function_parameter : variant)
: option variant :=
match function_parameter with
| Field_annot None => None
| Field_annot (Some a) =>
Some
(* ❌ Variants not supported *)
variant
end.
Definition opt_type_of_type_opt (function_parameter : variant)
: option variant :=
match function_parameter with
| Type_annot None => None
| Type_annot (Some a) =>
Some
(* ❌ Variants not supported *)
variant
end.
Definition classify_annot
(loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
(l : list variant)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((list (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)) *
(list (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)) *
(list (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))) :=
(* ❌ Try-with are not handled *)
try
(let '(_, rv, _, rt, _, rf) :=
List.fold_left
(fun function_parameter =>
let '(in_v, rv, in_t, rt, in_f, rf) := function_parameter in
fun a =>
match (a, in_v, rv, in_t, rt, in_f, rf) with
|
((Var_annot _) as a, true, _, _, _, _, _) |
((Var_annot _) as a, false, [], _, _, _, _) =>
(true, (cons (opt_var_of_var_opt a) rv), false, rt, false, rf)
|
((Type_annot _) as a, _, _, true, _, _, _) |
((Type_annot _) as a, _, _, false, [], _, _) =>
(false, rv, true, (cons (opt_type_of_type_opt a) rt), false, rf)
|
((Field_annot _) as a, _, _, _, _, true, _) |
((Field_annot _) as a, _, _, _, _, false, []) =>
(false, rv, false, rt, true, (cons (opt_field_of_field_opt a) rf))
| _ => raise Exit
end) (false, [], false, [], false, []) l in
ok ((List.rev rv), (List.rev rt), (List.rev rf))).
Definition get_one_annot {A : Type}
(loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
(function_parameter : list (option A))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option A) :=
match function_parameter with
| [] => ok None
| cons a [] => ok a
| _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc)
end.
Definition get_two_annot {A : Type}
(loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
(function_parameter : list (option A))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option A) * (option A)) :=
match function_parameter with
| [] => ok (None, None)
| cons a [] => ok (a, None)
| cons a (cons b []) => ok (a, b)
| _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc)
end.
Definition parse_type_annot (loc : Z) (annot : list string)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) :=
op_gtgtquestion
(op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
(fun function_parameter =>
let '(vars, types, fields) := function_parameter in
op_gtgtquestion (error_unexpected_annot loc vars)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (error_unexpected_annot loc fields)
(fun function_parameter =>
let 'tt := function_parameter in
get_one_annot loc types))).
Definition parse_type_field_annot (loc : Z) (annot : list string)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
op_gtgtquestion
(op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
(fun function_parameter =>
let '(vars, types, fields) := function_parameter in
op_gtgtquestion (error_unexpected_annot loc vars)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (get_one_annot loc types)
(fun t =>
op_gtpipequestion (get_one_annot loc fields) (fun f => (t, f))))).
Definition parse_composed_type_annot (loc : Z) (annot : list string)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
op_gtgtquestion
(op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
(fun function_parameter =>
let '(vars, types, fields) := function_parameter in
op_gtgtquestion (error_unexpected_annot loc vars)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (get_one_annot loc types)
(fun t =>
op_gtpipequestion (get_two_annot loc fields)
(fun function_parameter =>
let '(f1, f2) := function_parameter in
(t, f1, f2))))).
Definition parse_field_annot (loc : Z) (annot : list string)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) :=
op_gtgtquestion
(op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
(fun function_parameter =>
let '(vars, types, fields) := function_parameter in
op_gtgtquestion (error_unexpected_annot loc vars)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (error_unexpected_annot loc types)
(fun function_parameter =>
let 'tt := function_parameter in
get_one_annot loc fields))).
Definition extract_field_annot
(function_parameter : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.Script.node *
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc prim args
annot =>
let fix extract_first (acc : list string) (function_parameter : list string)
: (option string) *
Tezos_protocol_environment_alpha__Environment.Micheline.annot :=
match function_parameter with
| [] => (None, annot)
| cons s rest =>
if
op_andand
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
(String.length s) 0)
(Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.get s 0) "%" % char) then
((Some s), (List.rev_append acc rest))
else
extract_first (cons s acc) rest
end in
let '(field_annot, annot) := extract_first [] annot in
let field_annot :=
match field_annot with
| None => None
| Some field_annot =>
Some
(* ❌ Variants not supported *)
variant
end in
ok
((Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc prim
args annot), field_annot)
| expr => ok (expr, None)
end.
Definition check_correct_field
(f1 : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
(f2 : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
match (f1, f2) with
| (None, _) | (_, None) => ok tt
| (Some (Field_annot s1), Some (Field_annot s2)) =>
if String.equal s1 s2 then
ok tt
else
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_field_annotations
(op_caret "%" % string s1) (op_caret "%" % string s2))
end.
Definition parse_var_annot
(loc : Z)
(default : option (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
(annot : list string)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) :=
op_gtgtquestion
(op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
(fun function_parameter =>
let '(vars, types, fields) := function_parameter in
op_gtgtquestion (error_unexpected_annot loc types)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (error_unexpected_annot loc fields)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtpipequestion (get_one_annot loc vars)
(fun function_parameter =>
match function_parameter with
| (Some _) as a => a
| None =>
match default with
| Some a => a
| None => None
end
end)))).
Definition split_last_dot (function_parameter : option variant)
: (option variant) * (option variant) :=
match function_parameter with
| None => (None, None)
| Some (Field_annot s) =>
match String.rindex_opt s "." % char with
| None =>
(None,
(Some
(* ❌ Variants not supported *)
variant))
| Some i =>
let s1 := String.sub s 0 i in
let s2 :=
String.sub s (op_plus i 1) (op_minus (op_minus (String.length s) i) 1)
in
let f :=
if
op_pipepipe
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.equal)
s2 "car" % string)
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.equal)
s2 "cdr" % string) then
None
else
Some
(* ❌ Variants not supported *)
variant in
((Some
(* ❌ Variants not supported *)
variant), f)
end
end.
Definition common_prefix (v1 : option variant) (v2 : option variant)
: option variant :=
match (v1, v2) with
| (Some (Var_annot s1), Some (Var_annot s2)) => v1
| (Some _, None) => v1
| (None, Some _) => v2
| (_, _) => None
end.
Definition parse_constr_annot
(loc : Z)
(if_special_first :
option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
(if_special_second :
option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
(annot : list string)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
op_gtgtquestion
(op_gtgtquestion (parse_annots loc None (Some true) annot)
(classify_annot loc))
(fun function_parameter =>
let '(vars, types, fields) := function_parameter in
op_gtgtquestion (get_one_annot loc vars)
(fun v =>
op_gtgtquestion (get_one_annot loc types)
(fun t =>
op_gtgtquestion (get_two_annot loc fields)
(fun function_parameter =>
let '(f1, f2) := function_parameter in
op_gtgtquestion
match (if_special_first, f1) with
| (Some special_var, Some (Field_annot "@" % string)) =>
ok (split_last_dot special_var)
| (None, Some (Field_annot "@" % string)) =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc)
| (_, _) => ok (v, f1)
end
(fun function_parameter =>
let '(v1, f1) := function_parameter in
op_gtpipequestion
match (if_special_second, f2) with
| (Some special_var, Some (Field_annot "@" % string)) =>
ok (split_last_dot special_var)
| (None, Some (Field_annot "@" % string)) =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc)
| (_, _) => ok (v, f2)
end
(fun function_parameter =>
let '(v2, f2) := function_parameter in
let v :=
match v with
| None => common_prefix v1 v2
| Some _ => v
end in
(v, t, f1, f2))))))).
Definition parse_two_var_annot (loc : Z) (annot : list string)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)) :=
op_gtgtquestion
(op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
(fun function_parameter =>
let '(vars, types, fields) := function_parameter in
op_gtgtquestion (error_unexpected_annot loc types)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (error_unexpected_annot loc fields)
(fun function_parameter =>
let 'tt := function_parameter in
get_two_annot loc vars))).
Definition parse_destr_annot
(loc : Z) (annot : list string)
(default_accessor :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
(field_name : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
(pair_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
(value_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
op_gtgtquestion
(op_gtgtquestion (parse_annots loc (Some true) None annot)
(classify_annot loc))
(fun function_parameter =>
let '(vars, types, fields) := function_parameter in
op_gtgtquestion (error_unexpected_annot loc types)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (get_one_annot loc vars)
(fun v =>
op_gtpipequestion (get_one_annot loc fields)
(fun f =>
let default :=
gen_access_annot pair_annot (Some default_accessor)
field_name in
let v :=
match v with
| Some (Var_annot "%" % string) =>
field_to_var_annot field_name
| Some (Var_annot "%%" % string) => default
| Some _ => v
| None => value_annot
end in
(v, f))))).
Definition parse_entrypoint_annot
(loc : Z)
(default : option (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
(annot : list string)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
op_gtgtquestion
(op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
(fun function_parameter =>
let '(vars, types, fields) := function_parameter in
op_gtgtquestion (error_unexpected_annot loc types)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (get_one_annot loc fields)
(fun f =>
op_gtpipequestion (get_one_annot loc vars)
(fun function_parameter =>
match function_parameter with
| (Some _) as a => (a, f)
| None =>
match default with
| Some a => (a, f)
| None => (None, f)
end
end)))).
Definition parse_var_type_annot (loc : Z) (annot : list string)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)) :=
op_gtgtquestion
(op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
(fun function_parameter =>
let '(vars, types, fields) := function_parameter in
op_gtgtquestion (error_unexpected_annot loc fields)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (get_one_annot loc vars)
(fun v =>
op_gtpipequestion (get_one_annot loc types) (fun t => (v, t))))).
src/proto_alpha/lib_protocol/script_ir_translator.ml 515 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
open Micheline
open Script
open Script_typed_ir
open Script_tc_errors
open Script_ir_annot
module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking
module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse
type ex_comparable_ty =
| Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty
type ex_ty = Ex_ty : 'a ty -> ex_ty
type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty
type tc_context =
| Lambda : tc_context
| Dip : 'a stack_ty * tc_context -> tc_context
| Toplevel : {
storage_type : 'sto ty;
param_type : 'param ty;
root_name : string option;
legacy_create_contract_literal : bool;
}
-> tc_context
type unparsing_mode = Optimized | Readable
type type_logger =
int ->
(Script.expr * Script.annot) list ->
(Script.expr * Script.annot) list ->
unit
let add_dip ty annot prev =
match prev with
| Lambda | Toplevel _ ->
Dip (Item_t (ty, Empty_t, annot), prev)
| Dip (stack, _) ->
Dip (Item_t (ty, stack, annot), prev)
(* ---- Type size accounting ------------------------------------------------*)
let rec comparable_type_size : type t a. (t, a) comparable_struct -> int =
fun ty ->
(* No wildcard to force the update when comparable_ty chages. *)
match ty with
| Int_key _ ->
1
| Nat_key _ ->
1
| String_key _ ->
1
| Bytes_key _ ->
1
| Mutez_key _ ->
1
| Bool_key _ ->
1
| Key_hash_key _ ->
1
| Timestamp_key _ ->
1
| Address_key _ ->
1
| Pair_key (_, (t, _), _) ->
1 + comparable_type_size t
let rec type_size : type t. t ty -> int =
fun ty ->
match ty with
| Unit_t _ ->
1
| Int_t _ ->
1
| Nat_t _ ->
1
| Signature_t _ ->
1
| Bytes_t _ ->
1
| String_t _ ->
1
| Mutez_t _ ->
1
| Key_hash_t _ ->
1
| Key_t _ ->
1
| Timestamp_t _ ->
1
| Address_t _ ->
1
| Bool_t _ ->
1
| Operation_t _ ->
1
| Pair_t ((l, _, _), (r, _, _), _, _) ->
1 + type_size l + type_size r
| Union_t ((l, _), (r, _), _, _) ->
1 + type_size l + type_size r
| Lambda_t (arg, ret, _) ->
1 + type_size arg + type_size ret
| Option_t (t, _, _) ->
1 + type_size t
| List_t (t, _, _) ->
1 + type_size t
| Set_t (k, _) ->
1 + comparable_type_size k
| Map_t (k, v, _, _) ->
1 + comparable_type_size k + type_size v
| Big_map_t (k, v, _) ->
1 + comparable_type_size k + type_size v
| Contract_t (arg, _) ->
1 + type_size arg
| Chain_id_t _ ->
1
let rec type_size_of_stack_head : type st. st stack_ty -> up_to:int -> int =
fun stack ~up_to ->
match stack with
| Empty_t ->
0
| Item_t (head, tail, _annot) ->
if Compare.Int.(up_to > 0) then
Compare.Int.max
(type_size head)
(type_size_of_stack_head tail ~up_to:(up_to - 1))
else 0
(* This is the depth of the stack to inspect for sizes overflow. We
only need to check the produced types that can be larger than the
arguments. That's why Swap is 0 for instance as no type grows.
Constant sized types are not checked: it is assumed they are lower
than the bound (otherwise every program would be rejected). *)
let number_of_generated_growing_types : type b a. (b, a) instr -> int =
function
| Drop ->
0
| Dup ->
0
| Swap ->
0
| Const _ ->
1
| Cons_pair ->
1
| Car ->
0
| Cdr ->
0
| Cons_some ->
1
| Cons_none _ ->
1
| If_none _ ->
0
| Left ->
0
| Right ->
0
| If_left _ ->
0
| Cons_list ->
1
| Nil ->
1
| If_cons _ ->
0
| List_map _ ->
1
| List_size ->
0
| List_iter _ ->
1
| Empty_set _ ->
1
| Set_iter _ ->
0
| Set_mem ->
0
| Set_update ->
0
| Set_size ->
0
| Empty_map _ ->
1
| Map_map _ ->
1
| Map_iter _ ->
1
| Map_mem ->
0
| Map_get ->
0
| Map_update ->
0
| Map_size ->
0
| Empty_big_map _ ->
1
| Big_map_get ->
0
| Big_map_update ->
0
| Big_map_mem ->
0
| Concat_string ->
0
| Concat_string_pair ->
0
| Slice_string ->
0
| String_size ->
0
| Concat_bytes ->
0
| Concat_bytes_pair ->
0
| Slice_bytes ->
0
| Bytes_size ->
0
| Add_seconds_to_timestamp ->
0
| Add_timestamp_to_seconds ->
0
| Sub_timestamp_seconds ->
0
| Diff_timestamps ->
0
| Add_tez ->
0
| Sub_tez ->
0
| Mul_teznat ->
0
| Mul_nattez ->
0
| Ediv_teznat ->
0
| Ediv_tez ->
0
| Or ->
0
| And ->
0
| Xor ->
0
| Not ->
0
| Is_nat ->
0
| Neg_nat ->
0
| Neg_int ->
0
| Abs_int ->
0
| Int_nat ->
0
| Add_intint ->
0
| Add_intnat ->
0
| Add_natint ->
0
| Add_natnat ->
0
| Sub_int ->
0
| Mul_intint ->
0
| Mul_intnat ->
0
| Mul_natint ->
0
| Mul_natnat ->
0
| Ediv_intint ->
0
| Ediv_intnat ->
0
| Ediv_natint ->
0
| Ediv_natnat ->
0
| Lsl_nat ->
0
| Lsr_nat ->
0
| Or_nat ->
0
| And_nat ->
0
| And_int_nat ->
0
| Xor_nat ->
0
| Not_nat ->
0
| Not_int ->
0
| Seq _ ->
0
| If _ ->
0
| Loop _ ->
0
| Loop_left _ ->
0
| Dip _ ->
0
| Exec ->
0
| Apply _ ->
0
| Lambda _ ->
1
| Failwith _ ->
1
| Nop ->
0
| Compare _ ->
1
| Eq ->
0
| Neq ->
0
| Lt ->
0
| Gt ->
0
| Le ->
0
| Ge ->
0
| Address ->
0
| Contract _ ->
1
| Transfer_tokens ->
1
| Create_account ->
0
| Implicit_account ->
0
| Create_contract _ ->
1
| Create_contract_2 _ ->
1
| Now ->
0
| Balance ->
0
| Check_signature ->
0
| Hash_key ->
0
| Blake2b ->
0
| Sha256 ->
0
| Sha512 ->
0
| Steps_to_quota ->
0
| Source ->
0
| Sender ->
0
| Self _ ->
1
| Amount ->
0
| Set_delegate ->
0
| Pack _ ->
0
| Unpack _ ->
1
| Dig _ ->
0
| Dug _ ->
0
| Dipn _ ->
0
| Dropn _ ->
0
| ChainId ->
0
(* ---- Error helpers -------------------------------------------------------*)
let location = function
| Prim (loc, _, _, _)
| Int (loc, _)
| String (loc, _)
| Bytes (loc, _)
| Seq (loc, _) ->
loc
let kind = function
| Int _ ->
Int_kind
| String _ ->
String_kind
| Bytes _ ->
Bytes_kind
| Prim _ ->
Prim_kind
| Seq _ ->
Seq_kind
let namespace = function
| K_parameter | K_storage | K_code ->
Keyword_namespace
| D_False
| D_Elt
| D_Left
| D_None
| D_Pair
| D_Right
| D_Some
| D_True
| D_Unit ->
Constant_namespace
| I_PACK
| I_UNPACK
| I_BLAKE2B
| I_SHA256
| I_SHA512
| I_ABS
| I_ADD
| I_AMOUNT
| I_AND
| I_BALANCE
| I_CAR
| I_CDR
| I_CHAIN_ID
| I_CHECK_SIGNATURE
| I_COMPARE
| I_CONCAT
| I_CONS
| I_CREATE_ACCOUNT
| I_CREATE_CONTRACT
| I_IMPLICIT_ACCOUNT
| I_DIP
| I_DROP
| I_DUP
| I_EDIV
| I_EMPTY_BIG_MAP
| I_EMPTY_MAP
| I_EMPTY_SET
| I_EQ
| I_EXEC
| I_APPLY
| I_FAILWITH
| I_GE
| I_GET
| I_GT
| I_HASH_KEY
| I_IF
| I_IF_CONS
| I_IF_LEFT
| I_IF_NONE
| I_INT
| I_LAMBDA
| I_LE
| I_LEFT
| I_LOOP
| I_LSL
| I_LSR
| I_LT
| I_MAP
| I_MEM
| I_MUL
| I_NEG
| I_NEQ
| I_NIL
| I_NONE
| I_NOT
| I_NOW
| I_OR
| I_PAIR
| I_PUSH
| I_RIGHT
| I_SIZE
| I_SOME
| I_SOURCE
| I_SENDER
| I_SELF
| I_SLICE
| I_STEPS_TO_QUOTA
| I_SUB
| I_SWAP
| I_TRANSFER_TOKENS
| I_SET_DELEGATE
| I_UNIT
| I_UPDATE
| I_XOR
| I_ITER
| I_LOOP_LEFT
| I_ADDRESS
| I_CONTRACT
| I_ISNAT
| I_CAST
| I_RENAME
| I_DIG
| I_DUG ->
Instr_namespace
| T_bool
| T_contract
| T_int
| T_key
| T_key_hash
| T_lambda
| T_list
| T_map
| T_big_map
| T_nat
| T_option
| T_or
| T_pair
| T_set
| T_signature
| T_string
| T_bytes
| T_mutez
| T_timestamp
| T_unit
| T_operation
| T_address
| T_chain_id ->
Type_namespace
let unexpected expr exp_kinds exp_ns exp_prims =
match expr with
| Int (loc, _) ->
Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind)
| String (loc, _) ->
Invalid_kind (loc, Prim_kind :: exp_kinds, String_kind)
| Bytes (loc, _) ->
Invalid_kind (loc, Prim_kind :: exp_kinds, Bytes_kind)
| Seq (loc, _) ->
Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind)
| Prim (loc, name, _, _) -> (
match (namespace name, exp_ns) with
| (Type_namespace, Type_namespace)
| (Instr_namespace, Instr_namespace)
| (Constant_namespace, Constant_namespace) ->
Invalid_primitive (loc, exp_prims, name)
| (ns, _) ->
Invalid_namespace (loc, name, exp_ns, ns) )
let check_kind kinds expr =
let kind = kind expr in
if List.mem kind kinds then return_unit
else
let loc = location expr in
fail (Invalid_kind (loc, kinds, kind))
(* ---- Sets and Maps -------------------------------------------------------*)
let wrap_compare compare a b =
let res = compare a b in
if Compare.Int.(res = 0) then 0 else if Compare.Int.(res > 0) then 1 else -1
let rec compare_comparable :
type a s. (a, s) comparable_struct -> a -> a -> int =
fun kind ->
match kind with
| String_key _ ->
wrap_compare Compare.String.compare
| Bool_key _ ->
wrap_compare Compare.Bool.compare
| Mutez_key _ ->
wrap_compare Tez.compare
| Key_hash_key _ ->
wrap_compare Signature.Public_key_hash.compare
| Int_key _ ->
wrap_compare Script_int.compare
| Nat_key _ ->
wrap_compare Script_int.compare
| Timestamp_key _ ->
wrap_compare Script_timestamp.compare
| Address_key _ ->
wrap_compare
@@ fun (x, ex) (y, ey) ->
let lres = Contract.compare x y in
if Compare.Int.(lres = 0) then Compare.String.compare ex ey else lres
| Bytes_key _ ->
wrap_compare MBytes.compare
| Pair_key ((tl, _), (tr, _), _) ->
fun (lx, rx) (ly, ry) ->
let lres = compare_comparable tl lx ly in
if Compare.Int.(lres = 0) then compare_comparable tr rx ry else lres
let empty_set : type a. a comparable_ty -> a set =
fun ty ->
let module OPS = Set.Make (struct
type t = a
let compare = compare_comparable ty
end) in
( module struct
type elt = a
let elt_ty = ty
module OPS = OPS
let boxed = OPS.empty
let size = 0
end )
let set_update : type a. a -> bool -> a set -> a set =
fun v b (module Box) ->
( module struct
type elt = a
let elt_ty = Box.elt_ty
module OPS = Box.OPS
let boxed =
if b then Box.OPS.add v Box.boxed else Box.OPS.remove v Box.boxed
let size =
let mem = Box.OPS.mem v Box.boxed in
if mem then if b then Box.size else Box.size - 1
else if b then Box.size + 1
else Box.size
end )
let set_mem : type elt. elt -> elt set -> bool =
fun v (module Box) -> Box.OPS.mem v Box.boxed
let set_fold : type elt acc. (elt -> acc -> acc) -> elt set -> acc -> acc =
fun f (module Box) -> Box.OPS.fold f Box.boxed
let set_size : type elt. elt set -> Script_int.n Script_int.num =
fun (module Box) -> Script_int.(abs (of_int Box.size))
let map_key_ty : type a b. (a, b) map -> a comparable_ty =
fun (module Box) -> Box.key_ty
let empty_map : type a b. a comparable_ty -> (a, b) map =
fun ty ->
let module OPS = Map.Make (struct
type t = a
let compare = compare_comparable ty
end) in
( module struct
type key = a
type value = b
let key_ty = ty
module OPS = OPS
let boxed = (OPS.empty, 0)
end )
let map_get : type key value. key -> (key, value) map -> value option =
fun k (module Box) -> Box.OPS.find_opt k (fst Box.boxed)
let map_update : type a b. a -> b option -> (a, b) map -> (a, b) map =
fun k v (module Box) ->
( module struct
type key = a
type value = b
let key_ty = Box.key_ty
module OPS = Box.OPS
let boxed =
let (map, size) = Box.boxed in
let contains = Box.OPS.mem k map in
match v with
| Some v ->
(Box.OPS.add k v map, size + if contains then 0 else 1)
| None ->
(Box.OPS.remove k map, size - if contains then 1 else 0)
end )
let map_set : type a b. a -> b -> (a, b) map -> (a, b) map =
fun k v (module Box) ->
( module struct
type key = a
type value = b
let key_ty = Box.key_ty
module OPS = Box.OPS
let boxed =
let (map, size) = Box.boxed in
(Box.OPS.add k v map, if Box.OPS.mem k map then size else size + 1)
end )
let map_mem : type key value. key -> (key, value) map -> bool =
fun k (module Box) -> Box.OPS.mem k (fst Box.boxed)
let map_fold :
type key value acc.
(key -> value -> acc -> acc) -> (key, value) map -> acc -> acc =
fun f (module Box) -> Box.OPS.fold f (fst Box.boxed)
let map_size : type key value. (key, value) map -> Script_int.n Script_int.num
=
fun (module Box) -> Script_int.(abs (of_int (snd Box.boxed)))
(* ---- Unparsing (Typed IR -> Untyped expressions) of types -----------------*)
let rec ty_of_comparable_ty : type a s. (a, s) comparable_struct -> a ty =
function
| Int_key tname ->
Int_t tname
| Nat_key tname ->
Nat_t tname
| String_key tname ->
String_t tname
| Bytes_key tname ->
Bytes_t tname
| Mutez_key tname ->
Mutez_t tname
| Bool_key tname ->
Bool_t tname
| Key_hash_key tname ->
Key_hash_t tname
| Timestamp_key tname ->
Timestamp_t tname
| Address_key tname ->
Address_t tname
| Pair_key ((l, al), (r, ar), tname) ->
Pair_t
( (ty_of_comparable_ty l, al, None),
(ty_of_comparable_ty r, ar, None),
tname,
false )
let rec comparable_ty_of_ty : type a. a ty -> a comparable_ty option = function
| Int_t tname ->
Some (Int_key tname)
| Nat_t tname ->
Some (Nat_key tname)
| String_t tname ->
Some (String_key tname)
| Bytes_t tname ->
Some (Bytes_key tname)
| Mutez_t tname ->
Some (Mutez_key tname)
| Bool_t tname ->
Some (Bool_key tname)
| Key_hash_t tname ->
Some (Key_hash_key tname)
| Timestamp_t tname ->
Some (Timestamp_key tname)
| Address_t tname ->
Some (Address_key tname)
| Pair_t ((l, al, _), (r, ar, _), pname, _) -> (
match comparable_ty_of_ty r with
| None ->
None
| Some rty -> (
match comparable_ty_of_ty l with
| None ->
None
| Some (Pair_key _) ->
None (* not a comb *)
| Some (Int_key tname) ->
Some (Pair_key ((Int_key tname, al), (rty, ar), pname))
| Some (Nat_key tname) ->
Some (Pair_key ((Nat_key tname, al), (rty, ar), pname))
| Some (String_key tname) ->
Some (Pair_key ((String_key tname, al), (rty, ar), pname))
| Some (Bytes_key tname) ->
Some (Pair_key ((Bytes_key tname, al), (rty, ar), pname))
| Some (Mutez_key tname) ->
Some (Pair_key ((Mutez_key tname, al), (rty, ar), pname))
| Some (Bool_key tname) ->
Some (Pair_key ((Bool_key tname, al), (rty, ar), pname))
| Some (Key_hash_key tname) ->
Some (Pair_key ((Key_hash_key tname, al), (rty, ar), pname))
| Some (Timestamp_key tname) ->
Some (Pair_key ((Timestamp_key tname, al), (rty, ar), pname))
| Some (Address_key tname) ->
Some (Pair_key ((Address_key tname, al), (rty, ar), pname)) ) )
| _ ->
None
let add_field_annot a var = function
| Prim (loc, prim, args, annots) ->
Prim
( loc,
prim,
args,
annots @ unparse_field_annot a @ unparse_var_annot var )
| expr ->
expr
let rec unparse_comparable_ty :
type a s. (a, s) comparable_struct -> Script.node = function
| Int_key tname ->
Prim (-1, T_int, [], unparse_type_annot tname)
| Nat_key tname ->
Prim (-1, T_nat, [], unparse_type_annot tname)
| String_key tname ->
Prim (-1, T_string, [], unparse_type_annot tname)
| Bytes_key tname ->
Prim (-1, T_bytes, [], unparse_type_annot tname)
| Mutez_key tname ->
Prim (-1, T_mutez, [], unparse_type_annot tname)
| Bool_key tname ->
Prim (-1, T_bool, [], unparse_type_annot tname)
| Key_hash_key tname ->
Prim (-1, T_key_hash, [], unparse_type_annot tname)
| Timestamp_key tname ->
Prim (-1, T_timestamp, [], unparse_type_annot tname)
| Address_key tname ->
Prim (-1, T_address, [], unparse_type_annot tname)
| Pair_key ((l, al), (r, ar), pname) ->
let tl = add_field_annot al None (unparse_comparable_ty l) in
let tr = add_field_annot ar None (unparse_comparable_ty r) in
Prim (-1, T_pair, [tl; tr], unparse_type_annot pname)
let rec unparse_ty_no_lwt :
type a. context -> a ty -> (Script.node * context) tzresult =
fun ctxt ty ->
Gas.consume ctxt Unparse_costs.cycle
>>? fun ctxt ->
let return ctxt (name, args, annot) =
let result = Prim (-1, name, args, annot) in
Gas.consume ctxt (Unparse_costs.prim_cost (List.length args) annot)
>>? fun ctxt -> ok (result, ctxt)
in
match ty with
| Unit_t tname ->
return ctxt (T_unit, [], unparse_type_annot tname)
| Int_t tname ->
return ctxt (T_int, [], unparse_type_annot tname)
| Nat_t tname ->
return ctxt (T_nat, [], unparse_type_annot tname)
| String_t tname ->
return ctxt (T_string, [], unparse_type_annot tname)
| Bytes_t tname ->
return ctxt (T_bytes, [], unparse_type_annot tname)
| Mutez_t tname ->
return ctxt (T_mutez, [], unparse_type_annot tname)
| Bool_t tname ->
return ctxt (T_bool, [], unparse_type_annot tname)
| Key_hash_t tname ->
return ctxt (T_key_hash, [], unparse_type_annot tname)
| Key_t tname ->
return ctxt (T_key, [], unparse_type_annot tname)
| Timestamp_t tname ->
return ctxt (T_timestamp, [], unparse_type_annot tname)
| Address_t tname ->
return ctxt (T_address, [], unparse_type_annot tname)
| Signature_t tname ->
return ctxt (T_signature, [], unparse_type_annot tname)
| Operation_t tname ->
return ctxt (T_operation, [], unparse_type_annot tname)
| Chain_id_t tname ->
return ctxt (T_chain_id, [], unparse_type_annot tname)
| Contract_t (ut, tname) ->
unparse_ty_no_lwt ctxt ut
>>? fun (t, ctxt) ->
return ctxt (T_contract, [t], unparse_type_annot tname)
| Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname, _) ->
let annot = unparse_type_annot tname in
unparse_ty_no_lwt ctxt utl
>>? fun (utl, ctxt) ->
let tl = add_field_annot l_field l_var utl in
unparse_ty_no_lwt ctxt utr
>>? fun (utr, ctxt) ->
let tr = add_field_annot r_field r_var utr in
return ctxt (T_pair, [tl; tr], annot)
| Union_t ((utl, l_field), (utr, r_field), tname, _) ->
let annot = unparse_type_annot tname in
unparse_ty_no_lwt ctxt utl
>>? fun (utl, ctxt) ->
let tl = add_field_annot l_field None utl in
unparse_ty_no_lwt ctxt utr
>>? fun (utr, ctxt) ->
let tr = add_field_annot r_field None utr in
return ctxt (T_or, [tl; tr], annot)
| Lambda_t (uta, utr, tname) ->
unparse_ty_no_lwt ctxt uta
>>? fun (ta, ctxt) ->
unparse_ty_no_lwt ctxt utr
>>? fun (tr, ctxt) ->
return ctxt (T_lambda, [ta; tr], unparse_type_annot tname)
| Option_t (ut, tname, _) ->
let annot = unparse_type_annot tname in
unparse_ty_no_lwt ctxt ut
>>? fun (ut, ctxt) -> return ctxt (T_option, [ut], annot)
| List_t (ut, tname, _) ->
unparse_ty_no_lwt ctxt ut
>>? fun (t, ctxt) -> return ctxt (T_list, [t], unparse_type_annot tname)
| Set_t (ut, tname) ->
let t = unparse_comparable_ty ut in
return ctxt (T_set, [t], unparse_type_annot tname)
| Map_t (uta, utr, tname, _) ->
let ta = unparse_comparable_ty uta in
unparse_ty_no_lwt ctxt utr
>>? fun (tr, ctxt) ->
return ctxt (T_map, [ta; tr], unparse_type_annot tname)
| Big_map_t (uta, utr, tname) ->
let ta = unparse_comparable_ty uta in
unparse_ty_no_lwt ctxt utr
>>? fun (tr, ctxt) ->
return ctxt (T_big_map, [ta; tr], unparse_type_annot tname)
let unparse_ty ctxt ty = Lwt.return (unparse_ty_no_lwt ctxt ty)
let rec strip_var_annots = function
| (Int _ | String _ | Bytes _) as atom ->
atom
| Seq (loc, args) ->
Seq (loc, List.map strip_var_annots args)
| Prim (loc, name, args, annots) ->
let not_var_annot s = Compare.Char.(s.[0] <> '@') in
let annots = List.filter not_var_annot annots in
Prim (loc, name, List.map strip_var_annots args, annots)
let serialize_ty_for_error ctxt ty =
unparse_ty_no_lwt ctxt ty
|> record_trace Cannot_serialize_error
>|? fun (ty, ctxt) -> (strip_locations (strip_var_annots ty), ctxt)
let rec unparse_stack :
type a.
context ->
a stack_ty ->
((Script.expr * Script.annot) list * context) tzresult Lwt.t =
fun ctxt -> function
| Empty_t ->
return ([], ctxt)
| Item_t (ty, rest, annot) ->
unparse_ty ctxt ty
>>=? fun (uty, ctxt) ->
unparse_stack ctxt rest
>>=? fun (urest, ctxt) ->
return ((strip_locations uty, unparse_var_annot annot) :: urest, ctxt)
let serialize_stack_for_error ctxt stack_ty =
trace Cannot_serialize_error (unparse_stack ctxt stack_ty)
let name_of_ty : type a. a ty -> type_annot option = function
| Unit_t tname ->
tname
| Int_t tname ->
tname
| Nat_t tname ->
tname
| String_t tname ->
tname
| Bytes_t tname ->
tname
| Mutez_t tname ->
tname
| Bool_t tname ->
tname
| Key_hash_t tname ->
tname
| Key_t tname ->
tname
| Timestamp_t tname ->
tname
| Address_t tname ->
tname
| Signature_t tname ->
tname
| Operation_t tname ->
tname
| Chain_id_t tname ->
tname
| Contract_t (_, tname) ->
tname
| Pair_t (_, _, tname, _) ->
tname
| Union_t (_, _, tname, _) ->
tname
| Lambda_t (_, _, tname) ->
tname
| Option_t (_, tname, _) ->
tname
| List_t (_, tname, _) ->
tname
| Set_t (_, tname) ->
tname
| Map_t (_, _, tname, _) ->
tname
| Big_map_t (_, _, tname) ->
tname
(* ---- Equality witnesses --------------------------------------------------*)
type ('ta, 'tb) eq = Eq : ('same, 'same) eq
let comparable_ty_eq :
type ta tb.
context ->
ta comparable_ty ->
tb comparable_ty ->
(ta comparable_ty, tb comparable_ty) eq tzresult =
fun ctxt ta tb ->
match (ta, tb) with
| (Int_key _, Int_key _) ->
Ok Eq
| (Nat_key _, Nat_key _) ->
Ok Eq
| (String_key _, String_key _) ->
Ok Eq
| (Bytes_key _, Bytes_key _) ->
Ok Eq
| (Mutez_key _, Mutez_key _) ->
Ok Eq
| (Bool_key _, Bool_key _) ->
Ok Eq
| (Key_hash_key _, Key_hash_key _) ->
Ok Eq
| (Timestamp_key _, Timestamp_key _) ->
Ok Eq
| (Address_key _, Address_key _) ->
Ok Eq
| (_, _) ->
serialize_ty_for_error ctxt (ty_of_comparable_ty ta)
>>? fun (ta, ctxt) ->
serialize_ty_for_error ctxt (ty_of_comparable_ty tb)
>>? fun (tb, _ctxt) -> error (Inconsistent_types (ta, tb))
let record_inconsistent ctxt ta tb =
record_trace_eval (fun () ->
serialize_ty_for_error ctxt ta
>>? fun (ta, ctxt) ->
serialize_ty_for_error ctxt tb
>|? fun (tb, _ctxt) -> Inconsistent_types (ta, tb))
let record_inconsistent_type_annotations ctxt loc ta tb =
record_trace_eval (fun () ->
serialize_ty_for_error ctxt ta
>>? fun (ta, ctxt) ->
serialize_ty_for_error ctxt tb
>|? fun (tb, _ctxt) -> Inconsistent_type_annotations (loc, ta, tb))
let rec ty_eq :
type ta tb.
context -> ta ty -> tb ty -> ((ta ty, tb ty) eq * context) tzresult =
fun ctxt ta tb ->
let ok (eq : (ta ty, tb ty) eq) ctxt nb_args :
((ta ty, tb ty) eq * context) tzresult =
Gas.consume ctxt (Typecheck_costs.type_ (2 * nb_args))
>>? fun ctxt -> Ok (eq, ctxt)
in
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt ->
match (ta, tb) with
| (Unit_t _, Unit_t _) ->
ok Eq ctxt 0
| (Int_t _, Int_t _) ->
ok Eq ctxt 0
| (Nat_t _, Nat_t _) ->
ok Eq ctxt 0
| (Key_t _, Key_t _) ->
ok Eq ctxt 0
| (Key_hash_t _, Key_hash_t _) ->
ok Eq ctxt 0
| (String_t _, String_t _) ->
ok Eq ctxt 0
| (Bytes_t _, Bytes_t _) ->
ok Eq ctxt 0
| (Signature_t _, Signature_t _) ->
ok Eq ctxt 0
| (Mutez_t _, Mutez_t _) ->
ok Eq ctxt 0
| (Timestamp_t _, Timestamp_t _) ->
ok Eq ctxt 0
| (Chain_id_t _, Chain_id_t _) ->
ok Eq ctxt 0
| (Address_t _, Address_t _) ->
ok Eq ctxt 0
| (Bool_t _, Bool_t _) ->
ok Eq ctxt 0
| (Operation_t _, Operation_t _) ->
ok Eq ctxt 0
| (Map_t (tal, tar, _, _), Map_t (tbl, tbr, _, _)) ->
comparable_ty_eq ctxt tal tbl
>>? (fun Eq -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
|> record_inconsistent ctxt ta tb
| (Big_map_t (tal, tar, _), Big_map_t (tbl, tbr, _)) ->
comparable_ty_eq ctxt tal tbl
>>? (fun Eq -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
|> record_inconsistent ctxt ta tb
| (Set_t (ea, _), Set_t (eb, _)) ->
comparable_ty_eq ctxt ea eb
>>? (fun Eq -> ok Eq ctxt 1)
|> record_inconsistent ctxt ta tb
| ( Pair_t ((tal, _, _), (tar, _, _), _, _),
Pair_t ((tbl, _, _), (tbr, _, _), _, _) ) ->
ty_eq ctxt tal tbl
>>? (fun (Eq, ctxt) ->
ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
|> record_inconsistent ctxt ta tb
| (Union_t ((tal, _), (tar, _), _, _), Union_t ((tbl, _), (tbr, _), _, _)) ->
ty_eq ctxt tal tbl
>>? (fun (Eq, ctxt) ->
ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
|> record_inconsistent ctxt ta tb
| (Lambda_t (tal, tar, _), Lambda_t (tbl, tbr, _)) ->
ty_eq ctxt tal tbl
>>? (fun (Eq, ctxt) ->
ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
|> record_inconsistent ctxt ta tb
| (Contract_t (tal, _), Contract_t (tbl, _)) ->
ty_eq ctxt tal tbl
>>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
|> record_inconsistent ctxt ta tb
| (Option_t (tva, _, _), Option_t (tvb, _, _)) ->
ty_eq ctxt tva tvb
>>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
|> record_inconsistent ctxt ta tb
| (List_t (tva, _, _), List_t (tvb, _, _)) ->
ty_eq ctxt tva tvb
>>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
|> record_inconsistent ctxt ta tb
| (_, _) ->
serialize_ty_for_error ctxt ta
>>? fun (ta, ctxt) ->
serialize_ty_for_error ctxt tb
>>? fun (tb, _ctxt) -> error (Inconsistent_types (ta, tb))
let rec stack_ty_eq :
type ta tb.
context ->
int ->
ta stack_ty ->
tb stack_ty ->
((ta stack_ty, tb stack_ty) eq * context) tzresult =
fun ctxt lvl ta tb ->
match (ta, tb) with
| (Item_t (tva, ra, _), Item_t (tvb, rb, _)) ->
ty_eq ctxt tva tvb
|> record_trace (Bad_stack_item lvl)
>>? fun (Eq, ctxt) ->
stack_ty_eq ctxt (lvl + 1) ra rb
>>? fun (Eq, ctxt) ->
(Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult)
| (Empty_t, Empty_t) ->
Ok (Eq, ctxt)
| (_, _) ->
error Bad_stack_length
let merge_comparable_types :
type ta.
legacy:bool ->
ta comparable_ty ->
ta comparable_ty ->
ta comparable_ty tzresult =
fun ~legacy ta tb ->
match (ta, tb) with
| (Int_key annot_a, Int_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Int_key annot
| (Nat_key annot_a, Nat_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Nat_key annot
| (String_key annot_a, String_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b
>|? fun annot -> String_key annot
| (Bytes_key annot_a, Bytes_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bytes_key annot
| (Mutez_key annot_a, Mutez_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Mutez_key annot
| (Bool_key annot_a, Bool_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bool_key annot
| (Key_hash_key annot_a, Key_hash_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b
>|? fun annot -> Key_hash_key annot
| (Timestamp_key annot_a, Timestamp_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b
>|? fun annot -> Timestamp_key annot
| (Address_key annot_a, Address_key annot_b) ->
merge_type_annot ~legacy annot_a annot_b
>|? fun annot -> Address_key annot
| (_, _) ->
assert false
(* FIXME: fix injectivity of some types *)
let merge_types :
type b.
legacy:bool ->
context ->
Script.location ->
b ty ->
b ty ->
(b ty * context) tzresult =
fun ~legacy ->
let rec help : type a. context -> a ty -> a ty -> (a ty * context) tzresult =
fun ctxt ty1 ty2 ->
match (ty1, ty2) with
| (Unit_t tn1, Unit_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Unit_t tname, ctxt)
| (Int_t tn1, Int_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Int_t tname, ctxt)
| (Nat_t tn1, Nat_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Nat_t tname, ctxt)
| (Key_t tn1, Key_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Key_t tname, ctxt)
| (Key_hash_t tn1, Key_hash_t tn2) ->
merge_type_annot ~legacy tn1 tn2
>|? fun tname -> (Key_hash_t tname, ctxt)
| (String_t tn1, String_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (String_t tname, ctxt)
| (Bytes_t tn1, Bytes_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Bytes_t tname, ctxt)
| (Signature_t tn1, Signature_t tn2) ->
merge_type_annot ~legacy tn1 tn2
>|? fun tname -> (Signature_t tname, ctxt)
| (Mutez_t tn1, Mutez_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Mutez_t tname, ctxt)
| (Timestamp_t tn1, Timestamp_t tn2) ->
merge_type_annot ~legacy tn1 tn2
>|? fun tname -> (Timestamp_t tname, ctxt)
| (Address_t tn1, Address_t tn2) ->
merge_type_annot ~legacy tn1 tn2
>|? fun tname -> (Address_t tname, ctxt)
| (Bool_t tn1, Bool_t tn2) ->
merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Bool_t tname, ctxt)
| (Chain_id_t tn1, Chain_id_t tn2) ->
merge_type_annot ~legacy tn1 tn2
>|? fun tname -> (Chain_id_t tname, ctxt)
| (Operation_t tn1, Operation_t tn2) ->
merge_type_annot ~legacy tn1 tn2
>|? fun tname -> (Operation_t tname, ctxt)
| (Map_t (tal, tar, tn1, has_big_map), Map_t (tbl, tbr, tn2, _)) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
help ctxt tar tbr
>>? fun (value, ctxt) ->
ty_eq ctxt tar value
>>? fun (Eq, ctxt) ->
merge_comparable_types ~legacy tal tbl
>|? fun tk -> (Map_t (tk, value, tname, has_big_map), ctxt)
| (Big_map_t (tal, tar, tn1), Big_map_t (tbl, tbr, tn2)) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
help ctxt tar tbr
>>? fun (value, ctxt) ->
ty_eq ctxt tar value
>>? fun (Eq, ctxt) ->
merge_comparable_types ~legacy tal tbl
>|? fun tk -> (Big_map_t (tk, value, tname), ctxt)
| (Set_t (ea, tn1), Set_t (eb, tn2)) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
merge_comparable_types ~legacy ea eb
>|? fun e -> (Set_t (e, tname), ctxt)
| ( Pair_t
((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1, has_big_map),
Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2, _) ) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
merge_field_annot ~legacy l_field1 l_field2
>>? fun l_field ->
merge_field_annot ~legacy r_field1 r_field2
>>? fun r_field ->
let l_var = merge_var_annot l_var1 l_var2 in
let r_var = merge_var_annot r_var1 r_var2 in
help ctxt tal tbl
>>? fun (left_ty, ctxt) ->
help ctxt tar tbr
>|? fun (right_ty, ctxt) ->
( Pair_t
( (left_ty, l_field, l_var),
(right_ty, r_field, r_var),
tname,
has_big_map ),
ctxt )
| ( Union_t ((tal, tal_annot), (tar, tar_annot), tn1, has_big_map),
Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2, _) ) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
merge_field_annot ~legacy tal_annot tbl_annot
>>? fun left_annot ->
merge_field_annot ~legacy tar_annot tbr_annot
>>? fun right_annot ->
help ctxt tal tbl
>>? fun (left_ty, ctxt) ->
help ctxt tar tbr
>|? fun (right_ty, ctxt) ->
( Union_t
((left_ty, left_annot), (right_ty, right_annot), tname, has_big_map),
ctxt )
| (Lambda_t (tal, tar, tn1), Lambda_t (tbl, tbr, tn2)) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
help ctxt tal tbl
>>? fun (left_ty, ctxt) ->
help ctxt tar tbr
>|? fun (right_ty, ctxt) -> (Lambda_t (left_ty, right_ty, tname), ctxt)
| (Contract_t (tal, tn1), Contract_t (tbl, tn2)) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
help ctxt tal tbl
>|? fun (arg_ty, ctxt) -> (Contract_t (arg_ty, tname), ctxt)
| (Option_t (tva, tn1, has_big_map), Option_t (tvb, tn2, _)) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
help ctxt tva tvb
>|? fun (ty, ctxt) -> (Option_t (ty, tname, has_big_map), ctxt)
| (List_t (tva, tn1, has_big_map), List_t (tvb, tn2, _)) ->
merge_type_annot ~legacy tn1 tn2
>>? fun tname ->
help ctxt tva tvb
>|? fun (ty, ctxt) -> (List_t (ty, tname, has_big_map), ctxt)
| (_, _) ->
assert false
in
fun ctxt loc ty1 ty2 ->
record_inconsistent_type_annotations ctxt loc ty1 ty2 (help ctxt ty1 ty2)
let merge_stacks :
type ta.
legacy:bool ->
Script.location ->
context ->
ta stack_ty ->
ta stack_ty ->
(ta stack_ty * context) tzresult =
fun ~legacy loc ->
let rec help :
type a.
context -> a stack_ty -> a stack_ty -> (a stack_ty * context) tzresult =
fun ctxt stack1 stack2 ->
match (stack1, stack2) with
| (Empty_t, Empty_t) ->
ok (Empty_t, ctxt)
| (Item_t (ty1, rest1, annot1), Item_t (ty2, rest2, annot2)) ->
let annot = merge_var_annot annot1 annot2 in
merge_types ~legacy ctxt loc ty1 ty2
>>? fun (ty, ctxt) ->
help ctxt rest1 rest2
>|? fun (rest, ctxt) -> (Item_t (ty, rest, annot), ctxt)
in
help
let has_big_map : type t. t ty -> bool = function
| Unit_t _ ->
false
| Int_t _ ->
false
| Nat_t _ ->
false
| Signature_t _ ->
false
| String_t _ ->
false
| Bytes_t _ ->
false
| Mutez_t _ ->
false
| Key_hash_t _ ->
false
| Key_t _ ->
false
| Timestamp_t _ ->
false
| Address_t _ ->
false
| Bool_t _ ->
false
| Lambda_t (_, _, _) ->
false
| Set_t (_, _) ->
false
| Big_map_t (_, _, _) ->
true
| Contract_t (_, _) ->
false
| Operation_t _ ->
false
| Chain_id_t _ ->
false
| Pair_t (_, _, _, has_big_map) ->
has_big_map
| Union_t (_, _, _, has_big_map) ->
has_big_map
| Option_t (_, _, has_big_map) ->
has_big_map
| List_t (_, _, has_big_map) ->
has_big_map
| Map_t (_, _, _, has_big_map) ->
has_big_map
(* ---- Type checker results -------------------------------------------------*)
type 'bef judgement =
| Typed : ('bef, 'aft) descr -> 'bef judgement
| Failed : {
descr : 'aft. 'aft stack_ty -> ('bef, 'aft) descr;
}
-> 'bef judgement
(* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*)
type ('t, 'f, 'b) branch = {
branch : 'r. ('t, 'r) descr -> ('f, 'r) descr -> ('b, 'r) descr;
}
[@@unboxed]
let merge_branches :
type bef a b.
legacy:bool ->
context ->
int ->
a judgement ->
b judgement ->
(a, b, bef) branch ->
(bef judgement * context) tzresult Lwt.t =
fun ~legacy ctxt loc btr bfr {branch} ->
match (btr, bfr) with
| (Typed ({aft = aftbt; _} as dbt), Typed ({aft = aftbf; _} as dbf)) ->
let unmatched_branches () =
serialize_stack_for_error ctxt aftbt
>>=? fun (aftbt, ctxt) ->
serialize_stack_for_error ctxt aftbf
>>|? fun (aftbf, _ctxt) -> Unmatched_branches (loc, aftbt, aftbf)
in
trace_eval
unmatched_branches
( Lwt.return (stack_ty_eq ctxt 1 aftbt aftbf)
>>=? fun (Eq, ctxt) ->
Lwt.return (merge_stacks ~legacy loc ctxt aftbt aftbf)
>>=? fun (merged_stack, ctxt) ->
return
( Typed
(branch
{dbt with aft = merged_stack}
{dbf with aft = merged_stack}),
ctxt ) )
| (Failed {descr = descrt}, Failed {descr = descrf}) ->
let descr ret = branch (descrt ret) (descrf ret) in
return (Failed {descr}, ctxt)
| (Typed dbt, Failed {descr = descrf}) ->
return (Typed (branch dbt (descrf dbt.aft)), ctxt)
| (Failed {descr = descrt}, Typed dbf) ->
return (Typed (branch (descrt dbf.aft) dbf), ctxt)
let rec parse_comparable_ty :
context -> Script.node -> (ex_comparable_ty * context) tzresult =
fun ctxt ty ->
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>>? fun ctxt ->
match ty with
| Prim (loc, T_int, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Int_key tname), ctxt)
| Prim (loc, T_nat, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Nat_key tname), ctxt)
| Prim (loc, T_string, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (String_key tname), ctxt)
| Prim (loc, T_bytes, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Bytes_key tname), ctxt)
| Prim (loc, T_mutez, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Mutez_key tname), ctxt)
| Prim (loc, T_bool, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Bool_key tname), ctxt)
| Prim (loc, T_key_hash, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Key_hash_key tname), ctxt)
| Prim (loc, T_timestamp, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Timestamp_key tname), ctxt)
| Prim (loc, T_address, [], annot) ->
parse_type_annot loc annot
>|? fun tname -> (Ex_comparable_ty (Address_key tname), ctxt)
| Prim
( loc,
( ( T_int
| T_nat
| T_string
| T_mutez
| T_bool
| T_key
| T_address
| T_timestamp ) as prim ),
l,
_ ) ->
error (Invalid_arity (loc, prim, 0, List.length l))
| Prim
( loc,
( T_pair
| T_or
| T_set
| T_map
| T_list
| T_option
| T_lambda
| T_unit
| T_signature
| T_contract ),
_,
_ ) ->
error (Comparable_type_expected (loc, Micheline.strip_locations ty))
| expr ->
error
@@ unexpected
expr
[]
Type_namespace
[ T_int;
T_nat;
T_string;
T_mutez;
T_bool;
T_key;
T_key_hash;
T_timestamp ]
and parse_packable_ty :
context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
fun ctxt ~legacy ->
parse_ty
ctxt
~legacy
~allow_big_map:false
~allow_operation:false
~allow_contract:legacy
and parse_parameter_ty :
context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
fun ctxt ~legacy ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:true
and parse_any_ty :
context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
fun ctxt ~legacy ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:true
~allow_contract:true
and parse_ty :
context ->
legacy:bool ->
allow_big_map:bool ->
allow_operation:bool ->
allow_contract:bool ->
Script.node ->
(ex_ty * context) tzresult =
fun ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract node ->
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt ->
match node with
| Prim (loc, T_unit, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Unit_t ty_name), ctxt)
| Prim (loc, T_int, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Int_t ty_name), ctxt)
| Prim (loc, T_nat, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Nat_t ty_name), ctxt)
| Prim (loc, T_string, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (String_t ty_name), ctxt)
| Prim (loc, T_bytes, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Bytes_t ty_name), ctxt)
| Prim (loc, T_mutez, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Mutez_t ty_name), ctxt)
| Prim (loc, T_bool, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Bool_t ty_name), ctxt)
| Prim (loc, T_key, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Key_t ty_name), ctxt)
| Prim (loc, T_key_hash, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Key_hash_t ty_name), ctxt)
| Prim (loc, T_timestamp, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Timestamp_t ty_name), ctxt)
| Prim (loc, T_address, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Address_t ty_name), ctxt)
| Prim (loc, T_signature, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Signature_t ty_name), ctxt)
| Prim (loc, T_operation, [], annot) ->
if allow_operation then
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Operation_t ty_name), ctxt)
else error (Unexpected_operation loc)
| Prim (loc, T_chain_id, [], annot) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 0)
>|? fun ctxt -> (Ex_ty (Chain_id_t ty_name), ctxt)
| Prim (loc, T_contract, [utl], annot) ->
if allow_contract then
parse_parameter_ty ctxt ~legacy utl
>>? fun (Ex_ty tl, ctxt) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 1)
>|? fun ctxt -> (Ex_ty (Contract_t (tl, ty_name)), ctxt)
else error (Unexpected_contract loc)
| Prim (loc, T_pair, [utl; utr], annot) ->
extract_field_annot utl
>>? fun (utl, left_field) ->
extract_field_annot utr
>>? fun (utr, right_field) ->
parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl
>>? fun (Ex_ty tl, ctxt) ->
parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
>>? fun (Ex_ty tr, ctxt) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 2)
>|? fun ctxt ->
( Ex_ty
(Pair_t
( (tl, left_field, None),
(tr, right_field, None),
ty_name,
has_big_map tl || has_big_map tr )),
ctxt )
| Prim (loc, T_or, [utl; utr], annot) ->
extract_field_annot utl
>>? fun (utl, left_constr) ->
extract_field_annot utr
>>? fun (utr, right_constr) ->
parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl
>>? fun (Ex_ty tl, ctxt) ->
parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
>>? fun (Ex_ty tr, ctxt) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 2)
>|? fun ctxt ->
( Ex_ty
(Union_t
( (tl, left_constr),
(tr, right_constr),
ty_name,
has_big_map tl || has_big_map tr )),
ctxt )
| Prim (loc, T_lambda, [uta; utr], annot) ->
parse_any_ty ctxt ~legacy uta
>>? fun (Ex_ty ta, ctxt) ->
parse_any_ty ctxt ~legacy utr
>>? fun (Ex_ty tr, ctxt) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 2)
>|? fun ctxt -> (Ex_ty (Lambda_t (ta, tr, ty_name)), ctxt)
| Prim (loc, T_option, [ut], annot) ->
( if legacy then
(* legacy semantics with (broken) field annotations *)
extract_field_annot ut
>>? fun (ut, _some_constr) ->
parse_composed_type_annot loc annot
>>? fun (ty_name, _none_constr, _) -> ok (ut, ty_name)
else parse_type_annot loc annot >>? fun ty_name -> ok (ut, ty_name) )
>>? fun (ut, ty_name) ->
parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut
>>? fun (Ex_ty t, ctxt) ->
Gas.consume ctxt (Typecheck_costs.type_ 2)
>|? fun ctxt -> (Ex_ty (Option_t (t, ty_name, has_big_map t)), ctxt)
| Prim (loc, T_list, [ut], annot) ->
parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut
>>? fun (Ex_ty t, ctxt) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 1)
>|? fun ctxt -> (Ex_ty (List_t (t, ty_name, has_big_map t)), ctxt)
| Prim (loc, T_set, [ut], annot) ->
parse_comparable_ty ctxt ut
>>? fun (Ex_comparable_ty t, ctxt) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 1)
>|? fun ctxt -> (Ex_ty (Set_t (t, ty_name)), ctxt)
| Prim (loc, T_map, [uta; utr], annot) ->
parse_comparable_ty ctxt uta
>>? fun (Ex_comparable_ty ta, ctxt) ->
parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
>>? fun (Ex_ty tr, ctxt) ->
parse_type_annot loc annot
>>? fun ty_name ->
Gas.consume ctxt (Typecheck_costs.type_ 2)
>|? fun ctxt -> (Ex_ty (Map_t (ta, tr, ty_name, has_big_map tr)), ctxt)
| Prim (loc, T_big_map, args, annot) when allow_big_map ->
parse_big_map_ty ctxt ~legacy loc args annot
>>? fun (big_map_ty, ctxt) ->
Gas.consume ctxt (Typecheck_costs.type_ 2)
>|? fun ctxt -> (big_map_ty, ctxt)
| Prim (loc, T_big_map, _, _) ->
error (Unexpected_big_map loc)
| Prim
( loc,
( ( T_unit
| T_signature
| T_int
| T_nat
| T_string
| T_bytes
| T_mutez
| T_bool
| T_key
| T_key_hash
| T_timestamp
| T_address ) as prim ),
l,
_ ) ->
error (Invalid_arity (loc, prim, 0, List.length l))
| Prim (loc, ((T_set | T_list | T_option | T_contract) as prim), l, _) ->
error (Invalid_arity (loc, prim, 1, List.length l))
| Prim (loc, ((T_pair | T_or | T_map | T_lambda) as prim), l, _) ->
error (Invalid_arity (loc, prim, 2, List.length l))
| expr ->
error
@@ unexpected
expr
[]
Type_namespace
[ T_pair;
T_or;
T_set;
T_map;
T_list;
T_option;
T_lambda;
T_unit;
T_signature;
T_contract;
T_int;
T_nat;
T_operation;
T_string;
T_bytes;
T_mutez;
T_bool;
T_key;
T_key_hash;
T_timestamp;
T_chain_id ]
and parse_big_map_ty ctxt ~legacy big_map_loc args map_annot =
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt ->
match args with
| [key_ty; value_ty] ->
parse_comparable_ty ctxt key_ty
>>? fun (Ex_comparable_ty key_ty, ctxt) ->
parse_packable_ty ctxt ~legacy value_ty
>>? fun (Ex_ty value_ty, ctxt) ->
parse_type_annot big_map_loc map_annot
>|? fun map_name ->
let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in
(Ex_ty big_map_ty, ctxt)
| args ->
error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args)
and parse_storage_ty :
context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
fun ctxt ~legacy node ->
match node with
| Prim
( loc,
T_pair,
[Prim (big_map_loc, T_big_map, args, map_annot); remaining_storage],
storage_annot )
when legacy -> (
match storage_annot with
| [] ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:legacy
node
| [single]
when Compare.Int.(String.length single > 0)
&& Compare.Char.(single.[0] = '%') ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:legacy
node
| _ ->
(* legacy semantics of big maps used the wrong annotation parser *)
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt ->
parse_big_map_ty ctxt ~legacy big_map_loc args map_annot
>>? fun (Ex_ty big_map_ty, ctxt) ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:legacy
remaining_storage
>>? fun (Ex_ty remaining_storage, ctxt) ->
parse_composed_type_annot loc storage_annot
>>? fun (ty_name, map_field, storage_field) ->
Gas.consume ctxt (Typecheck_costs.type_ 5)
>|? fun ctxt ->
( Ex_ty
(Pair_t
( (big_map_ty, map_field, None),
(remaining_storage, storage_field, None),
ty_name,
true )),
ctxt ) )
| _ ->
parse_ty
ctxt
~legacy
~allow_big_map:true
~allow_operation:false
~allow_contract:legacy
node
let check_packable ~legacy loc root =
let rec check : type t. t ty -> unit tzresult = function
| Big_map_t _ ->
error (Unexpected_big_map loc)
| Operation_t _ ->
error (Unexpected_operation loc)
| Unit_t _ ->
ok ()
| Int_t _ ->
ok ()
| Nat_t _ ->
ok ()
| Signature_t _ ->
ok ()
| String_t _ ->
ok ()
| Bytes_t _ ->
ok ()
| Mutez_t _ ->
ok ()
| Key_hash_t _ ->
ok ()
| Key_t _ ->
ok ()
| Timestamp_t _ ->
ok ()
| Address_t _ ->
ok ()
| Bool_t _ ->
ok ()
| Chain_id_t _ ->
ok ()
| Pair_t ((l_ty, _, _), (r_ty, _, _), _, _) ->
check l_ty >>? fun () -> check r_ty
| Union_t ((l_ty, _), (r_ty, _), _, _) ->
check l_ty >>? fun () -> check r_ty
| Option_t (v_ty, _, _) ->
check v_ty
| List_t (elt_ty, _, _) ->
check elt_ty
| Set_t (_, _) ->
ok ()
| Map_t (_, elt_ty, _, _) ->
check elt_ty
| Lambda_t (_l_ty, _r_ty, _) ->
ok ()
| Contract_t (_, _) when legacy ->
ok ()
| Contract_t (_, _) ->
error (Unexpected_contract loc)
in
check root
type ex_script = Ex_script : ('a, 'c) script -> ex_script
type _ dig_proof_argument =
| Dig_proof_argument :
( ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness
* ('x ty * var_annot option)
* 'aft stack_ty )
-> 'bef dig_proof_argument
type (_, _) dug_proof_argument =
| Dug_proof_argument :
( ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness
* unit
* 'aft stack_ty )
-> ('bef, 'x) dug_proof_argument
type _ dipn_proof_argument =
| Dipn_proof_argument :
( ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness
* (context * ('fbef, 'faft) descr)
* 'aft stack_ty )
-> 'bef dipn_proof_argument
type _ dropn_proof_argument =
| Dropn_proof_argument :
( ('rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness
* 'rest stack_ty
* 'aft stack_ty )
-> 'bef dropn_proof_argument
(* Lwt versions *)
let parse_var_annot loc ?default annot =
Lwt.return (parse_var_annot loc ?default annot)
let parse_entrypoint_annot loc ?default annot =
Lwt.return (parse_entrypoint_annot loc ?default annot)
let parse_constr_annot loc ?if_special_first ?if_special_second annot =
Lwt.return
(parse_constr_annot loc ?if_special_first ?if_special_second annot)
let parse_two_var_annot loc annot = Lwt.return (parse_two_var_annot loc annot)
let parse_destr_annot loc annot ~default_accessor ~field_name ~pair_annot
~value_annot =
Lwt.return
(parse_destr_annot
loc
annot
~default_accessor
~field_name
~pair_annot
~value_annot)
let parse_var_type_annot loc annot =
Lwt.return (parse_var_type_annot loc annot)
let find_entrypoint (type full) (full : full ty) ~root_name entrypoint =
let rec find_entrypoint :
type t. t ty -> string -> (Script.node -> Script.node) * ex_ty =
fun t entrypoint ->
match t with
| Union_t ((tl, al), (tr, ar), _, _) -> (
if
match al with
| None ->
false
| Some (`Field_annot l) ->
Compare.String.(l = entrypoint)
then ((fun e -> Prim (0, D_Left, [e], [])), Ex_ty tl)
else if
match ar with
| None ->
false
| Some (`Field_annot r) ->
Compare.String.(r = entrypoint)
then ((fun e -> Prim (0, D_Right, [e], [])), Ex_ty tr)
else
try
let (f, t) = find_entrypoint tl entrypoint in
((fun e -> Prim (0, D_Left, [f e], [])), t)
with Not_found ->
let (f, t) = find_entrypoint tr entrypoint in
((fun e -> Prim (0, D_Right, [f e], [])), t) )
| _ ->
raise Not_found
in
let entrypoint =
if Compare.String.(entrypoint = "") then "default" else entrypoint
in
if Compare.Int.(String.length entrypoint > 31) then
error (Entrypoint_name_too_long entrypoint)
else
match root_name with
| Some root_name when Compare.String.(entrypoint = root_name) ->
ok ((fun e -> e), Ex_ty full)
| _ -> (
try ok (find_entrypoint full entrypoint)
with Not_found -> (
match entrypoint with
| "default" ->
ok ((fun e -> e), Ex_ty full)
| _ ->
error (No_such_entrypoint entrypoint) ) )
let find_entrypoint_for_type (type full exp) ~(full : full ty)
~(expected : exp ty) ~root_name entrypoint ctxt :
(context * string * exp ty) tzresult =
match (entrypoint, root_name) with
| ("default", Some "root") -> (
match find_entrypoint full ~root_name entrypoint with
| Error _ as err ->
err
| Ok (_, Ex_ty ty) -> (
match ty_eq ctxt expected ty with
| Ok (Eq, ctxt) ->
ok (ctxt, "default", (ty : exp ty))
| Error _ ->
ty_eq ctxt expected full
>>? fun (Eq, ctxt) -> ok (ctxt, "root", (full : exp ty)) ) )
| _ ->
find_entrypoint full ~root_name entrypoint
>>? fun (_, Ex_ty ty) ->
ty_eq ctxt expected ty
>>? fun (Eq, ctxt) -> ok (ctxt, entrypoint, (ty : exp ty))
module Entrypoints = Set.Make (String)
exception Duplicate of string
exception Too_long of string
let well_formed_entrypoints (type full) (full : full ty) ~root_name =
let merge path annot (type t) (ty : t ty) reachable
((first_unreachable, all) as acc) =
match annot with
| None | Some (`Field_annot "") -> (
if reachable then acc
else
match ty with
| Union_t _ ->
acc
| _ -> (
match first_unreachable with
| None ->
(Some (List.rev path), all)
| Some _ ->
acc ) )
| Some (`Field_annot name) ->
if Compare.Int.(String.length name > 31) then raise (Too_long name)
else if Entrypoints.mem name all then raise (Duplicate name)
else (first_unreachable, Entrypoints.add name all)
in
let rec check :
type t.
t ty ->
prim list ->
bool ->
prim list option * Entrypoints.t ->
prim list option * Entrypoints.t =
fun t path reachable acc ->
match t with
| Union_t ((tl, al), (tr, ar), _, _) ->
let acc = merge (D_Left :: path) al tl reachable acc in
let acc = merge (D_Right :: path) ar tr reachable acc in
let acc =
check
tl
(D_Left :: path)
(match al with Some _ -> true | None -> reachable)
acc
in
check
tr
(D_Right :: path)
(match ar with Some _ -> true | None -> reachable)
acc
| _ ->
acc
in
try
let (init, reachable) =
match root_name with
| None | Some "" ->
(Entrypoints.empty, false)
| Some name ->
(Entrypoints.singleton name, true)
in
let (first_unreachable, all) = check full [] reachable (None, init) in
if not (Entrypoints.mem "default" all) then ok ()
else
match first_unreachable with
| None ->
ok ()
| Some path ->
error (Unreachable_entrypoint path)
with
| Duplicate name ->
error (Duplicate_entrypoint name)
| Too_long name ->
error (Entrypoint_name_too_long name)
let rec parse_data :
type a.
?type_logger:type_logger ->
context ->
legacy:bool ->
a ty ->
Script.node ->
(a * context) tzresult Lwt.t =
fun ?type_logger ctxt ~legacy ty script_data ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
let error () =
Lwt.return (serialize_ty_for_error ctxt ty)
>>|? fun (ty, _ctxt) ->
Invalid_constant (location script_data, strip_locations script_data, ty)
in
let traced body = trace_eval error body in
let parse_items ?type_logger loc ctxt expr key_type value_type items
item_wrapper =
let length = List.length items in
fold_left_s
(fun (last_value, map, ctxt) item ->
Lwt.return (Gas.consume ctxt (Typecheck_costs.map_element length))
>>=? fun ctxt ->
match item with
| Prim (_, D_Elt, [k; v], _) ->
parse_comparable_data ?type_logger ctxt key_type k
>>=? fun (k, ctxt) ->
parse_data ?type_logger ctxt ~legacy value_type v
>>=? fun (v, ctxt) ->
( match last_value with
| Some value ->
if Compare.Int.(0 <= compare_comparable key_type value k) then
if Compare.Int.(0 = compare_comparable key_type value k) then
fail (Duplicate_map_keys (loc, strip_locations expr))
else fail (Unordered_map_keys (loc, strip_locations expr))
else return_unit
| None ->
return_unit )
>>=? fun () ->
return (Some k, map_update k (Some (item_wrapper v)) map, ctxt)
| Prim (loc, D_Elt, l, _) ->
fail @@ Invalid_arity (loc, D_Elt, 2, List.length l)
| Prim (loc, name, _, _) ->
fail @@ Invalid_primitive (loc, [D_Elt], name)
| Int _ | String _ | Bytes _ | Seq _ ->
error () >>=? fail)
(None, empty_map key_type, ctxt)
items
|> traced
>>|? fun (_, items, ctxt) -> (items, ctxt)
in
match (ty, script_data) with
(* Unit *)
| (Unit_t _, Prim (loc, D_Unit, [], annot)) ->
(if legacy then return () else fail_unexpected_annot loc annot)
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.unit)
>>|? fun ctxt -> ((() : a), ctxt)
| (Unit_t _, Prim (loc, D_Unit, l, _)) ->
traced (fail (Invalid_arity (loc, D_Unit, 0, List.length l)))
| (Unit_t _, expr) ->
traced (fail (unexpected expr [] Constant_namespace [D_Unit]))
(* Booleans *)
| (Bool_t _, Prim (loc, D_True, [], annot)) ->
(if legacy then return () else fail_unexpected_annot loc annot)
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.bool)
>>|? fun ctxt -> (true, ctxt)
| (Bool_t _, Prim (loc, D_False, [], annot)) ->
(if legacy then return () else fail_unexpected_annot loc annot)
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.bool)
>>|? fun ctxt -> (false, ctxt)
| (Bool_t _, Prim (loc, ((D_True | D_False) as c), l, _)) ->
traced (fail (Invalid_arity (loc, c, 0, List.length l)))
| (Bool_t _, expr) ->
traced (fail (unexpected expr [] Constant_namespace [D_True; D_False]))
(* Strings *)
| (String_t _, String (_, v)) ->
Lwt.return (Gas.consume ctxt (Typecheck_costs.string (String.length v)))
>>=? fun ctxt ->
let rec check_printable_ascii i =
if Compare.Int.(i < 0) then true
else
match v.[i] with
| '\n' | '\x20' .. '\x7E' ->
check_printable_ascii (i - 1)
| _ ->
false
in
if check_printable_ascii (String.length v - 1) then return (v, ctxt)
else error () >>=? fail
| (String_t _, expr) ->
traced (fail (Invalid_kind (location expr, [String_kind], kind expr)))
(* Byte sequences *)
| (Bytes_t _, Bytes (_, v)) ->
Lwt.return (Gas.consume ctxt (Typecheck_costs.string (MBytes.length v)))
>>=? fun ctxt -> return (v, ctxt)
| (Bytes_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Bytes_kind], kind expr)))
(* Integers *)
| (Int_t _, Int (_, v)) ->
Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
>>=? fun ctxt -> return (Script_int.of_zint v, ctxt)
| (Nat_t _, Int (_, v)) ->
Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
>>=? fun ctxt ->
let v = Script_int.of_zint v in
if Compare.Int.(Script_int.compare v Script_int.zero >= 0) then
return (Script_int.abs v, ctxt)
else error () >>=? fail
| (Int_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
| (Nat_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
(* Tez amounts *)
| (Mutez_t _, Int (_, v)) -> (
Lwt.return
( Gas.consume ctxt Typecheck_costs.tez
>>? fun ctxt ->
Gas.consume ctxt Michelson_v1_gas.Cost_of.Legacy.z_to_int64 )
>>=? fun ctxt ->
try
match Tez.of_mutez (Z.to_int64 v) with
| None ->
raise Exit
| Some tez ->
return (tez, ctxt)
with _ -> error () >>=? fail )
| (Mutez_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
(* Timestamps *)
| (Timestamp_t _, Int (_, v))
(* As unparsed with [Optimized] or out of bounds [Readable]. *) ->
Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
>>=? fun ctxt -> return (Script_timestamp.of_zint v, ctxt)
| (Timestamp_t _, String (_, s)) (* As unparsed with [Redable]. *) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp)
>>=? fun ctxt ->
match Script_timestamp.of_string s with
| Some v ->
return (v, ctxt)
| None ->
error () >>=? fail )
| (Timestamp_t _, expr) ->
traced
(fail
(Invalid_kind (location expr, [String_kind; Int_kind], kind expr)))
(* IDs *)
| (Key_t _, Bytes (_, bytes)) -> (
(* As unparsed with [Optimized]. *)
Lwt.return (Gas.consume ctxt Typecheck_costs.key)
>>=? fun ctxt ->
match
Data_encoding.Binary.of_bytes Signature.Public_key.encoding bytes
with
| Some k ->
return (k, ctxt)
| None ->
error () >>=? fail )
| (Key_t _, String (_, s)) -> (
(* As unparsed with [Readable]. *)
Lwt.return (Gas.consume ctxt Typecheck_costs.key)
>>=? fun ctxt ->
match Signature.Public_key.of_b58check_opt s with
| Some k ->
return (k, ctxt)
| None ->
error () >>=? fail )
| (Key_t _, expr) ->
traced
(fail
(Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
| (Key_hash_t _, Bytes (_, bytes)) -> (
(* As unparsed with [Optimized]. *)
Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash)
>>=? fun ctxt ->
match
Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding bytes
with
| Some k ->
return (k, ctxt)
| None ->
error () >>=? fail )
| (Key_hash_t _, String (_, s)) (* As unparsed with [Readable]. *) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash)
>>=? fun ctxt ->
match Signature.Public_key_hash.of_b58check_opt s with
| Some k ->
return (k, ctxt)
| None ->
error () >>=? fail )
| (Key_hash_t _, expr) ->
traced
(fail
(Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
(* Signatures *)
| (Signature_t _, Bytes (_, bytes)) (* As unparsed with [Optimized]. *) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.signature)
>>=? fun ctxt ->
match Data_encoding.Binary.of_bytes Signature.encoding bytes with
| Some k ->
return (k, ctxt)
| None ->
error () >>=? fail )
| (Signature_t _, String (_, s)) (* As unparsed with [Readable]. *) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.signature)
>>=? fun ctxt ->
match Signature.of_b58check_opt s with
| Some s ->
return (s, ctxt)
| None ->
error () >>=? fail )
| (Signature_t _, expr) ->
traced
(fail
(Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
(* Operations *)
| (Operation_t _, _) ->
(* operations cannot appear in parameters or storage,
the protocol should never parse the bytes of an operation *)
assert false
(* Chain_ids *)
| (Chain_id_t _, Bytes (_, bytes)) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id)
>>=? fun ctxt ->
match Data_encoding.Binary.of_bytes Chain_id.encoding bytes with
| Some k ->
return (k, ctxt)
| None ->
error () >>=? fail )
| (Chain_id_t _, String (_, s)) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id)
>>=? fun ctxt ->
match Chain_id.of_b58check_opt s with
| Some s ->
return (s, ctxt)
| None ->
error () >>=? fail )
| (Chain_id_t _, expr) ->
traced
(fail
(Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
(* Addresses *)
| (Address_t _, Bytes (loc, bytes)) (* As unparsed with [O[ptimized]. *) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
>>=? fun ctxt ->
match
Data_encoding.Binary.of_bytes
Data_encoding.(tup2 Contract.encoding Variable.string)
bytes
with
| Some (c, entrypoint) ->
if Compare.Int.(String.length entrypoint > 31) then
fail (Entrypoint_name_too_long entrypoint)
else
( match entrypoint with
| "" ->
return "default"
| "default" ->
fail (Unexpected_annotation loc)
| name ->
return name )
>>=? fun entrypoint -> return ((c, entrypoint), ctxt)
| None ->
error () >>=? fail )
| (Address_t _, String (loc, s)) (* As unparsed with [Readable]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
>>=? fun ctxt ->
( match String.index_opt s '%' with
| None ->
return (s, "default")
| Some pos -> (
let len = String.length s - pos - 1 in
let name = String.sub s (pos + 1) len in
if Compare.Int.(len > 31) then fail (Entrypoint_name_too_long name)
else
match (String.sub s 0 pos, name) with
| (_, "default") ->
traced (fail (Unexpected_annotation loc))
| addr_and_name ->
return addr_and_name ) )
>>=? fun (addr, entrypoint) ->
Lwt.return (Contract.of_b58check addr)
>>=? fun c -> return ((c, entrypoint), ctxt)
| (Address_t _, expr) ->
traced
(fail
(Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
(* Contracts *)
| (Contract_t (ty, _), Bytes (loc, bytes))
(* As unparsed with [Optimized]. *) -> (
Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
>>=? fun ctxt ->
match
Data_encoding.Binary.of_bytes
Data_encoding.(tup2 Contract.encoding Variable.string)
bytes
with
| Some (c, entrypoint) ->
if Compare.Int.(String.length entrypoint > 31) then
fail (Entrypoint_name_too_long entrypoint)
else
( match entrypoint with
| "" ->
return "default"
| "default" ->
traced (fail (Unexpected_annotation loc))
| name ->
return name )
>>=? fun entrypoint ->
traced (parse_contract ~legacy ctxt loc ty c ~entrypoint)
>>=? fun (ctxt, _) -> return ((ty, (c, entrypoint)), ctxt)
| None ->
error () >>=? fail )
| (Contract_t (ty, _), String (loc, s)) (* As unparsed with [Readable]. *) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
>>=? fun ctxt ->
( match String.index_opt s '%' with
| None ->
return (s, "default")
| Some pos -> (
let len = String.length s - pos - 1 in
let name = String.sub s (pos + 1) len in
if Compare.Int.(len > 31) then fail (Entrypoint_name_too_long name)
else
match (String.sub s 0 pos, name) with
| (_, "default") ->
traced (fail (Unexpected_annotation loc))
| addr_and_name ->
return addr_and_name ) )
>>=? fun (addr, entrypoint) ->
traced (Lwt.return (Contract.of_b58check addr))
>>=? fun c ->
parse_contract ~legacy ctxt loc ty c ~entrypoint
>>=? fun (ctxt, _) -> return ((ty, (c, entrypoint)), ctxt)
| (Contract_t _, expr) ->
traced
(fail
(Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
(* Pairs *)
| (Pair_t ((ta, _, _), (tb, _, _), _, _), Prim (loc, D_Pair, [va; vb], annot))
->
(if legacy then return () else fail_unexpected_annot loc annot)
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.pair)
>>=? fun ctxt ->
traced @@ parse_data ?type_logger ctxt ~legacy ta va
>>=? fun (va, ctxt) ->
parse_data ?type_logger ctxt ~legacy tb vb
>>=? fun (vb, ctxt) -> return ((va, vb), ctxt)
| (Pair_t _, Prim (loc, D_Pair, l, _)) ->
fail @@ Invalid_arity (loc, D_Pair, 2, List.length l)
| (Pair_t _, expr) ->
traced (fail (unexpected expr [] Constant_namespace [D_Pair]))
(* Unions *)
| (Union_t ((tl, _), _, _, _), Prim (loc, D_Left, [v], annot)) ->
(if legacy then return () else fail_unexpected_annot loc annot)
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.union)
>>=? fun ctxt ->
traced @@ parse_data ?type_logger ctxt ~legacy tl v
>>=? fun (v, ctxt) -> return (L v, ctxt)
| (Union_t _, Prim (loc, D_Left, l, _)) ->
fail @@ Invalid_arity (loc, D_Left, 1, List.length l)
| (Union_t (_, (tr, _), _, _), Prim (loc, D_Right, [v], annot)) ->
fail_unexpected_annot loc annot
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.union)
>>=? fun ctxt ->
traced @@ parse_data ?type_logger ctxt ~legacy tr v
>>=? fun (v, ctxt) -> return (R v, ctxt)
| (Union_t _, Prim (loc, D_Right, l, _)) ->
fail @@ Invalid_arity (loc, D_Right, 1, List.length l)
| (Union_t _, expr) ->
traced (fail (unexpected expr [] Constant_namespace [D_Left; D_Right]))
(* Lambdas *)
| (Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr)) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.lambda)
>>=? fun ctxt ->
traced
@@ parse_returning
Lambda
?type_logger
ctxt
~legacy
(ta, Some (`Var_annot "@arg"))
tr
script_instr
| (Lambda_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
(* Options *)
| (Option_t (t, _, _), Prim (loc, D_Some, [v], annot)) ->
(if legacy then return () else fail_unexpected_annot loc annot)
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.some)
>>=? fun ctxt ->
traced @@ parse_data ?type_logger ctxt ~legacy t v
>>=? fun (v, ctxt) -> return (Some v, ctxt)
| (Option_t _, Prim (loc, D_Some, l, _)) ->
fail @@ Invalid_arity (loc, D_Some, 1, List.length l)
| (Option_t (_, _, _), Prim (loc, D_None, [], annot)) ->
(if legacy then return () else fail_unexpected_annot loc annot)
>>=? fun () ->
Lwt.return (Gas.consume ctxt Typecheck_costs.none)
>>=? fun ctxt -> return (None, ctxt)
| (Option_t _, Prim (loc, D_None, l, _)) ->
fail @@ Invalid_arity (loc, D_None, 0, List.length l)
| (Option_t _, expr) ->
traced (fail (unexpected expr [] Constant_namespace [D_Some; D_None]))
(* Lists *)
| (List_t (t, _ty_name, _), Seq (_loc, items)) ->
traced
@@ fold_right_s
(fun v (rest, ctxt) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.list_element)
>>=? fun ctxt ->
parse_data ?type_logger ctxt ~legacy t v
>>=? fun (v, ctxt) -> return (v :: rest, ctxt))
items
([], ctxt)
| (List_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
(* Sets *)
| (Set_t (t, _ty_name), (Seq (loc, vs) as expr)) ->
let length = List.length vs in
traced
@@ fold_left_s
(fun (last_value, set, ctxt) v ->
Lwt.return (Gas.consume ctxt (Typecheck_costs.set_element length))
>>=? fun ctxt ->
parse_comparable_data ?type_logger ctxt t v
>>=? fun (v, ctxt) ->
( match last_value with
| Some value ->
if Compare.Int.(0 <= compare_comparable t value v) then
if Compare.Int.(0 = compare_comparable t value v) then
fail (Duplicate_set_values (loc, strip_locations expr))
else fail (Unordered_set_values (loc, strip_locations expr))
else return_unit
| None ->
return_unit )
>>=? fun () ->
Lwt.return
(Gas.consume
ctxt
(Michelson_v1_gas.Cost_of.Legacy.set_update v false set))
>>=? fun ctxt -> return (Some v, set_update v true set, ctxt))
(None, empty_set t, ctxt)
vs
>>|? fun (_, set, ctxt) -> (set, ctxt)
| (Set_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
(* Maps *)
| (Map_t (tk, tv, _ty_name, _), (Seq (loc, vs) as expr)) ->
parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x)
| (Map_t _, expr) ->
traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
| (Big_map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr)) ->
parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x)
>>|? fun (diff, ctxt) ->
( {id = None; diff; key_type = ty_of_comparable_ty tk; value_type = tv},
ctxt )
| (Big_map_t (tk, tv, _ty_name), Int (loc, id)) -> (
Big_map.exists ctxt id
>>=? function
| (_, None) ->
traced (fail (Invalid_big_map (loc, id)))
| (ctxt, Some (btk, btv)) ->
Lwt.return
( parse_comparable_ty ctxt (Micheline.root btk)
>>? fun (Ex_comparable_ty btk, ctxt) ->
parse_packable_ty ctxt ~legacy (Micheline.root btv)
>>? fun (Ex_ty btv, ctxt) ->
comparable_ty_eq ctxt tk btk
>>? fun Eq ->
ty_eq ctxt tv btv
>>? fun (Eq, ctxt) ->
ok
( {
id = Some id;
diff = empty_map tk;
key_type = ty_of_comparable_ty tk;
value_type = tv;
},
ctxt ) ) )
| (Big_map_t (_tk, _tv, _), expr) ->
traced
(fail (Invalid_kind (location expr, [Seq_kind; Int_kind], kind expr)))
and parse_comparable_data :
type a.
?type_logger:type_logger ->
context ->
a comparable_ty ->
Script.node ->
(a * context) tzresult Lwt.t =
fun ?type_logger ctxt ty script_data ->
parse_data
?type_logger
ctxt
~legacy:false
(ty_of_comparable_ty ty)
script_data
and parse_returning :
type arg ret.
?type_logger:type_logger ->
tc_context ->
context ->
legacy:bool ->
arg ty * var_annot option ->
ret ty ->
Script.node ->
((arg, ret) lambda * context) tzresult Lwt.t =
fun ?type_logger tc_context ctxt ~legacy (arg, arg_annot) ret script_instr ->
parse_instr
?type_logger
tc_context
ctxt
~legacy
script_instr
(Item_t (arg, Empty_t, arg_annot))
>>=? function
| (Typed ({loc; aft = Item_t (ty, Empty_t, _) as stack_ty; _} as descr), ctxt)
->
trace_eval
(fun () ->
Lwt.return (serialize_ty_for_error ctxt ret)
>>=? fun (ret, ctxt) ->
serialize_stack_for_error ctxt stack_ty
>>|? fun (stack_ty, _ctxt) -> Bad_return (loc, stack_ty, ret))
( Lwt.return (ty_eq ctxt ty ret)
>>=? fun (Eq, ctxt) ->
Lwt.return (merge_types ~legacy ctxt loc ty ret)
>>=? fun (_ret, ctxt) ->
return ((Lam (descr, script_instr) : (arg, ret) lambda), ctxt) )
| (Typed {loc; aft = stack_ty; _}, ctxt) ->
Lwt.return (serialize_ty_for_error ctxt ret)
>>=? fun (ret, ctxt) ->
serialize_stack_for_error ctxt stack_ty
>>=? fun (stack_ty, _ctxt) -> fail (Bad_return (loc, stack_ty, ret))
| (Failed {descr}, ctxt) ->
return
( ( Lam (descr (Item_t (ret, Empty_t, None)), script_instr)
: (arg, ret) lambda ),
ctxt )
and parse_int32 (n : (location, prim) Micheline.node) : int tzresult =
let error' () =
Invalid_syntactic_constant
( location n,
strip_locations n,
"a positive 32-bit integer (between 0 and "
^ Int32.to_string Int32.max_int
^ ")" )
in
match n with
| Micheline.Int (_, n') -> (
try
let n'' = Z.to_int n' in
if
Compare.Int.(0 <= n'')
&& Compare.Int.(n'' <= Int32.to_int Int32.max_int)
then ok n''
else error @@ error' ()
with _ -> error @@ error' () )
| _ ->
error @@ error' ()
and parse_instr :
type bef.
?type_logger:type_logger ->
tc_context ->
context ->
legacy:bool ->
Script.node ->
bef stack_ty ->
(bef judgement * context) tzresult Lwt.t =
fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty ->
let _check_item check loc name n m =
trace_eval (fun () ->
serialize_stack_for_error ctxt stack_ty
>>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
@@ trace (Bad_stack_item n) @@ Lwt.return check
in
let check_item_ty (type a b) ctxt (exp : a ty) (got : b ty) loc name n m :
((a, b) eq * a ty * context) tzresult Lwt.t =
trace_eval (fun () ->
serialize_stack_for_error ctxt stack_ty
>>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
@@ trace (Bad_stack_item n)
@@ Lwt.return
( ty_eq ctxt exp got
>>? fun (Eq, ctxt) ->
merge_types ~legacy ctxt loc exp got
>>? fun (ty, ctxt) -> ok ((Eq : (a, b) eq), (ty : a ty), ctxt) )
in
let check_item_comparable_ty (type a b) (exp : a comparable_ty)
(got : b comparable_ty) loc name n m :
((a, b) eq * a comparable_ty) tzresult Lwt.t =
trace_eval (fun () ->
serialize_stack_for_error ctxt stack_ty
>>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
@@ trace (Bad_stack_item n)
@@ Lwt.return
( comparable_ty_eq ctxt exp got
>>? fun Eq ->
merge_comparable_types ~legacy exp got
>>? fun ty -> ok ((Eq : (a, b) eq), (ty : a comparable_ty)) )
in
let log_stack ctxt loc stack_ty aft =
match (type_logger, script_instr) with
| (None, _) | (Some _, (Seq (-1, _) | Int _ | String _ | Bytes _)) ->
return_unit
| (Some log, (Prim _ | Seq _)) ->
(* Unparsing for logging done in an unlimited context as this
is used only by the client and not the protocol *)
let ctxt = Gas.set_unlimited ctxt in
unparse_stack ctxt stack_ty
>>=? fun (stack_ty, _) ->
unparse_stack ctxt aft
>>=? fun (aft, _) -> log loc stack_ty aft ; return_unit
in
let outer_return = return in
let return :
type bef.
context -> bef judgement -> (bef judgement * context) tzresult Lwt.t =
fun ctxt judgement ->
match judgement with
| Typed {instr; loc; aft; _} ->
let maximum_type_size = Constants.michelson_maximum_type_size ctxt in
let type_size =
type_size_of_stack_head
aft
~up_to:(number_of_generated_growing_types instr)
in
if Compare.Int.(type_size > maximum_type_size) then
fail (Type_too_large (loc, type_size, maximum_type_size))
else return (judgement, ctxt)
| Failed _ ->
return (judgement, ctxt)
in
let typed ctxt loc instr aft =
log_stack ctxt loc stack_ty aft
>>=? fun () ->
Lwt.return @@ Gas.consume ctxt (Typecheck_costs.instr instr)
>>=? fun ctxt -> return ctxt (Typed {loc; instr; bef = stack_ty; aft})
in
Lwt.return @@ Gas.consume ctxt Typecheck_costs.cycle
>>=? fun ctxt ->
match (script_instr, stack_ty) with
(* stack ops *)
| (Prim (loc, I_DROP, [], annot), Item_t (_, rest, _)) ->
( fail_unexpected_annot loc annot >>=? fun () -> typed ctxt loc Drop rest
: (bef judgement * context) tzresult Lwt.t )
| (Prim (loc, I_DROP, [n], result_annot), whole_stack) ->
Lwt.return (parse_int32 n)
>>=? fun whole_n ->
let rec make_proof_argument :
type tstk.
int -> tstk stack_ty -> tstk dropn_proof_argument tzresult Lwt.t =
fun n stk ->
match (Compare.Int.(n = 0), stk) with
| (true, rest) ->
outer_return @@ Dropn_proof_argument (Rest, rest, rest)
| (false, Item_t (v, rest, annot)) ->
make_proof_argument (n - 1) rest
>>=? fun (Dropn_proof_argument (n', stack_after_drops, aft')) ->
outer_return
@@ Dropn_proof_argument
(Prefix n', stack_after_drops, Item_t (v, aft', annot))
| (_, _) ->
serialize_stack_for_error ctxt whole_stack
>>=? fun (whole_stack, _ctxt) ->
fail (Bad_stack (loc, I_DROP, whole_n, whole_stack))
in
fail_unexpected_annot loc result_annot
>>=? fun () ->
make_proof_argument whole_n whole_stack
>>=? fun (Dropn_proof_argument (n', stack_after_drops, _aft)) ->
typed ctxt loc (Dropn (whole_n, n')) stack_after_drops
| (Prim (loc, I_DROP, (_ :: _ :: _ as l), _), _) ->
(* Technically, the arities 0 and 1 are allowed but the error only mentions 1.
However, DROP is equivalent to DROP 1 so hinting at an arity of 1 makes sense. *)
fail (Invalid_arity (loc, I_DROP, 1, List.length l))
| (Prim (loc, I_DUP, [], annot), Item_t (v, rest, stack_annot)) ->
parse_var_annot loc annot ~default:stack_annot
>>=? fun annot ->
typed ctxt loc Dup (Item_t (v, Item_t (v, rest, stack_annot), annot))
| (Prim (loc, I_DIG, [n], result_annot), stack) ->
let rec make_proof_argument :
type tstk.
int -> tstk stack_ty -> tstk dig_proof_argument tzresult Lwt.t =
fun n stk ->
match (Compare.Int.(n = 0), stk) with
| (true, Item_t (v, rest, annot)) ->
outer_return @@ Dig_proof_argument (Rest, (v, annot), rest)
| (false, Item_t (v, rest, annot)) ->
make_proof_argument (n - 1) rest
>>=? fun (Dig_proof_argument (n', (x, xv), aft')) ->
outer_return
@@ Dig_proof_argument (Prefix n', (x, xv), Item_t (v, aft', annot))
| (_, _) ->
serialize_stack_for_error ctxt stack
>>=? fun (whole_stack, _ctxt) ->
fail (Bad_stack (loc, I_DIG, 1, whole_stack))
in
Lwt.return (parse_int32 n)
>>=? fun n ->
fail_unexpected_annot loc result_annot
>>=? fun () ->
make_proof_argument n stack
>>=? fun (Dig_proof_argument (n', (x, stack_annot), aft)) ->
typed ctxt loc (Dig (n, n')) (Item_t (x, aft, stack_annot))
| (Prim (loc, I_DIG, (([] | _ :: _ :: _) as l), _), _) ->
fail (Invalid_arity (loc, I_DIG, 1, List.length l))
| (Prim (loc, I_DUG, [n], result_annot), Item_t (x, whole_stack, stack_annot))
->
Lwt.return (parse_int32 n)
>>=? fun whole_n ->
let rec make_proof_argument :
type tstk x.
int ->
x ty ->
var_annot option ->
tstk stack_ty ->
(tstk, x) dug_proof_argument tzresult Lwt.t =
fun n x stack_annot stk ->
match (Compare.Int.(n = 0), stk) with
| (true, rest) ->
outer_return
@@ Dug_proof_argument (Rest, (), Item_t (x, rest, stack_annot))
| (false, Item_t (v, rest, annot)) ->
make_proof_argument (n - 1) x stack_annot rest
>>=? fun (Dug_proof_argument (n', (), aft')) ->
outer_return
@@ Dug_proof_argument (Prefix n', (), Item_t (v, aft', annot))
| (_, _) ->
serialize_stack_for_error ctxt whole_stack
>>=? fun (whole_stack, _ctxt) ->
fail (Bad_stack (loc, I_DUG, whole_n, whole_stack))
in
fail_unexpected_annot loc result_annot
>>=? fun () ->
make_proof_argument whole_n x stack_annot whole_stack
>>=? fun (Dug_proof_argument (n', (), aft)) ->
typed ctxt loc (Dug (whole_n, n')) aft
| (Prim (loc, I_DUG, [_], result_annot), (Empty_t as stack)) ->
fail_unexpected_annot loc result_annot
>>=? fun () ->
serialize_stack_for_error ctxt stack
>>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, I_DUG, 1, stack))
| (Prim (loc, I_DUG, (([] | _ :: _ :: _) as l), _), _) ->
fail (Invalid_arity (loc, I_DUG, 1, List.length l))
| ( Prim (loc, I_SWAP, [], annot),
Item_t (v, Item_t (w, rest, stack_annot), cur_top_annot) ) ->
fail_unexpected_annot loc annot
>>=? fun () ->
typed
ctxt
loc
Swap
(Item_t (w, Item_t (v, rest, cur_top_annot), stack_annot))
| (Prim (loc, I_PUSH, [t; d], annot), stack) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ parse_packable_ty ctxt ~legacy t
>>=? fun (Ex_ty t, ctxt) ->
parse_data ?type_logger ctxt ~legacy t d
>>=? fun (v, ctxt) -> typed ctxt loc (Const v) (Item_t (t, stack, annot))
| (Prim (loc, I_UNIT, [], annot), stack) ->
parse_var_type_annot loc annot
>>=? fun (annot, ty_name) ->
typed ctxt loc (Const ()) (Item_t (Unit_t ty_name, stack, annot))
(* options *)
| (Prim (loc, I_SOME, [], annot), Item_t (t, rest, _)) ->
parse_var_type_annot loc annot
>>=? fun (annot, ty_name) ->
typed
ctxt
loc
Cons_some
(Item_t (Option_t (t, ty_name, has_big_map t), rest, annot))
| (Prim (loc, I_NONE, [t], annot), stack) ->
Lwt.return @@ parse_any_ty ctxt ~legacy t
>>=? fun (Ex_ty t, ctxt) ->
parse_var_type_annot loc annot
>>=? fun (annot, ty_name) ->
typed
ctxt
loc
(Cons_none t)
(Item_t (Option_t (t, ty_name, has_big_map t), stack, annot))
| ( Prim (loc, I_IF_NONE, [bt; bf], annot),
(Item_t (Option_t (t, _, _), rest, option_annot) as bef) ) ->
check_kind [Seq_kind] bt
>>=? fun () ->
check_kind [Seq_kind] bf
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
let annot = gen_access_annot option_annot default_some_annot in
parse_instr ?type_logger tc_context ctxt ~legacy bt rest
>>=? fun (btr, ctxt) ->
parse_instr
?type_logger
tc_context
ctxt
~legacy
bf
(Item_t (t, rest, annot))
>>=? fun (bfr, ctxt) ->
let branch ibt ibf =
{loc; instr = If_none (ibt, ibf); bef; aft = ibt.aft}
in
merge_branches ~legacy ctxt loc btr bfr {branch}
>>=? fun (judgement, ctxt) -> return ctxt judgement
(* pairs *)
| ( Prim (loc, I_PAIR, [], annot),
Item_t (a, Item_t (b, rest, snd_annot), fst_annot) ) ->
parse_constr_annot
loc
annot
~if_special_first:(var_to_field_annot fst_annot)
~if_special_second:(var_to_field_annot snd_annot)
>>=? fun (annot, ty_name, l_field, r_field) ->
typed
ctxt
loc
Cons_pair
(Item_t
( Pair_t
( (a, l_field, fst_annot),
(b, r_field, snd_annot),
ty_name,
has_big_map a || has_big_map b ),
rest,
annot ))
| ( Prim (loc, I_CAR, [], annot),
Item_t
(Pair_t ((a, expected_field_annot, a_annot), _, _, _), rest, pair_annot)
) ->
parse_destr_annot
loc
annot
~pair_annot
~value_annot:a_annot
~field_name:expected_field_annot
~default_accessor:default_car_annot
>>=? fun (annot, field_annot) ->
Lwt.return @@ check_correct_field field_annot expected_field_annot
>>=? fun () -> typed ctxt loc Car (Item_t (a, rest, annot))
| ( Prim (loc, I_CDR, [], annot),
Item_t
(Pair_t (_, (b, expected_field_annot, b_annot), _, _), rest, pair_annot)
) ->
parse_destr_annot
loc
annot
~pair_annot
~value_annot:b_annot
~field_name:expected_field_annot
~default_accessor:default_cdr_annot
>>=? fun (annot, field_annot) ->
Lwt.return @@ check_correct_field field_annot expected_field_annot
>>=? fun () -> typed ctxt loc Cdr (Item_t (b, rest, annot))
(* unions *)
| (Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest, stack_annot)) ->
Lwt.return @@ parse_any_ty ctxt ~legacy tr
>>=? fun (Ex_ty tr, ctxt) ->
parse_constr_annot
loc
annot
~if_special_first:(var_to_field_annot stack_annot)
>>=? fun (annot, tname, l_field, r_field) ->
typed
ctxt
loc
Left
(Item_t
( Union_t
( (tl, l_field),
(tr, r_field),
tname,
has_big_map tl || has_big_map tr ),
rest,
annot ))
| (Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest, stack_annot)) ->
Lwt.return @@ parse_any_ty ctxt ~legacy tl
>>=? fun (Ex_ty tl, ctxt) ->
parse_constr_annot
loc
annot
~if_special_second:(var_to_field_annot stack_annot)
>>=? fun (annot, tname, l_field, r_field) ->
typed
ctxt
loc
Right
(Item_t
( Union_t
( (tl, l_field),
(tr, r_field),
tname,
has_big_map tl || has_big_map tr ),
rest,
annot ))
| ( Prim (loc, I_IF_LEFT, [bt; bf], annot),
( Item_t (Union_t ((tl, l_field), (tr, r_field), _, _), rest, union_annot)
as bef ) ) ->
check_kind [Seq_kind] bt
>>=? fun () ->
check_kind [Seq_kind] bf
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
let left_annot =
gen_access_annot union_annot l_field ~default:default_left_annot
in
let right_annot =
gen_access_annot union_annot r_field ~default:default_right_annot
in
parse_instr
?type_logger
tc_context
ctxt
~legacy
bt
(Item_t (tl, rest, left_annot))
>>=? fun (btr, ctxt) ->
parse_instr
?type_logger
tc_context
ctxt
~legacy
bf
(Item_t (tr, rest, right_annot))
>>=? fun (bfr, ctxt) ->
let branch ibt ibf =
{loc; instr = If_left (ibt, ibf); bef; aft = ibt.aft}
in
merge_branches ~legacy ctxt loc btr bfr {branch}
>>=? fun (judgement, ctxt) -> return ctxt judgement
(* lists *)
| (Prim (loc, I_NIL, [t], annot), stack) ->
Lwt.return @@ parse_any_ty ctxt ~legacy t
>>=? fun (Ex_ty t, ctxt) ->
parse_var_type_annot loc annot
>>=? fun (annot, ty_name) ->
typed
ctxt
loc
Nil
(Item_t (List_t (t, ty_name, has_big_map t), stack, annot))
| ( Prim (loc, I_CONS, [], annot),
Item_t (tv, Item_t (List_t (t, ty_name, has_big_map), rest, _), _) ) ->
check_item_ty ctxt tv t loc I_CONS 1 2
>>=? fun (Eq, t, ctxt) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Cons_list
(Item_t (List_t (t, ty_name, has_big_map), rest, annot))
| ( Prim (loc, I_IF_CONS, [bt; bf], annot),
(Item_t (List_t (t, ty_name, has_big_map), rest, list_annot) as bef) ) ->
check_kind [Seq_kind] bt
>>=? fun () ->
check_kind [Seq_kind] bf
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
let hd_annot = gen_access_annot list_annot default_hd_annot in
let tl_annot = gen_access_annot list_annot default_tl_annot in
parse_instr
?type_logger
tc_context
ctxt
~legacy
bt
(Item_t
( t,
Item_t (List_t (t, ty_name, has_big_map), rest, tl_annot),
hd_annot ))
>>=? fun (btr, ctxt) ->
parse_instr ?type_logger tc_context ctxt ~legacy bf rest
>>=? fun (bfr, ctxt) ->
let branch ibt ibf =
{loc; instr = If_cons (ibt, ibf); bef; aft = ibt.aft}
in
merge_branches ~legacy ctxt loc btr bfr {branch}
>>=? fun (judgement, ctxt) -> return ctxt judgement
| (Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest, _)) ->
parse_var_type_annot loc annot
>>=? fun (annot, tname) ->
typed ctxt loc List_size (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_MAP, [body], annot),
Item_t (List_t (elt, _, _), starting_rest, list_annot) ) -> (
check_kind [Seq_kind] body
>>=? fun () ->
parse_var_type_annot loc annot
>>=? fun (ret_annot, list_ty_name) ->
let elt_annot = gen_access_annot list_annot default_elt_annot in
parse_instr
?type_logger
tc_context
ctxt
~legacy
body
(Item_t (elt, starting_rest, elt_annot))
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ({aft = Item_t (ret, rest, _); _} as ibody) ->
let invalid_map_body () =
serialize_stack_for_error ctxt ibody.aft
>>|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft)
in
trace_eval
invalid_map_body
( Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest
>>=? fun (rest, ctxt) ->
typed
ctxt
loc
(List_map ibody)
(Item_t
(List_t (ret, list_ty_name, has_big_map ret), rest, ret_annot))
)
| Typed {aft; _} ->
serialize_stack_for_error ctxt aft
>>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft))
| Failed _ ->
fail (Invalid_map_block_fail loc) )
| ( Prim (loc, I_ITER, [body], annot),
Item_t (List_t (elt, _, _), rest, list_annot) ) -> (
check_kind [Seq_kind] body
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
let elt_annot = gen_access_annot list_annot default_elt_annot in
parse_instr
?type_logger
tc_context
ctxt
~legacy
body
(Item_t (elt, rest, elt_annot))
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ({aft; _} as ibody) ->
let invalid_iter_body () =
serialize_stack_for_error ctxt ibody.aft
>>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt rest
>>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
in
trace_eval
invalid_iter_body
( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
>>=? fun (rest, ctxt) -> typed ctxt loc (List_iter ibody) rest )
| Failed {descr} ->
typed ctxt loc (List_iter (descr rest)) rest )
(* sets *)
| (Prim (loc, I_EMPTY_SET, [t], annot), rest) ->
Lwt.return @@ parse_comparable_ty ctxt t
>>=? fun (Ex_comparable_ty t, ctxt) ->
parse_var_type_annot loc annot
>>=? fun (annot, tname) ->
typed ctxt loc (Empty_set t) (Item_t (Set_t (t, tname), rest, annot))
| ( Prim (loc, I_ITER, [body], annot),
Item_t (Set_t (comp_elt, _), rest, set_annot) ) -> (
check_kind [Seq_kind] body
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
let elt_annot = gen_access_annot set_annot default_elt_annot in
let elt = ty_of_comparable_ty comp_elt in
parse_instr
?type_logger
tc_context
ctxt
~legacy
body
(Item_t (elt, rest, elt_annot))
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ({aft; _} as ibody) ->
let invalid_iter_body () =
serialize_stack_for_error ctxt ibody.aft
>>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt rest
>>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
in
trace_eval
invalid_iter_body
( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
>>=? fun (rest, ctxt) -> typed ctxt loc (Set_iter ibody) rest )
| Failed {descr} ->
typed ctxt loc (Set_iter (descr rest)) rest )
| ( Prim (loc, I_MEM, [], annot),
Item_t (v, Item_t (Set_t (elt, _), rest, _), _) ) ->
let elt = ty_of_comparable_ty elt in
parse_var_type_annot loc annot
>>=? fun (annot, tname) ->
check_item_ty ctxt elt v loc I_MEM 1 2
>>=? fun (Eq, _, ctxt) ->
typed ctxt loc Set_mem (Item_t (Bool_t tname, rest, annot))
| ( Prim (loc, I_UPDATE, [], annot),
Item_t
( v,
Item_t (Bool_t _, Item_t (Set_t (elt, tname), rest, set_annot), _),
_ ) ) -> (
match comparable_ty_of_ty v with
| None ->
unparse_ty ctxt v
>>=? fun (v, _ctxt) ->
fail (Comparable_type_expected (loc, Micheline.strip_locations v))
| Some v ->
parse_var_annot loc annot ~default:set_annot
>>=? fun annot ->
check_item_comparable_ty elt v loc I_UPDATE 1 3
>>=? fun (Eq, elt) ->
typed ctxt loc Set_update (Item_t (Set_t (elt, tname), rest, annot)) )
| (Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Set_size (Item_t (Nat_t None, rest, annot))
(* maps *)
| (Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack) ->
Lwt.return @@ parse_comparable_ty ctxt tk
>>=? fun (Ex_comparable_ty tk, ctxt) ->
Lwt.return @@ parse_any_ty ctxt ~legacy tv
>>=? fun (Ex_ty tv, ctxt) ->
parse_var_type_annot loc annot
>>=? fun (annot, ty_name) ->
typed
ctxt
loc
(Empty_map (tk, tv))
(Item_t (Map_t (tk, tv, ty_name, has_big_map tv), stack, annot))
| ( Prim (loc, I_MAP, [body], annot),
Item_t (Map_t (ck, elt, _, _), starting_rest, _map_annot) ) -> (
let k = ty_of_comparable_ty ck in
check_kind [Seq_kind] body
>>=? fun () ->
parse_var_type_annot loc annot
>>=? fun (ret_annot, ty_name) ->
let k_name = field_to_var_annot default_key_annot in
let e_name = field_to_var_annot default_elt_annot in
parse_instr
?type_logger
tc_context
ctxt
~legacy
body
(Item_t
( Pair_t
((k, None, k_name), (elt, None, e_name), None, has_big_map elt),
starting_rest,
None ))
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ({aft = Item_t (ret, rest, _); _} as ibody) ->
let invalid_map_body () =
serialize_stack_for_error ctxt ibody.aft
>>|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft)
in
trace_eval
invalid_map_body
( Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest
>>=? fun (rest, ctxt) ->
typed
ctxt
loc
(Map_map ibody)
(Item_t
(Map_t (ck, ret, ty_name, has_big_map ret), rest, ret_annot))
)
| Typed {aft; _} ->
serialize_stack_for_error ctxt aft
>>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft))
| Failed _ ->
fail (Invalid_map_block_fail loc) )
| ( Prim (loc, I_ITER, [body], annot),
Item_t (Map_t (comp_elt, element_ty, _, _), rest, _map_annot) ) -> (
check_kind [Seq_kind] body
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
let k_name = field_to_var_annot default_key_annot in
let e_name = field_to_var_annot default_elt_annot in
let key = ty_of_comparable_ty comp_elt in
parse_instr
?type_logger
tc_context
ctxt
~legacy
body
(Item_t
( Pair_t
( (key, None, k_name),
(element_ty, None, e_name),
None,
has_big_map element_ty ),
rest,
None ))
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ({aft; _} as ibody) ->
let invalid_iter_body () =
serialize_stack_for_error ctxt ibody.aft
>>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt rest
>>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
in
trace_eval
invalid_iter_body
( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
>>=? fun (rest, ctxt) -> typed ctxt loc (Map_iter ibody) rest )
| Failed {descr} ->
typed ctxt loc (Map_iter (descr rest)) rest )
| ( Prim (loc, I_MEM, [], annot),
Item_t (vk, Item_t (Map_t (ck, _, _, _), rest, _), _) ) ->
let k = ty_of_comparable_ty ck in
check_item_ty ctxt vk k loc I_MEM 1 2
>>=? fun (Eq, _, ctxt) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Map_mem (Item_t (Bool_t None, rest, annot))
| ( Prim (loc, I_GET, [], annot),
Item_t (vk, Item_t (Map_t (ck, elt, _, has_big_map), rest, _), _) ) ->
let k = ty_of_comparable_ty ck in
check_item_ty ctxt vk k loc I_GET 1 2
>>=? fun (Eq, _, ctxt) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Map_get
(Item_t (Option_t (elt, None, has_big_map), rest, annot))
| ( Prim (loc, I_UPDATE, [], annot),
Item_t
( vk,
Item_t
( Option_t (vv, _, _),
Item_t (Map_t (ck, v, map_name, has_big_map), rest, map_annot),
_ ),
_ ) ) ->
let k = ty_of_comparable_ty ck in
check_item_ty ctxt vk k loc I_UPDATE 1 3
>>=? fun (Eq, _, ctxt) ->
check_item_ty ctxt vv v loc I_UPDATE 2 3
>>=? fun (Eq, v, ctxt) ->
parse_var_annot loc annot ~default:map_annot
>>=? fun annot ->
typed
ctxt
loc
Map_update
(Item_t (Map_t (ck, v, map_name, has_big_map), rest, annot))
| (Prim (loc, I_SIZE, [], annot), Item_t (Map_t (_, _, _, _), rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Map_size (Item_t (Nat_t None, rest, annot))
(* big_map *)
| (Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack) ->
Lwt.return @@ parse_comparable_ty ctxt tk
>>=? fun (Ex_comparable_ty tk, ctxt) ->
Lwt.return @@ parse_packable_ty ctxt ~legacy tv
>>=? fun (Ex_ty tv, ctxt) ->
parse_var_type_annot loc annot
>>=? fun (annot, ty_name) ->
typed
ctxt
loc
(Empty_big_map (tk, tv))
(Item_t (Big_map_t (tk, tv, ty_name), stack, annot))
| ( Prim (loc, I_MEM, [], annot),
Item_t (set_key, Item_t (Big_map_t (map_key, _, _), rest, _), _) ) ->
let k = ty_of_comparable_ty map_key in
check_item_ty ctxt set_key k loc I_MEM 1 2
>>=? fun (Eq, _, ctxt) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Big_map_mem (Item_t (Bool_t None, rest, annot))
| ( Prim (loc, I_GET, [], annot),
Item_t (vk, Item_t (Big_map_t (ck, elt, _), rest, _), _) ) ->
let k = ty_of_comparable_ty ck in
check_item_ty ctxt vk k loc I_GET 1 2
>>=? fun (Eq, _, ctxt) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Big_map_get
(Item_t (Option_t (elt, None, has_big_map elt), rest, annot))
| ( Prim (loc, I_UPDATE, [], annot),
Item_t
( set_key,
Item_t
( Option_t (set_value, _, _),
Item_t (Big_map_t (map_key, map_value, map_name), rest, map_annot),
_ ),
_ ) ) ->
let k = ty_of_comparable_ty map_key in
check_item_ty ctxt set_key k loc I_UPDATE 1 3
>>=? fun (Eq, _, ctxt) ->
check_item_ty ctxt set_value map_value loc I_UPDATE 2 3
>>=? fun (Eq, map_value, ctxt) ->
parse_var_annot loc annot ~default:map_annot
>>=? fun annot ->
typed
ctxt
loc
Big_map_update
(Item_t (Big_map_t (map_key, map_value, map_name), rest, annot))
(* control *)
| (Seq (loc, []), stack) ->
typed ctxt loc Nop stack
| (Seq (loc, [single]), stack) -> (
parse_instr ?type_logger tc_context ctxt ~legacy single stack
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ({aft; _} as instr) ->
let nop = {bef = aft; loc; aft; instr = Nop} in
typed ctxt loc (Seq (instr, nop)) aft
| Failed {descr; _} ->
let descr aft =
let nop = {bef = aft; loc; aft; instr = Nop} in
let descr = descr aft in
{descr with instr = Seq (descr, nop)}
in
return ctxt (Failed {descr}) )
| (Seq (loc, hd :: tl), stack) -> (
parse_instr ?type_logger tc_context ctxt ~legacy hd stack
>>=? fun (judgement, ctxt) ->
match judgement with
| Failed _ ->
fail (Fail_not_in_tail_position (Micheline.location hd))
| Typed ({aft = middle; _} as ihd) -> (
parse_instr
?type_logger
tc_context
ctxt
~legacy
(Seq (-1, tl))
middle
>>=? fun (judgement, ctxt) ->
match judgement with
| Failed {descr} ->
let descr ret =
{loc; instr = Seq (ihd, descr ret); bef = stack; aft = ret}
in
return ctxt (Failed {descr})
| Typed itl ->
typed ctxt loc (Seq (ihd, itl)) itl.aft ) )
| (Prim (loc, I_IF, [bt; bf], annot), (Item_t (Bool_t _, rest, _) as bef)) ->
check_kind [Seq_kind] bt
>>=? fun () ->
check_kind [Seq_kind] bf
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
parse_instr ?type_logger tc_context ctxt ~legacy bt rest
>>=? fun (btr, ctxt) ->
parse_instr ?type_logger tc_context ctxt ~legacy bf rest
>>=? fun (bfr, ctxt) ->
let branch ibt ibf = {loc; instr = If (ibt, ibf); bef; aft = ibt.aft} in
merge_branches ~legacy ctxt loc btr bfr {branch}
>>=? fun (judgement, ctxt) -> return ctxt judgement
| ( Prim (loc, I_LOOP, [body], annot),
(Item_t (Bool_t _, rest, _stack_annot) as stack) ) -> (
check_kind [Seq_kind] body
>>=? fun () ->
fail_unexpected_annot loc annot
>>=? fun () ->
parse_instr ?type_logger tc_context ctxt ~legacy body rest
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ibody ->
let unmatched_branches () =
serialize_stack_for_error ctxt ibody.aft
>>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt stack
>>|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack)
in
trace_eval
unmatched_branches
( Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack
>>=? fun (_stack, ctxt) -> typed ctxt loc (Loop ibody) rest )
| Failed {descr} ->
let ibody = descr stack in
typed ctxt loc (Loop ibody) rest )
| ( Prim (loc, I_LOOP_LEFT, [body], annot),
( Item_t (Union_t ((tl, l_field), (tr, _), _, _), rest, union_annot) as
stack ) ) -> (
check_kind [Seq_kind] body
>>=? fun () ->
parse_var_annot loc annot
>>=? fun annot ->
let l_annot =
gen_access_annot union_annot l_field ~default:default_left_annot
in
parse_instr
?type_logger
tc_context
ctxt
~legacy
body
(Item_t (tl, rest, l_annot))
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed ibody ->
let unmatched_branches () =
serialize_stack_for_error ctxt ibody.aft
>>=? fun (aft, ctxt) ->
serialize_stack_for_error ctxt stack
>>|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack)
in
trace_eval
unmatched_branches
( Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack
>>=? fun (_stack, ctxt) ->
typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) )
| Failed {descr} ->
let ibody = descr stack in
typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) )
| (Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack) ->
Lwt.return @@ parse_any_ty ctxt ~legacy arg
>>=? fun (Ex_ty arg, ctxt) ->
Lwt.return @@ parse_any_ty ctxt ~legacy ret
>>=? fun (Ex_ty ret, ctxt) ->
check_kind [Seq_kind] code
>>=? fun () ->
parse_var_annot loc annot
>>=? fun annot ->
parse_returning
Lambda
?type_logger
ctxt
~legacy
(arg, default_arg_annot)
ret
code
>>=? fun (lambda, ctxt) ->
typed
ctxt
loc
(Lambda lambda)
(Item_t (Lambda_t (arg, ret, None), stack, annot))
| ( Prim (loc, I_EXEC, [], annot),
Item_t (arg, Item_t (Lambda_t (param, ret, _), rest, _), _) ) ->
check_item_ty ctxt arg param loc I_EXEC 1 2
>>=? fun (Eq, _, ctxt) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Exec (Item_t (ret, rest, annot))
| ( Prim (loc, I_APPLY, [], annot),
Item_t
( capture,
Item_t
( Lambda_t
( Pair_t ((capture_ty, _, _), (arg_ty, _, _), lam_annot, _),
ret,
_ ),
rest,
_ ),
_ ) ) ->
Lwt.return @@ check_packable ~legacy:false loc capture_ty
>>=? fun () ->
check_item_ty ctxt capture capture_ty loc I_APPLY 1 2
>>=? fun (Eq, capture_ty, ctxt) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
(Apply capture_ty)
(Item_t (Lambda_t (arg_ty, ret, lam_annot), rest, annot))
| (Prim (loc, I_DIP, [code], annot), Item_t (v, rest, stack_annot)) -> (
fail_unexpected_annot loc annot
>>=? fun () ->
check_kind [Seq_kind] code
>>=? fun () ->
parse_instr
?type_logger
(add_dip v stack_annot tc_context)
ctxt
~legacy
code
rest
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed descr ->
typed ctxt loc (Dip descr) (Item_t (v, descr.aft, stack_annot))
| Failed _ ->
fail (Fail_not_in_tail_position loc) )
| (Prim (loc, I_DIP, [n; code], result_annot), stack)
when match parse_int32 n with Ok _ -> true | Error _ -> false ->
let rec make_proof_argument :
type tstk.
int
(* -> (fbef stack_ty -> (fbef judgement * context) tzresult Lwt.t) *) ->
tc_context ->
tstk stack_ty ->
tstk dipn_proof_argument tzresult Lwt.t =
fun n inner_tc_context stk ->
match (Compare.Int.(n = 0), stk) with
| (true, rest) -> (
parse_instr ?type_logger inner_tc_context ctxt ~legacy code rest
>>=? fun (judgement, ctxt) ->
match judgement with
| Typed descr ->
outer_return
@@ Dipn_proof_argument (Rest, (ctxt, descr), descr.aft)
| Failed _ ->
fail (Fail_not_in_tail_position loc) )
| (false, Item_t (v, rest, annot)) ->
make_proof_argument (n - 1) (add_dip v annot tc_context) rest
>>=? fun (Dipn_proof_argument (n', descr, aft')) ->
outer_return
@@ Dipn_proof_argument (Prefix n', descr, Item_t (v, aft', annot))
| (_, _) ->
serialize_stack_for_error ctxt stack
>>=? fun (whole_stack, _ctxt) ->
fail (Bad_stack (loc, I_DIP, 1, whole_stack))
in
Lwt.return (parse_int32 n)
>>=? fun n ->
fail_unexpected_annot loc result_annot
>>=? fun () ->
make_proof_argument n tc_context stack
>>=? fun (Dipn_proof_argument (n', (new_ctxt, descr), aft)) ->
(* TODO: which context should be used in the next line? new_ctxt or the old ctxt? *)
typed new_ctxt loc (Dipn (n, n', descr)) aft
| (Prim (loc, I_DIP, (([] | _ :: _ :: _ :: _) as l), _), _) ->
(* Technically, the arities 1 and 2 are allowed but the error only mentions 2.
However, DIP {code} is equivalent to DIP 1 {code} so hinting at an arity of 2 makes sense. *)
fail (Invalid_arity (loc, I_DIP, 2, List.length l))
| (Prim (loc, I_FAILWITH, [], annot), Item_t (v, _rest, _)) ->
fail_unexpected_annot loc annot
>>=? fun () ->
let descr aft = {loc; instr = Failwith v; bef = stack_ty; aft} in
log_stack ctxt loc stack_ty Empty_t
>>=? fun () -> return ctxt (Failed {descr})
(* timestamp operations *)
| ( Prim (loc, I_ADD, [], annot),
Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Add_timestamp_to_seconds
(Item_t (Timestamp_t tname, rest, annot))
| ( Prim (loc, I_ADD, [], annot),
Item_t (Int_t _, Item_t (Timestamp_t tname, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Add_seconds_to_timestamp
(Item_t (Timestamp_t tname, rest, annot))
| ( Prim (loc, I_SUB, [], annot),
Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Sub_timestamp_seconds
(Item_t (Timestamp_t tname, rest, annot))
| ( Prim (loc, I_SUB, [], annot),
Item_t (Timestamp_t tn1, Item_t (Timestamp_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Diff_timestamps (Item_t (Int_t tname, rest, annot))
(* string operations *)
| ( Prim (loc, I_CONCAT, [], annot),
Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Concat_string_pair (Item_t (String_t tname, rest, annot))
| ( Prim (loc, I_CONCAT, [], annot),
Item_t (List_t (String_t tname, _, _), rest, list_annot) ) ->
parse_var_annot ~default:list_annot loc annot
>>=? fun annot ->
typed ctxt loc Concat_string (Item_t (String_t tname, rest, annot))
| ( Prim (loc, I_SLICE, [], annot),
Item_t
( Nat_t _,
Item_t (Nat_t _, Item_t (String_t tname, rest, string_annot), _),
_ ) ) ->
parse_var_annot
~default:(gen_access_annot string_annot default_slice_annot)
loc
annot
>>=? fun annot ->
typed
ctxt
loc
Slice_string
(Item_t (Option_t (String_t tname, None, false), rest, annot))
| (Prim (loc, I_SIZE, [], annot), Item_t (String_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc String_size (Item_t (Nat_t None, rest, annot))
(* bytes operations *)
| ( Prim (loc, I_CONCAT, [], annot),
Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Concat_bytes_pair (Item_t (Bytes_t tname, rest, annot))
| ( Prim (loc, I_CONCAT, [], annot),
Item_t (List_t (Bytes_t tname, _, _), rest, list_annot) ) ->
parse_var_annot ~default:list_annot loc annot
>>=? fun annot ->
typed ctxt loc Concat_bytes (Item_t (Bytes_t tname, rest, annot))
| ( Prim (loc, I_SLICE, [], annot),
Item_t
( Nat_t _,
Item_t (Nat_t _, Item_t (Bytes_t tname, rest, bytes_annot), _),
_ ) ) ->
parse_var_annot
~default:(gen_access_annot bytes_annot default_slice_annot)
loc
annot
>>=? fun annot ->
typed
ctxt
loc
Slice_bytes
(Item_t (Option_t (Bytes_t tname, None, false), rest, annot))
| (Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Bytes_size (Item_t (Nat_t None, rest, annot))
(* currency operations *)
| ( Prim (loc, I_ADD, [], annot),
Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Add_tez (Item_t (Mutez_t tname, rest, annot))
| ( Prim (loc, I_SUB, [], annot),
Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Sub_tez (Item_t (Mutez_t tname, rest, annot))
| ( Prim (loc, I_MUL, [], annot),
Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) ) ->
(* no type name check *)
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Mul_teznat (Item_t (Mutez_t tname, rest, annot))
| ( Prim (loc, I_MUL, [], annot),
Item_t (Nat_t _, Item_t (Mutez_t tname, rest, _), _) ) ->
(* no type name check *)
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Mul_nattez (Item_t (Mutez_t tname, rest, annot))
(* boolean operations *)
| ( Prim (loc, I_OR, [], annot),
Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname -> typed ctxt loc Or (Item_t (Bool_t tname, rest, annot))
| ( Prim (loc, I_AND, [], annot),
Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname -> typed ctxt loc And (Item_t (Bool_t tname, rest, annot))
| ( Prim (loc, I_XOR, [], annot),
Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname -> typed ctxt loc Xor (Item_t (Bool_t tname, rest, annot))
| (Prim (loc, I_NOT, [], annot), Item_t (Bool_t tname, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Not (Item_t (Bool_t tname, rest, annot))
(* integer operations *)
| (Prim (loc, I_ABS, [], annot), Item_t (Int_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Abs_int (Item_t (Nat_t None, rest, annot))
| (Prim (loc, I_ISNAT, [], annot), Item_t (Int_t _, rest, int_annot)) ->
parse_var_annot loc annot ~default:int_annot
>>=? fun annot ->
typed
ctxt
loc
Is_nat
(Item_t (Option_t (Nat_t None, None, false), rest, annot))
| (Prim (loc, I_INT, [], annot), Item_t (Nat_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Int_nat (Item_t (Int_t None, rest, annot))
| (Prim (loc, I_NEG, [], annot), Item_t (Int_t tname, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Neg_int (Item_t (Int_t tname, rest, annot))
| (Prim (loc, I_NEG, [], annot), Item_t (Nat_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Neg_nat (Item_t (Int_t None, rest, annot))
| ( Prim (loc, I_ADD, [], annot),
Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Add_intint (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_ADD, [], annot),
Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Add_intnat (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_ADD, [], annot),
Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Add_natint (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_ADD, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Add_natnat (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_SUB, [], annot),
Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_SUB, [], annot),
Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_SUB, [], annot),
Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_SUB, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun _tname ->
typed ctxt loc Sub_int (Item_t (Int_t None, rest, annot))
| ( Prim (loc, I_MUL, [], annot),
Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Mul_intint (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_MUL, [], annot),
Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Mul_intnat (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_MUL, [], annot),
Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Mul_natint (Item_t (Int_t tname, rest, annot))
| ( Prim (loc, I_MUL, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Mul_natnat (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_EDIV, [], annot),
Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Ediv_teznat
(Item_t
( Option_t
( Pair_t
( (Mutez_t tname, None, None),
(Mutez_t tname, None, None),
None,
false ),
None,
false ),
rest,
annot ))
| ( Prim (loc, I_EDIV, [], annot),
Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed
ctxt
loc
Ediv_tez
(Item_t
( Option_t
( Pair_t
( (Nat_t None, None, None),
(Mutez_t tname, None, None),
None,
false ),
None,
false ),
rest,
annot ))
| ( Prim (loc, I_EDIV, [], annot),
Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed
ctxt
loc
Ediv_intint
(Item_t
( Option_t
( Pair_t
( (Int_t tname, None, None),
(Nat_t None, None, None),
None,
false ),
None,
false ),
rest,
annot ))
| ( Prim (loc, I_EDIV, [], annot),
Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Ediv_intnat
(Item_t
( Option_t
( Pair_t
( (Int_t tname, None, None),
(Nat_t None, None, None),
None,
false ),
None,
false ),
rest,
annot ))
| ( Prim (loc, I_EDIV, [], annot),
Item_t (Nat_t tname, Item_t (Int_t _, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Ediv_natint
(Item_t
( Option_t
( Pair_t
( (Int_t None, None, None),
(Nat_t tname, None, None),
None,
false ),
None,
false ),
rest,
annot ))
| ( Prim (loc, I_EDIV, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed
ctxt
loc
Ediv_natnat
(Item_t
( Option_t
( Pair_t
( (Nat_t tname, None, None),
(Nat_t tname, None, None),
None,
false ),
None,
false ),
rest,
annot ))
| ( Prim (loc, I_LSL, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Lsl_nat (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_LSR, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Lsr_nat (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_OR, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Or_nat (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_AND, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc And_nat (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_AND, [], annot),
Item_t (Int_t _, Item_t (Nat_t tname, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc And_int_nat (Item_t (Nat_t tname, rest, annot))
| ( Prim (loc, I_XOR, [], annot),
Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
Lwt.return @@ merge_type_annot ~legacy tn1 tn2
>>=? fun tname ->
typed ctxt loc Xor_nat (Item_t (Nat_t tname, rest, annot))
| (Prim (loc, I_NOT, [], annot), Item_t (Int_t tname, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Not_int (Item_t (Int_t tname, rest, annot))
| (Prim (loc, I_NOT, [], annot), Item_t (Nat_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Not_nat (Item_t (Int_t None, rest, annot))
(* comparison *)
| (Prim (loc, I_COMPARE, [], annot), Item_t (t1, Item_t (t2, rest, _), _))
-> (
parse_var_annot loc annot
>>=? fun annot ->
check_item_ty ctxt t1 t2 loc I_COMPARE 1 2
>>=? fun (Eq, t, ctxt) ->
match comparable_ty_of_ty t with
| None ->
Lwt.return (serialize_ty_for_error ctxt t)
>>=? fun (t, _ctxt) -> fail (Comparable_type_expected (loc, t))
| Some key ->
typed ctxt loc (Compare key) (Item_t (Int_t None, rest, annot)) )
(* comparators *)
| (Prim (loc, I_EQ, [], annot), Item_t (Int_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Eq (Item_t (Bool_t None, rest, annot))
| (Prim (loc, I_NEQ, [], annot), Item_t (Int_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Neq (Item_t (Bool_t None, rest, annot))
| (Prim (loc, I_LT, [], annot), Item_t (Int_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Lt (Item_t (Bool_t None, rest, annot))
| (Prim (loc, I_GT, [], annot), Item_t (Int_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Gt (Item_t (Bool_t None, rest, annot))
| (Prim (loc, I_LE, [], annot), Item_t (Int_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Le (Item_t (Bool_t None, rest, annot))
| (Prim (loc, I_GE, [], annot), Item_t (Int_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot -> typed ctxt loc Ge (Item_t (Bool_t None, rest, annot))
(* annotations *)
| (Prim (loc, I_CAST, [cast_t], annot), Item_t (t, stack, item_annot)) ->
parse_var_annot loc annot ~default:item_annot
>>=? fun annot ->
Lwt.return @@ parse_any_ty ctxt ~legacy cast_t
>>=? fun (Ex_ty cast_t, ctxt) ->
Lwt.return @@ ty_eq ctxt cast_t t
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_types ~legacy ctxt loc cast_t t
>>=? fun (_, ctxt) -> typed ctxt loc Nop (Item_t (cast_t, stack, annot))
| (Prim (loc, I_RENAME, [], annot), Item_t (t, stack, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
(* can erase annot *)
typed ctxt loc Nop (Item_t (t, stack, annot))
(* packing *)
| (Prim (loc, I_PACK, [], annot), Item_t (t, rest, unpacked_annot)) ->
Lwt.return
(check_packable
~legacy:true
(* allow to pack contracts for hash/signature checks *) loc
t)
>>=? fun () ->
parse_var_annot
loc
annot
~default:(gen_access_annot unpacked_annot default_pack_annot)
>>=? fun annot ->
typed ctxt loc (Pack t) (Item_t (Bytes_t None, rest, annot))
| (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t _, rest, packed_annot))
->
Lwt.return @@ parse_packable_ty ctxt ~legacy ty
>>=? fun (Ex_ty t, ctxt) ->
parse_var_type_annot loc annot
>>=? fun (annot, ty_name) ->
let annot =
default_annot
annot
~default:(gen_access_annot packed_annot default_unpack_annot)
in
typed
ctxt
loc
(Unpack t)
(Item_t
( Option_t (t, ty_name, false (* cannot unpack big_maps *)),
rest,
annot ))
(* protocol *)
| ( Prim (loc, I_ADDRESS, [], annot),
Item_t (Contract_t _, rest, contract_annot) ) ->
parse_var_annot
loc
annot
~default:(gen_access_annot contract_annot default_addr_annot)
>>=? fun annot ->
typed ctxt loc Address (Item_t (Address_t None, rest, annot))
| ( Prim (loc, I_CONTRACT, [ty], annot),
Item_t (Address_t _, rest, addr_annot) ) ->
Lwt.return @@ parse_parameter_ty ctxt ~legacy ty
>>=? fun (Ex_ty t, ctxt) ->
parse_entrypoint_annot
loc
annot
~default:(gen_access_annot addr_annot default_contract_annot)
>>=? fun (annot, entrypoint) ->
( Lwt.return
@@
match entrypoint with
| None ->
Ok "default"
| Some (`Field_annot "default") ->
error (Unexpected_annotation loc)
| Some (`Field_annot entrypoint) ->
if Compare.Int.(String.length entrypoint > 31) then
error (Entrypoint_name_too_long entrypoint)
else Ok entrypoint )
>>=? fun entrypoint ->
typed
ctxt
loc
(Contract (t, entrypoint))
(Item_t (Option_t (Contract_t (t, None), None, false), rest, annot))
| ( Prim (loc, I_TRANSFER_TOKENS, [], annot),
Item_t (p, Item_t (Mutez_t _, Item_t (Contract_t (cp, _), rest, _), _), _)
) ->
check_item_ty ctxt p cp loc I_TRANSFER_TOKENS 1 4
>>=? fun (Eq, _, ctxt) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Transfer_tokens (Item_t (Operation_t None, rest, annot))
| ( Prim (loc, I_SET_DELEGATE, [], annot),
Item_t (Option_t (Key_hash_t _, _, _), rest, _) ) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Set_delegate (Item_t (Operation_t None, rest, annot))
| ( Prim (loc, I_CREATE_ACCOUNT, [], annot),
Item_t
( Key_hash_t _,
Item_t
( Option_t (Key_hash_t _, _, _),
Item_t (Bool_t _, Item_t (Mutez_t _, rest, _), _),
_ ),
_ ) ) ->
if legacy then
(* For existing contracts, this instruction is still allowed *)
parse_two_var_annot loc annot
>>=? fun (op_annot, addr_annot) ->
typed
ctxt
loc
Create_account
(Item_t
( Operation_t None,
Item_t (Address_t None, rest, addr_annot),
op_annot ))
else
(* For new contracts this instruction is not allowed anymore *)
fail (Deprecated_instruction I_CREATE_ACCOUNT)
| (Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t _, rest, _))
->
parse_var_annot loc annot
>>=? fun annot ->
typed
ctxt
loc
Implicit_account
(Item_t (Contract_t (Unit_t None, None), rest, annot))
| ( Prim (loc, I_CREATE_CONTRACT, [(Seq _ as code)], annot),
Item_t
( Key_hash_t _,
Item_t
( Option_t (Key_hash_t _, _, _),
Item_t
( Bool_t _,
Item_t
( Bool_t _,
Item_t (Mutez_t _, Item_t (ginit, rest, _), _),
_ ),
_ ),
_ ),
_ ) ) ->
if legacy then
(* For existing contracts, this instruction is still allowed *)
parse_two_var_annot loc annot
>>=? fun (op_annot, addr_annot) ->
let cannonical_code = fst @@ Micheline.extract_locations code in
Lwt.return @@ parse_toplevel ~legacy cannonical_code
>>=? fun (arg_type, storage_type, code_field, root_name) ->
trace
(Ill_formed_type
(Some "parameter", cannonical_code, location arg_type))
(Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type)
>>=? fun (Ex_ty arg_type, ctxt) ->
( if legacy then Error_monad.return ()
else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
>>=? fun () ->
trace
(Ill_formed_type
(Some "storage", cannonical_code, location storage_type))
(Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type)
>>=? fun (Ex_ty storage_type, ctxt) ->
let arg_annot =
default_annot
(type_to_var_annot (name_of_ty arg_type))
~default:default_param_annot
in
let storage_annot =
default_annot
(type_to_var_annot (name_of_ty storage_type))
~default:default_storage_annot
in
let arg_type_full =
Pair_t
( (arg_type, None, arg_annot),
(storage_type, None, storage_annot),
None,
has_big_map arg_type || has_big_map storage_type )
in
let ret_type_full =
Pair_t
( (List_t (Operation_t None, None, false), None, None),
(storage_type, None, None),
None,
has_big_map storage_type )
in
trace
(Ill_typed_contract (cannonical_code, []))
(parse_returning
(Toplevel
{
storage_type;
param_type = arg_type;
root_name;
legacy_create_contract_literal = true;
})
ctxt
~legacy
?type_logger
(arg_type_full, None)
ret_type_full
code_field)
>>=? fun ( ( Lam
( { bef = Item_t (arg, Empty_t, _);
aft = Item_t (ret, Empty_t, _);
_ },
_ ) as lambda ),
ctxt ) ->
Lwt.return @@ ty_eq ctxt arg arg_type_full
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full
>>=? fun (_, ctxt) ->
Lwt.return @@ ty_eq ctxt ret ret_type_full
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full
>>=? fun (_, ctxt) ->
Lwt.return @@ ty_eq ctxt storage_type ginit
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit
>>=? fun (_, ctxt) ->
typed
ctxt
loc
(Create_contract (storage_type, arg_type, lambda, root_name))
(Item_t
( Operation_t None,
Item_t (Address_t None, rest, addr_annot),
op_annot ))
else
(* For new contracts this instruction is not allowed anymore *)
fail (Deprecated_instruction I_CREATE_CONTRACT)
| ( Prim (loc, I_CREATE_CONTRACT, [(Seq _ as code)], annot),
(* Removed the instruction's arguments manager, spendable and delegatable *)
Item_t
( Option_t (Key_hash_t _, _, _),
Item_t (Mutez_t _, Item_t (ginit, rest, _), _),
_ ) ) ->
parse_two_var_annot loc annot
>>=? fun (op_annot, addr_annot) ->
let cannonical_code = fst @@ Micheline.extract_locations code in
Lwt.return @@ parse_toplevel ~legacy cannonical_code
>>=? fun (arg_type, storage_type, code_field, root_name) ->
trace
(Ill_formed_type (Some "parameter", cannonical_code, location arg_type))
(Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type)
>>=? fun (Ex_ty arg_type, ctxt) ->
( if legacy then Error_monad.return ()
else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
>>=? fun () ->
trace
(Ill_formed_type
(Some "storage", cannonical_code, location storage_type))
(Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type)
>>=? fun (Ex_ty storage_type, ctxt) ->
let arg_annot =
default_annot
(type_to_var_annot (name_of_ty arg_type))
~default:default_param_annot
in
let storage_annot =
default_annot
(type_to_var_annot (name_of_ty storage_type))
~default:default_storage_annot
in
let arg_type_full =
Pair_t
( (arg_type, None, arg_annot),
(storage_type, None, storage_annot),
None,
has_big_map arg_type || has_big_map storage_type )
in
let ret_type_full =
Pair_t
( (List_t (Operation_t None, None, false), None, None),
(storage_type, None, None),
None,
has_big_map storage_type )
in
trace
(Ill_typed_contract (cannonical_code, []))
(parse_returning
(Toplevel
{
storage_type;
param_type = arg_type;
root_name;
legacy_create_contract_literal = false;
})
ctxt
~legacy
?type_logger
(arg_type_full, None)
ret_type_full
code_field)
>>=? fun ( ( Lam
( { bef = Item_t (arg, Empty_t, _);
aft = Item_t (ret, Empty_t, _);
_ },
_ ) as lambda ),
ctxt ) ->
Lwt.return @@ ty_eq ctxt arg arg_type_full
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full
>>=? fun (_, ctxt) ->
Lwt.return @@ ty_eq ctxt ret ret_type_full
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full
>>=? fun (_, ctxt) ->
Lwt.return @@ ty_eq ctxt storage_type ginit
>>=? fun (Eq, ctxt) ->
Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit
>>=? fun (_, ctxt) ->
typed
ctxt
loc
(Create_contract_2 (storage_type, arg_type, lambda, root_name))
(Item_t
( Operation_t None,
Item_t (Address_t None, rest, addr_annot),
op_annot ))
| (Prim (loc, I_NOW, [], annot), stack) ->
parse_var_annot loc annot ~default:default_now_annot
>>=? fun annot ->
typed ctxt loc Now (Item_t (Timestamp_t None, stack, annot))
| (Prim (loc, I_AMOUNT, [], annot), stack) ->
parse_var_annot loc annot ~default:default_amount_annot
>>=? fun annot ->
typed ctxt loc Amount (Item_t (Mutez_t None, stack, annot))
| (Prim (loc, I_CHAIN_ID, [], annot), stack) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc ChainId (Item_t (Chain_id_t None, stack, annot))
| (Prim (loc, I_BALANCE, [], annot), stack) ->
parse_var_annot loc annot ~default:default_balance_annot
>>=? fun annot ->
typed ctxt loc Balance (Item_t (Mutez_t None, stack, annot))
| (Prim (loc, I_HASH_KEY, [], annot), Item_t (Key_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Hash_key (Item_t (Key_hash_t None, rest, annot))
| ( Prim (loc, I_CHECK_SIGNATURE, [], annot),
Item_t
(Key_t _, Item_t (Signature_t _, Item_t (Bytes_t _, rest, _), _), _) )
->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Check_signature (Item_t (Bool_t None, rest, annot))
| (Prim (loc, I_BLAKE2B, [], annot), Item_t (Bytes_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Blake2b (Item_t (Bytes_t None, rest, annot))
| (Prim (loc, I_SHA256, [], annot), Item_t (Bytes_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Sha256 (Item_t (Bytes_t None, rest, annot))
| (Prim (loc, I_SHA512, [], annot), Item_t (Bytes_t _, rest, _)) ->
parse_var_annot loc annot
>>=? fun annot ->
typed ctxt loc Sha512 (Item_t (Bytes_t None, rest, annot))
| (Prim (loc, I_STEPS_TO_QUOTA, [], annot), stack) ->
if legacy then
(* For existing contracts, this instruction is still allowed *)
parse_var_annot loc annot ~default:default_steps_annot
>>=? fun annot ->
typed ctxt loc Steps_to_quota (Item_t (Nat_t None, stack, annot))
else
(* For new contracts this instruction is not allowed anymore *)
fail (Deprecated_instruction I_STEPS_TO_QUOTA)
| (Prim (loc, I_SOURCE, [], annot), stack) ->
parse_var_annot loc annot ~default:default_source_annot
>>=? fun annot ->
typed ctxt loc Source (Item_t (Address_t None, stack, annot))
| (Prim (loc, I_SENDER, [], annot), stack) ->
parse_var_annot loc annot ~default:default_sender_annot
>>=? fun annot ->
typed ctxt loc Sender (Item_t (Address_t None, stack, annot))
| (Prim (loc, I_SELF, [], annot), stack) ->
parse_entrypoint_annot loc annot ~default:default_self_annot
>>=? fun (annot, entrypoint) ->
let entrypoint =
Option.unopt_map
~f:(fun (`Field_annot annot) -> annot)
~default:"default"
entrypoint
in
let rec get_toplevel_type :
tc_context -> (bef judgement * context) tzresult Lwt.t = function
| Lambda ->
fail (Self_in_lambda loc)
| Dip (_, prev) ->
get_toplevel_type prev
| Toplevel
{param_type; root_name; legacy_create_contract_literal = false} ->
Lwt.return (find_entrypoint param_type ~root_name entrypoint)
>>=? fun (_, Ex_ty param_type) ->
typed
ctxt
loc
(Self (param_type, entrypoint))
(Item_t (Contract_t (param_type, None), stack, annot))
| Toplevel
{param_type; root_name = _; legacy_create_contract_literal = true}
->
typed
ctxt
loc
(Self (param_type, "default"))
(Item_t (Contract_t (param_type, None), stack, annot))
in
get_toplevel_type tc_context
(* Primitive parsing errors *)
| ( Prim
( loc,
( ( I_DUP
| I_SWAP
| I_SOME
| I_UNIT
| I_PAIR
| I_CAR
| I_CDR
| I_CONS
| I_CONCAT
| I_SLICE
| I_MEM
| I_UPDATE
| I_MAP
| I_GET
| I_EXEC
| I_FAILWITH
| I_SIZE
| I_ADD
| I_SUB
| I_MUL
| I_EDIV
| I_OR
| I_AND
| I_XOR
| I_NOT
| I_ABS
| I_NEG
| I_LSL
| I_LSR
| I_COMPARE
| I_EQ
| I_NEQ
| I_LT
| I_GT
| I_LE
| I_GE
| I_TRANSFER_TOKENS
| I_CREATE_ACCOUNT
| I_SET_DELEGATE
| I_NOW
| I_IMPLICIT_ACCOUNT
| I_AMOUNT
| I_BALANCE
| I_CHECK_SIGNATURE
| I_HASH_KEY
| I_SOURCE
| I_SENDER
| I_BLAKE2B
| I_SHA256
| I_SHA512
| I_STEPS_TO_QUOTA
| I_ADDRESS ) as name ),
(_ :: _ as l),
_ ),
_ ) ->
fail (Invalid_arity (loc, name, 0, List.length l))
| ( Prim
( loc,
( ( I_NONE
| I_LEFT
| I_RIGHT
| I_NIL
| I_MAP
| I_ITER
| I_EMPTY_SET
| I_DIP
| I_LOOP
| I_LOOP_LEFT
| I_CONTRACT ) as name ),
(([] | _ :: _ :: _) as l),
_ ),
_ ) ->
fail (Invalid_arity (loc, name, 1, List.length l))
| ( Prim
( loc,
( (I_PUSH | I_IF_NONE | I_IF_LEFT | I_IF_CONS | I_EMPTY_MAP | I_IF)
as name ),
(([] | [_] | _ :: _ :: _ :: _) as l),
_ ),
_ ) ->
fail (Invalid_arity (loc, name, 2, List.length l))
| (Prim (loc, I_LAMBDA, (([] | [_] | _ :: _ :: _ :: _ :: _) as l), _), _) ->
fail (Invalid_arity (loc, I_LAMBDA, 3, List.length l))
(* Stack errors *)
| ( Prim
( loc,
( ( I_ADD
| I_SUB
| I_MUL
| I_EDIV
| I_AND
| I_OR
| I_XOR
| I_LSL
| I_LSR ) as name ),
[],
_ ),
Item_t (ta, Item_t (tb, _, _), _) ) ->
Lwt.return @@ serialize_ty_for_error ctxt ta
>>=? fun (ta, ctxt) ->
Lwt.return @@ serialize_ty_for_error ctxt tb
>>=? fun (tb, _ctxt) -> fail (Undefined_binop (loc, name, ta, tb))
| ( Prim
( loc,
( ( I_NEG
| I_ABS
| I_NOT
| I_CONCAT
| I_SIZE
| I_EQ
| I_NEQ
| I_LT
| I_GT
| I_LE
| I_GE ) as name ),
[],
_ ),
Item_t (t, _, _) ) ->
Lwt.return @@ serialize_ty_for_error ctxt t
>>=? fun (t, _ctxt) -> fail (Undefined_unop (loc, name, t))
| (Prim (loc, ((I_UPDATE | I_SLICE) as name), [], _), stack) ->
serialize_stack_for_error ctxt stack
>>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 3, stack))
| (Prim (loc, I_CREATE_CONTRACT, _, _), stack) ->
serialize_stack_for_error ctxt stack
>>=? fun (stack, _ctxt) ->
fail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack))
| (Prim (loc, I_CREATE_ACCOUNT, [], _), stack) ->
serialize_stack_for_error ctxt stack
>>=? fun (stack, _ctxt) ->
fail (Bad_stack (loc, I_CREATE_ACCOUNT, 4, stack))
| (Prim (loc, I_TRANSFER_TOKENS, [], _), stack) ->
serialize_stack_for_error ctxt stack
>>=? fun (stack, _ctxt) ->
fail (Bad_stack (loc, I_TRANSFER_TOKENS, 4, stack))
| ( Prim
( loc,
( ( I_DROP
| I_DUP
| I_CAR
| I_CDR
| I_SOME
| I_BLAKE2B
| I_SHA256
| I_SHA512
| I_DIP
| I_IF_NONE
| I_LEFT
| I_RIGHT
| I_IF_LEFT
| I_IF
| I_LOOP
| I_IF_CONS
| I_IMPLICIT_ACCOUNT
| I_NEG
| I_ABS
| I_INT
| I_NOT
| I_HASH_KEY
| I_EQ
| I_NEQ
| I_LT
| I_GT
| I_LE
| I_GE ) as name ),
_,
_ ),
stack ) ->
serialize_stack_for_error ctxt stack
>>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 1, stack))
| ( Prim
( loc,
( ( I_SWAP
| I_PAIR
| I_CONS
| I_GET
| I_MEM
| I_EXEC
| I_CHECK_SIGNATURE
| I_ADD
| I_SUB
| I_MUL
| I_EDIV
| I_AND
| I_OR
| I_XOR
| I_LSL
| I_LSR ) as name ),
_,
_ ),
stack ) ->
serialize_stack_for_error ctxt stack
>>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 2, stack))
(* Generic parsing errors *)
| (expr, _) ->
fail
@@ unexpected
expr
[Seq_kind]
Instr_namespace
[ I_DROP;
I_DUP;
I_DIG;
I_DUG;
I_SWAP;
I_SOME;
I_UNIT;
I_PAIR;
I_CAR;
I_CDR;
I_CONS;
I_MEM;
I_UPDATE;
I_MAP;
I_ITER;
I_GET;
I_EXEC;
I_FAILWITH;
I_SIZE;
I_CONCAT;
I_ADD;
I_SUB;
I_MUL;
I_EDIV;
I_OR;
I_AND;
I_XOR;
I_NOT;
I_ABS;
I_INT;
I_NEG;
I_LSL;
I_LSR;
I_COMPARE;
I_EQ;
I_NEQ;
I_LT;
I_GT;
I_LE;
I_GE;
I_TRANSFER_TOKENS;
I_CREATE_ACCOUNT;
I_CREATE_CONTRACT;
I_NOW;
I_AMOUNT;
I_BALANCE;
I_IMPLICIT_ACCOUNT;
I_CHECK_SIGNATURE;
I_BLAKE2B;
I_SHA256;
I_SHA512;
I_HASH_KEY;
I_STEPS_TO_QUOTA;
I_PUSH;
I_NONE;
I_LEFT;
I_RIGHT;
I_NIL;
I_EMPTY_SET;
I_DIP;
I_LOOP;
I_IF_NONE;
I_IF_LEFT;
I_IF_CONS;
I_EMPTY_MAP;
I_IF;
I_SOURCE;
I_SENDER;
I_SELF;
I_LAMBDA ]
and parse_contract :
type arg.
legacy:bool ->
context ->
Script.location ->
arg ty ->
Contract.t ->
entrypoint:string ->
(context * arg typed_contract) tzresult Lwt.t =
fun ~legacy ctxt loc arg contract ~entrypoint ->
Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists
>>=? fun ctxt ->
Contract.exists ctxt contract
>>=? function
| false ->
fail (Invalid_contract (loc, contract))
| true -> (
Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script
>>=? fun ctxt ->
trace (Invalid_contract (loc, contract))
@@ Contract.get_script_code ctxt contract
>>=? fun (ctxt, code) ->
match code with
| None ->
Lwt.return
( ty_eq ctxt arg (Unit_t None)
>>? fun (Eq, ctxt) ->
match entrypoint with
| "default" ->
let contract : arg typed_contract =
(arg, (contract, entrypoint))
in
ok (ctxt, contract)
| entrypoint ->
error (No_such_entrypoint entrypoint) )
| Some code ->
Script.force_decode ctxt code
>>=? fun (code, ctxt) ->
Lwt.return
( parse_toplevel ~legacy:true code
>>? fun (arg_type, _, _, root_name) ->
parse_parameter_ty ctxt ~legacy:true arg_type
>>? fun (Ex_ty targ, ctxt) ->
let return ctxt targ entrypoint =
merge_types ~legacy ctxt loc targ arg
>>? fun (arg, ctxt) ->
let contract : arg typed_contract =
(arg, (contract, entrypoint))
in
ok (ctxt, contract)
in
find_entrypoint_for_type
~full:targ
~expected:arg
~root_name
entrypoint
ctxt
>>? fun (ctxt, entrypoint, targ) ->
merge_types ~legacy ctxt loc targ arg
>>? fun (targ, ctxt) -> return ctxt targ entrypoint ) )
(* Same as the one above, but does not fail when the contact is missing or
if the expected type doesn't match the actual one. In that case None is
returned and some overapproximation of the typechecking gas is consumed.
This can still fail on gas exhaustion. *)
and parse_contract_for_script :
type arg.
legacy:bool ->
context ->
Script.location ->
arg ty ->
Contract.t ->
entrypoint:string ->
(context * arg typed_contract option) tzresult Lwt.t =
fun ~legacy ctxt loc arg contract ~entrypoint ->
Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists
>>=? fun ctxt ->
Contract.exists ctxt contract
>>=? function
| false ->
return (ctxt, None)
| true -> (
Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script
>>=? fun ctxt ->
trace (Invalid_contract (loc, contract))
@@ Contract.get_script_code ctxt contract
>>=? fun (ctxt, code) ->
match code with
(* can only fail because of gas *)
| None -> (
match entrypoint with
| "default" ->
Lwt.return
( match ty_eq ctxt arg (Unit_t None) with
| Ok (Eq, ctxt) ->
let contract : arg typed_contract =
(arg, (contract, entrypoint))
in
ok (ctxt, Some contract)
| Error _ ->
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt -> ok (ctxt, None) )
| _ ->
return (ctxt, None) )
| Some code ->
Script.force_decode ctxt code
>>=? fun (code, ctxt) ->
(* can only fail because of gas *)
Lwt.return
( match parse_toplevel ~legacy:true code with
| Error _ ->
error (Invalid_contract (loc, contract))
| Ok (arg_type, _, _, root_name) -> (
match parse_parameter_ty ctxt ~legacy:true arg_type with
| Error _ ->
error (Invalid_contract (loc, contract))
| Ok (Ex_ty targ, ctxt) -> (
match
find_entrypoint_for_type
~full:targ
~expected:arg
~root_name
entrypoint
ctxt
>>? fun (ctxt, entrypoint, targ) ->
merge_types ~legacy ctxt loc targ arg
>>? fun (targ, ctxt) ->
merge_types ~legacy ctxt loc targ arg
>>? fun (arg, ctxt) ->
let contract : arg typed_contract =
(arg, (contract, entrypoint))
in
ok (ctxt, Some contract)
with
| Ok res ->
ok res
| Error _ ->
(* overapproximation by checking if targ = targ,
can only fail because of gas *)
ty_eq ctxt targ targ
>>? fun (Eq, ctxt) ->
merge_types ~legacy ctxt loc targ targ
>>? fun (_, ctxt) -> ok (ctxt, None) ) ) ) )
and parse_toplevel :
legacy:bool ->
Script.expr ->
(Script.node * Script.node * Script.node * string option) tzresult =
fun ~legacy toplevel ->
record_trace (Ill_typed_contract (toplevel, []))
@@
match root toplevel with
| Int (loc, _) ->
error (Invalid_kind (loc, [Seq_kind], Int_kind))
| String (loc, _) ->
error (Invalid_kind (loc, [Seq_kind], String_kind))
| Bytes (loc, _) ->
error (Invalid_kind (loc, [Seq_kind], Bytes_kind))
| Prim (loc, _, _, _) ->
error (Invalid_kind (loc, [Seq_kind], Prim_kind))
| Seq (_, fields) -> (
let rec find_fields p s c fields =
match fields with
| [] ->
ok (p, s, c)
| Int (loc, _) :: _ ->
error (Invalid_kind (loc, [Prim_kind], Int_kind))
| String (loc, _) :: _ ->
error (Invalid_kind (loc, [Prim_kind], String_kind))
| Bytes (loc, _) :: _ ->
error (Invalid_kind (loc, [Prim_kind], Bytes_kind))
| Seq (loc, _) :: _ ->
error (Invalid_kind (loc, [Prim_kind], Seq_kind))
| Prim (loc, K_parameter, [arg], annot) :: rest -> (
match p with
| None ->
find_fields (Some (arg, loc, annot)) s c rest
| Some _ ->
error (Duplicate_field (loc, K_parameter)) )
| Prim (loc, K_storage, [arg], annot) :: rest -> (
match s with
| None ->
find_fields p (Some (arg, loc, annot)) c rest
| Some _ ->
error (Duplicate_field (loc, K_storage)) )
| Prim (loc, K_code, [arg], annot) :: rest -> (
match c with
| None ->
find_fields p s (Some (arg, loc, annot)) rest
| Some _ ->
error (Duplicate_field (loc, K_code)) )
| Prim (loc, ((K_parameter | K_storage | K_code) as name), args, _)
:: _ ->
error (Invalid_arity (loc, name, 1, List.length args))
| Prim (loc, name, _, _) :: _ ->
let allowed = [K_parameter; K_storage; K_code] in
error (Invalid_primitive (loc, allowed, name))
in
find_fields None None None fields
>>? function
| (None, _, _) ->
error (Missing_field K_parameter)
| (Some _, None, _) ->
error (Missing_field K_storage)
| (Some _, Some _, None) ->
error (Missing_field K_code)
| (Some (p, ploc, pannot), Some (s, sloc, sannot), Some (c, cloc, carrot))
->
let maybe_root_name =
(* root name can be attached to either the parameter
primitive or the toplevel constructor *)
Script_ir_annot.extract_field_annot p
>>? fun (p, root_name) ->
match root_name with
| Some (`Field_annot root_name) ->
ok (p, pannot, Some root_name)
| None -> (
match pannot with
| [single]
when Compare.Int.(String.length single > 0)
&& Compare.Char.(single.[0] = '%') ->
ok
( p,
[],
Some (String.sub single 1 (String.length single - 1)) )
| _ ->
ok (p, pannot, None) )
in
if legacy then
(* legacy semantics ignores spurious annotations *)
let (p, root_name) =
match maybe_root_name with
| Ok (p, _, root_name) ->
(p, root_name)
| Error _ ->
(p, None)
in
ok (p, s, c, root_name)
else
(* only one field annot is allowed to set the root entrypoint name *)
maybe_root_name
>>? fun (p, pannot, root_name) ->
Script_ir_annot.error_unexpected_annot ploc pannot
>>? fun () ->
Script_ir_annot.error_unexpected_annot cloc carrot
>>? fun () ->
Script_ir_annot.error_unexpected_annot sloc sannot
>>? fun () -> ok (p, s, c, root_name) )
let parse_script :
?type_logger:type_logger ->
context ->
legacy:bool ->
Script.t ->
(ex_script * context) tzresult Lwt.t =
fun ?type_logger ctxt ~legacy {code; storage} ->
Script.force_decode ctxt code
>>=? fun (code, ctxt) ->
Script.force_decode ctxt storage
>>=? fun (storage, ctxt) ->
Lwt.return @@ parse_toplevel ~legacy code
>>=? fun (arg_type, storage_type, code_field, root_name) ->
trace
(Ill_formed_type (Some "parameter", code, location arg_type))
(Lwt.return (parse_parameter_ty ctxt ~legacy arg_type))
>>=? fun (Ex_ty arg_type, ctxt) ->
( if legacy then return ()
else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
>>=? fun () ->
trace
(Ill_formed_type (Some "storage", code, location storage_type))
(Lwt.return (parse_storage_ty ctxt ~legacy storage_type))
>>=? fun (Ex_ty storage_type, ctxt) ->
let arg_annot =
default_annot
(type_to_var_annot (name_of_ty arg_type))
~default:default_param_annot
in
let storage_annot =
default_annot
(type_to_var_annot (name_of_ty storage_type))
~default:default_storage_annot
in
let arg_type_full =
Pair_t
( (arg_type, None, arg_annot),
(storage_type, None, storage_annot),
None,
has_big_map arg_type || has_big_map storage_type )
in
let ret_type_full =
Pair_t
( (List_t (Operation_t None, None, false), None, None),
(storage_type, None, None),
None,
has_big_map storage_type )
in
trace_eval
(fun () ->
Lwt.return @@ serialize_ty_for_error ctxt storage_type
>>|? fun (storage_type, _ctxt) ->
Ill_typed_data (None, storage, storage_type))
(parse_data ?type_logger ctxt ~legacy storage_type (root storage))
>>=? fun (storage, ctxt) ->
trace
(Ill_typed_contract (code, []))
(parse_returning
(Toplevel
{
storage_type;
param_type = arg_type;
root_name;
legacy_create_contract_literal = false;
})
ctxt
~legacy
?type_logger
(arg_type_full, None)
ret_type_full
code_field)
>>=? fun (code, ctxt) ->
return (Ex_script {code; arg_type; storage; storage_type; root_name}, ctxt)
let typecheck_code :
context -> Script.expr -> (type_map * context) tzresult Lwt.t =
fun ctxt code ->
let legacy = false in
Lwt.return @@ parse_toplevel ~legacy code
>>=? fun (arg_type, storage_type, code_field, root_name) ->
let type_map = ref [] in
trace
(Ill_formed_type (Some "parameter", code, location arg_type))
(Lwt.return (parse_parameter_ty ctxt ~legacy arg_type))
>>=? fun (Ex_ty arg_type, ctxt) ->
( if legacy then return ()
else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
>>=? fun () ->
trace
(Ill_formed_type (Some "storage", code, location storage_type))
(Lwt.return (parse_storage_ty ctxt ~legacy storage_type))
>>=? fun (Ex_ty storage_type, ctxt) ->
let arg_annot =
default_annot
(type_to_var_annot (name_of_ty arg_type))
~default:default_param_annot
in
let storage_annot =
default_annot
(type_to_var_annot (name_of_ty storage_type))
~default:default_storage_annot
in
let arg_type_full =
Pair_t
( (arg_type, None, arg_annot),
(storage_type, None, storage_annot),
None,
has_big_map arg_type || has_big_map storage_type )
in
let ret_type_full =
Pair_t
( (List_t (Operation_t None, None, false), None, None),
(storage_type, None, None),
None,
has_big_map storage_type )
in
let result =
parse_returning
(Toplevel
{
storage_type;
param_type = arg_type;
root_name;
legacy_create_contract_literal = false;
})
ctxt
~legacy
~type_logger:(fun loc bef aft ->
type_map := (loc, (bef, aft)) :: !type_map)
(arg_type_full, None)
ret_type_full
code_field
in
trace (Ill_typed_contract (code, !type_map)) result
>>=? fun (Lam _, ctxt) -> return (!type_map, ctxt)
let typecheck_data :
?type_logger:type_logger ->
context ->
Script.expr * Script.expr ->
context tzresult Lwt.t =
fun ?type_logger ctxt (data, exp_ty) ->
let legacy = false in
trace
(Ill_formed_type (None, exp_ty, 0))
(Lwt.return @@ parse_packable_ty ctxt ~legacy (root exp_ty))
>>=? fun (Ex_ty exp_ty, ctxt) ->
trace_eval
(fun () ->
Lwt.return @@ serialize_ty_for_error ctxt exp_ty
>>|? fun (exp_ty, _ctxt) -> Ill_typed_data (None, data, exp_ty))
(parse_data ?type_logger ctxt ~legacy exp_ty (root data))
>>=? fun (_, ctxt) -> return ctxt
module Entrypoints_map = Map.Make (String)
let list_entrypoints (type full) (full : full ty) ctxt ~root_name =
let merge path annot (type t) (ty : t ty) reachable
((unreachables, all) as acc) =
match annot with
| None | Some (`Field_annot "") -> (
ok
@@
if reachable then acc
else
match ty with
| Union_t _ ->
acc
| _ ->
(List.rev path :: unreachables, all) )
| Some (`Field_annot name) ->
if Compare.Int.(String.length name > 31) then
ok (List.rev path :: unreachables, all)
else if Entrypoints_map.mem name all then
ok (List.rev path :: unreachables, all)
else
unparse_ty_no_lwt ctxt ty
>>? fun (unparsed_ty, _) ->
ok
( unreachables,
Entrypoints_map.add name (List.rev path, unparsed_ty) all )
in
let rec fold_tree :
type t.
t ty ->
prim list ->
bool ->
prim list list * (prim list * Script.node) Entrypoints_map.t ->
(prim list list * (prim list * Script.node) Entrypoints_map.t) tzresult =
fun t path reachable acc ->
match t with
| Union_t ((tl, al), (tr, ar), _, _) ->
merge (D_Left :: path) al tl reachable acc
>>? fun acc ->
merge (D_Right :: path) ar tr reachable acc
>>? fun acc ->
fold_tree
tl
(D_Left :: path)
(match al with Some _ -> true | None -> reachable)
acc
>>? fun acc ->
fold_tree
tr
(D_Right :: path)
(match ar with Some _ -> true | None -> reachable)
acc
| _ ->
ok acc
in
unparse_ty_no_lwt ctxt full
>>? fun (unparsed_full, _) ->
let (init, reachable) =
match root_name with
| None | Some "" ->
(Entrypoints_map.empty, false)
| Some name ->
(Entrypoints_map.singleton name ([], unparsed_full), true)
in
fold_tree full [] reachable ([], init)
(* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*)
let rec unparse_data :
type a.
context ->
unparsing_mode ->
a ty ->
a ->
(Script.node * context) tzresult Lwt.t =
fun ctxt mode ty a ->
Lwt.return (Gas.consume ctxt Unparse_costs.cycle)
>>=? fun ctxt ->
match (ty, a) with
| (Unit_t _, ()) ->
Lwt.return (Gas.consume ctxt Unparse_costs.unit)
>>=? fun ctxt -> return (Prim (-1, D_Unit, [], []), ctxt)
| (Int_t _, v) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.int v))
>>=? fun ctxt -> return (Int (-1, Script_int.to_zint v), ctxt)
| (Nat_t _, v) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.int v))
>>=? fun ctxt -> return (Int (-1, Script_int.to_zint v), ctxt)
| (String_t _, s) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.string s))
>>=? fun ctxt -> return (String (-1, s), ctxt)
| (Bytes_t _, s) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s))
>>=? fun ctxt -> return (Bytes (-1, s), ctxt)
| (Bool_t _, true) ->
Lwt.return (Gas.consume ctxt Unparse_costs.bool)
>>=? fun ctxt -> return (Prim (-1, D_True, [], []), ctxt)
| (Bool_t _, false) ->
Lwt.return (Gas.consume ctxt Unparse_costs.bool)
>>=? fun ctxt -> return (Prim (-1, D_False, [], []), ctxt)
| (Timestamp_t _, t) -> (
Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t))
>>=? fun ctxt ->
match mode with
| Optimized ->
return (Int (-1, Script_timestamp.to_zint t), ctxt)
| Readable -> (
match Script_timestamp.to_notation t with
| None ->
return (Int (-1, Script_timestamp.to_zint t), ctxt)
| Some s ->
return (String (-1, s), ctxt) ) )
| (Address_t _, (c, entrypoint)) -> (
Lwt.return (Gas.consume ctxt Unparse_costs.contract)
>>=? fun ctxt ->
match mode with
| Optimized ->
let entrypoint =
match entrypoint with "default" -> "" | name -> name
in
let bytes =
Data_encoding.Binary.to_bytes_exn
Data_encoding.(tup2 Contract.encoding Variable.string)
(c, entrypoint)
in
return (Bytes (-1, bytes), ctxt)
| Readable ->
let notation =
match entrypoint with
| "default" ->
Contract.to_b58check c
| entrypoint ->
Contract.to_b58check c ^ "%" ^ entrypoint
in
return (String (-1, notation), ctxt) )
| (Contract_t _, (_, (c, entrypoint))) -> (
Lwt.return (Gas.consume ctxt Unparse_costs.contract)
>>=? fun ctxt ->
match mode with
| Optimized ->
let entrypoint =
match entrypoint with "default" -> "" | name -> name
in
let bytes =
Data_encoding.Binary.to_bytes_exn
Data_encoding.(tup2 Contract.encoding Variable.string)
(c, entrypoint)
in
return (Bytes (-1, bytes), ctxt)
| Readable ->
let notation =
match entrypoint with
| "default" ->
Contract.to_b58check c
| entrypoint ->
Contract.to_b58check c ^ "%" ^ entrypoint
in
return (String (-1, notation), ctxt) )
| (Signature_t _, s) -> (
Lwt.return (Gas.consume ctxt Unparse_costs.signature)
>>=? fun ctxt ->
match mode with
| Optimized ->
let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in
return (Bytes (-1, bytes), ctxt)
| Readable ->
return (String (-1, Signature.to_b58check s), ctxt) )
| (Mutez_t _, v) ->
Lwt.return (Gas.consume ctxt Unparse_costs.tez)
>>=? fun ctxt -> return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt)
| (Key_t _, k) -> (
Lwt.return (Gas.consume ctxt Unparse_costs.key)
>>=? fun ctxt ->
match mode with
| Optimized ->
let bytes =
Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k
in
return (Bytes (-1, bytes), ctxt)
| Readable ->
return (String (-1, Signature.Public_key.to_b58check k), ctxt) )
| (Key_hash_t _, k) -> (
Lwt.return (Gas.consume ctxt Unparse_costs.key_hash)
>>=? fun ctxt ->
match mode with
| Optimized ->
let bytes =
Data_encoding.Binary.to_bytes_exn
Signature.Public_key_hash.encoding
k
in
return (Bytes (-1, bytes), ctxt)
| Readable ->
return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) )
| (Operation_t _, (op, _big_map_diff)) ->
let bytes =
Data_encoding.Binary.to_bytes_exn
Operation.internal_operation_encoding
op
in
Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes))
>>=? fun ctxt -> return (Bytes (-1, bytes), ctxt)
| (Chain_id_t _, chain_id) ->
let bytes =
Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id
in
Lwt.return (Gas.consume ctxt (Unparse_costs.chain_id bytes))
>>=? fun ctxt -> return (Bytes (-1, bytes), ctxt)
| (Pair_t ((tl, _, _), (tr, _, _), _, _), (l, r)) ->
Lwt.return (Gas.consume ctxt Unparse_costs.pair)
>>=? fun ctxt ->
unparse_data ctxt mode tl l
>>=? fun (l, ctxt) ->
unparse_data ctxt mode tr r
>>=? fun (r, ctxt) -> return (Prim (-1, D_Pair, [l; r], []), ctxt)
| (Union_t ((tl, _), _, _, _), L l) ->
Lwt.return (Gas.consume ctxt Unparse_costs.union)
>>=? fun ctxt ->
unparse_data ctxt mode tl l
>>=? fun (l, ctxt) -> return (Prim (-1, D_Left, [l], []), ctxt)
| (Union_t (_, (tr, _), _, _), R r) ->
Lwt.return (Gas.consume ctxt Unparse_costs.union)
>>=? fun ctxt ->
unparse_data ctxt mode tr r
>>=? fun (r, ctxt) -> return (Prim (-1, D_Right, [r], []), ctxt)
| (Option_t (t, _, _), Some v) ->
Lwt.return (Gas.consume ctxt Unparse_costs.some)
>>=? fun ctxt ->
unparse_data ctxt mode t v
>>=? fun (v, ctxt) -> return (Prim (-1, D_Some, [v], []), ctxt)
| (Option_t _, None) ->
Lwt.return (Gas.consume ctxt Unparse_costs.none)
>>=? fun ctxt -> return (Prim (-1, D_None, [], []), ctxt)
| (List_t (t, _, _), items) ->
fold_left_s
(fun (l, ctxt) element ->
Lwt.return (Gas.consume ctxt Unparse_costs.list_element)
>>=? fun ctxt ->
unparse_data ctxt mode t element
>>=? fun (unparsed, ctxt) -> return (unparsed :: l, ctxt))
([], ctxt)
items
>>=? fun (items, ctxt) ->
return (Micheline.Seq (-1, List.rev items), ctxt)
| (Set_t (t, _), set) ->
let t = ty_of_comparable_ty t in
fold_left_s
(fun (l, ctxt) item ->
Lwt.return (Gas.consume ctxt Unparse_costs.set_element)
>>=? fun ctxt ->
unparse_data ctxt mode t item
>>=? fun (item, ctxt) -> return (item :: l, ctxt))
([], ctxt)
(set_fold (fun e acc -> e :: acc) set [])
>>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
| (Map_t (kt, vt, _, _), map) ->
let kt = ty_of_comparable_ty kt in
fold_left_s
(fun (l, ctxt) (k, v) ->
Lwt.return (Gas.consume ctxt Unparse_costs.map_element)
>>=? fun ctxt ->
unparse_data ctxt mode kt k
>>=? fun (key, ctxt) ->
unparse_data ctxt mode vt v
>>=? fun (value, ctxt) ->
return (Prim (-1, D_Elt, [key; value], []) :: l, ctxt))
([], ctxt)
(map_fold (fun k v acc -> (k, v) :: acc) map [])
>>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
| (Big_map_t (kt, vt, _), {id = None; diff = (module Diff); _}) ->
(* this branch is to allow roundtrip of big map literals *)
let kt = ty_of_comparable_ty kt in
fold_left_s
(fun (l, ctxt) (k, v) ->
Lwt.return (Gas.consume ctxt Unparse_costs.map_element)
>>=? fun ctxt ->
unparse_data ctxt mode kt k
>>=? fun (key, ctxt) ->
unparse_data ctxt mode vt v
>>=? fun (value, ctxt) ->
return (Prim (-1, D_Elt, [key; value], []) :: l, ctxt))
([], ctxt)
(Diff.OPS.fold
(fun k v acc ->
match v with None -> acc | Some v -> (k, v) :: acc)
(fst Diff.boxed)
[])
>>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
| (Big_map_t (_kt, _kv, _), {id = Some id; diff = (module Diff); _}) ->
if Compare.Int.(Diff.OPS.cardinal (fst Diff.boxed) = 0) then
return (Micheline.Int (-1, id), ctxt)
else
(* this can only be the result of an execution and the map
must have been flushed at this point *)
assert false
| (Lambda_t _, Lam (_, original_code)) ->
unparse_code ctxt mode original_code
(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
and unparse_code ctxt mode =
let legacy = true in
function
| Prim (loc, I_PUSH, [ty; data], annot) ->
Lwt.return (parse_packable_ty ctxt ~legacy ty)
>>=? fun (Ex_ty t, ctxt) ->
parse_data ctxt ~legacy t data
>>=? fun (data, ctxt) ->
unparse_data ctxt mode t data
>>=? fun (data, ctxt) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot))
>>=? fun ctxt -> return (Prim (loc, I_PUSH, [ty; data], annot), ctxt)
| Seq (loc, items) ->
fold_left_s
(fun (l, ctxt) item ->
unparse_code ctxt mode item
>>=? fun (item, ctxt) -> return (item :: l, ctxt))
([], ctxt)
items
>>=? fun (items, ctxt) ->
Lwt.return
(Gas.consume ctxt (Unparse_costs.seq_cost (List.length items)))
>>=? fun ctxt -> return (Micheline.Seq (loc, List.rev items), ctxt)
| Prim (loc, prim, items, annot) ->
fold_left_s
(fun (l, ctxt) item ->
unparse_code ctxt mode item
>>=? fun (item, ctxt) -> return (item :: l, ctxt))
([], ctxt)
items
>>=? fun (items, ctxt) ->
Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot))
>>=? fun ctxt -> return (Prim (loc, prim, List.rev items, annot), ctxt)
| (Int _ | String _ | Bytes _) as atom ->
return (atom, ctxt)
(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
let unparse_script ctxt mode {code; arg_type; storage; storage_type; root_name}
=
let (Lam (_, original_code)) = code in
unparse_code ctxt mode original_code
>>=? fun (code, ctxt) ->
unparse_data ctxt mode storage_type storage
>>=? fun (storage, ctxt) ->
unparse_ty ctxt arg_type
>>=? fun (arg_type, ctxt) ->
unparse_ty ctxt storage_type
>>=? fun (storage_type, ctxt) ->
let arg_type =
add_field_annot
(Option.map ~f:(fun n -> `Field_annot n) root_name)
None
arg_type
in
let open Micheline in
let code =
Seq
( -1,
[ Prim (-1, K_parameter, [arg_type], []);
Prim (-1, K_storage, [storage_type], []);
Prim (-1, K_code, [code], []) ] )
in
Lwt.return
( Gas.consume ctxt (Unparse_costs.seq_cost 3)
>>? fun ctxt ->
Gas.consume ctxt (Unparse_costs.prim_cost 1 [])
>>? fun ctxt ->
Gas.consume ctxt (Unparse_costs.prim_cost 1 [])
>>? fun ctxt -> Gas.consume ctxt (Unparse_costs.prim_cost 1 []) )
>>=? fun ctxt ->
return
( {
code = lazy_expr (strip_locations code);
storage = lazy_expr (strip_locations storage);
},
ctxt )
let pack_data ctxt typ data =
unparse_data ctxt Optimized typ data
>>=? fun (unparsed, ctxt) ->
let bytes =
Data_encoding.Binary.to_bytes_exn
expr_encoding
(Micheline.strip_locations unparsed)
in
Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes)
>>=? fun ctxt ->
let bytes = MBytes.concat "" [MBytes.of_string "\005"; bytes] in
Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes)
>>=? fun ctxt -> return (bytes, ctxt)
let hash_data ctxt typ data =
pack_data ctxt typ data
>>=? fun (bytes, ctxt) ->
Lwt.return
@@ Gas.consume
ctxt
(Michelson_v1_gas.Cost_of.Legacy.hash bytes Script_expr_hash.size)
>>=? fun ctxt -> return (Script_expr_hash.(hash_bytes [bytes]), ctxt)
(* ---------------- Big map -------------------------------------------------*)
let empty_big_map tk tv =
{
id = None;
diff = empty_map tk;
key_type = ty_of_comparable_ty tk;
value_type = tv;
}
let big_map_mem ctxt key {id; diff; key_type; _} =
match (map_get key diff, id) with
| (None, None) ->
return (false, ctxt)
| (None, Some id) ->
hash_data ctxt key_type key
>>=? fun (hash, ctxt) ->
Alpha_context.Big_map.mem ctxt id hash
>>=? fun (ctxt, res) -> return (res, ctxt)
| (Some None, _) ->
return (false, ctxt)
| (Some (Some _), _) ->
return (true, ctxt)
let big_map_get ctxt key {id; diff; key_type; value_type} =
match (map_get key diff, id) with
| (Some x, _) ->
return (x, ctxt)
| (None, None) ->
return (None, ctxt)
| (None, Some id) -> (
hash_data ctxt key_type key
>>=? fun (hash, ctxt) ->
Alpha_context.Big_map.get_opt ctxt id hash
>>=? function
| (ctxt, None) ->
return (None, ctxt)
| (ctxt, Some value) ->
parse_data ctxt ~legacy:true value_type (Micheline.root value)
>>=? fun (x, ctxt) -> return (Some x, ctxt) )
let big_map_update key value ({diff; _} as map) =
{map with diff = map_set key value diff}
module Ids = Set.Make (Compare.Z)
type big_map_ids = Ids.t
let no_big_map_id = Ids.empty
let diff_of_big_map ctxt fresh mode ~ids {id; key_type; value_type; diff} =
Lwt.return
(Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list diff))
>>=? fun ctxt ->
( match id with
| Some id ->
if Ids.mem id ids then
fresh ctxt
>>=? fun (ctxt, duplicate) ->
return (ctxt, [Contract.Copy (id, duplicate)], duplicate)
else
(* The first occurence encountered of a big_map reuses the
ID. This way, the payer is only charged for the diff.
For this to work, this diff has to be put at the end of
the global diff, otherwise the duplicates will use the
updated version as a base. This is true because we add
this diff first in the accumulator of
`extract_big_map_updates`, and this accumulator is not
reversed before being flattened. *)
return (ctxt, [], id)
| None ->
fresh ctxt
>>=? fun (ctxt, id) ->
unparse_ty ctxt key_type
>>=? fun (kt, ctxt) ->
unparse_ty ctxt value_type
>>=? fun (kv, ctxt) ->
return
( ctxt,
[ Contract.Alloc
{
big_map = id;
key_type = Micheline.strip_locations kt;
value_type = Micheline.strip_locations kv;
} ],
id ) )
>>=? fun (ctxt, init, big_map) ->
let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in
fold_left_s
(fun (acc, ctxt) (key, value) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
hash_data ctxt key_type key
>>=? fun (diff_key_hash, ctxt) ->
unparse_data ctxt mode key_type key
>>=? fun (key_node, ctxt) ->
let diff_key = Micheline.strip_locations key_node in
( match value with
| None ->
return (None, ctxt)
| Some x ->
unparse_data ctxt mode value_type x
>>=? fun (node, ctxt) ->
return (Some (Micheline.strip_locations node), ctxt) )
>>=? fun (diff_value, ctxt) ->
let diff_item =
Contract.Update {big_map; diff_key; diff_key_hash; diff_value}
in
return (diff_item :: acc, ctxt))
([], ctxt)
pairs
>>=? fun (diff, ctxt) -> return (init @ diff, big_map, ctxt)
let rec extract_big_map_updates :
type a.
context ->
(context -> (context * Big_map.id) tzresult Lwt.t) ->
unparsing_mode ->
Ids.t ->
Contract.big_map_diff list ->
a ty ->
a ->
(context * a * Ids.t * Contract.big_map_diff list) tzresult Lwt.t =
fun ctxt fresh mode ids acc ty x ->
match (ty, x) with
| (Big_map_t (_, _, _), map) ->
diff_of_big_map ctxt fresh mode ids map
>>=? fun (diff, id, ctxt) ->
let (module Map) = map.diff in
let map = {map with diff = empty_map Map.key_ty; id = Some id} in
return (ctxt, map, Ids.add id ids, diff :: acc)
| (Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr)) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
extract_big_map_updates ctxt fresh mode ids acc tyl xl
>>=? fun (ctxt, xl, ids, acc) ->
extract_big_map_updates ctxt fresh mode ids acc tyr xr
>>=? fun (ctxt, xr, ids, acc) -> return (ctxt, (xl, xr), ids, acc)
| (Union_t ((ty, _), (_, _), _, true), L x) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
extract_big_map_updates ctxt fresh mode ids acc ty x
>>=? fun (ctxt, x, ids, acc) -> return (ctxt, L x, ids, acc)
| (Union_t ((_, _), (ty, _), _, true), R x) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
extract_big_map_updates ctxt fresh mode ids acc ty x
>>=? fun (ctxt, x, ids, acc) -> return (ctxt, R x, ids, acc)
| (Option_t (ty, _, true), Some x) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
extract_big_map_updates ctxt fresh mode ids acc ty x
>>=? fun (ctxt, x, ids, acc) -> return (ctxt, Some x, ids, acc)
| (List_t (ty, _, true), l) ->
fold_left_s
(fun (ctxt, l, ids, acc) x ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
extract_big_map_updates ctxt fresh mode ids acc ty x
>>=? fun (ctxt, x, ids, acc) -> return (ctxt, x :: l, ids, acc))
(ctxt, [], ids, acc)
l
>>=? fun (ctxt, l, ids, acc) -> return (ctxt, List.rev l, ids, acc)
| (Map_t (_, ty, _, true), ((module M) as m)) ->
Lwt.return
(Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list m))
>>=? fun ctxt ->
fold_left_s
(fun (ctxt, m, ids, acc) (k, x) ->
Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
>>=? fun ctxt ->
extract_big_map_updates ctxt fresh mode ids acc ty x
>>=? fun (ctxt, x, ids, acc) ->
return (ctxt, M.OPS.add k x m, ids, acc))
(ctxt, M.OPS.empty, ids, acc)
(M.OPS.bindings (fst M.boxed))
>>=? fun (ctxt, m, ids, acc) ->
let module M = struct
module OPS = M.OPS
type key = M.key
type value = M.value
let key_ty = M.key_ty
let boxed = (m, snd M.boxed)
end in
return
( ctxt,
(module M : Boxed_map with type key = M.key and type value = M.value),
ids,
acc )
| (Option_t (_, _, true), None) ->
return (ctxt, None, ids, acc)
| (List_t (_, _, false), v) ->
return (ctxt, v, ids, acc)
| (Map_t (_, _, _, false), v) ->
return (ctxt, v, ids, acc)
| (Option_t (_, _, false), None) ->
return (ctxt, None, ids, acc)
| (Pair_t (_, _, _, false), v) ->
return (ctxt, v, ids, acc)
| (Union_t (_, _, _, false), v) ->
return (ctxt, v, ids, acc)
| (Option_t (_, _, false), v) ->
return (ctxt, v, ids, acc)
| (Chain_id_t _, v) ->
return (ctxt, v, ids, acc)
| (Set_t (_, _), v) ->
return (ctxt, v, ids, acc)
| (Unit_t _, v) ->
return (ctxt, v, ids, acc)
| (Int_t _, v) ->
return (ctxt, v, ids, acc)
| (Nat_t _, v) ->
return (ctxt, v, ids, acc)
| (Signature_t _, v) ->
return (ctxt, v, ids, acc)
| (String_t _, v) ->
return (ctxt, v, ids, acc)
| (Bytes_t _, v) ->
return (ctxt, v, ids, acc)
| (Mutez_t _, v) ->
return (ctxt, v, ids, acc)
| (Key_hash_t _, v) ->
return (ctxt, v, ids, acc)
| (Key_t _, v) ->
return (ctxt, v, ids, acc)
| (Timestamp_t _, v) ->
return (ctxt, v, ids, acc)
| (Address_t _, v) ->
return (ctxt, v, ids, acc)
| (Bool_t _, v) ->
return (ctxt, v, ids, acc)
| (Lambda_t (_, _, _), v) ->
return (ctxt, v, ids, acc)
| (Contract_t (_, _), v) ->
return (ctxt, v, ids, acc)
| (Operation_t _, _) ->
assert false
(* called only on parameters and storage, which cannot contain operations *)
let collect_big_maps ctxt ty x =
let rec collect :
type a. context -> a ty -> a -> Ids.t -> (Ids.t * context) tzresult =
fun ctxt ty x acc ->
match (ty, x) with
| (Big_map_t (_, _, _), {id = Some id}) ->
Gas.consume ctxt Typecheck_costs.cycle
>>? fun ctxt -> ok (Ids.add id acc, ctxt)
| (Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr)) ->
collect ctxt tyl xl acc >>? fun (acc, ctxt) -> collect ctxt tyr xr acc
| (Union_t ((ty, _), (_, _), _, true), L x) ->
collect ctxt ty x acc
| (Union_t ((_, _), (ty, _), _, true), R x) ->
collect ctxt ty x acc
| (Option_t (ty, _, true), Some x) ->
collect ctxt ty x acc
| (List_t (ty, _, true), l) ->
List.fold_left
(fun acc x -> acc >>? fun (acc, ctxt) -> collect ctxt ty x acc)
(ok (acc, ctxt))
l
| (Map_t (_, ty, _, true), m) ->
map_fold
(fun _ v acc -> acc >>? fun (acc, ctxt) -> collect ctxt ty v acc)
m
(ok (acc, ctxt))
| (List_t (_, _, false), _) ->
ok (acc, ctxt)
| (Map_t (_, _, _, false), _) ->
ok (acc, ctxt)
| (Big_map_t (_, _, _), {id = None}) ->
ok (acc, ctxt)
| (Option_t (_, _, true), None) ->
ok (acc, ctxt)
| (Option_t (_, _, false), _) ->
ok (acc, ctxt)
| (Union_t (_, _, _, false), _) ->
ok (acc, ctxt)
| (Pair_t (_, _, _, false), _) ->
ok (acc, ctxt)
| (Chain_id_t _, _) ->
ok (acc, ctxt)
| (Set_t (_, _), _) ->
ok (acc, ctxt)
| (Unit_t _, _) ->
ok (acc, ctxt)
| (Int_t _, _) ->
ok (acc, ctxt)
| (Nat_t _, _) ->
ok (acc, ctxt)
| (Signature_t _, _) ->
ok (acc, ctxt)
| (String_t _, _) ->
ok (acc, ctxt)
| (Bytes_t _, _) ->
ok (acc, ctxt)
| (Mutez_t _, _) ->
ok (acc, ctxt)
| (Key_hash_t _, _) ->
ok (acc, ctxt)
| (Key_t _, _) ->
ok (acc, ctxt)
| (Timestamp_t _, _) ->
ok (acc, ctxt)
| (Address_t _, _) ->
ok (acc, ctxt)
| (Bool_t _, _) ->
ok (acc, ctxt)
| (Lambda_t (_, _, _), _) ->
ok (acc, ctxt)
| (Contract_t (_, _), _) ->
ok (acc, ctxt)
| (Operation_t _, _) ->
assert false
(* called only on parameters and storage, which cannot contain operations *)
in
Lwt.return (collect ctxt ty x no_big_map_id)
let extract_big_map_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v =
let to_duplicate = Ids.diff to_duplicate to_update in
let fresh =
if temporary then fun c -> return (Big_map.fresh_temporary c)
else Big_map.fresh
in
extract_big_map_updates ctxt fresh mode to_duplicate [] ty v
>>=? fun (ctxt, v, alive, diffs) ->
let diffs =
if temporary then diffs
else
let dead = Ids.diff to_update alive in
Ids.fold (fun id acc -> Contract.Clear id :: acc) dead [] :: diffs
in
match diffs with
| [] ->
return (v, None, ctxt)
| diffs ->
return (v, Some (List.flatten diffs (* do not reverse *)), ctxt)
let list_of_big_map_ids ids = Ids.elements ids
src/proto_alpha/lib_protocol/script_ir_translator.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Import Micheline.
Import Script.
Import Script_typed_ir.
Import Script_tc_errors.
Import Script_ir_annot.
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
Inductive ex_comparable_ty : Type :=
| Ex_comparable_ty : forall {a : Type},
(Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a) -> ex_comparable_ty.
Inductive ex_ty : Type :=
| Ex_ty : forall {a : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.ty a) ->
ex_ty.
Inductive ex_stack_ty : Type :=
| Ex_stack_ty : forall {a : Type},
(Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a) -> ex_stack_ty.
Inductive tc_context : Type :=
| Lambda : tc_context
| Dip : forall {a : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a)
-> tc_context -> tc_context
| Toplevel : forall {param sto : Type},
(Tezos_raw_protocol_alpha.Script_typed_ir.ty sto) ->
(Tezos_raw_protocol_alpha.Script_typed_ir.ty param) -> (option string) -> bool
-> tc_context.
Inductive unparsing_mode : Type :=
| Optimized : unparsing_mode
| Readable : unparsing_mode.
Definition type_logger :=
Z ->
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.annot)) ->
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.annot)) -> unit.
Definition add_dip {A : Type}
(ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
(annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
(prev : tc_context) : tc_context :=
match prev with
| Lambda | Toplevel _ =>
Dip
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ty
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t annot) prev
| Dip stack _ =>
Dip (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ty stack annot) prev
end.
Fixpoint comparable_type_size {a t : Type}
(ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct t a) : Z :=
match ty with
| Tezos_raw_protocol_alpha.Script_typed_ir.Int_key _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.String_key _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Address_key _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key _ (t, _) _ =>
op_plus 1 (comparable_type_size t)
end.
Fixpoint type_size {t : Type}
(ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) : Z :=
match ty with
| Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.String_t _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (l, _, _) (r, _, _) _ _ =>
op_plus (op_plus 1 (type_size l)) (type_size r)
| Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (l, _) (r, _) _ _ =>
op_plus (op_plus 1 (type_size l)) (type_size r)
| Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t arg ret _ =>
op_plus (op_plus 1 (type_size arg)) (type_size ret)
| Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t _ _ =>
op_plus 1 (type_size t)
| Tezos_raw_protocol_alpha.Script_typed_ir.List_t t _ _ =>
op_plus 1 (type_size t)
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_t k _ =>
op_plus 1 (comparable_type_size k)
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_t k v _ _ =>
op_plus (op_plus 1 (comparable_type_size k)) (type_size v)
| Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t k v _ =>
op_plus (op_plus 1 (comparable_type_size k)) (type_size v)
| Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t arg _ =>
op_plus 1 (type_size arg)
| Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _ => 1
end.
Fixpoint type_size_of_stack_head {st : Type}
(stack : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty st) (up_to : Z)
: Z :=
match stack with
| Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Item_t head tail _annot =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
up_to 0 then
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
(type_size head) (type_size_of_stack_head tail (op_minus up_to 1))
else
0
end.
Definition number_of_generated_growing_types {a b : Type}
(function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.instr b a)
: Z :=
match function_parameter with
| Tezos_raw_protocol_alpha.Script_typed_ir.Drop => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Dup => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Swap => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Const _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Cons_pair => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Car => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Cdr => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Cons_some => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Cons_none _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.If_none _ _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Left => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Right => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.If_left _ _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Cons_list => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Nil => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.If_cons _ _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.List_map _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.List_size => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.List_iter _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Empty_set _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_iter _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_mem => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_update => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_size => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Empty_map _ _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_map _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_iter _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_mem => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_get => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_update => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_size => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Empty_big_map _ _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_get => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_update => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_mem => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string_pair => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Slice_string => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.String_size => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes_pair => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Slice_bytes => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_size => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Add_seconds_to_timestamp => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Add_timestamp_to_seconds => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Sub_timestamp_seconds => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Diff_timestamps => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Add_tez => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Sub_tez => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Mul_teznat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Mul_nattez => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_teznat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_tez => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Or => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.And => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Xor => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Not => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Is_nat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Neg_nat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Neg_int => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Abs_int => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Int_nat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Add_intint => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Add_intnat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Add_natint => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Add_natnat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Sub_int => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intint => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intnat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natint => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natnat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intint => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intnat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natint => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natnat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Lsl_nat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Lsr_nat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Or_nat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.And_nat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.And_int_nat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Xor_nat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Not_nat => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Not_int => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Seq _ _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.If _ _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Loop _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Loop_left _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Dip _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Exec => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Apply _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Lambda _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Failwith _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Nop => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Compare _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Eq => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Neq => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Lt => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Gt => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Le => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Ge => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Address => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Contract _ _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Transfer_tokens => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Create_account => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Implicit_account => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract _ _ _ _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract_2 _ _ _ _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Now => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Balance => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Check_signature => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Hash_key => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Blake2b => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Sha256 => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Sha512 => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Steps_to_quota => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Source => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Sender => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Self _ _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Amount => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_delegate => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Pack _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Unpack _ => 1
| Tezos_raw_protocol_alpha.Script_typed_ir.Dig _ _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Dug _ _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Dipn _ _ _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.Dropn _ _ => 0
| Tezos_raw_protocol_alpha.Script_typed_ir.ChainId => 0
end.
Definition location {A B : Type}
(function_parameter :
Tezos_protocol_environment_alpha__Environment.Micheline.node A B) : A :=
let
'Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc _ _ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Int loc _ |
Tezos_protocol_environment_alpha__Environment.Micheline.String loc _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes loc _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc _ :=
function_parameter in
loc.
Definition kind {A B : Type}
(function_parameter :
Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
: Tezos_raw_protocol_alpha.Script_tc_errors.kind :=
match function_parameter with
| Tezos_protocol_environment_alpha__Environment.Micheline.Int _ _ =>
Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind
| Tezos_protocol_environment_alpha__Environment.Micheline.String _ _ =>
Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
| Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ _ =>
Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind
| Tezos_protocol_environment_alpha__Environment.Micheline.Prim _ _ _ _ =>
Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind
| Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ _ =>
Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind
end.
Definition namespace
(function_parameter : Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
: Tezos_raw_protocol_alpha.Script_tc_errors.namespace :=
match function_parameter with
|
Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter |
Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage |
Tezos_raw_protocol_alpha.Alpha_context.Script.K_code =>
Tezos_raw_protocol_alpha.Script_tc_errors.Keyword_namespace
|
Tezos_raw_protocol_alpha.Alpha_context.Script.D_False |
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Elt |
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left |
Tezos_raw_protocol_alpha.Alpha_context.Script.D_None |
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Pair |
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right |
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Some |
Tezos_raw_protocol_alpha.Alpha_context.Script.D_True |
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Unit =>
Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace
|
Tezos_raw_protocol_alpha.Alpha_context.Script.I_PACK |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UNPACK |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_BLAKE2B |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA256 |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA512 |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ABS |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_AMOUNT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_BALANCE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CAR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CDR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CHAIN_ID |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CHECK_SIGNATURE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_COMPARE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONS |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_ACCOUNT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_CONTRACT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IMPLICIT_ACCOUNT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_BIG_MAP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_MAP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_SET |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EQ |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EXEC |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_APPLY |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_FAILWITH |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_HASH_KEY |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_CONS |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_LEFT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_NONE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_INT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LAMBDA |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LEFT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSL |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MAP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEG |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEQ |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NIL |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NONE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOW |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_OR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_PAIR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_PUSH |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_RIGHT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOME |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOURCE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SENDER |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SELF |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SLICE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_STEPS_TO_QUOTA |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SWAP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_TRANSFER_TOKENS |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SET_DELEGATE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UNIT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_XOR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ITER |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP_LEFT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADDRESS |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONTRACT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ISNAT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CAST |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_RENAME |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIG |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG =>
Tezos_raw_protocol_alpha.Script_tc_errors.Instr_namespace
|
Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_contract |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_int |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_key |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_lambda |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_list |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_map |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_big_map |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_option |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_or |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_set |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_signature |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_string |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_bytes |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_unit |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_operation |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_address |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_chain_id =>
Tezos_raw_protocol_alpha.Script_tc_errors.Type_namespace
end.
Definition unexpected
(expr :
Tezos_protocol_environment_alpha__Environment.Micheline.node
Tezos_raw_protocol_alpha.Alpha_context.Script.location
Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
(exp_kinds : list Tezos_raw_protocol_alpha.Script_tc_errors.kind)
(exp_ns : Tezos_raw_protocol_alpha.Script_tc_errors.namespace)
(exp_prims : list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
: Tezos_protocol_environment_alpha__Environment.Error_monad.error :=
match expr with
| Tezos_protocol_environment_alpha__Environment.Micheline.Int loc _ =>
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind loc
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind exp_kinds)
Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind
| Tezos_protocol_environment_alpha__Environment.Micheline.String loc _ =>
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind loc
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind exp_kinds)
Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
| Tezos_protocol_environment_alpha__Environment.Micheline.Bytes loc _ =>
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind loc
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind exp_kinds)
Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind
| Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc _ =>
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind loc
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind exp_kinds)
Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind
| Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc name _ _ =>
match ((namespace name), exp_ns) with
|
(Tezos_raw_protocol_alpha.Script_tc_errors.Type_namespace,
Tezos_raw_protocol_alpha.Script_tc_errors.Type_namespace) |
(Tezos_raw_protocol_alpha.Script_tc_errors.Instr_namespace,
Tezos_raw_protocol_alpha.Script_tc_errors.Instr_namespace) |
(Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace,
Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace) =>
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive
loc exp_prims name
| (ns, _) =>
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_namespace
loc name exp_ns ns
end
end.
Definition check_kind {A : Type}
(kinds : list Tezos_raw_protocol_alpha.Script_tc_errors.kind)
(expr :
Tezos_protocol_environment_alpha__Environment.Micheline.node
Tezos_raw_protocol_alpha.Alpha_context.Script.location A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let kind := kind expr in
if List.mem kind kinds then
return_unit
else
let loc := location expr in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
loc kinds kind).
Definition wrap_compare {A B : Type}
(compare :
A ->
B ->
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(a : A) (b : B) : Z :=
let res := compare a b in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
res 0 then
0
else
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
res 0 then
1
else
(-1).
Fixpoint compare_comparable {a s : Type}
(kind : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a s)
: a -> a -> Z :=
match kind with
| Tezos_raw_protocol_alpha.Script_typed_ir.String_key _ =>
wrap_compare
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
| Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key _ =>
wrap_compare
Tezos_protocol_environment_alpha__Environment.Compare.Bool.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
| Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key _ =>
wrap_compare Tez.compare
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key _ =>
wrap_compare Signature.Public_key_hash.compare
| Tezos_raw_protocol_alpha.Script_typed_ir.Int_key _ =>
wrap_compare Script_int.compare
| Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key _ =>
wrap_compare Script_int.compare
| Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key _ =>
wrap_compare Script_timestamp.compare
| Tezos_raw_protocol_alpha.Script_typed_ir.Address_key _ =>
op_atat wrap_compare
(fun function_parameter =>
let '(x, ex) := function_parameter in
fun function_parameter =>
let '(y, ey) := function_parameter in
let lres := Contract.compare x y in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
lres 0 then
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
ex ey
else
lres)
| Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key _ =>
wrap_compare MBytes.compare
| Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key (tl, _) (tr, _) _ =>
fun function_parameter =>
let '(lx, rx) := function_parameter in
fun function_parameter =>
let '(ly, ry) := function_parameter in
let lres := compare_comparable tl lx ly in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
lres 0 then
compare_comparable tr rx ry
else
lres
end.
Definition empty_set {a : Type}
(ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a)
: Tezos_raw_protocol_alpha.Script_typed_ir.set a :=
let OPS :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
existT _ _
{|
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.elt_ty := ty;
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS := OPS;
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed := OPS.empty;
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size := 0
|}.
Definition set_update {a : Type}
(v : a) (b : bool) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set a)
: Tezos_raw_protocol_alpha.Script_typed_ir.set a :=
let Box := projT2 Box in
existT _ _
{|
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.elt_ty :=
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.elt_ty);
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS :=
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS);
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed :=
if b then
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.add)
v Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed)
else
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.remove)
v Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed);
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size :=
let mem :=
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.mem)
v Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed) in
if mem then
if b then
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size)
else
op_minus
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size) 1
else
if b then
op_plus
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size) 1
else
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size)
|}.
Definition set_mem {elt : Type}
(v : elt) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt) : bool :=
let Box := projT2 Box in
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.mem)
v Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed).
Definition set_fold {acc elt : Type}
(f : elt -> acc -> acc)
(Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt) : acc -> acc :=
let Box := projT2 Box in
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.fold)
f Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed).
Definition set_size {elt : Type}
(Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt)
: Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n :=
let Box := projT2 Box in
abs (of_int Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size)).
Definition map_key_ty {a b : Type}
(Box : Tezos_raw_protocol_alpha.Script_typed_ir.map a b)
: Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a :=
let Box := projT2 Box in
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty).
Definition empty_map {a b : Type}
(ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a)
: Tezos_raw_protocol_alpha.Script_typed_ir.map a b :=
let OPS :=
(* ❌ Applications of functors are not supported for first-class module values *)
unsupported_functor_application in
existT _ _
{|
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty := ty;
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS := OPS;
(* ❌ This kind of definition of value for first-class modules is not handled *)
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed := unhandled
|}.
Definition map_get {key value : Type}
(k : key) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
: option value :=
let Box := projT2 Box in
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.find_opt)
k (fst Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)).
Definition map_update {a b : Type}
(k : a) (v : option b)
(Box : Tezos_raw_protocol_alpha.Script_typed_ir.map a b)
: Tezos_raw_protocol_alpha.Script_typed_ir.map a b :=
let Box := projT2 Box in
existT _ _
{|
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty :=
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty);
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS :=
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS);
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed :=
let '(map, size) :=
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed) in
let contains :=
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.mem)
k map in
match v with
| Some v =>
((Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
k v map),
(op_plus size
(if contains then
0
else
1)))
| None =>
((Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.remove)
k map),
(op_minus size
(if contains then
1
else
0)))
end
|}.
Definition map_set {a b : Type}
(k : a) (v : b) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map a b)
: Tezos_raw_protocol_alpha.Script_typed_ir.map a b :=
let Box := projT2 Box in
existT _ _
{|
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty :=
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty);
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS :=
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS);
Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed :=
let '(map, size) :=
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed) in
((Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
k v map),
(if
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.mem)
k map then
size
else
op_plus size 1))
|}.
Definition map_mem {key value : Type}
(k : key) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
: bool :=
let Box := projT2 Box in
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.mem)
k (fst Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)).
Definition map_fold {acc key value : Type}
(f : key -> value -> acc -> acc)
(Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value) : acc -> acc :=
let Box := projT2 Box in
Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.fold)
f (fst Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)).
Definition map_size {key value : Type}
(Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
: Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n :=
let Box := projT2 Box in
abs
(of_int (snd Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed))).
Fixpoint ty_of_comparable_ty {a s : Type}
(function_parameter :
Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a s)
: Tezos_raw_protocol_alpha.Script_typed_ir.ty a :=
match function_parameter with
| Tezos_raw_protocol_alpha.Script_typed_ir.Int_key tname =>
Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key tname =>
Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname
| Tezos_raw_protocol_alpha.Script_typed_ir.String_key tname =>
Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key tname =>
Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key tname =>
Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key tname =>
Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key tname =>
Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key tname =>
Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Address_key tname =>
Tezos_raw_protocol_alpha.Script_typed_ir.Address_t tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key (l, al) (r, ar) tname =>
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
((ty_of_comparable_ty l), al, None) ((ty_of_comparable_ty r), ar, None)
tname false
end.
Fixpoint comparable_ty_of_ty {a : Type}
(function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
: option (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a) :=
match function_parameter with
| Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname =>
Some (Tezos_raw_protocol_alpha.Script_typed_ir.Int_key tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname =>
Some (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname =>
Some (Tezos_raw_protocol_alpha.Script_typed_ir.String_key tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname =>
Some (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname =>
Some (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname =>
Some (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t tname =>
Some (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname =>
Some (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Address_t tname =>
Some (Tezos_raw_protocol_alpha.Script_typed_ir.Address_key tname)
|
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (l, al, _) (r, ar, _) pname
_ =>
match comparable_ty_of_ty r with
| None => None
| Some rty =>
match comparable_ty_of_ty l with
| None => None
| Some (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key _ _ _) => None
| Some (Tezos_raw_protocol_alpha.Script_typed_ir.Int_key tname) =>
Some
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
((Tezos_raw_protocol_alpha.Script_typed_ir.Int_key tname), al)
(rty, ar) pname)
| Some (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key tname) =>
Some
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key tname), al)
(rty, ar) pname)
| Some (Tezos_raw_protocol_alpha.Script_typed_ir.String_key tname) =>
Some
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
((Tezos_raw_protocol_alpha.Script_typed_ir.String_key tname), al)
(rty, ar) pname)
| Some (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key tname) =>
Some
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
((Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key tname), al)
(rty, ar) pname)
| Some (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key tname) =>
Some
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
((Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key tname), al)
(rty, ar) pname)
| Some (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key tname) =>
Some
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
((Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key tname), al)
(rty, ar) pname)
| Some (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key tname) =>
Some
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
((Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key tname), al)
(rty, ar) pname)
| Some (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key tname) =>
Some
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
((Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key tname), al)
(rty, ar) pname)
| Some (Tezos_raw_protocol_alpha.Script_typed_ir.Address_key tname) =>
Some
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
((Tezos_raw_protocol_alpha.Script_typed_ir.Address_key tname), al)
(rty, ar) pname)
end
end
| _ => None
end.
Definition add_field_annot {A B : Type}
(a : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
(var : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
(function_parameter :
Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
: Tezos_protocol_environment_alpha__Environment.Micheline.node A B :=
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc prim args
annots =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc prim args
(op_at annots (op_at (unparse_field_annot a) (unparse_var_annot var)))
| expr => expr
end.
Fixpoint unparse_comparable_ty {a s : Type}
(function_parameter :
Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a s)
: Tezos_raw_protocol_alpha.Alpha_context.Script.node :=
match function_parameter with
| Tezos_raw_protocol_alpha.Script_typed_ir.Int_key tname =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.T_int []
(unparse_type_annot tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key tname =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat []
(unparse_type_annot tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.String_key tname =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.T_string []
(unparse_type_annot tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key tname =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.T_bytes []
(unparse_type_annot tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key tname =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez []
(unparse_type_annot tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key tname =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool []
(unparse_type_annot tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key tname =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash []
(unparse_type_annot tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key tname =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp []
(unparse_type_annot tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Address_key tname =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.T_address []
(unparse_type_annot tname)
| Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key (l, al) (r, ar) pname =>
let tl := add_field_annot al None (unparse_comparable_ty l) in
let tr := add_field_annot ar None (unparse_comparable_ty r) in
Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair
(cons tl (cons tr [])) (unparse_type_annot pname)
end.
Fixpoint unparse_ty_no_lwt {a : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.Script.node *
Tezos_raw_protocol_alpha.Alpha_context.context) :=
op_gtgtquestion (Gas.consume ctxt Unparse_costs.cycle)
(fun ctxt =>
let _return {B : Type}
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(function_parameter :
B *
(list
(Tezos_protocol_environment_alpha__Environment.Micheline.node Z B))
* Tezos_protocol_environment_alpha__Environment.Micheline.annot)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_protocol_environment_alpha__Environment.Micheline.node Z B) *
Tezos_raw_protocol_alpha__Alpha_context.context) :=
let '(name, args, annot) := function_parameter in
let result :=
Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1) name
args annot in
op_gtgtquestion
(Gas.consume ctxt (Unparse_costs.prim_cost (List.length args) annot))
(fun ctxt => ok (result, ctxt)) in
match ty with
| Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t tname =>
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_unit, [],
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname =>
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_int, [],
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname =>
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat, [],
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname =>
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_string, [],
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname =>
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_bytes, [],
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname =>
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez, [],
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname =>
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool, [],
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t tname =>
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash, [],
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_t tname =>
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_key, [],
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname =>
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp, [],
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.Address_t tname =>
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_address, [],
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t tname =>
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_signature, [],
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t tname =>
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_operation, [],
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t tname =>
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_chain_id, [],
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t ut tname =>
op_gtgtquestion (unparse_ty_no_lwt ctxt ut)
(fun function_parameter =>
let '(t, ctxt) := function_parameter in
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_contract,
(cons t []), (unparse_type_annot tname)))
|
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (utl, l_field, l_var)
(utr, r_field, r_var) tname _ =>
let annot := unparse_type_annot tname in
op_gtgtquestion (unparse_ty_no_lwt ctxt utl)
(fun function_parameter =>
let '(utl, ctxt) := function_parameter in
let tl := add_field_annot l_field l_var utl in
op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
(fun function_parameter =>
let '(utr, ctxt) := function_parameter in
let tr := add_field_annot r_field r_var utr in
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair,
(cons tl (cons tr [])), annot)))
|
Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (utl, l_field)
(utr, r_field) tname _ =>
let annot := unparse_type_annot tname in
op_gtgtquestion (unparse_ty_no_lwt ctxt utl)
(fun function_parameter =>
let '(utl, ctxt) := function_parameter in
let tl := add_field_annot l_field None utl in
op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
(fun function_parameter =>
let '(utr, ctxt) := function_parameter in
let tr := add_field_annot r_field None utr in
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_or,
(cons tl (cons tr [])), annot)))
| Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t uta utr tname =>
op_gtgtquestion (unparse_ty_no_lwt ctxt uta)
(fun function_parameter =>
let '(ta, ctxt) := function_parameter in
op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
(fun function_parameter =>
let '(tr, ctxt) := function_parameter in
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_lambda,
(cons ta (cons tr [])), (unparse_type_annot tname))))
| Tezos_raw_protocol_alpha.Script_typed_ir.Option_t ut tname _ =>
let annot := unparse_type_annot tname in
op_gtgtquestion (unparse_ty_no_lwt ctxt ut)
(fun function_parameter =>
let '(ut, ctxt) := function_parameter in
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_option,
(cons ut []), annot))
| Tezos_raw_protocol_alpha.Script_typed_ir.List_t ut tname _ =>
op_gtgtquestion (unparse_ty_no_lwt ctxt ut)
(fun function_parameter =>
let '(t, ctxt) := function_parameter in
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_list,
(cons t []), (unparse_type_annot tname)))
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_t ut tname =>
let t := unparse_comparable_ty ut in
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_set, (cons t []),
(unparse_type_annot tname))
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_t uta utr tname _ =>
let ta := unparse_comparable_ty uta in
op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
(fun function_parameter =>
let '(tr, ctxt) := function_parameter in
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_map,
(cons ta (cons tr [])), (unparse_type_annot tname)))
| Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t uta utr tname =>
let ta := unparse_comparable_ty uta in
op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
(fun function_parameter =>
let '(tr, ctxt) := function_parameter in
_return ctxt
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_big_map,
(cons ta (cons tr [])), (unparse_type_annot tname)))
end).
Definition unparse_ty {A : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.Script.node *
Tezos_raw_protocol_alpha.Alpha_context.context)) :=
Lwt._return (unparse_ty_no_lwt ctxt ty).
Fixpoint strip_var_annots {A B : Type}
(function_parameter :
Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
: Tezos_protocol_environment_alpha__Environment.Micheline.node A B :=
match function_parameter with
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Int _ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.String _ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ _) as atom
=> atom
| Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc args =>
Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc
(List.map strip_var_annots args)
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc name args
annots =>
let not_var_annot (s : string) : bool :=
Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt)
(String.get s 0) "@" % char in
let annots := List.filter not_var_annot annots in
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc name
(List.map strip_var_annots args) annots
end.
Definition serialize_ty_for_error {A : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
Tezos_raw_protocol_alpha.Alpha_context.context) :=
op_gtpipequestion
(op_pipegt (unparse_ty_no_lwt ctxt ty)
(record_trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_error))
(fun function_parameter =>
let '(ty, ctxt) := function_parameter in
((strip_locations (strip_var_annots ty)), ctxt)).
Fixpoint unparse_stack {a : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.annot)) *
Tezos_raw_protocol_alpha.Alpha_context.context)) :=
match function_parameter with
| Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t => _return ([], ctxt)
| Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ty rest annot =>
op_gtgteqquestion (unparse_ty ctxt ty)
(fun function_parameter =>
let '(uty, ctxt) := function_parameter in
op_gtgteqquestion (unparse_stack ctxt rest)
(fun function_parameter =>
let '(urest, ctxt) := function_parameter in
_return
((cons ((strip_locations uty), (unparse_var_annot annot)) urest),
ctxt)))
end.
Definition serialize_stack_for_error {A : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(stack_ty : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.annot)) *
Tezos_raw_protocol_alpha.Alpha_context.context)) :=
trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_error
(unparse_stack ctxt stack_ty).
Definition name_of_ty {a : Type}
(function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
: option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot :=
match function_parameter with
| Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_t tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Address_t tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t _ _ tname _ => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ tname _ => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t _ _ tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ tname _ => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.List_t _ tname _ => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_t _ tname => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ _ tname _ => tname
| Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _ _ tname => tname
end.
Inductive eq : forall (ta tb : Type), Type :=
| Eq : forall {same : Type}, eq same same.
Definition comparable_ty_eq {ta tb : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(ta : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta)
(tb : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty tb)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(eq (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta)
(Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty tb)) :=
match (ta, tb) with
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_key _,
Tezos_raw_protocol_alpha.Script_typed_ir.Int_key _) =>
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key _,
Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key _) =>
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
|
(Tezos_raw_protocol_alpha.Script_typed_ir.String_key _,
Tezos_raw_protocol_alpha.Script_typed_ir.String_key _) =>
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key _,
Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key _) =>
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key _,
Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key _) =>
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key _,
Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key _) =>
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key _,
Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key _) =>
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key _,
Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key _) =>
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_key _,
Tezos_raw_protocol_alpha.Script_typed_ir.Address_key _) =>
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
| (_, _) =>
op_gtgtquestion (serialize_ty_for_error ctxt (ty_of_comparable_ty ta))
(fun function_parameter =>
let '(ta, ctxt) := function_parameter in
op_gtgtquestion (serialize_ty_for_error ctxt (ty_of_comparable_ty tb))
(fun function_parameter =>
let '(tb, _ctxt) := function_parameter in
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_types
ta tb)))
end.
Definition record_inconsistent {A B C : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(ta : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
(tb : Tezos_raw_protocol_alpha.Script_typed_ir.ty B)
: (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C :=
record_trace_eval
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (serialize_ty_for_error ctxt ta)
(fun function_parameter =>
let '(ta, ctxt) := function_parameter in
op_gtpipequestion (serialize_ty_for_error ctxt tb)
(fun function_parameter =>
let '(tb, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_types
ta tb))).
Definition record_inconsistent_type_annotations {A B C : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
(ta : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
(tb : Tezos_raw_protocol_alpha.Script_typed_ir.ty B)
: (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C :=
record_trace_eval
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion (serialize_ty_for_error ctxt ta)
(fun function_parameter =>
let '(ta, ctxt) := function_parameter in
op_gtpipequestion (serialize_ty_for_error ctxt tb)
(fun function_parameter =>
let '(tb, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_type_annotations
loc ta tb))).
Fixpoint ty_eq {ta tb : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(ta : Tezos_raw_protocol_alpha.Script_typed_ir.ty ta)
(tb : Tezos_raw_protocol_alpha.Script_typed_ir.ty tb)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((eq (Tezos_raw_protocol_alpha.Script_typed_ir.ty ta)
(Tezos_raw_protocol_alpha.Script_typed_ir.ty tb)) *
Tezos_raw_protocol_alpha.Alpha_context.context) :=
let ok
(eq :
eq (Tezos_raw_protocol_alpha.Script_typed_ir.ty ta)
(Tezos_raw_protocol_alpha.Script_typed_ir.ty tb)) (ctxt :
Tezos_raw_protocol_alpha__Alpha_context.context) (nb_args : Z)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((eq (Tezos_raw_protocol_alpha.Script_typed_ir.ty ta)
(Tezos_raw_protocol_alpha.Script_typed_ir.ty tb)) *
Tezos_raw_protocol_alpha.Alpha_context.context) :=
op_gtgtquestion
(Gas.consume ctxt (Typecheck_costs.type_ (op_star 2 nb_args)))
(fun ctxt =>
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok (eq, ctxt))
in
op_gtgtquestion (Gas.consume ctxt Typecheck_costs.cycle)
(fun ctxt =>
match (ta, tb) with
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _,
Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _) => ok Eq ctxt 0
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _,
Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) => ok Eq ctxt 0
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _,
Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) => ok Eq ctxt 0
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _,
Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _) => ok Eq ctxt 0
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _,
Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _) => ok Eq ctxt 0
|
(Tezos_raw_protocol_alpha.Script_typed_ir.String_t _,
Tezos_raw_protocol_alpha.Script_typed_ir.String_t _) => ok Eq ctxt 0
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _,
Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _) => ok Eq ctxt 0
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _,
Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _) =>
ok Eq ctxt 0
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _,
Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _) => ok Eq ctxt 0
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _,
Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _) =>
ok Eq ctxt 0
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _,
Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _) => ok Eq ctxt 0
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _,
Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _) => ok Eq ctxt 0
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _,
Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _) => ok Eq ctxt 0
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _,
Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _) =>
ok Eq ctxt 0
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_t tal tar _ _,
Tezos_raw_protocol_alpha.Script_typed_ir.Map_t tbl tbr _ _) =>
op_pipegt
(op_gtgtquestion (comparable_ty_eq ctxt tal tbl)
(fun function_parameter =>
let 'Eq := function_parameter in
op_gtgtquestion (ty_eq ctxt tar tbr)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tal tar _,
Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tbl tbr _) =>
op_pipegt
(op_gtgtquestion (comparable_ty_eq ctxt tal tbl)
(fun function_parameter =>
let 'Eq := function_parameter in
op_gtgtquestion (ty_eq ctxt tar tbr)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_t ea _,
Tezos_raw_protocol_alpha.Script_typed_ir.Set_t eb _) =>
op_pipegt
(op_gtgtquestion (comparable_ty_eq ctxt ea eb)
(fun function_parameter =>
let 'Eq := function_parameter in
ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (tal, _, _) (tar, _, _)
_ _,
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (tbl, _, _)
(tbr, _, _) _ _) =>
op_pipegt
(op_gtgtquestion (ty_eq ctxt tal tbl)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgtquestion (ty_eq ctxt tar tbr)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tal, _) (tar, _) _ _,
Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tbl, _) (tbr, _) _ _)
=>
op_pipegt
(op_gtgtquestion (ty_eq ctxt tal tbl)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgtquestion (ty_eq ctxt tar tbr)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t tal tar _,
Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t tbl tbr _) =>
op_pipegt
(op_gtgtquestion (ty_eq ctxt tal tbl)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgtquestion (ty_eq ctxt tar tbr)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t tal _,
Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t tbl _) =>
op_pipegt
(op_gtgtquestion (ty_eq ctxt tal tbl)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t tva _ _,
Tezos_raw_protocol_alpha.Script_typed_ir.Option_t tvb _ _) =>
op_pipegt
(op_gtgtquestion (ty_eq ctxt tva tvb)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t tva _ _,
Tezos_raw_protocol_alpha.Script_typed_ir.List_t tvb _ _) =>
op_pipegt
(op_gtgtquestion (ty_eq ctxt tva tvb)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
| (_, _) =>
op_gtgtquestion (serialize_ty_for_error ctxt ta)
(fun function_parameter =>
let '(ta, ctxt) := function_parameter in
op_gtgtquestion (serialize_ty_for_error ctxt tb)
(fun function_parameter =>
let '(tb, _ctxt) := function_parameter in
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_types
ta tb)))
end).
Fixpoint stack_ty_eq {ta tb : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (lvl : Z)
(ta : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta)
(tb : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tb)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((eq (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta)
(Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tb)) *
Tezos_raw_protocol_alpha.Alpha_context.context) :=
match (ta, tb) with
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tva ra _,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tvb rb _) =>
op_gtgtquestion
(op_pipegt (ty_eq ctxt tva tvb)
(record_trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack_item
lvl)))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgtquestion (stack_ty_eq ctxt (op_plus lvl 1) ra rb)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
(Eq, ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t,
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t) =>
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok (Eq, ctxt)
| (_, _) =>
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack_length
end.
Definition merge_comparable_types {ta : Type}
(legacy : bool)
(ta : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta)
(tb : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta) :=
match (ta, tb) with
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_key annot_a,
Tezos_raw_protocol_alpha.Script_typed_ir.Int_key annot_b) =>
op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
(fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Int_key annot)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key annot_a,
Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key annot_b) =>
op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
(fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key annot)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.String_key annot_a,
Tezos_raw_protocol_alpha.Script_typed_ir.String_key annot_b) =>
op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
(fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.String_key annot)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key annot_a,
Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key annot_b) =>
op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
(fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key annot)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key annot_a,
Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key annot_b) =>
op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
(fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key annot)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key annot_a,
Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key annot_b) =>
op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
(fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key annot)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key annot_a,
Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key annot_b) =>
op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
(fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key annot)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key annot_a,
Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key annot_b) =>
op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
(fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key annot)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_key annot_a,
Tezos_raw_protocol_alpha.Script_typed_ir.Address_key annot_b) =>
op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
(fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Address_key annot)
| (_, _) =>
(* ❌ Assert instruction is not handled. *)
assert false
end.
Definition merge_types {b : Type} (legacy : bool)
: Tezos_raw_protocol_alpha.Alpha_context.context ->
Tezos_raw_protocol_alpha.Alpha_context.Script.location ->
(Tezos_raw_protocol_alpha.Script_typed_ir.ty b) ->
(Tezos_raw_protocol_alpha.Script_typed_ir.ty b) ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_raw_protocol_alpha.Script_typed_ir.ty b) *
Tezos_raw_protocol_alpha.Alpha_context.context) :=
let fix help {a : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (ty1 :
Tezos_raw_protocol_alpha.Script_typed_ir.ty a) (ty2 :
Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_raw_protocol_alpha.Script_typed_ir.ty a) *
Tezos_raw_protocol_alpha.Alpha_context.context) :=
match (ty1, ty2) with
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t tn2) =>
op_gtpipequestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t tname), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn2) =>
op_gtpipequestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) =>
op_gtpipequestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_t tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Key_t tn2) =>
op_gtpipequestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Key_t tname), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t tn2) =>
op_gtpipequestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t tname), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.String_t tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.String_t tn2) =>
op_gtpipequestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
((Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tn2) =>
op_gtpipequestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t tn2) =>
op_gtpipequestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t tname), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn2) =>
op_gtpipequestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tn2) =>
op_gtpipequestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_t tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Address_t tn2) =>
op_gtpipequestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Address_t tname), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn2) =>
op_gtpipequestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t tn2) =>
op_gtpipequestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t tname), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t tn2) =>
op_gtpipequestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t tname), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_t tal tar tn1 has_big_map,
Tezos_raw_protocol_alpha.Script_typed_ir.Map_t tbl tbr tn2 _) =>
op_gtgtquestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
op_gtgtquestion (help ctxt tar tbr)
(fun function_parameter =>
let '(value, ctxt) := function_parameter in
op_gtgtquestion (ty_eq ctxt tar value)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtpipequestion (merge_comparable_types legacy tal tbl)
(fun tk =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Map_t tk value
tname has_big_map), ctxt)))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tal tar tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tbl tbr tn2) =>
op_gtgtquestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
op_gtgtquestion (help ctxt tar tbr)
(fun function_parameter =>
let '(value, ctxt) := function_parameter in
op_gtgtquestion (ty_eq ctxt tar value)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtpipequestion (merge_comparable_types legacy tal tbl)
(fun tk =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tk
value tname), ctxt)))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_t ea tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Set_t eb tn2) =>
op_gtgtquestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
op_gtpipequestion (merge_comparable_types legacy ea eb)
(fun e =>
((Tezos_raw_protocol_alpha.Script_typed_ir.Set_t e tname), ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (tal, l_field1, l_var1)
(tar, r_field1, r_var1) tn1 has_big_map,
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (tbl, l_field2, l_var2)
(tbr, r_field2, r_var2) tn2 _) =>
op_gtgtquestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
op_gtgtquestion (merge_field_annot legacy l_field1 l_field2)
(fun l_field =>
op_gtgtquestion (merge_field_annot legacy r_field1 r_field2)
(fun r_field =>
let l_var := merge_var_annot l_var1 l_var2 in
let r_var := merge_var_annot r_var1 r_var2 in
op_gtgtquestion (help ctxt tal tbl)
(fun function_parameter =>
let '(left_ty, ctxt) := function_parameter in
op_gtpipequestion (help ctxt tar tbr)
(fun function_parameter =>
let '(right_ty, ctxt) := function_parameter in
((Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
(left_ty, l_field, l_var) (right_ty, r_field, r_var)
tname has_big_map), ctxt))))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tal, tal_annot)
(tar, tar_annot) tn1 has_big_map,
Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tbl, tbl_annot)
(tbr, tbr_annot) tn2 _) =>
op_gtgtquestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
op_gtgtquestion (merge_field_annot legacy tal_annot tbl_annot)
(fun left_annot =>
op_gtgtquestion (merge_field_annot legacy tar_annot tbr_annot)
(fun right_annot =>
op_gtgtquestion (help ctxt tal tbl)
(fun function_parameter =>
let '(left_ty, ctxt) := function_parameter in
op_gtpipequestion (help ctxt tar tbr)
(fun function_parameter =>
let '(right_ty, ctxt) := function_parameter in
((Tezos_raw_protocol_alpha.Script_typed_ir.Union_t
(left_ty, left_annot) (right_ty, right_annot) tname
has_big_map), ctxt))))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t tal tar tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t tbl tbr tn2) =>
op_gtgtquestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
op_gtgtquestion (help ctxt tal tbl)
(fun function_parameter =>
let '(left_ty, ctxt) := function_parameter in
op_gtpipequestion (help ctxt tar tbr)
(fun function_parameter =>
let '(right_ty, ctxt) := function_parameter in
((Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t left_ty
right_ty tname), ctxt))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t tal tn1,
Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t tbl tn2) =>
op_gtgtquestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
op_gtpipequestion (help ctxt tal tbl)
(fun function_parameter =>
let '(arg_ty, ctxt) := function_parameter in
((Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t arg_ty tname),
ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t tva tn1 has_big_map,
Tezos_raw_protocol_alpha.Script_typed_ir.Option_t tvb tn2 _) =>
op_gtgtquestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
op_gtpipequestion (help ctxt tva tvb)
(fun function_parameter =>
let '(ty, ctxt) := function_parameter in
((Tezos_raw_protocol_alpha.Script_typed_ir.Option_t ty tname
has_big_map), ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t tva tn1 has_big_map,
Tezos_raw_protocol_alpha.Script_typed_ir.List_t tvb tn2 _) =>
op_gtgtquestion (merge_type_annot legacy tn1 tn2)
(fun tname =>
op_gtpipequestion (help ctxt tva tvb)
(fun function_parameter =>
let '(ty, ctxt) := function_parameter in
((Tezos_raw_protocol_alpha.Script_typed_ir.List_t ty tname
has_big_map), ctxt)))
| (_, _) =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
fun ctxt =>
fun loc =>
fun ty1 =>
fun ty2 =>
record_inconsistent_type_annotations ctxt loc ty1 ty2
(help ctxt ty1 ty2).
Definition merge_stacks {ta : Type}
(legacy : bool) (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
: Tezos_raw_protocol_alpha.Alpha_context.context ->
(Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta) ->
(Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta) ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta) *
Tezos_raw_protocol_alpha.Alpha_context.context) :=
let fix help {a : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (stack1 :
Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a) (stack2 :
Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a) *
Tezos_raw_protocol_alpha.Alpha_context.context) :=
match (stack1, stack2) with
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t,
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t) =>
ok (Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t, ctxt)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ty1 rest1 annot1,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ty2 rest2 annot2) =>
let annot := merge_var_annot annot1 annot2 in
op_gtgtquestion (merge_types legacy ctxt loc ty1 ty2)
(fun function_parameter =>
let '(ty, ctxt) := function_parameter in
op_gtpipequestion (help ctxt rest1 rest2)
(fun function_parameter =>
let '(rest, ctxt) := function_parameter in
((Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ty rest annot),
ctxt)))
end in
help.
Definition has_big_map {t : Type}
(function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) : bool :=
match function_parameter with
| Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.String_t _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t _ _ _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_t _ _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _ _ _ => true
| Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _ => false
| Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t _ _ _ has_big_map =>
has_big_map
| Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ has_big_map =>
has_big_map
| Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ has_big_map =>
has_big_map
| Tezos_raw_protocol_alpha.Script_typed_ir.List_t _ _ has_big_map =>
has_big_map
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ _ _ has_big_map =>
has_big_map
end.
Inductive judgement (bef : Type) : Type :=
| Typed : forall {aft : Type},
(Tezos_raw_protocol_alpha.Script_typed_ir.descr bef aft) -> judgement bef
| Failed : forall {aft : Type},
(((Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft) ->
Tezos_raw_protocol_alpha.Script_typed_ir.descr bef aft) * (aft)) ->
judgement bef.
Arguments Typed {_}.
Arguments Failed {_}.
Record branch {t f b : Type} := {
branch :
((Tezos_raw_protocol_alpha.Script_typed_ir.descr t r) ->
(Tezos_raw_protocol_alpha.Script_typed_ir.descr f r) ->
Tezos_raw_protocol_alpha.Script_typed_ir.descr b r) * (r) }.
Arguments branch : clear implicits.
Definition merge_branches {a b bef : Type}
(legacy : bool) (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(loc : Z) (btr : judgement a) (bfr : judgement b)
(function_parameter : branch a b bef)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((judgement bef) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let '{| branch := branch |} := function_parameter in
match (btr, bfr) with
| (Typed ({| aft := aftbt |} as dbt), Typed ({| aft := aftbf |} as dbf)) =>
let unmatched_branches (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
let 'tt := function_parameter in
op_gtgteqquestion (serialize_stack_for_error ctxt aftbt)
(fun function_parameter =>
let '(aftbt, ctxt) := function_parameter in
op_gtgtpipequestion (serialize_stack_for_error ctxt aftbf)
(fun function_parameter =>
let '(aftbf, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Unmatched_branches
loc aftbt aftbf)) in
trace_eval unmatched_branches
(op_gtgteqquestion (Lwt._return (stack_ty_eq ctxt 1 aftbt aftbf))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgteqquestion
(Lwt._return (merge_stacks legacy loc ctxt aftbt aftbf))
(fun function_parameter =>
let '(merged_stack, ctxt) := function_parameter in
_return
((Typed
(branch
(* ❌ Record substitution not handled *)
record_substitution
(* ❌ Record substitution not handled *)
record_substitution)), ctxt))))
| (Failed {| descr := descrt |}, Failed {| descr := descrf |}) =>
let descr {D : Type}
(ret : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty D)
: Tezos_raw_protocol_alpha.Script_typed_ir.descr bef D :=
branch (descrt ret) (descrf ret) in
_return ((Failed {| descr := descr |}), ctxt)
| (Typed dbt, Failed {| descr := descrf |}) =>
_return ((Typed (branch dbt (descrf (aft dbt)))), ctxt)
| (Failed {| descr := descrt |}, Typed dbf) =>
_return ((Typed (branch (descrt (aft dbf)) dbf)), ctxt)
end.
Fixpoint parse_comparable_ty
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(ty : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(ex_comparable_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
op_gtgtquestion (Gas.consume ctxt Typecheck_costs.cycle)
(fun ctxt =>
op_gtgtquestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
match ty with
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_int [] annot =>
op_gtpipequestion (parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_key tname)),
ctxt))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat [] annot =>
op_gtpipequestion (parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key tname)),
ctxt))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_string [] annot =>
op_gtpipequestion (parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.String_key tname)),
ctxt))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_bytes [] annot =>
op_gtpipequestion (parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key tname)),
ctxt))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez [] annot =>
op_gtpipequestion (parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key tname)),
ctxt))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool [] annot =>
op_gtpipequestion (parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key tname)),
ctxt))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash [] annot
=>
op_gtpipequestion (parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key tname)),
ctxt))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp [] annot
=>
op_gtpipequestion (parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key tname)),
ctxt))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_address [] annot
=>
op_gtpipequestion (parse_type_annot loc annot)
(fun tname =>
((Ex_comparable_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_key tname)),
ctxt))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
((Tezos_raw_protocol_alpha.Alpha_context.Script.T_int |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_string |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_key |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_address |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp) as
prim) l _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc prim 0 (List.length l))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
(Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_or |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_set |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_map |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_list |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_option |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_lambda |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_unit |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_signature |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_contract) _ _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Comparable_type_expected
loc (Micheline.strip_locations ty))
| expr =>
op_atat error
(unexpected expr []
Tezos_raw_protocol_alpha.Script_tc_errors.Type_namespace
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_int
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_string
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_key
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp
[])))))))))
end))
with parse_packable_ty
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
: Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
parse_ty ctxt legacy false false legacy
with parse_parameter_ty
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
: Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
parse_ty ctxt legacy true false true
with parse_any_ty
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
: Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
parse_ty ctxt legacy true true true
with parse_ty
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
(allow_big_map : bool) (allow_operation : bool) (allow_contract : bool)
(node : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
op_gtgtquestion (Gas.consume ctxt Typecheck_costs.cycle)
(fun ctxt =>
match node with
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_unit [] annot =>
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t ty_name)),
ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_int [] annot =>
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t ty_name)),
ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat [] annot =>
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t ty_name)),
ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_string [] annot =>
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.String_t ty_name)),
ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_bytes [] annot =>
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t ty_name)),
ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez [] annot =>
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t ty_name)),
ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool [] annot =>
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t ty_name)),
ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_key [] annot =>
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t ty_name)),
ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash [] annot =>
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t ty_name)),
ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp [] annot =>
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t ty_name)),
ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_address [] annot =>
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_t ty_name)),
ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_signature [] annot =>
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t ty_name)),
ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_operation [] annot =>
if allow_operation then
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t
ty_name)), ctxt)))
else
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_operation
loc)
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_chain_id [] annot =>
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t ty_name)),
ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_contract (cons utl [])
annot =>
if allow_contract then
op_gtgtquestion (parse_parameter_ty ctxt legacy utl)
(fun function_parameter =>
let '(Ex_ty tl, ctxt) := function_parameter in
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 1))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t tl
ty_name)), ctxt))))
else
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_contract
loc)
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair
(cons utl (cons utr [])) annot =>
op_gtgtquestion (extract_field_annot utl)
(fun function_parameter =>
let '(utl, left_field) := function_parameter in
op_gtgtquestion (extract_field_annot utr)
(fun function_parameter =>
let '(utr, right_field) := function_parameter in
op_gtgtquestion
(parse_ty ctxt legacy allow_big_map allow_operation
allow_contract utl)
(fun function_parameter =>
let '(Ex_ty tl, ctxt) := function_parameter in
op_gtgtquestion
(parse_ty ctxt legacy allow_big_map allow_operation
allow_contract utr)
(fun function_parameter =>
let '(Ex_ty tr, ctxt) := function_parameter in
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion
(Gas.consume ctxt (Typecheck_costs.type_ 2))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
(tl, left_field, None)
(tr, right_field, None) ty_name
(op_pipepipe (has_big_map tl)
(has_big_map tr)))), ctxt)))))))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_or
(cons utl (cons utr [])) annot =>
op_gtgtquestion (extract_field_annot utl)
(fun function_parameter =>
let '(utl, left_constr) := function_parameter in
op_gtgtquestion (extract_field_annot utr)
(fun function_parameter =>
let '(utr, right_constr) := function_parameter in
op_gtgtquestion
(parse_ty ctxt legacy allow_big_map allow_operation
allow_contract utl)
(fun function_parameter =>
let '(Ex_ty tl, ctxt) := function_parameter in
op_gtgtquestion
(parse_ty ctxt legacy allow_big_map allow_operation
allow_contract utr)
(fun function_parameter =>
let '(Ex_ty tr, ctxt) := function_parameter in
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion
(Gas.consume ctxt (Typecheck_costs.type_ 2))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t
(tl, left_constr) (tr, right_constr) ty_name
(op_pipepipe (has_big_map tl)
(has_big_map tr)))), ctxt)))))))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_lambda
(cons uta (cons utr [])) annot =>
op_gtgtquestion (parse_any_ty ctxt legacy uta)
(fun function_parameter =>
let '(Ex_ty ta, ctxt) := function_parameter in
op_gtgtquestion (parse_any_ty ctxt legacy utr)
(fun function_parameter =>
let '(Ex_ty tr, ctxt) := function_parameter in
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion
(Gas.consume ctxt (Typecheck_costs.type_ 2))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t ta
tr ty_name)), ctxt)))))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_option (cons ut [])
annot =>
op_gtgtquestion
(if legacy then
op_gtgtquestion (extract_field_annot ut)
(fun function_parameter =>
let '(ut, _some_constr) := function_parameter in
op_gtgtquestion (parse_composed_type_annot loc annot)
(fun function_parameter =>
let '(ty_name, _none_constr, _) := function_parameter in
ok (ut, ty_name)))
else
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name => ok (ut, ty_name)))
(fun function_parameter =>
let '(ut, ty_name) := function_parameter in
op_gtgtquestion
(parse_ty ctxt legacy allow_big_map allow_operation allow_contract
ut)
(fun function_parameter =>
let '(Ex_ty t, ctxt) := function_parameter in
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 2))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t
ty_name (has_big_map t))), ctxt))))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_list (cons ut [])
annot =>
op_gtgtquestion
(parse_ty ctxt legacy allow_big_map allow_operation allow_contract ut)
(fun function_parameter =>
let '(Ex_ty t, ctxt) := function_parameter in
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 1))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t t ty_name
(has_big_map t))), ctxt))))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_set (cons ut []) annot
=>
op_gtgtquestion (parse_comparable_ty ctxt ut)
(fun function_parameter =>
let '(Ex_comparable_ty t, ctxt) := function_parameter in
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 1))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_t t ty_name)),
ctxt))))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_map
(cons uta (cons utr [])) annot =>
op_gtgtquestion (parse_comparable_ty ctxt uta)
(fun function_parameter =>
let '(Ex_comparable_ty ta, ctxt) := function_parameter in
op_gtgtquestion
(parse_ty ctxt legacy allow_big_map allow_operation allow_contract
utr)
(fun function_parameter =>
let '(Ex_ty tr, ctxt) := function_parameter in
op_gtgtquestion (parse_type_annot loc annot)
(fun ty_name =>
op_gtpipequestion
(Gas.consume ctxt (Typecheck_costs.type_ 2))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_t ta tr
ty_name (has_big_map tr))), ctxt)))))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_big_map args annot =>
op_gtgtquestion (parse_big_map_ty ctxt legacy loc args annot)
(fun function_parameter =>
let '(big_map_ty, ctxt) := function_parameter in
op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 2))
(fun ctxt => (big_map_ty, ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_big_map _ _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_big_map
loc)
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
((Tezos_raw_protocol_alpha.Alpha_context.Script.T_unit |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_signature |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_int |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_string |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_bytes |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_key |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_address) as prim) l
_ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc prim 0 (List.length l))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
((Tezos_raw_protocol_alpha.Alpha_context.Script.T_set |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_list |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_option |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_contract) as prim) l
_ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc prim 1 (List.length l))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
((Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_or |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_map |
Tezos_raw_protocol_alpha.Alpha_context.Script.T_lambda) as prim) l _
=>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc prim 2 (List.length l))
| expr =>
op_atat error
(unexpected expr []
Tezos_raw_protocol_alpha.Script_tc_errors.Type_namespace
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_or
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_set
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_map
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_list
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_option
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_lambda
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_unit
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_signature
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_contract
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_int
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_operation
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_string
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_bytes
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_key
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.T_chain_id
[]))))))))))))))))))))))
end)
with parse_big_map_ty
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (legacy : bool)
(big_map_loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
(args :
list
(Tezos_protocol_environment_alpha__Environment.Micheline.node
Tezos_raw_protocol_alpha.Alpha_context.Script.location
Tezos_raw_protocol_alpha.Alpha_context.Script.prim))
(map_annot : Tezos_protocol_environment_alpha__Environment.Micheline.annot)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(ex_ty * Tezos_raw_protocol_alpha__Alpha_context.context) :=
op_gtgtquestion (Gas.consume ctxt Typecheck_costs.cycle)
(fun ctxt =>
match args with
| cons key_ty (cons value_ty []) =>
op_gtgtquestion (parse_comparable_ty ctxt key_ty)
(fun function_parameter =>
let '(Ex_comparable_ty key_ty, ctxt) := function_parameter in
op_gtgtquestion (parse_packable_ty ctxt legacy value_ty)
(fun function_parameter =>
let '(Ex_ty value_ty, ctxt) := function_parameter in
op_gtpipequestion (parse_type_annot big_map_loc map_annot)
(fun map_name =>
let big_map_ty :=
Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t key_ty
value_ty map_name in
((Ex_ty big_map_ty), ctxt))))
| args =>
op_atat error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
big_map_loc Tezos_raw_protocol_alpha.Alpha_context.Script.T_big_map
2 (List.length args))
end)
with parse_storage_ty
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
(node : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
match node with
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
big_map_loc Tezos_raw_protocol_alpha.Alpha_context.Script.T_big_map
args map_annot) (cons remaining_storage [])) storage_annot =>
match storage_annot with
| [] => parse_ty ctxt legacy true false legacy node
| cons single [] => parse_ty ctxt legacy true false legacy node
| _ =>
op_gtgtquestion (Gas.consume ctxt Typecheck_costs.cycle)
(fun ctxt =>
op_gtgtquestion
(parse_big_map_ty ctxt legacy big_map_loc args map_annot)
(fun function_parameter =>
let '(Ex_ty big_map_ty, ctxt) := function_parameter in
op_gtgtquestion
(parse_ty ctxt legacy true false legacy remaining_storage)
(fun function_parameter =>
let '(Ex_ty remaining_storage, ctxt) := function_parameter in
op_gtgtquestion (parse_composed_type_annot loc storage_annot)
(fun function_parameter =>
let '(ty_name, map_field, storage_field) :=
function_parameter in
op_gtpipequestion
(Gas.consume ctxt (Typecheck_costs.type_ 5))
(fun ctxt =>
((Ex_ty
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
(big_map_ty, map_field, None)
(remaining_storage, storage_field, None) ty_name
true)), ctxt))))))
end
| _ => parse_ty ctxt legacy true false legacy node
end.
Definition check_packable {A : Type}
(legacy : bool) (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
(root : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
let fix check {t : Type}
(function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.ty t)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
match function_parameter with
| Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _ _ _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_big_map
loc)
| Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_operation
loc)
| Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.String_t _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _ => ok tt
|
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (l_ty, _, _) (r_ty, _, _)
_ _ =>
op_gtgtquestion (check l_ty)
(fun function_parameter =>
let 'tt := function_parameter in
check r_ty)
| Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (l_ty, _) (r_ty, _) _ _
=>
op_gtgtquestion (check l_ty)
(fun function_parameter =>
let 'tt := function_parameter in
check r_ty)
| Tezos_raw_protocol_alpha.Script_typed_ir.Option_t v_ty _ _ => check v_ty
| Tezos_raw_protocol_alpha.Script_typed_ir.List_t elt_ty _ _ => check elt_ty
| Tezos_raw_protocol_alpha.Script_typed_ir.Set_t _ _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ elt_ty _ _ =>
check elt_ty
| Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t _l_ty _r_ty _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _ => ok tt
| Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_contract
loc)
end in
check root.
Inductive ex_script : Type :=
| Ex_script : forall {a c : Type},
(Tezos_raw_protocol_alpha.Script_typed_ir.script a c) -> ex_script.
Inductive dig_proof_argument : forall (_ : Type), Type :=
| Dig_proof_argument : forall {aft bef rest x : Type},
((Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
(x * rest) rest bef aft) *
((Tezos_raw_protocol_alpha.Script_typed_ir.ty x) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)) *
(Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft)) ->
dig_proof_argument bef.
Inductive dug_proof_argument : forall (_ _ : Type), Type :=
| Dug_proof_argument : forall {aft bef rest x : Type},
((Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
rest (x * rest) bef aft) * unit *
(Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft)) ->
dug_proof_argument bef x.
Inductive dipn_proof_argument : forall (_ : Type), Type :=
| Dipn_proof_argument : forall {aft bef faft fbef : Type},
((Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
fbef faft bef aft) *
(Tezos_raw_protocol_alpha.Alpha_context.context *
(Tezos_raw_protocol_alpha.Script_typed_ir.descr fbef faft)) *
(Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft)) ->
dipn_proof_argument bef.
Inductive dropn_proof_argument : forall (_ : Type), Type :=
| Dropn_proof_argument : forall {aft bef rest : Type},
((Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
rest rest bef aft) *
(Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty rest) *
(Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft)) ->
dropn_proof_argument bef.
Definition parse_var_annot
(loc : Z)
(default : option (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
(annot : list string)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)) :=
Lwt._return (parse_var_annot loc default annot).
Definition parse_entrypoint_annot
(loc : Z)
(default : option (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
(annot : list string)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))) :=
Lwt._return (parse_entrypoint_annot loc default annot).
Definition parse_constr_annot
(loc : Z)
(if_special_first :
option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
(if_special_second :
option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
(annot : list string)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))) :=
Lwt._return (parse_constr_annot loc if_special_first if_special_second annot).
Definition parse_two_var_annot (loc : Z) (annot : list string)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))) :=
Lwt._return (parse_two_var_annot loc annot).
Definition parse_destr_annot
(loc : Z) (annot : list string)
(default_accessor :
option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
(field_name : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
(pair_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
(value_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))) :=
Lwt._return
(parse_destr_annot loc annot default_accessor field_name pair_annot
value_annot).
Definition parse_var_type_annot (loc : Z) (annot : list string)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot))) :=
Lwt._return (parse_var_type_annot loc annot).
Definition find_entrypoint {A : Type}
(full : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
(root_name :
option
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(entrypoint :
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
Tezos_raw_protocol_alpha.Alpha_context.Script.node) * ex_ty) :=
let fix find_entrypoint {t : Type}
(t : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) (entrypoint : string)
: (Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
Tezos_raw_protocol_alpha.Alpha_context.Script.node) * ex_ty :=
match t with
| Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tl, al) (tr, ar) _ _ =>
if
match al with
| None => false
| Some (Field_annot l) =>
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
l entrypoint
end then
((fun e =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left (cons e []) []),
(Ex_ty tl))
else
if
match ar with
| None => false
| Some (Field_annot r) =>
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
r entrypoint
end then
((fun e =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right (cons e [])
[]), (Ex_ty tr))
else
(* ❌ Try-with are not handled *)
try
(let '(f, t) := find_entrypoint tl entrypoint in
((fun e =>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left
(cons (f e) []) []), t))
| _ => raise OCaml.Not_found
end in
let entrypoint :=
if
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
entrypoint "" % string then
"default" % string
else
entrypoint in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
(String.length entrypoint) 31 then
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Entrypoint_name_too_long
entrypoint)
else
match root_name with
| Some root_name => ok ((fun e => e), (Ex_ty full))
| _ =>
(* ❌ Try-with are not handled *)
try (ok (find_entrypoint full entrypoint))
end.
Definition find_entrypoint_for_type {A B : Type}
(full : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
(expected : Tezos_raw_protocol_alpha.Script_typed_ir.ty B)
(root_name :
option
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(entrypoint :
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.context * string *
(Tezos_raw_protocol_alpha.Script_typed_ir.ty B)) :=
match (entrypoint, root_name) with
| ("default" % string, Some "root" % string) =>
match find_entrypoint full root_name entrypoint with
| (Tezos_protocol_environment_alpha__Environment.Pervasives.Error _) as err
=> err
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok (_, Ex_ty ty)
=>
match ty_eq ctxt expected ty with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok (Eq, ctxt)
=> ok (ctxt, "default" % string, ty)
| Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ =>
op_gtgtquestion (ty_eq ctxt expected full)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok (ctxt, "root" % string, full))
end
end
| _ =>
op_gtgtquestion (find_entrypoint full root_name entrypoint)
(fun function_parameter =>
let '(_, Ex_ty ty) := function_parameter in
op_gtgtquestion (ty_eq ctxt expected ty)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok (ctxt, entrypoint, ty)))
end.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ The definition of exceptions is not handled. *)
exception
(* ❌ The definition of exceptions is not handled. *)
exception
Definition well_formed_entrypoints {A : Type}
(full : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
(root_name :
option Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.elt))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
let merge {B C : Type}
(path : list B) (annot : option variant) (ty :
Tezos_raw_protocol_alpha.Script_typed_ir.ty C) (reachable : bool)
(function_parameter :
(option (list B)) *
Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
: (option (list B)) *
Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.t) :=
let '(first_unreachable, all) as acc := function_parameter in
match annot with
| None | Some (Field_annot "" % string) =>
if reachable then
acc
else
match ty with
| Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ _ => acc
| _ =>
match first_unreachable with
| None => ((Some (List.rev path)), all)
| Some _ => acc
end
end
| Some (Field_annot name) =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
(String.length name) 31 then
raise (Too_long name)
else
if
Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.mem)
name all then
raise (Duplicate name)
else
(first_unreachable,
(Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.add)
name all))
end in
let fix check {t : Type}
(t : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) (path :
list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (reachable : bool)
(acc :
(option (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
: (option (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.t) :=
match t with
| Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tl, al) (tr, ar) _ _ =>
let acc :=
merge (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left path)
al tl reachable acc in
let acc :=
merge (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right path)
ar tr reachable acc in
let acc :=
check tl
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left path)
match al with
| Some _ => true
| None => reachable
end acc in
check tr (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right path)
match ar with
| Some _ => true
| None => reachable
end acc
| _ => acc
end in
(* ❌ Try-with are not handled *)
try
(let '(init, reachable) :=
match root_name with
| None | Some "" % string =>
(Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.empty),
false)
| Some name =>
((Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.singleton)
name), true)
end in
let '(first_unreachable, all) := check full [] reachable (None, init) in
if
not
(Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.mem)
"default" % string all) then
ok tt
else
match first_unreachable with
| None => ok tt
| Some path =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unreachable_entrypoint
path)
end).
Fixpoint parse_data {a : Type}
(type_logger : option type_logger)
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
(ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
(script_data : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(a * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
let error (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
let 'tt := function_parameter in
op_gtgtpipequestion (Lwt._return (serialize_ty_for_error ctxt ty))
(fun function_parameter =>
let '(ty, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_constant
(location script_data) (strip_locations script_data) ty) in
let traced {B : Type}
(body :
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
trace_eval error body in
let parse_items {B C D E : Type}
(type_logger : option type_logger) (loc :
Tezos_raw_protocol_alpha.Alpha_context.Script.location) (ctxt :
Tezos_raw_protocol_alpha__Alpha_context.context) (expr :
Tezos_protocol_environment_alpha__Environment.Micheline.node B
Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (key_type :
Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty C) (value_type :
Tezos_raw_protocol_alpha.Script_typed_ir.ty D) (items :
list
(Tezos_protocol_environment_alpha__Environment.Micheline.node
Tezos_raw_protocol_alpha.Alpha_context.Script.location
Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) (item_wrapper :
D -> E)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_raw_protocol_alpha.Script_typed_ir.map C E) *
Tezos_raw_protocol_alpha__Alpha_context.context)) :=
let length := List.length items in
op_gtgtpipequestion
(op_pipegt
(fold_left_s
(fun function_parameter =>
let '(last_value, map, ctxt) := function_parameter in
fun item =>
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Typecheck_costs.map_element length)))
(fun ctxt =>
match item with
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim
_ Tezos_raw_protocol_alpha.Alpha_context.Script.D_Elt
(cons k (cons v [])) _ =>
op_gtgteqquestion
(parse_comparable_data type_logger ctxt key_type k)
(fun function_parameter =>
let '(k, ctxt) := function_parameter in
op_gtgteqquestion
(parse_data type_logger ctxt legacy value_type v)
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
op_gtgteqquestion
match last_value with
| Some value =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
0 (compare_comparable key_type value k)
then
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
0
(compare_comparable key_type value k)
then
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_map_keys
loc (strip_locations expr))
else
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unordered_map_keys
loc (strip_locations expr))
else
return_unit
| None => return_unit
end
(fun function_parameter =>
let 'tt := function_parameter in
_return
((Some k),
(map_update k (Some (item_wrapper v))
map), ctxt))))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim
loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Elt l
_ =>
op_atat fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Elt
2 (List.length l))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim
loc name _ _ =>
op_atat fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive
loc
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Elt
[]) name)
|
Tezos_protocol_environment_alpha__Environment.Micheline.Int
_ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.String
_ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
_ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Seq
_ _ => op_gtgteqquestion (error tt) fail
end)) (None, (empty_map key_type), ctxt) items) traced)
(fun function_parameter =>
let '(_, items, ctxt) := function_parameter in
(items, ctxt)) in
match (ty, script_data) with
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Unit [] annot) =>
op_gtgteqquestion
(if legacy then
_return tt
else
fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtpipequestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.unit))
(fun ctxt => (tt, ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Unit l _) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc Tezos_raw_protocol_alpha.Alpha_context.Script.D_Unit 0
(List.length l)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _, expr) =>
traced
(fail
(unexpected expr []
Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Unit [])))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_True [] annot) =>
op_gtgteqquestion
(if legacy then
_return tt
else
fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtpipequestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.bool))
(fun ctxt => (true, ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_False [] annot) =>
op_gtgteqquestion
(if legacy then
_return tt
else
fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtpipequestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.bool))
(fun ctxt => (false, ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
((Tezos_raw_protocol_alpha.Alpha_context.Script.D_True |
Tezos_raw_protocol_alpha.Alpha_context.Script.D_False) as c) l _)
=>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc c 0 (List.length l)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _, expr) =>
traced
(fail
(unexpected expr []
Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_True
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_False []))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.String_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.String _ v) =>
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Typecheck_costs.string (String.length v))))
(fun ctxt =>
let fix check_printable_ascii
(i :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: bool :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
i 0 then
true
else
match String.get v i with
|
"010" % char |
" " % char |
"!" % char |
"""" % char |
"#" % char |
"$" % char |
"%" % char |
"&" % char |
"'" % char |
"(" % char |
")" % char |
"*" % char |
"+" % char |
"," % char |
"-" % char |
"." % char |
"/" % char |
"0" % char |
"1" % char |
"2" % char |
"3" % char |
"4" % char |
"5" % char |
"6" % char |
"7" % char |
"8" % char |
"9" % char
|
":" %
char |
";" %
char
|
"<"
%
char
|
"="
%
char
|
">"
%
char
|
"?"
%
char
|
"@"
%
char
|
"A"
%
char
|
"B"
%
char
|
"C"
%
char
|
"D"
%
char
|
"E"
%
char
|
"F"
%
char
|
"G"
%
char
|
"H"
%
char
|
"I"
%
char
|
"J"
%
char
|
"K"
%
char
|
"L"
%
char
|
"M"
%
char
|
"N"
%
char
|
"O"
%
char
|
"P"
%
char
|
"Q"
%
char
|
"R"
%
char
|
"S"
%
char
|
"T"
%
char
|
"U"
%
char
|
"V"
%
char
|
"W"
%
char
|
"X"
%
char
|
"Y"
%
char
|
"Z"
%
char
|
"["
%
char
|
"\"
%
char
|
"]"
%
char
|
"^"
%
char
|
"_"
%
char
|
"`"
%
char
|
"a"
%
char
|
"b"
%
char
|
"c"
%
char
|
"d"
%
char
|
"e"
%
char
|
"f"
%
char
|
"g"
%
char
|
"h"
%
char
|
"i"
%
char
|
"j"
%
char
|
"k"
%
char
|
"l"
%
char
|
"m"
%
char
|
"n"
%
char
|
"o"
%
char
|
"p"
%
char
|
"q"
%
char
|
"r"
%
char
|
"s"
%
char
|
"t"
%
char
|
"u"
%
char
|
"v"
%
char
|
"w"
%
char
|
"x"
%
char
|
"y"
%
char
|
"z"
%
char
|
"{"
%
char
|
"|"
%
char
|
"}"
%
char
|
"~"
%
char
=> check_printable_ascii (op_minus i 1)
| _ => false
end in
if check_printable_ascii (op_minus (String.length v) 1) then
_return (v, ctxt)
else
op_gtgteqquestion (error tt) fail)
| (Tezos_raw_protocol_alpha.Script_typed_ir.String_t _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind [])
(kind expr)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ v) =>
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Typecheck_costs.string (MBytes.length v))))
(fun ctxt => _return (v, ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind [])
(kind expr)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Int _ v) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt (Typecheck_costs.z v)))
(fun ctxt => _return ((Script_int.of_zint v), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Int _ v) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt (Typecheck_costs.z v)))
(fun ctxt =>
let v := Script_int.of_zint v in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
(Script_int.compare v Script_int.zero) 0 then
_return ((Script_int.abs v), ctxt)
else
op_gtgteqquestion (error tt) fail)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind [])
(kind expr)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind [])
(kind expr)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Int _ v) =>
op_gtgteqquestion
(Lwt._return
(op_gtgtquestion (Gas.consume ctxt Typecheck_costs.tez)
(fun ctxt =>
Gas.consume ctxt Michelson_v1_gas.Cost_of.Legacy.z_to_int64)))
(fun ctxt =>
(* ❌ Try-with are not handled *)
try
match Tez.of_mutez (Z.to_int64 v) with
| None => raise Exit
| Some tez => _return (tez, ctxt)
end)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind [])
(kind expr)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Int _ v) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt (Typecheck_costs.z v)))
(fun ctxt => _return ((Script_timestamp.of_zint v), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.String _ s) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.string_timestamp))
(fun ctxt =>
match Script_timestamp.of_string s with
| Some v => _return (v, ctxt)
| None => op_gtgteqquestion (error tt) fail
end)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind []))
(kind expr)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ bytes)
=>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Typecheck_costs.key))
(fun ctxt =>
match
Data_encoding.Binary.of_bytes Signature.Public_key.encoding string
with
| Some k => _return (k, ctxt)
| None => op_gtgteqquestion (error tt) fail
end)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.String _ s) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Typecheck_costs.key))
(fun ctxt =>
match Signature.Public_key.of_b58check_opt s with
| Some k => _return (k, ctxt)
| None => op_gtgteqquestion (error tt) fail
end)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind []))
(kind expr)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ bytes)
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.key_hash))
(fun ctxt =>
match
Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding
string with
| Some k => _return (k, ctxt)
| None => op_gtgteqquestion (error tt) fail
end)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.String _ s) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.key_hash))
(fun ctxt =>
match Signature.Public_key_hash.of_b58check_opt s with
| Some k => _return (k, ctxt)
| None => op_gtgteqquestion (error tt) fail
end)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind []))
(kind expr)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ bytes)
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.signature))
(fun ctxt =>
match Data_encoding.Binary.of_bytes Signature.encoding string with
| Some k => _return (k, ctxt)
| None => op_gtgteqquestion (error tt) fail
end)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.String _ s) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.signature))
(fun ctxt =>
match Signature.of_b58check_opt s with
| Some s => _return (s, ctxt)
| None => op_gtgteqquestion (error tt) fail
end)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind []))
(kind expr)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _, _) =>
(* ❌ Assert instruction is not handled. *)
assert false
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ bytes)
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.chain_id))
(fun ctxt =>
match
Data_encoding.Binary.of_bytes
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)
string with
| Some k => _return (k, ctxt)
| None => op_gtgteqquestion (error tt) fail
end)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.String _ s) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.chain_id))
(fun ctxt =>
match
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.of_b58check_opt)
s with
| Some s => _return (s, ctxt)
| None => op_gtgteqquestion (error tt) fail
end)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind []))
(kind expr)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes loc
bytes) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.contract))
(fun ctxt =>
match
Data_encoding.Binary.of_bytes
(tup2 Contract.encoding Variable.string) string with
| Some (c, entrypoint) =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
(String.length entrypoint) 31 then
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Entrypoint_name_too_long
entrypoint)
else
op_gtgteqquestion
match entrypoint with
| "" % string => _return "default" % string
| "default" % string =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc)
| name => _return name
end (fun entrypoint => _return ((c, entrypoint), ctxt))
| None => op_gtgteqquestion (error tt) fail
end)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _,
Tezos_protocol_environment_alpha__Environment.Micheline.String loc s)
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.contract))
(fun ctxt =>
op_gtgteqquestion
match String.index_opt s "%" % char with
| None => _return (s, "default" % string)
| Some pos =>
let len := op_minus (op_minus (String.length s) pos) 1 in
let name := String.sub s (op_plus pos 1) len in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
len 31 then
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Entrypoint_name_too_long
name)
else
match ((String.sub s 0 pos), name) with
| (_, "default" % string) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc))
| addr_and_name => _return addr_and_name
end
end
(fun function_parameter =>
let '(addr, entrypoint) := function_parameter in
op_gtgteqquestion (Lwt._return (Contract.of_b58check addr))
(fun c => _return ((c, entrypoint), ctxt))))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind []))
(kind expr)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t ty _,
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes loc
bytes) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.contract))
(fun ctxt =>
match
Data_encoding.Binary.of_bytes
(tup2 Contract.encoding Variable.string) string with
| Some (c, entrypoint) =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
(String.length entrypoint) 31 then
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Entrypoint_name_too_long
entrypoint)
else
op_gtgteqquestion
match entrypoint with
| "" % string => _return "default" % string
| "default" % string =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc))
| name => _return name
end
(fun entrypoint =>
op_gtgteqquestion
(traced (parse_contract legacy ctxt loc ty c entrypoint))
(fun function_parameter =>
let '(ctxt, _) := function_parameter in
_return ((ty, (c, entrypoint)), ctxt)))
| None => op_gtgteqquestion (error tt) fail
end)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t ty _,
Tezos_protocol_environment_alpha__Environment.Micheline.String loc s)
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.contract))
(fun ctxt =>
op_gtgteqquestion
match String.index_opt s "%" % char with
| None => _return (s, "default" % string)
| Some pos =>
let len := op_minus (op_minus (String.length s) pos) 1 in
let name := String.sub s (op_plus pos 1) len in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
len 31 then
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Entrypoint_name_too_long
name)
else
match ((String.sub s 0 pos), name) with
| (_, "default" % string) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc))
| addr_and_name => _return addr_and_name
end
end
(fun function_parameter =>
let '(addr, entrypoint) := function_parameter in
op_gtgteqquestion
(traced (Lwt._return (Contract.of_b58check addr)))
(fun c =>
op_gtgteqquestion
(parse_contract legacy ctxt loc ty c entrypoint)
(fun function_parameter =>
let '(ctxt, _) := function_parameter in
_return ((ty, (c, entrypoint)), ctxt)))))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind []))
(kind expr)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (ta, _, _) (tb, _, _) _
_,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Pair
(cons va (cons vb [])) annot) =>
op_gtgteqquestion
(if legacy then
_return tt
else
fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.pair))
(fun ctxt =>
op_gtgteqquestion
(op_atat traced (parse_data type_logger ctxt legacy ta va))
(fun function_parameter =>
let '(va, ctxt) := function_parameter in
op_gtgteqquestion (parse_data type_logger ctxt legacy tb vb)
(fun function_parameter =>
let '(vb, ctxt) := function_parameter in
_return ((va, vb), ctxt)))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t _ _ _ _,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Pair l _) =>
op_atat fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc Tezos_raw_protocol_alpha.Alpha_context.Script.D_Pair 2
(List.length l))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t _ _ _ _, expr) =>
traced
(fail
(unexpected expr []
Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Pair [])))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tl, _) _ _ _,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left (cons v [])
annot) =>
op_gtgteqquestion
(if legacy then
_return tt
else
fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.union))
(fun ctxt =>
op_gtgteqquestion
(op_atat traced (parse_data type_logger ctxt legacy tl v))
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
_return
((Tezos_raw_protocol_alpha.Script_typed_ir.L v), ctxt))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ _,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left l _) =>
op_atat fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left 1
(List.length l))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ (tr, _) _ _,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right (cons v [])
annot) =>
op_gtgteqquestion (fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.union))
(fun ctxt =>
op_gtgteqquestion
(op_atat traced (parse_data type_logger ctxt legacy tr v))
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
_return
((Tezos_raw_protocol_alpha.Script_typed_ir.R v), ctxt))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ _,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right l _) =>
op_atat fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right 1
(List.length l))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ _, expr) =>
traced
(fail
(unexpected expr []
Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right []))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t ta tr _ty_name,
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq _loc _)
as script_instr) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.lambda))
(fun ctxt =>
op_atat traced
(parse_returning type_logger Lambda ctxt legacy
(ta,
(Some
(* ❌ Variants not supported *)
variant)) tr script_instr))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t _ _ _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
(kind expr)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t _ _,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Some (cons v [])
annot) =>
op_gtgteqquestion
(if legacy then
_return tt
else
fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.some))
(fun ctxt =>
op_gtgteqquestion
(op_atat traced (parse_data type_logger ctxt legacy t v))
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
_return ((Some v), ctxt))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ _,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Some l _) =>
op_atat fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc Tezos_raw_protocol_alpha.Alpha_context.Script.D_Some 1
(List.length l))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ _,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_None [] annot) =>
op_gtgteqquestion
(if legacy then
_return tt
else
fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.none))
(fun ctxt => _return (None, ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ _,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.D_None l _) =>
op_atat fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc Tezos_raw_protocol_alpha.Alpha_context.Script.D_None 0
(List.length l))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ _, expr) =>
traced
(fail
(unexpected expr []
Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Some
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_None []))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t t _ty_name _,
Tezos_protocol_environment_alpha__Environment.Micheline.Seq _loc items)
=>
op_atat traced
(fold_right_s
(fun v =>
fun function_parameter =>
let '(rest, ctxt) := function_parameter in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.list_element))
(fun ctxt =>
op_gtgteqquestion (parse_data type_logger ctxt legacy t v)
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
_return ((cons v rest), ctxt)))) items ([], ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.List_t _ _ _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
(kind expr)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_t t _ty_name,
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc vs)
as expr) =>
let length := List.length vs in
op_gtgtpipequestion
(op_atat traced
(fold_left_s
(fun function_parameter =>
let '(last_value, set, ctxt) := function_parameter in
fun v =>
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Typecheck_costs.set_element length)))
(fun ctxt =>
op_gtgteqquestion
(parse_comparable_data type_logger ctxt t v)
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
op_gtgteqquestion
match last_value with
| Some value =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
0 (compare_comparable t value v) then
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
0 (compare_comparable t value v) then
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_set_values
loc (strip_locations expr))
else
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unordered_set_values
loc (strip_locations expr))
else
return_unit
| None => return_unit
end
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Legacy.set_update
v false set)))
(fun ctxt =>
_return
((Some v), (set_update v true set), ctxt))))))
(None, (empty_set t), ctxt) vs))
(fun function_parameter =>
let '(_, set, ctxt) := function_parameter in
(set, ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t _ _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
(kind expr)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_t tk tv _ty_name _,
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc vs)
as expr) =>
parse_items type_logger loc ctxt expr tk tv vs (fun x => x)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ _ _ _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
(kind expr)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tk tv _ty_name,
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc vs)
as expr) =>
op_gtgtpipequestion
(parse_items type_logger loc ctxt expr tk tv vs (fun x => Some x))
(fun function_parameter =>
let '(diff, ctxt) := function_parameter in
({| id := None; diff := diff; key_type := ty_of_comparable_ty tk;
value_type := tv |}, ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tk tv _ty_name,
Tezos_protocol_environment_alpha__Environment.Micheline.Int loc id) =>
op_gtgteqquestion (Big_map._exists ctxt id)
(fun function_parameter =>
match function_parameter with
| (_, None) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_big_map
loc id))
| (ctxt, Some (btk, btv)) =>
Lwt._return
(op_gtgtquestion (parse_comparable_ty ctxt (Micheline.root btk))
(fun function_parameter =>
let '(Ex_comparable_ty btk, ctxt) := function_parameter in
op_gtgtquestion
(parse_packable_ty ctxt legacy (Micheline.root btv))
(fun function_parameter =>
let '(Ex_ty btv, ctxt) := function_parameter in
op_gtgtquestion (comparable_ty_eq ctxt tk btk)
(fun function_parameter =>
let 'Eq := function_parameter in
op_gtgtquestion (ty_eq ctxt tv btv)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
ok
({| id := Some id; diff := empty_map tk;
key_type := ty_of_comparable_ty tk;
value_type := tv |}, ctxt))))))
end)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _tk _tv _, expr) =>
traced
(fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
(location expr)
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind []))
(kind expr)))
end)
with parse_comparable_data {a : Type}
(type_logger : option type_logger)
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a)
(script_data : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(a * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
parse_data type_logger ctxt false (ty_of_comparable_ty ty) script_data
with parse_returning {arg ret : Type}
(type_logger : option type_logger) (tc_context : tc_context)
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
(function_parameter :
(Tezos_raw_protocol_alpha.Script_typed_ir.ty arg) *
(option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
: (Tezos_raw_protocol_alpha.Script_typed_ir.ty ret) ->
Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_raw_protocol_alpha.Script_typed_ir.lambda arg ret) *
Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let '(arg, arg_annot) := function_parameter in
fun ret =>
fun script_instr =>
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy script_instr
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t arg
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t arg_annot))
(fun function_parameter =>
match function_parameter with
|
(Typed
({|
loc := loc;
aft :=
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
ty
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
_) as stack_ty
|} as descr), ctxt) =>
trace_eval
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Lwt._return (serialize_ty_for_error ctxt ret))
(fun function_parameter =>
let '(ret, ctxt) := function_parameter in
op_gtgtpipequestion
(serialize_stack_for_error ctxt stack_ty)
(fun function_parameter =>
let '(stack_ty, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_return
loc stack_ty ret)))
(op_gtgteqquestion (Lwt._return (ty_eq ctxt ty ret))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgteqquestion
(Lwt._return (merge_types legacy ctxt loc ty ret))
(fun function_parameter =>
let '(_ret, ctxt) := function_parameter in
_return
((Tezos_raw_protocol_alpha.Script_typed_ir.Lam descr
script_instr), ctxt))))
| (Typed {| loc := loc; aft := stack_ty |}, ctxt) =>
op_gtgteqquestion (Lwt._return (serialize_ty_for_error ctxt ret))
(fun function_parameter =>
let '(ret, ctxt) := function_parameter in
op_gtgteqquestion (serialize_stack_for_error ctxt stack_ty)
(fun function_parameter =>
let '(stack_ty, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_return
loc stack_ty ret)))
| (Failed {| descr := descr |}, ctxt) =>
_return
((Tezos_raw_protocol_alpha.Script_typed_ir.Lam
(descr
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ret
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t None))
script_instr), ctxt)
end)
with parse_int32
(n :
Tezos_protocol_environment_alpha__Environment.Micheline.node
Tezos_raw_protocol_alpha.Alpha_context.Script.location
Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z :=
let error' (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Error_monad.error :=
let 'tt := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_syntactic_constant
(location n) (strip_locations n)
(op_caret "a positive 32-bit integer (between 0 and " % string
(op_caret (Int32.to_string Int32.max_int) ")" % string)) in
match n with
| Tezos_protocol_environment_alpha__Environment.Micheline.Int _ n' =>
(* ❌ Try-with are not handled *)
try
(let n'' := Z.to_int n' in
if
op_andand
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
0 n'')
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
n'' (Int32.to_int Int32.max_int)) then
ok n''
else
op_atat error (error' tt))
| _ => op_atat error (error' tt)
end
with parse_instr {bef : Type}
(type_logger : option type_logger) (tc_context : tc_context)
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
(script_instr : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
(stack_ty : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty bef)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((judgement bef) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let _check_item {B : Type}
(check :
Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) (loc :
Tezos_raw_protocol_alpha.Alpha_context.Script.location) (name :
Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (n : Z) (m : Z)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
op_atat
(trace_eval
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtpipequestion (serialize_stack_for_error ctxt stack_ty)
(fun function_parameter =>
let '(stack_ty, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc name m stack_ty)))
(op_atat
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack_item
n)) (Lwt._return check)) in
let check_item_ty {B C : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (exp :
Tezos_raw_protocol_alpha.Script_typed_ir.ty B) (got :
Tezos_raw_protocol_alpha.Script_typed_ir.ty C) (loc :
Tezos_raw_protocol_alpha.Alpha_context.Script.location) (name :
Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (n : Z) (m : Z)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((eq B C) * (Tezos_raw_protocol_alpha.Script_typed_ir.ty B) *
Tezos_raw_protocol_alpha.Alpha_context.context)) :=
op_atat
(trace_eval
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtpipequestion (serialize_stack_for_error ctxt stack_ty)
(fun function_parameter =>
let '(stack_ty, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc name m stack_ty)))
(op_atat
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack_item
n))
(Lwt._return
(op_gtgtquestion (ty_eq ctxt exp got)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgtquestion (merge_types legacy ctxt loc exp got)
(fun function_parameter =>
let '(ty, ctxt) := function_parameter in
ok (Eq, ty, ctxt)))))) in
let check_item_comparable_ty {B C : Type}
(exp : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty B) (got :
Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty C) (loc :
Tezos_raw_protocol_alpha.Alpha_context.Script.location) (name :
Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (n : Z) (m : Z)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((eq B C) * (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty B))) :=
op_atat
(trace_eval
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtpipequestion (serialize_stack_for_error ctxt stack_ty)
(fun function_parameter =>
let '(stack_ty, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc name m stack_ty)))
(op_atat
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack_item
n))
(Lwt._return
(op_gtgtquestion (comparable_ty_eq ctxt exp got)
(fun function_parameter =>
let 'Eq := function_parameter in
op_gtgtquestion (merge_comparable_types legacy exp got)
(fun ty => ok (Eq, ty)))))) in
let log_stack {B C : Type}
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (loc : Z) (stack_ty
: Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B) (aft :
Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty C)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
match (type_logger, script_instr) with
|
(None, _) |
(Some _,
Tezos_protocol_environment_alpha__Environment.Micheline.Seq (-1) _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Int _ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.String _ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ _)
=> return_unit
|
(Some log,
Tezos_protocol_environment_alpha__Environment.Micheline.Prim _ _ _ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ _) =>
let ctxt := Gas.set_unlimited ctxt in
op_gtgteqquestion (unparse_stack ctxt stack_ty)
(fun function_parameter =>
let '(stack_ty, _) := function_parameter in
op_gtgteqquestion (unparse_stack ctxt aft)
(fun function_parameter =>
let '(aft, _) := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := log loc stack_ty aft in
return_unit))
end in
let outer_return := _return in
let _return
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (judgement :
judgement bef)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((judgement bef) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
match judgement with
| Typed {| loc := loc; aft := aft; instr := instr |} =>
let maximum_type_size := Constants.michelson_maximum_type_size ctxt in
let type_size :=
type_size_of_stack_head aft (number_of_generated_growing_types instr) in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
type_size maximum_type_size then
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Type_too_large
loc type_size maximum_type_size)
else
_return (judgement, ctxt)
| Failed _ => _return (judgement, ctxt)
end in
let typed {B : Type}
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (loc : Z) (instr :
Tezos_raw_protocol_alpha.Script_typed_ir.instr bef B) (aft :
Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((judgement bef) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
op_gtgteqquestion (log_stack ctxt loc stack_ty aft)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return (Gas.consume ctxt (Typecheck_costs.instr instr)))
(fun ctxt =>
_return ctxt
(Typed
{| loc := loc; bef := stack_ty; aft := aft; instr := instr |})))
in
op_gtgteqquestion
(op_atat Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
match (script_instr, stack_ty) with
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t _ rest _) =>
op_gtgteqquestion (fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Drop rest)
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP (cons n [])
result_annot, whole_stack) =>
op_gtgteqquestion (Lwt._return (parse_int32 n))
(fun whole_n =>
let fix make_proof_argument {tstk : Type}
(n : Z) (stk :
Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tstk)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(dropn_proof_argument tstk)) :=
match
((Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
n 0), stk) with
| (true, rest) =>
op_atat outer_return
(Dropn_proof_argument
(Tezos_raw_protocol_alpha.Script_typed_ir.Rest, rest, rest))
|
(false,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest annot)
=>
op_gtgteqquestion (make_proof_argument (op_minus n 1) rest)
(fun function_parameter =>
let 'Dropn_proof_argument (n', stack_after_drops, aft') :=
function_parameter in
op_atat outer_return
(Dropn_proof_argument
((Tezos_raw_protocol_alpha.Script_typed_ir.Prefix n'),
stack_after_drops,
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v
aft' annot))))
| (_, _) =>
op_gtgteqquestion (serialize_stack_for_error ctxt whole_stack)
(fun function_parameter =>
let '(whole_stack, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP
whole_n whole_stack))
end in
op_gtgteqquestion (fail_unexpected_annot loc result_annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (make_proof_argument whole_n whole_stack)
(fun function_parameter =>
let 'Dropn_proof_argument (n', stack_after_drops, _aft) :=
function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Dropn whole_n n')
stack_after_drops)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP
((cons _ (cons _ _)) as l) _, _) =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP 1
(List.length l))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUP [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest stack_annot) =>
op_gtgteqquestion (parse_var_annot loc (Some stack_annot) annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Dup
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest
stack_annot) annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIG (cons n [])
result_annot, stack) =>
let fix make_proof_argument {tstk : Type}
(n : Z) (stk : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tstk)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(dig_proof_argument tstk)) :=
match
((Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
n 0), stk) with
| (true, Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest annot)
=>
op_atat outer_return
(Dig_proof_argument
(Tezos_raw_protocol_alpha.Script_typed_ir.Rest, (v, annot), rest))
|
(false, Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest annot)
=>
op_gtgteqquestion (make_proof_argument (op_minus n 1) rest)
(fun function_parameter =>
let 'Dig_proof_argument (n', (x, xv), aft') :=
function_parameter in
op_atat outer_return
(Dig_proof_argument
((Tezos_raw_protocol_alpha.Script_typed_ir.Prefix n'),
(x, xv),
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v aft'
annot))))
| (_, _) =>
op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(whole_stack, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIG 1
whole_stack))
end in
op_gtgteqquestion (Lwt._return (parse_int32 n))
(fun n =>
op_gtgteqquestion (fail_unexpected_annot loc result_annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (make_proof_argument n stack)
(fun function_parameter =>
let 'Dig_proof_argument (n', (x, stack_annot), aft) :=
function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Dig n n')
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t x aft
stack_annot))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIG
(([] | cons _ (cons _ _)) as l) _, _) =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIG 1
(List.length l))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG (cons n [])
result_annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t x whole_stack
stack_annot) =>
op_gtgteqquestion (Lwt._return (parse_int32 n))
(fun whole_n =>
let fix make_proof_argument {tstk x : Type}
(n : Z) (x : Tezos_raw_protocol_alpha.Script_typed_ir.ty x)
(stack_annot :
option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) (stk :
Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tstk)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(dug_proof_argument tstk x)) :=
match
((Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
n 0), stk) with
| (true, rest) =>
op_atat outer_return
(Dug_proof_argument
(Tezos_raw_protocol_alpha.Script_typed_ir.Rest, tt,
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t x rest
stack_annot)))
|
(false,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest annot)
=>
op_gtgteqquestion
(make_proof_argument (op_minus n 1) x stack_annot rest)
(fun function_parameter =>
let 'Dug_proof_argument (n', tt, aft') := function_parameter
in
op_atat outer_return
(Dug_proof_argument
((Tezos_raw_protocol_alpha.Script_typed_ir.Prefix n'),
tt,
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v
aft' annot))))
| (_, _) =>
op_gtgteqquestion (serialize_stack_for_error ctxt whole_stack)
(fun function_parameter =>
let '(whole_stack, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG
whole_n whole_stack))
end in
op_gtgteqquestion (fail_unexpected_annot loc result_annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(make_proof_argument whole_n x stack_annot whole_stack)
(fun function_parameter =>
let 'Dug_proof_argument (n', tt, aft) := function_parameter
in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Dug whole_n n')
aft)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG (cons _ [])
result_annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t as stack) =>
op_gtgteqquestion (fail_unexpected_annot loc result_annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG 1
stack)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG
(([] | cons _ (cons _ _)) as l) _, _) =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG 1
(List.length l))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SWAP [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t w rest stack_annot)
cur_top_annot) =>
op_gtgteqquestion (fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Swap
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t w
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest
cur_top_annot) stack_annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_PUSH
(cons t (cons d [])) annot, stack) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (parse_packable_ty ctxt legacy t))
(fun function_parameter =>
let '(Ex_ty t, ctxt) := function_parameter in
op_gtgteqquestion (parse_data type_logger ctxt legacy t d)
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Const v)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t stack
annot))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UNIT [] annot, stack)
=>
op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, ty_name) := function_parameter in
typed ctxt loc (Tezos_raw_protocol_alpha.Script_typed_ir.Const tt)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t ty_name) stack
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOME [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t rest _) =>
op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, ty_name) := function_parameter in
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Cons_some
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t ty_name
(has_big_map t)) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NONE (cons t []) annot,
stack) =>
op_gtgteqquestion (op_atat Lwt._return (parse_any_ty ctxt legacy t))
(fun function_parameter =>
let '(Ex_ty t, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, ty_name) := function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Cons_none t)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t ty_name
(has_big_map t)) stack annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_NONE
(cons bt (cons bf [])) annot,
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t _ _) rest
option_annot) as bef) =>
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bf)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
let annot :=
gen_access_annot option_annot None default_some_annot in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bt rest)
(fun function_parameter =>
let '(btr, ctxt) := function_parameter in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bf
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t
rest annot))
(fun function_parameter =>
let '(bfr, ctxt) := function_parameter in
let branch {B : Type}
(ibt :
Tezos_raw_protocol_alpha.Script_typed_ir.descr
op_dollar57 B) (ibf :
Tezos_raw_protocol_alpha.Script_typed_ir.descr
(op_dollar58 * op_dollar57) B)
: Tezos_raw_protocol_alpha.Script_typed_ir.descr
((option op_dollar58) * op_dollar57) B :=
{| loc := loc; bef := bef; aft := aft ibt;
instr :=
Tezos_raw_protocol_alpha.Script_typed_ir.If_none
ibt ibf |} in
op_gtgteqquestion
(merge_branches legacy ctxt loc btr bfr
{| branch := branch |})
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
_return ctxt judgement))))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_PAIR [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t a
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t b rest snd_annot)
fst_annot) =>
op_gtgteqquestion
(parse_constr_annot loc (Some (var_to_field_annot fst_annot))
(Some (var_to_field_annot snd_annot)) annot)
(fun function_parameter =>
let '(annot, ty_name, l_field, r_field) := function_parameter in
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Cons_pair
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
(a, l_field, fst_annot) (b, r_field, snd_annot) ty_name
(op_pipepipe (has_big_map a) (has_big_map b))) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CAR [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
(a, expected_field_annot, a_annot) _ _ _) rest pair_annot) =>
op_gtgteqquestion
(parse_destr_annot loc annot default_car_annot expected_field_annot
pair_annot a_annot)
(fun function_parameter =>
let '(annot, field_annot) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(check_correct_field field_annot expected_field_annot))
(fun function_parameter =>
let 'tt := function_parameter in
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Car
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t a rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CDR [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t _
(b, expected_field_annot, b_annot) _ _) rest pair_annot) =>
op_gtgteqquestion
(parse_destr_annot loc annot default_cdr_annot expected_field_annot
pair_annot b_annot)
(fun function_parameter =>
let '(annot, field_annot) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(check_correct_field field_annot expected_field_annot))
(fun function_parameter =>
let 'tt := function_parameter in
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Cdr
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t b rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LEFT (cons tr [])
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tl rest stack_annot)
=>
op_gtgteqquestion (op_atat Lwt._return (parse_any_ty ctxt legacy tr))
(fun function_parameter =>
let '(Ex_ty tr, ctxt) := function_parameter in
op_gtgteqquestion
(parse_constr_annot loc (Some (var_to_field_annot stack_annot))
None annot)
(fun function_parameter =>
let '(annot, tname, l_field, r_field) := function_parameter in
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Left
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t
(tl, l_field) (tr, r_field) tname
(op_pipepipe (has_big_map tl) (has_big_map tr))) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_RIGHT (cons tl [])
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tr rest stack_annot)
=>
op_gtgteqquestion (op_atat Lwt._return (parse_any_ty ctxt legacy tl))
(fun function_parameter =>
let '(Ex_ty tl, ctxt) := function_parameter in
op_gtgteqquestion
(parse_constr_annot loc None
(Some (var_to_field_annot stack_annot)) annot)
(fun function_parameter =>
let '(annot, tname, l_field, r_field) := function_parameter in
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Right
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t
(tl, l_field) (tr, r_field) tname
(op_pipepipe (has_big_map tl) (has_big_map tr))) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_LEFT
(cons bt (cons bf [])) annot,
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tl, l_field)
(tr, r_field) _ _) rest union_annot) as bef) =>
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bf)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
let left_annot :=
gen_access_annot union_annot (Some default_left_annot)
l_field in
let right_annot :=
gen_access_annot union_annot (Some default_right_annot)
r_field in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bt
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tl rest
left_annot))
(fun function_parameter =>
let '(btr, ctxt) := function_parameter in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bf
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tr
rest right_annot))
(fun function_parameter =>
let '(bfr, ctxt) := function_parameter in
let branch {B : Type}
(ibt :
Tezos_raw_protocol_alpha.Script_typed_ir.descr
(op_dollar77 * op_dollar76) B) (ibf :
Tezos_raw_protocol_alpha.Script_typed_ir.descr
(op_dollar78 * op_dollar76) B)
: Tezos_raw_protocol_alpha.Script_typed_ir.descr
((Tezos_raw_protocol_alpha.Script_typed_ir.union
op_dollar77 op_dollar78) * op_dollar76) B :=
{| loc := loc; bef := bef; aft := aft ibt;
instr :=
Tezos_raw_protocol_alpha.Script_typed_ir.If_left
ibt ibf |} in
op_gtgteqquestion
(merge_branches legacy ctxt loc btr bfr
{| branch := branch |})
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
_return ctxt judgement))))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NIL (cons t []) annot,
stack) =>
op_gtgteqquestion (op_atat Lwt._return (parse_any_ty ctxt legacy t))
(fun function_parameter =>
let '(Ex_ty t, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, ty_name) := function_parameter in
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Nil
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t t ty_name
(has_big_map t)) stack annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONS [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tv
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t t ty_name
has_big_map) rest _) _) =>
op_gtgteqquestion
(check_item_ty ctxt tv t loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONS 1 2)
(fun function_parameter =>
let '(Eq, t, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Cons_list
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t t ty_name
has_big_map) rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_CONS
(cons bt (cons bf [])) annot,
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t t ty_name
has_big_map) rest list_annot) as bef) =>
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bf)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
let hd_annot :=
gen_access_annot list_annot None default_hd_annot in
let tl_annot :=
gen_access_annot list_annot None default_tl_annot in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bt
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t t
ty_name has_big_map) rest tl_annot) hd_annot))
(fun function_parameter =>
let '(btr, ctxt) := function_parameter in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bf
rest)
(fun function_parameter =>
let '(bfr, ctxt) := function_parameter in
let branch {B : Type}
(ibt :
Tezos_raw_protocol_alpha.Script_typed_ir.descr
(op_dollar86 *
((list op_dollar86) * op_dollar85)) B) (ibf :
Tezos_raw_protocol_alpha.Script_typed_ir.descr
op_dollar85 B)
: Tezos_raw_protocol_alpha.Script_typed_ir.descr
((list op_dollar86) * op_dollar85) B :=
{| loc := loc; bef := bef; aft := aft ibt;
instr :=
Tezos_raw_protocol_alpha.Script_typed_ir.If_cons
ibt ibf |} in
op_gtgteqquestion
(merge_branches legacy ctxt loc btr bfr
{| branch := branch |})
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
_return ctxt judgement))))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t _ _ _) rest _) =>
op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, tname) := function_parameter in
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.List_size
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MAP (cons body [])
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t elt _ _)
starting_rest list_annot) =>
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) body)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(ret_annot, list_ty_name) := function_parameter in
let elt_annot :=
gen_access_annot list_annot None default_elt_annot in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy body
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t elt
starting_rest elt_annot))
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
|
Typed
({|
aft := Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ret rest _
|} as ibody) =>
let invalid_map_body (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
let 'tt := function_parameter in
op_gtgtpipequestion
(serialize_stack_for_error ctxt (aft ibody))
(fun function_parameter =>
let '(aft, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_map_body
loc aft) in
trace_eval invalid_map_body
(op_gtgteqquestion
(op_atat Lwt._return
(stack_ty_eq ctxt 1 rest starting_rest))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(merge_stacks legacy loc ctxt rest starting_rest))
(fun function_parameter =>
let '(rest, ctxt) := function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.List_map
ibody)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t
ret list_ty_name (has_big_map ret)) rest
ret_annot))))
| Typed {| aft := aft |} =>
op_gtgteqquestion (serialize_stack_for_error ctxt aft)
(fun function_parameter =>
let '(aft, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_map_body
loc aft))
| Failed _ =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_map_block_fail
loc)
end)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ITER (cons body [])
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t elt _ _) rest
list_annot) =>
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) body)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
let elt_annot :=
gen_access_annot list_annot None default_elt_annot in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy body
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t elt rest
elt_annot))
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed ({| aft := aft |} as ibody) =>
let invalid_iter_body (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
let 'tt := function_parameter in
op_gtgteqquestion
(serialize_stack_for_error ctxt (aft ibody))
(fun function_parameter =>
let '(aft, ctxt) := function_parameter in
op_gtgtpipequestion
(serialize_stack_for_error ctxt rest)
(fun function_parameter =>
let '(rest, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_iter_body
loc rest aft)) in
trace_eval invalid_iter_body
(op_gtgteqquestion
(op_atat Lwt._return (stack_ty_eq ctxt 1 aft rest))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(merge_stacks legacy loc ctxt aft rest))
(fun function_parameter =>
let '(rest, ctxt) := function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.List_iter
ibody) rest)))
| Failed {| descr := descr |} =>
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.List_iter
(descr rest)) rest
end)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_SET (cons t [])
annot, rest) =>
op_gtgteqquestion (op_atat Lwt._return (parse_comparable_ty ctxt t))
(fun function_parameter =>
let '(Ex_comparable_ty t, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, tname) := function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Empty_set t)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_t t tname)
rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ITER (cons body [])
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_t comp_elt _) rest
set_annot) =>
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) body)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
let elt_annot :=
gen_access_annot set_annot None default_elt_annot in
let elt := ty_of_comparable_ty comp_elt in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy body
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t elt rest
elt_annot))
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed ({| aft := aft |} as ibody) =>
let invalid_iter_body (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
let 'tt := function_parameter in
op_gtgteqquestion
(serialize_stack_for_error ctxt (aft ibody))
(fun function_parameter =>
let '(aft, ctxt) := function_parameter in
op_gtgtpipequestion
(serialize_stack_for_error ctxt rest)
(fun function_parameter =>
let '(rest, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_iter_body
loc rest aft)) in
trace_eval invalid_iter_body
(op_gtgteqquestion
(op_atat Lwt._return (stack_ty_eq ctxt 1 aft rest))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(merge_stacks legacy loc ctxt aft rest))
(fun function_parameter =>
let '(rest, ctxt) := function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_iter
ibody) rest)))
| Failed {| descr := descr |} =>
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_iter
(descr rest)) rest
end)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_t elt _) rest _) _)
=>
let elt := ty_of_comparable_ty elt in
op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, tname) := function_parameter in
op_gtgteqquestion
(check_item_ty ctxt elt v loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM 1 2)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Set_mem
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_t elt tname) rest
set_annot) _) _) =>
match comparable_ty_of_ty v with
| None =>
op_gtgteqquestion (unparse_ty ctxt v)
(fun function_parameter =>
let '(v, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Comparable_type_expected
loc (Micheline.strip_locations v)))
| Some v =>
op_gtgteqquestion (parse_var_annot loc (Some set_annot) annot)
(fun annot =>
op_gtgteqquestion
(check_item_comparable_ty elt v loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE 1 3)
(fun function_parameter =>
let '(Eq, elt) := function_parameter in
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Set_update
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_t elt tname)
rest annot)))
end
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Set_t _ _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Set_size
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_MAP
(cons tk (cons tv [])) annot, stack) =>
op_gtgteqquestion (op_atat Lwt._return (parse_comparable_ty ctxt tk))
(fun function_parameter =>
let '(Ex_comparable_ty tk, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return (parse_any_ty ctxt legacy tv))
(fun function_parameter =>
let '(Ex_ty tv, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, ty_name) := function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Empty_map tk tv)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_t tk tv
ty_name (has_big_map tv)) stack annot))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MAP (cons body [])
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_t ck elt _ _)
starting_rest _map_annot) =>
let k := ty_of_comparable_ty ck in
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) body)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(ret_annot, ty_name) := function_parameter in
let k_name := field_to_var_annot default_key_annot in
let e_name := field_to_var_annot default_elt_annot in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy body
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
(k, None, k_name) (elt, None, e_name) None
(has_big_map elt)) starting_rest None))
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
|
Typed
({|
aft := Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ret rest _
|} as ibody) =>
let invalid_map_body (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
let 'tt := function_parameter in
op_gtgtpipequestion
(serialize_stack_for_error ctxt (aft ibody))
(fun function_parameter =>
let '(aft, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_map_body
loc aft) in
trace_eval invalid_map_body
(op_gtgteqquestion
(op_atat Lwt._return
(stack_ty_eq ctxt 1 rest starting_rest))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(merge_stacks legacy loc ctxt rest starting_rest))
(fun function_parameter =>
let '(rest, ctxt) := function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_map
ibody)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_t
ck ret ty_name (has_big_map ret)) rest
ret_annot))))
| Typed {| aft := aft |} =>
op_gtgteqquestion (serialize_stack_for_error ctxt aft)
(fun function_parameter =>
let '(aft, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_map_body
loc aft))
| Failed _ =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_map_block_fail
loc)
end)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ITER (cons body [])
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_t comp_elt element_ty
_ _) rest _map_annot) =>
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) body)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
let k_name := field_to_var_annot default_key_annot in
let e_name := field_to_var_annot default_elt_annot in
let key := ty_of_comparable_ty comp_elt in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy body
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
(key, None, k_name) (element_ty, None, e_name) None
(has_big_map element_ty)) rest None))
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed ({| aft := aft |} as ibody) =>
let invalid_iter_body (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
let 'tt := function_parameter in
op_gtgteqquestion
(serialize_stack_for_error ctxt (aft ibody))
(fun function_parameter =>
let '(aft, ctxt) := function_parameter in
op_gtgtpipequestion
(serialize_stack_for_error ctxt rest)
(fun function_parameter =>
let '(rest, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_iter_body
loc rest aft)) in
trace_eval invalid_iter_body
(op_gtgteqquestion
(op_atat Lwt._return (stack_ty_eq ctxt 1 aft rest))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(merge_stacks legacy loc ctxt aft rest))
(fun function_parameter =>
let '(rest, ctxt) := function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_iter
ibody) rest)))
| Failed {| descr := descr |} =>
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_iter
(descr rest)) rest
end)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t vk
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_t ck _ _ _) rest _)
_) =>
let k := ty_of_comparable_ty ck in
op_gtgteqquestion
(check_item_ty ctxt vk k loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM 1 2)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Map_mem
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t vk
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_t ck elt _
has_big_map) rest _) _) =>
let k := ty_of_comparable_ty ck in
op_gtgteqquestion
(check_item_ty ctxt vk k loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET 1 2)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Map_get
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t elt None
has_big_map) rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t vk
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t vv _ _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_t ck v map_name
has_big_map) rest map_annot) _) _) =>
let k := ty_of_comparable_ty ck in
op_gtgteqquestion
(check_item_ty ctxt vk k loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE 1 3)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
op_gtgteqquestion
(check_item_ty ctxt vv v loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE 2 3)
(fun function_parameter =>
let '(Eq, v, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_annot loc (Some map_annot) annot)
(fun annot =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Map_update
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_t ck v
map_name has_big_map) rest annot))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ _ _ _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Map_size
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_BIG_MAP
(cons tk (cons tv [])) annot, stack) =>
op_gtgteqquestion (op_atat Lwt._return (parse_comparable_ty ctxt tk))
(fun function_parameter =>
let '(Ex_comparable_ty tk, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return (parse_packable_ty ctxt legacy tv))
(fun function_parameter =>
let '(Ex_ty tv, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, ty_name) := function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Empty_big_map tk
tv)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tk
tv ty_name) stack annot))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t set_key
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t map_key _ _)
rest _) _) =>
let k := ty_of_comparable_ty map_key in
op_gtgteqquestion
(check_item_ty ctxt set_key k loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM 1 2)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_mem
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t vk
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t ck elt _) rest
_) _) =>
let k := ty_of_comparable_ty ck in
op_gtgteqquestion
(check_item_ty ctxt vk k loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET 1 2)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_get
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t elt None
(has_big_map elt)) rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t set_key
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t set_value _ _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t map_key
map_value map_name) rest map_annot) _) _) =>
let k := ty_of_comparable_ty map_key in
op_gtgteqquestion
(check_item_ty ctxt set_key k loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE 1 3)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
op_gtgteqquestion
(check_item_ty ctxt set_value map_value loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE 2 3)
(fun function_parameter =>
let '(Eq, map_value, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_annot loc (Some map_annot) annot)
(fun annot =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_update
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t
map_key map_value map_name) rest annot))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc [],
stack) =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Nop stack
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc
(cons single []), stack) =>
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy single stack)
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed ({| aft := aft |} as instr) =>
let nop :=
{| loc := loc; bef := aft; aft := aft;
instr := Tezos_raw_protocol_alpha.Script_typed_ir.Nop |} in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Seq instr nop) aft
| Failed {| descr := descr |} =>
let descr {B : Type}
(aft : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B)
: Tezos_raw_protocol_alpha.Script_typed_ir.descr bef B :=
let nop :=
{| loc := loc; bef := aft; aft := aft;
instr := Tezos_raw_protocol_alpha.Script_typed_ir.Nop |} in
let descr := descr aft in
(* ❌ Record substitution not handled *)
record_substitution in
_return ctxt (Failed {| descr := descr |})
end)
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc
(cons hd tl), stack) =>
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy hd stack)
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Failed _ =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Fail_not_in_tail_position
(Micheline.location hd))
| Typed ({| aft := middle |} as ihd) =>
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq
(-1) tl) middle)
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Failed {| descr := descr |} =>
let descr {B : Type}
(ret :
Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B)
: Tezos_raw_protocol_alpha.Script_typed_ir.descr bef B :=
{| loc := loc; bef := stack; aft := ret;
instr :=
Tezos_raw_protocol_alpha.Script_typed_ir.Seq ihd
(descr ret) |} in
_return ctxt (Failed {| descr := descr |})
| Typed itl =>
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Seq ihd itl)
(aft itl)
end)
end)
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF
(cons bt (cons bf [])) annot,
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _) rest _) as bef)
=>
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bf)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bt rest)
(fun function_parameter =>
let '(btr, ctxt) := function_parameter in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy bf
rest)
(fun function_parameter =>
let '(bfr, ctxt) := function_parameter in
let branch {B : Type}
(ibt :
Tezos_raw_protocol_alpha.Script_typed_ir.descr
op_dollar169 B) (ibf :
Tezos_raw_protocol_alpha.Script_typed_ir.descr
op_dollar169 B)
: Tezos_raw_protocol_alpha.Script_typed_ir.descr
(bool * op_dollar169) B :=
{| loc := loc; bef := bef; aft := aft ibt;
instr :=
Tezos_raw_protocol_alpha.Script_typed_ir.If
ibt ibf |} in
op_gtgteqquestion
(merge_branches legacy ctxt loc btr bfr
{| branch := branch |})
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
_return ctxt judgement))))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP (cons body [])
annot,
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _) rest
_stack_annot) as stack) =>
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) body)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy body rest)
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed ibody =>
let unmatched_branches (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
let 'tt := function_parameter in
op_gtgteqquestion
(serialize_stack_for_error ctxt (aft ibody))
(fun function_parameter =>
let '(aft, ctxt) := function_parameter in
op_gtgtpipequestion
(serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Unmatched_branches
loc aft stack)) in
trace_eval unmatched_branches
(op_gtgteqquestion
(op_atat Lwt._return
(stack_ty_eq ctxt 1 (aft ibody) stack))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(merge_stacks legacy loc ctxt (aft ibody) stack))
(fun function_parameter =>
let '(_stack, ctxt) := function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Loop
ibody) rest)))
| Failed {| descr := descr |} =>
let ibody := descr stack in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Loop ibody)
rest
end)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP_LEFT
(cons body []) annot,
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tl, l_field)
(tr, _) _ _) rest union_annot) as stack) =>
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) body)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
let l_annot :=
gen_access_annot union_annot (Some default_left_annot) l_field
in
op_gtgteqquestion
(parse_instr type_logger tc_context ctxt legacy body
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tl rest
l_annot))
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed ibody =>
let unmatched_branches (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
let 'tt := function_parameter in
op_gtgteqquestion
(serialize_stack_for_error ctxt (aft ibody))
(fun function_parameter =>
let '(aft, ctxt) := function_parameter in
op_gtgtpipequestion
(serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Unmatched_branches
loc aft stack)) in
trace_eval unmatched_branches
(op_gtgteqquestion
(op_atat Lwt._return
(stack_ty_eq ctxt 1 (aft ibody) stack))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(merge_stacks legacy loc ctxt (aft ibody) stack))
(fun function_parameter =>
let '(_stack, ctxt) := function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Loop_left
ibody)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
tr rest annot))))
| Failed {| descr := descr |} =>
let ibody := descr stack in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Loop_left
ibody)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tr rest
annot)
end)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LAMBDA
(cons arg (cons ret (cons code []))) annot, stack) =>
op_gtgteqquestion (op_atat Lwt._return (parse_any_ty ctxt legacy arg))
(fun function_parameter =>
let '(Ex_ty arg, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return (parse_any_ty ctxt legacy ret))
(fun function_parameter =>
let '(Ex_ty ret, ctxt) := function_parameter in
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
code)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(parse_returning type_logger Lambda ctxt legacy
(arg, default_arg_annot) ret code)
(fun function_parameter =>
let '(lambda, ctxt) := function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Lambda
lambda)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t
arg ret None) stack annot))))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EXEC [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t arg
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t param ret _)
rest _) _) =>
op_gtgteqquestion
(check_item_ty ctxt arg param loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EXEC 1 2)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Exec
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ret rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_APPLY [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t capture
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
(capture_ty, _, _) (arg_ty, _, _) lam_annot _) ret _) rest _)
_) =>
op_gtgteqquestion
(op_atat Lwt._return (check_packable false loc capture_ty))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(check_item_ty ctxt capture capture_ty loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_APPLY 1 2)
(fun function_parameter =>
let '(Eq, capture_ty, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Apply capture_ty)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t
arg_ty ret lam_annot) rest annot))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP (cons code [])
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest stack_annot) =>
op_gtgteqquestion (fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(check_kind
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
code)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(parse_instr type_logger (add_dip v stack_annot tc_context)
ctxt legacy code rest)
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed descr =>
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Dip descr)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v
(aft descr) stack_annot)
| Failed _ =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Fail_not_in_tail_position
loc)
end)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP
(cons n (cons code [])) result_annot, stack) =>
let fix make_proof_argument {tstk : Type}
(n : Z) (inner_tc_context : tc_context) (stk :
Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tstk)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(dipn_proof_argument tstk)) :=
match
((Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
n 0), stk) with
| (true, rest) =>
op_gtgteqquestion
(parse_instr type_logger inner_tc_context ctxt legacy code rest)
(fun function_parameter =>
let '(judgement, ctxt) := function_parameter in
match judgement with
| Typed descr =>
op_atat outer_return
(Dipn_proof_argument
(Tezos_raw_protocol_alpha.Script_typed_ir.Rest,
(ctxt, descr), (aft descr)))
| Failed _ =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Fail_not_in_tail_position
loc)
end)
|
(false, Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest annot)
=>
op_gtgteqquestion
(make_proof_argument (op_minus n 1) (add_dip v annot tc_context)
rest)
(fun function_parameter =>
let 'Dipn_proof_argument (n', descr, aft') := function_parameter
in
op_atat outer_return
(Dipn_proof_argument
((Tezos_raw_protocol_alpha.Script_typed_ir.Prefix n'),
descr,
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v aft'
annot))))
| (_, _) =>
op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(whole_stack, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP 1
whole_stack))
end in
op_gtgteqquestion (Lwt._return (parse_int32 n))
(fun n =>
op_gtgteqquestion (fail_unexpected_annot loc result_annot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (make_proof_argument n tc_context stack)
(fun function_parameter =>
let 'Dipn_proof_argument (n', (new_ctxt, descr), aft) :=
function_parameter in
typed new_ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Dipn n n' descr)
aft)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP
(([] | cons _ (cons _ (cons _ _))) as l) _, _) =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP 2
(List.length l))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_FAILWITH [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v _rest _) =>
op_gtgteqquestion (fail_unexpected_annot loc annot)
(fun function_parameter =>
let 'tt := function_parameter in
let descr {B : Type}
(aft : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B)
: Tezos_raw_protocol_alpha.Script_typed_ir.descr bef B :=
{| loc := loc; bef := stack_ty; aft := aft;
instr := Tezos_raw_protocol_alpha.Script_typed_ir.Failwith v |}
in
op_gtgteqquestion
(log_stack ctxt loc stack_ty
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t)
(fun function_parameter =>
let 'tt := function_parameter in
_return ctxt (Failed {| descr := descr |})))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Add_timestamp_to_seconds
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname)
rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname) rest
_) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Add_seconds_to_timestamp
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname)
rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Sub_timestamp_seconds
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname)
rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tn2) rest _)
_) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Diff_timestamps
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.String_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.String_t tn2) rest _) _)
=>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string_pair
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname)
rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t
(Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname) _ _)
rest list_annot) =>
op_gtgteqquestion (parse_var_annot loc (Some list_annot) annot)
(fun annot =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SLICE [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname) rest
string_annot) _) _) =>
op_gtgteqquestion
(parse_var_annot loc
(Some (gen_access_annot string_annot None default_slice_annot))
annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Slice_string
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
(Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname) None
false) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.String_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.String_size
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tn2) rest _) _)
=>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes_pair
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname)
rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.List_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname) _ _) rest
list_annot) =>
op_gtgteqquestion (parse_var_annot loc (Some list_annot) annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SLICE [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname) rest
bytes_annot) _) _) =>
op_gtgteqquestion
(parse_var_annot loc
(Some (gen_access_annot bytes_annot None default_slice_annot)) annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Slice_bytes
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname) None
false) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_size
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn2) rest _) _)
=>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Add_tez
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname)
rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn2) rest _) _)
=>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sub_tez
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname)
rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Mul_teznat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname) rest _) _)
=>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Mul_nattez
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_OR [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn2) rest _) _)
=>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Or
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn2) rest _) _)
=>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.And
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_XOR [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn2) rest _) _)
=>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Xor
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Not
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ABS [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Abs_int
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ISNAT [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest int_annot)
=>
op_gtgteqquestion (parse_var_annot loc (Some int_annot) annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Is_nat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None) None
false) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_INT [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Int_nat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t None) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEG [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Neg_int
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEG [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Neg_nat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t None) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn2) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Add_intint
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Add_intnat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest _) _)
=>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Add_natint
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Add_natnat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn2) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sub_int
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sub_int
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest _) _)
=>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sub_int
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun _tname =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sub_int
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t None) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn2) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intint
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intnat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest _) _)
=>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natint
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natnat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_teznat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
((Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname),
None, None)
((Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname),
None, None) None false) None false) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn2) rest _) _)
=>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_tez
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None),
None, None)
((Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname),
None, None) None false) None false) rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn2) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intint
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
((Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname),
None, None)
((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None),
None, None) None false) None false) rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intnat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
((Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname),
None, None)
((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None),
None, None) None false) None false) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natint
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
((Tezos_raw_protocol_alpha.Script_typed_ir.Int_t None),
None, None)
((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname),
None, None) None false) None false) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natnat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname),
None, None)
((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname),
None, None) None false) None false) rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSL [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Lsl_nat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSR [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Lsr_nat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_OR [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Or_nat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.And_nat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest _) _)
=>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.And_int_nat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_XOR [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
(fun tname =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Xor_nat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Not_int
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Not_nat
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t None) rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_COMPARE [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t1
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t2 rest _) _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
op_gtgteqquestion
(check_item_ty ctxt t1 t2 loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_COMPARE 1 2)
(fun function_parameter =>
let '(Eq, t, ctxt) := function_parameter in
match comparable_ty_of_ty t with
| None =>
op_gtgteqquestion
(Lwt._return (serialize_ty_for_error ctxt t))
(fun function_parameter =>
let '(t, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Comparable_type_expected
loc t))
| Some key =>
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Compare key)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t None) rest
annot)
end))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EQ [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Eq
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEQ [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Neq
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LT [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Lt
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GT [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Gt
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LE [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Le
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GE [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Ge
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CAST (cons cast_t [])
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t stack item_annot) =>
op_gtgteqquestion (parse_var_annot loc (Some item_annot) annot)
(fun annot =>
op_gtgteqquestion
(op_atat Lwt._return (parse_any_ty ctxt legacy cast_t))
(fun function_parameter =>
let '(Ex_ty cast_t, ctxt) := function_parameter in
op_gtgteqquestion (op_atat Lwt._return (ty_eq ctxt cast_t t))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(merge_types legacy ctxt loc cast_t t))
(fun function_parameter =>
let '(_, ctxt) := function_parameter in
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Nop
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
cast_t stack annot)))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_RENAME [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t stack _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Nop
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t stack annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_PACK [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t rest unpacked_annot)
=>
op_gtgteqquestion (Lwt._return (check_packable true loc t))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(parse_var_annot loc
(Some (gen_access_annot unpacked_annot None default_pack_annot))
annot)
(fun annot =>
typed ctxt loc (Tezos_raw_protocol_alpha.Script_typed_ir.Pack t)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t None) rest
annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UNPACK (cons ty [])
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _) rest
packed_annot) =>
op_gtgteqquestion
(op_atat Lwt._return (parse_packable_ty ctxt legacy ty))
(fun function_parameter =>
let '(Ex_ty t, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_type_annot loc annot)
(fun function_parameter =>
let '(annot, ty_name) := function_parameter in
let annot :=
default_annot
(gen_access_annot packed_annot None default_unpack_annot)
annot in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Unpack t)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t ty_name
false) rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADDRESS [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _) rest
contract_annot) =>
op_gtgteqquestion
(parse_var_annot loc
(Some (gen_access_annot contract_annot None default_addr_annot))
annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Address
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_t None) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONTRACT (cons ty [])
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _) rest
addr_annot) =>
op_gtgteqquestion
(op_atat Lwt._return (parse_parameter_ty ctxt legacy ty))
(fun function_parameter =>
let '(Ex_ty t, ctxt) := function_parameter in
op_gtgteqquestion
(parse_entrypoint_annot loc
(Some (gen_access_annot addr_annot None default_contract_annot))
annot)
(fun function_parameter =>
let '(annot, entrypoint) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
match entrypoint with
| None =>
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
"default" % string
| Some (Field_annot "default" % string) =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
loc)
| Some (Field_annot entrypoint) =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
(String.length entrypoint) 31 then
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Entrypoint_name_too_long
entrypoint)
else
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
entrypoint
end)
(fun entrypoint =>
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Contract t
entrypoint)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t t
None) None false) rest annot))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_TRANSFER_TOKENS []
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t p
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t cp _) rest
_) _) _) =>
op_gtgteqquestion
(check_item_ty ctxt p cp loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_TRANSFER_TOKENS 1 4)
(fun function_parameter =>
let '(Eq, _, ctxt) := function_parameter in
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Transfer_tokens
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t None)
rest annot)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SET_DELEGATE [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _) _ _) rest
_) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Set_delegate
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t None) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_ACCOUNT []
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _) _ _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _) rest _) _)
_) _) =>
if legacy then
op_gtgteqquestion (parse_two_var_annot loc annot)
(fun function_parameter =>
let '(op_annot, addr_annot) := function_parameter in
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Create_account
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t None)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_t None)
rest addr_annot) op_annot))
else
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Deprecated_instruction
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_ACCOUNT)
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IMPLICIT_ACCOUNT []
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Implicit_account
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t None) None)
rest annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_CONTRACT
(cons
((Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ _)
as code) []) annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _) _ _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ginit rest
_) _) _) _) _) _) =>
if legacy then
op_gtgteqquestion (parse_two_var_annot loc annot)
(fun function_parameter =>
let '(op_annot, addr_annot) := function_parameter in
let cannonical_code :=
op_atat fst (Micheline.extract_locations code) in
op_gtgteqquestion
(op_atat Lwt._return (parse_toplevel legacy cannonical_code))
(fun function_parameter =>
let '(arg_type, storage_type, code_field, root_name) :=
function_parameter in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
(Some "parameter" % string) cannonical_code
(location arg_type))
(op_atat Lwt._return
(parse_parameter_ty ctxt legacy arg_type)))
(fun function_parameter =>
let '(Ex_ty arg_type, ctxt) := function_parameter in
op_gtgteqquestion
(if legacy then
Error_monad._return tt
else
Lwt._return
(well_formed_entrypoints arg_type root_name))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
(Some "storage" % string) cannonical_code
(location storage_type))
(op_atat Lwt._return
(parse_storage_ty ctxt legacy storage_type)))
(fun function_parameter =>
let '(Ex_ty storage_type, ctxt) :=
function_parameter in
let arg_annot :=
default_annot default_param_annot
(type_to_var_annot (name_of_ty arg_type)) in
let storage_annot :=
default_annot default_storage_annot
(type_to_var_annot (name_of_ty storage_type))
in
let arg_type_full :=
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
(arg_type, None, arg_annot)
(storage_type, None, storage_annot) None
(op_pipepipe (has_big_map arg_type)
(has_big_map storage_type)) in
let ret_type_full :=
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
((Tezos_raw_protocol_alpha.Script_typed_ir.List_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t
None) None false), None, None)
(storage_type, None, None) None
(has_big_map storage_type) in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
cannonical_code [])
(parse_returning type_logger
(Toplevel
{| storage_type := storage_type;
param_type := arg_type;
root_name := root_name;
legacy_create_contract_literal := true
|}) ctxt legacy (arg_type_full, None)
ret_type_full code_field))
(fun function_parameter =>
let
'((Tezos_raw_protocol_alpha.Script_typed_ir.Lam
{|
bef :=
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
arg
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
_;
aft :=
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
ret
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
_
|} _) as lambda, ctxt) :=
function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(ty_eq ctxt arg arg_type_full))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(merge_types legacy ctxt loc arg
arg_type_full))
(fun function_parameter =>
let '(_, ctxt) := function_parameter
in
op_gtgteqquestion
(op_atat Lwt._return
(ty_eq ctxt ret ret_type_full))
(fun function_parameter =>
let '(Eq, ctxt) :=
function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(merge_types legacy ctxt loc
ret ret_type_full))
(fun function_parameter =>
let '(_, ctxt) :=
function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(ty_eq ctxt storage_type
ginit))
(fun function_parameter =>
let '(Eq, ctxt) :=
function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(merge_types legacy
ctxt loc
storage_type ginit))
(fun function_parameter
=>
let '(_, ctxt) :=
function_parameter
in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract
storage_type
arg_type lambda
root_name)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t
None)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_t
None) rest
addr_annot)
op_annot)))))))))))))
else
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Deprecated_instruction
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_CONTRACT)
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_CONTRACT
(cons
((Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ _)
as code) []) annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _) _ _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ginit rest _) _)
_) =>
op_gtgteqquestion (parse_two_var_annot loc annot)
(fun function_parameter =>
let '(op_annot, addr_annot) := function_parameter in
let cannonical_code :=
op_atat fst (Micheline.extract_locations code) in
op_gtgteqquestion
(op_atat Lwt._return (parse_toplevel legacy cannonical_code))
(fun function_parameter =>
let '(arg_type, storage_type, code_field, root_name) :=
function_parameter in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
(Some "parameter" % string) cannonical_code
(location arg_type))
(op_atat Lwt._return
(parse_parameter_ty ctxt legacy arg_type)))
(fun function_parameter =>
let '(Ex_ty arg_type, ctxt) := function_parameter in
op_gtgteqquestion
(if legacy then
Error_monad._return tt
else
Lwt._return (well_formed_entrypoints arg_type root_name))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
(Some "storage" % string) cannonical_code
(location storage_type))
(op_atat Lwt._return
(parse_storage_ty ctxt legacy storage_type)))
(fun function_parameter =>
let '(Ex_ty storage_type, ctxt) :=
function_parameter in
let arg_annot :=
default_annot default_param_annot
(type_to_var_annot (name_of_ty arg_type)) in
let storage_annot :=
default_annot default_storage_annot
(type_to_var_annot (name_of_ty storage_type)) in
let arg_type_full :=
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
(arg_type, None, arg_annot)
(storage_type, None, storage_annot) None
(op_pipepipe (has_big_map arg_type)
(has_big_map storage_type)) in
let ret_type_full :=
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
((Tezos_raw_protocol_alpha.Script_typed_ir.List_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t
None) None false), None, None)
(storage_type, None, None) None
(has_big_map storage_type) in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
cannonical_code [])
(parse_returning type_logger
(Toplevel
{| storage_type := storage_type;
param_type := arg_type;
root_name := root_name;
legacy_create_contract_literal := false |})
ctxt legacy (arg_type_full, None)
ret_type_full code_field))
(fun function_parameter =>
let
'((Tezos_raw_protocol_alpha.Script_typed_ir.Lam
{|
bef :=
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
arg
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
_;
aft :=
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
ret
Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
_
|} _) as lambda, ctxt) :=
function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(ty_eq ctxt arg arg_type_full))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(merge_types legacy ctxt loc arg
arg_type_full))
(fun function_parameter =>
let '(_, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(ty_eq ctxt ret ret_type_full))
(fun function_parameter =>
let '(Eq, ctxt) :=
function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(merge_types legacy ctxt loc ret
ret_type_full))
(fun function_parameter =>
let '(_, ctxt) :=
function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(ty_eq ctxt storage_type
ginit))
(fun function_parameter =>
let '(Eq, ctxt) :=
function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(merge_types legacy ctxt
loc storage_type ginit))
(fun function_parameter =>
let '(_, ctxt) :=
function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract_2
storage_type
arg_type lambda
root_name)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t
None)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_t
None) rest
addr_annot)
op_annot)))))))))))))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOW [] annot, stack)
=>
op_gtgteqquestion (parse_var_annot loc (Some default_now_annot) annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Now
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t None)
stack annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_AMOUNT [] annot, stack)
=>
op_gtgteqquestion
(parse_var_annot loc (Some default_amount_annot) annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Amount
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t None) stack
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CHAIN_ID [] annot,
stack) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.ChainId
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t None) stack
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_BALANCE [] annot,
stack) =>
op_gtgteqquestion
(parse_var_annot loc (Some default_balance_annot) annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Balance
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t None) stack
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_HASH_KEY [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Hash_key
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t None) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CHECK_SIGNATURE []
annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _) rest _) _)
_) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Check_signature
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_BLAKE2B [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Blake2b
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t None) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA256 [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sha256
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t None) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA512 [] annot,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _) rest _) =>
op_gtgteqquestion (parse_var_annot loc None annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sha512
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t None) rest
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_STEPS_TO_QUOTA []
annot, stack) =>
if legacy then
op_gtgteqquestion
(parse_var_annot loc (Some default_steps_annot) annot)
(fun annot =>
typed ctxt loc
Tezos_raw_protocol_alpha.Script_typed_ir.Steps_to_quota
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None) stack
annot))
else
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Deprecated_instruction
Tezos_raw_protocol_alpha.Alpha_context.Script.I_STEPS_TO_QUOTA)
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOURCE [] annot, stack)
=>
op_gtgteqquestion
(parse_var_annot loc (Some default_source_annot) annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Source
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_t None) stack
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SENDER [] annot, stack)
=>
op_gtgteqquestion
(parse_var_annot loc (Some default_sender_annot) annot)
(fun annot =>
typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sender
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Address_t None) stack
annot))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SELF [] annot, stack)
=>
op_gtgteqquestion
(parse_entrypoint_annot loc (Some default_self_annot) annot)
(fun function_parameter =>
let '(annot, entrypoint) := function_parameter in
let entrypoint :=
Option.unopt_map
(fun function_parameter =>
let 'Field_annot annot := function_parameter in
annot) "default" % string entrypoint in
let fix get_toplevel_type (function_parameter : tc_context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((judgement bef) *
Tezos_raw_protocol_alpha.Alpha_context.context)) :=
match function_parameter with
| Lambda =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Self_in_lambda
loc)
| Dip _ prev => get_toplevel_type prev
|
Toplevel {|
param_type := param_type;
root_name := root_name;
legacy_create_contract_literal := false
|} =>
op_gtgteqquestion
(Lwt._return (find_entrypoint param_type root_name entrypoint))
(fun function_parameter =>
let '(_, Ex_ty param_type) := function_parameter in
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Self param_type
entrypoint)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t
param_type None) stack annot))
|
Toplevel {|
param_type := param_type;
root_name := _;
legacy_create_contract_literal := true
|} =>
typed ctxt loc
(Tezos_raw_protocol_alpha.Script_typed_ir.Self param_type
"default" % string)
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t
param_type None) stack annot)
end in
get_toplevel_type tc_context)
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
((Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SWAP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOME |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UNIT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_PAIR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CAR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CDR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONS |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SLICE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MAP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EXEC |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_FAILWITH |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_OR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_XOR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ABS |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEG |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSL |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_COMPARE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EQ |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEQ |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_TRANSFER_TOKENS |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_ACCOUNT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SET_DELEGATE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOW |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IMPLICIT_ACCOUNT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_AMOUNT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_BALANCE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CHECK_SIGNATURE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_HASH_KEY |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOURCE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SENDER |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_BLAKE2B |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA256 |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA512 |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_STEPS_TO_QUOTA |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADDRESS) as name)
((cons _ _) as l) _, _) =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc name 0 (List.length l))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
((Tezos_raw_protocol_alpha.Alpha_context.Script.I_NONE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LEFT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_RIGHT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NIL |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MAP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ITER |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_SET |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP_LEFT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONTRACT) as name)
(([] | cons _ (cons _ _)) as l) _, _) =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc name 1 (List.length l))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
((Tezos_raw_protocol_alpha.Alpha_context.Script.I_PUSH |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_NONE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_LEFT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_CONS |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_MAP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF) as name)
(([] | cons _ [] | cons _ (cons _ (cons _ _))) as l) _, _) =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc name 2 (List.length l))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LAMBDA
(([] | cons _ [] | cons _ (cons _ (cons _ (cons _ _)))) as l) _, _) =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_LAMBDA 3
(List.length l))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
((Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_OR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_XOR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSL |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSR) as name) [] _,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ta
(Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tb _ _) _) =>
op_gtgteqquestion (op_atat Lwt._return (serialize_ty_for_error ctxt ta))
(fun function_parameter =>
let '(ta, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return (serialize_ty_for_error ctxt tb))
(fun function_parameter =>
let '(tb, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_binop
loc name ta tb)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
((Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEG |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ABS |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EQ |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEQ |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GE) as name) [] _,
Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t _ _) =>
op_gtgteqquestion (op_atat Lwt._return (serialize_ty_for_error ctxt t))
(fun function_parameter =>
let '(t, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_unop
loc name t))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
((Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SLICE) as name) [] _,
stack) =>
op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc name 3 stack))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_CONTRACT _ _,
stack) =>
op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_CONTRACT
7 stack))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_ACCOUNT [] _,
stack) =>
op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_ACCOUNT 4
stack))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_TRANSFER_TOKENS [] _,
stack) =>
op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_TRANSFER_TOKENS
4 stack))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
((Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CAR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CDR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOME |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_BLAKE2B |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA256 |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA512 |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_NONE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LEFT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_RIGHT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_LEFT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_CONS |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IMPLICIT_ACCOUNT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEG |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ABS |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_INT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_HASH_KEY |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EQ |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEQ |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GT |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GE) as name) _ _,
stack) =>
op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc name 1 stack))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
((Tezos_raw_protocol_alpha.Alpha_context.Script.I_SWAP |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_PAIR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONS |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EXEC |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CHECK_SIGNATURE |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_OR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_XOR |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSL |
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSR) as name) _ _,
stack) =>
op_gtgteqquestion (serialize_stack_for_error ctxt stack)
(fun function_parameter =>
let '(stack, _ctxt) := function_parameter in
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
loc name 2 stack))
| (expr, _) =>
op_atat fail
(unexpected expr
(cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
Tezos_raw_protocol_alpha.Script_tc_errors.Instr_namespace
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUP
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIG
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.I_SWAP
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOME
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UNIT
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_PAIR
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CAR
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CDR
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONS
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MAP
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ITER
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EXEC
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_FAILWITH
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_OR
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_XOR
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_ABS
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_INT
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEG
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSL
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSR
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_COMPARE
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EQ
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEQ
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LT
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GT
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LE
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_GE
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_TRANSFER_TOKENS
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_ACCOUNT
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_CONTRACT
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOW
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_AMOUNT
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_BALANCE
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IMPLICIT_ACCOUNT
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_CHECK_SIGNATURE
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_BLAKE2B
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA256
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA512
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_HASH_KEY
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_STEPS_TO_QUOTA
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_PUSH
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NONE
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LEFT
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_RIGHT
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_NIL
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_SET
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_NONE
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_LEFT
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_CONS
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_MAP
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOURCE
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SENDER
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_SELF
(cons
Tezos_raw_protocol_alpha.Alpha_context.Script.I_LAMBDA
[])))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
end)
with parse_contract {arg : Type}
(legacy : bool) (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
(arg : Tezos_raw_protocol_alpha.Script_typed_ir.ty arg)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
(entrypoint : string)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.context *
(Tezos_raw_protocol_alpha.Script_typed_ir.typed_contract arg))) :=
op_gtgteqquestion
(op_atat Lwt._return (Gas.consume ctxt Typecheck_costs.contract_exists))
(fun ctxt =>
op_gtgteqquestion (Contract._exists ctxt contract)
(fun function_parameter =>
match function_parameter with
| false =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
loc contract)
| true =>
op_gtgteqquestion
(op_atat Lwt._return (Gas.consume ctxt Typecheck_costs.get_script))
(fun ctxt =>
op_gtgteqquestion
(op_atat
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
loc contract)) (Contract.get_script_code ctxt contract))
(fun function_parameter =>
let '(ctxt, code) := function_parameter in
match code with
| None =>
Lwt._return
(op_gtgtquestion
(ty_eq ctxt arg
(Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t
None))
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
match entrypoint with
| "default" % string =>
let contract := (arg, (contract, entrypoint)) in
ok (ctxt, contract)
| entrypoint =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.No_such_entrypoint
entrypoint)
end))
| Some code =>
op_gtgteqquestion (Script.force_decode ctxt code)
(fun function_parameter =>
let '(code, ctxt) := function_parameter in
Lwt._return
(op_gtgtquestion (parse_toplevel true code)
(fun function_parameter =>
let '(arg_type, _, _, root_name) :=
function_parameter in
op_gtgtquestion
(parse_parameter_ty ctxt true arg_type)
(fun function_parameter =>
let '(Ex_ty targ, ctxt) :=
function_parameter in
let _return
(ctxt :
Tezos_raw_protocol_alpha.Alpha_context.context)
(targ :
Tezos_raw_protocol_alpha.Script_typed_ir.ty
arg) (entrypoint : string)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.context
*
(Tezos_raw_protocol_alpha.Script_typed_ir.typed_contract
arg)) :=
op_gtgtquestion
(merge_types legacy ctxt loc targ arg)
(fun function_parameter =>
let '(arg, ctxt) := function_parameter
in
let contract :=
(arg, (contract, entrypoint)) in
ok (ctxt, contract)) in
op_gtgtquestion
(find_entrypoint_for_type targ arg
root_name entrypoint ctxt)
(fun function_parameter =>
let '(ctxt, entrypoint, targ) :=
function_parameter in
op_gtgtquestion
(merge_types legacy ctxt loc targ arg)
(fun function_parameter =>
let '(targ, ctxt) :=
function_parameter in
_return ctxt targ entrypoint))))))
end))
end))
with parse_contract_for_script {arg : Type}
(legacy : bool) (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
(arg : Tezos_raw_protocol_alpha.Script_typed_ir.ty arg)
(contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
(entrypoint : string)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.context *
(option (Tezos_raw_protocol_alpha.Script_typed_ir.typed_contract arg)))) :=
op_gtgteqquestion
(op_atat Lwt._return (Gas.consume ctxt Typecheck_costs.contract_exists))
(fun ctxt =>
op_gtgteqquestion (Contract._exists ctxt contract)
(fun function_parameter =>
match function_parameter with
| false => _return (ctxt, None)
| true =>
op_gtgteqquestion
(op_atat Lwt._return (Gas.consume ctxt Typecheck_costs.get_script))
(fun ctxt =>
op_gtgteqquestion
(op_atat
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
loc contract)) (Contract.get_script_code ctxt contract))
(fun function_parameter =>
let '(ctxt, code) := function_parameter in
match code with
| None =>
match entrypoint with
| "default" % string =>
Lwt._return
match
ty_eq ctxt arg
(Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t
None) with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
(Eq, ctxt) =>
let contract := (arg, (contract, entrypoint)) in
ok (ctxt, (Some contract))
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ =>
op_gtgtquestion
(Gas.consume ctxt Typecheck_costs.cycle)
(fun ctxt => ok (ctxt, None))
end
| _ => _return (ctxt, None)
end
| Some code =>
op_gtgteqquestion (Script.force_decode ctxt code)
(fun function_parameter =>
let '(code, ctxt) := function_parameter in
Lwt._return
match parse_toplevel true code with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
loc contract)
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
(arg_type, _, _, root_name) =>
match parse_parameter_ty ctxt true arg_type with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
loc contract)
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
(Ex_ty targ, ctxt) =>
match
op_gtgtquestion
(find_entrypoint_for_type targ arg root_name
entrypoint ctxt)
(fun function_parameter =>
let '(ctxt, entrypoint, targ) :=
function_parameter in
op_gtgtquestion
(merge_types legacy ctxt loc targ arg)
(fun function_parameter =>
let '(targ, ctxt) :=
function_parameter in
op_gtgtquestion
(merge_types legacy ctxt loc targ
arg)
(fun function_parameter =>
let '(arg, ctxt) :=
function_parameter in
let contract :=
(arg, (contract, entrypoint)) in
ok (ctxt, (Some contract))))) with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
res => ok res
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ =>
op_gtgtquestion (ty_eq ctxt targ targ)
(fun function_parameter =>
let '(Eq, ctxt) := function_parameter in
op_gtgtquestion
(merge_types legacy ctxt loc targ targ)
(fun function_parameter =>
let '(_, ctxt) := function_parameter
in
ok (ctxt, None)))
end
end
end)
end))
end))
with parse_toplevel
(legacy : bool)
(toplevel : Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.Script.node *
Tezos_raw_protocol_alpha.Alpha_context.Script.node *
Tezos_raw_protocol_alpha.Alpha_context.Script.node * (option string)) :=
op_atat
(record_trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
toplevel []))
match root toplevel with
| Tezos_protocol_environment_alpha__Environment.Micheline.Int loc _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind)
| Tezos_protocol_environment_alpha__Environment.Micheline.String loc _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
Tezos_raw_protocol_alpha.Script_tc_errors.String_kind)
| Tezos_protocol_environment_alpha__Environment.Micheline.Bytes loc _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind)
| Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc _ _ _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind)
| Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ fields =>
let fix find_fields
(p :
option
((Tezos_protocol_environment_alpha__Environment.Micheline.node
Tezos_raw_protocol_alpha.Alpha_context.Script.location
Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
Tezos_raw_protocol_alpha.Alpha_context.Script.location *
Tezos_protocol_environment_alpha__Environment.Micheline.annot)) (s :
option
((Tezos_protocol_environment_alpha__Environment.Micheline.node
Tezos_raw_protocol_alpha.Alpha_context.Script.location
Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
Tezos_raw_protocol_alpha.Alpha_context.Script.location *
Tezos_protocol_environment_alpha__Environment.Micheline.annot)) (c :
option
((Tezos_protocol_environment_alpha__Environment.Micheline.node
Tezos_raw_protocol_alpha.Alpha_context.Script.location
Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
Tezos_raw_protocol_alpha.Alpha_context.Script.location *
Tezos_protocol_environment_alpha__Environment.Micheline.annot))
(fields :
list
(Tezos_protocol_environment_alpha__Environment.Micheline.node
Tezos_raw_protocol_alpha.Alpha_context.Script.location
Tezos_raw_protocol_alpha.Alpha_context.Script.prim))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option
((Tezos_protocol_environment_alpha__Environment.Micheline.node
Tezos_raw_protocol_alpha.Alpha_context.Script.location
Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
Tezos_raw_protocol_alpha.Alpha_context.Script.location *
Tezos_protocol_environment_alpha__Environment.Micheline.annot)) *
(option
((Tezos_protocol_environment_alpha__Environment.Micheline.node
Tezos_raw_protocol_alpha.Alpha_context.Script.location
Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
Tezos_raw_protocol_alpha.Alpha_context.Script.location *
Tezos_protocol_environment_alpha__Environment.Micheline.annot))
*
(option
((Tezos_protocol_environment_alpha__Environment.Micheline.node
Tezos_raw_protocol_alpha.Alpha_context.Script.location
Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
Tezos_raw_protocol_alpha.Alpha_context.Script.location *
Tezos_protocol_environment_alpha__Environment.Micheline.annot))) :=
match fields with
| [] => ok (p, s, c)
|
cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Int loc _)
_ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind [])
Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind)
|
cons
(Tezos_protocol_environment_alpha__Environment.Micheline.String loc
_) _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind [])
Tezos_raw_protocol_alpha.Script_tc_errors.String_kind)
|
cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Bytes loc _)
_ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind [])
Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind)
|
cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc _)
_ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind [])
Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind)
|
cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter
(cons arg []) annot) rest =>
match p with
| None => find_fields (Some (arg, loc, annot)) s c rest
| Some _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_field
loc Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter)
end
|
cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage
(cons arg []) annot) rest =>
match s with
| None => find_fields p (Some (arg, loc, annot)) c rest
| Some _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_field
loc Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage)
end
|
cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.K_code (cons arg [])
annot) rest =>
match c with
| None => find_fields p s (Some (arg, loc, annot)) rest
| Some _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_field
loc Tezos_raw_protocol_alpha.Alpha_context.Script.K_code)
end
|
cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
((Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter |
Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage |
Tezos_raw_protocol_alpha.Alpha_context.Script.K_code) as name)
args _) _ =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
loc name 1 (List.length args))
|
cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
name _ _) _ =>
let allowed :=
cons Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.K_code []))
in
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive
loc allowed name)
end in
op_gtgtquestion (find_fields None None None fields)
(fun function_parameter =>
match function_parameter with
| (None, _, _) =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Missing_field
Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter)
| (Some _, None, _) =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Missing_field
Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage)
| (Some _, Some _, None) =>
error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Missing_field
Tezos_raw_protocol_alpha.Alpha_context.Script.K_code)
|
(Some (p, ploc, pannot), Some (s, sloc, sannot),
Some (c, cloc, carrot)) =>
let maybe_root_name :=
op_gtgtquestion (Script_ir_annot.extract_field_annot p)
(fun function_parameter =>
let '(p, root_name) := function_parameter in
match root_name with
| Some (Field_annot root_name) =>
ok (p, pannot, (Some root_name))
| None =>
match pannot with
| cons single [] =>
ok
(p, [],
(Some
(String.sub single 1
(op_minus (String.length single) 1))))
| _ => ok (p, pannot, None)
end
end) in
if legacy then
let '(p, root_name) :=
match maybe_root_name with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
(p, _, root_name) => (p, root_name)
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ => (p, None)
end in
ok (p, s, c, root_name)
else
op_gtgtquestion maybe_root_name
(fun function_parameter =>
let '(p, pannot, root_name) := function_parameter in
op_gtgtquestion
(Script_ir_annot.error_unexpected_annot ploc pannot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(Script_ir_annot.error_unexpected_annot cloc carrot)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtquestion
(Script_ir_annot.error_unexpected_annot sloc sannot)
(fun function_parameter =>
let 'tt := function_parameter in
ok (p, s, c, root_name)))))
end)
end.
Definition parse_script
(type_logger : option type_logger)
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
(function_parameter : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(ex_script * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let '{| code := code; storage := storage |} := function_parameter in
op_gtgteqquestion (Script.force_decode ctxt code)
(fun function_parameter =>
let '(code, ctxt) := function_parameter in
op_gtgteqquestion (Script.force_decode ctxt storage)
(fun function_parameter =>
let '(storage, ctxt) := function_parameter in
op_gtgteqquestion (op_atat Lwt._return (parse_toplevel legacy code))
(fun function_parameter =>
let '(arg_type, storage_type, code_field, root_name) :=
function_parameter in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
(Some "parameter" % string) code (location arg_type))
(Lwt._return (parse_parameter_ty ctxt legacy arg_type)))
(fun function_parameter =>
let '(Ex_ty arg_type, ctxt) := function_parameter in
op_gtgteqquestion
(if legacy then
_return tt
else
Lwt._return (well_formed_entrypoints arg_type root_name))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
(Some "storage" % string) code
(location storage_type))
(Lwt._return
(parse_storage_ty ctxt legacy storage_type)))
(fun function_parameter =>
let '(Ex_ty storage_type, ctxt) := function_parameter
in
let arg_annot :=
default_annot default_param_annot
(type_to_var_annot (name_of_ty arg_type)) in
let storage_annot :=
default_annot default_storage_annot
(type_to_var_annot (name_of_ty storage_type)) in
let arg_type_full :=
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
(arg_type, None, arg_annot)
(storage_type, None, storage_annot) None
(op_pipepipe (has_big_map arg_type)
(has_big_map storage_type)) in
let ret_type_full :=
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
((Tezos_raw_protocol_alpha.Script_typed_ir.List_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t
None) None false), None, None)
(storage_type, None, None) None
(has_big_map storage_type) in
op_gtgteqquestion
(trace_eval
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtpipequestion
(op_atat Lwt._return
(serialize_ty_for_error ctxt storage_type))
(fun function_parameter =>
let '(storage_type, _ctxt) :=
function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_data
None storage storage_type))
(parse_data type_logger ctxt legacy storage_type
(root storage)))
(fun function_parameter =>
let '(storage, ctxt) := function_parameter in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
code [])
(parse_returning type_logger
(Toplevel
{| storage_type := storage_type;
param_type := arg_type;
root_name := root_name;
legacy_create_contract_literal := false
|}) ctxt legacy (arg_type_full, None)
ret_type_full code_field))
(fun function_parameter =>
let '(code, ctxt) := function_parameter in
_return
((Ex_script
{| code := code; arg_type := arg_type;
storage := storage;
storage_type := storage_type;
root_name := root_name |}), ctxt))))))))).
Definition typecheck_code
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(code : Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Script_tc_errors.type_map *
Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let legacy := false in
op_gtgteqquestion (op_atat Lwt._return (parse_toplevel legacy code))
(fun function_parameter =>
let '(arg_type, storage_type, code_field, root_name) := function_parameter
in
let type_map := ref [] in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
(Some "parameter" % string) code (location arg_type))
(Lwt._return (parse_parameter_ty ctxt legacy arg_type)))
(fun function_parameter =>
let '(Ex_ty arg_type, ctxt) := function_parameter in
op_gtgteqquestion
(if legacy then
_return tt
else
Lwt._return (well_formed_entrypoints arg_type root_name))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
(Some "storage" % string) code (location storage_type))
(Lwt._return (parse_storage_ty ctxt legacy storage_type)))
(fun function_parameter =>
let '(Ex_ty storage_type, ctxt) := function_parameter in
let arg_annot :=
default_annot default_param_annot
(type_to_var_annot (name_of_ty arg_type)) in
let storage_annot :=
default_annot default_storage_annot
(type_to_var_annot (name_of_ty storage_type)) in
let arg_type_full :=
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
(arg_type, None, arg_annot)
(storage_type, None, storage_annot) None
(op_pipepipe (has_big_map arg_type)
(has_big_map storage_type)) in
let ret_type_full :=
Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
((Tezos_raw_protocol_alpha.Script_typed_ir.List_t
(Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t
None) None false), None, None)
(storage_type, None, None) None (has_big_map storage_type)
in
let result :=
parse_returning
(Some
(fun loc =>
fun bef =>
fun aft =>
op_coloneq type_map
(cons (loc, (bef, aft))
(op_exclamation type_map))))
(Toplevel
{| storage_type := storage_type; param_type := arg_type;
root_name := root_name;
legacy_create_contract_literal := false |}) ctxt
legacy (arg_type_full, None) ret_type_full code_field in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
code (op_exclamation type_map)) result)
(fun function_parameter =>
let
'(Tezos_raw_protocol_alpha.Script_typed_ir.Lam _ _, ctxt) :=
function_parameter in
_return ((op_exclamation type_map), ctxt)))))).
Definition typecheck_data
(type_logger : option type_logger)
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(function_parameter :
Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Alpha_context.context) :=
let '(data, exp_ty) := function_parameter in
let legacy := false in
op_gtgteqquestion
(trace
(Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
None exp_ty 0)
(op_atat Lwt._return (parse_packable_ty ctxt legacy (root exp_ty))))
(fun function_parameter =>
let '(Ex_ty exp_ty, ctxt) := function_parameter in
op_gtgteqquestion
(trace_eval
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgtpipequestion
(op_atat Lwt._return (serialize_ty_for_error ctxt exp_ty))
(fun function_parameter =>
let '(exp_ty, _ctxt) := function_parameter in
Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_data
None data exp_ty))
(parse_data type_logger ctxt legacy exp_ty (root data)))
(fun function_parameter =>
let '(_, ctxt) := function_parameter in
_return ctxt)).
(* ❌ Applications of functors are not handled. *)
functor_application
Definition list_entrypoints {A : Type}
(full : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(root_name :
option
Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.key))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((list (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
(Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
((list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
Tezos_raw_protocol_alpha.Alpha_context.Script.node))) :=
let merge {B C : Type}
(path : list B) (annot : option variant) (ty :
Tezos_raw_protocol_alpha.Script_typed_ir.ty C) (reachable : bool)
(function_parameter :
(list (list B)) *
(Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
((list B) * Tezos_raw_protocol_alpha.Alpha_context.Script.node)))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((list (list B)) *
(Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
((list B) * Tezos_raw_protocol_alpha.Alpha_context.Script.node))) :=
let '(unreachables, all) as acc := function_parameter in
match annot with
| None | Some (Field_annot "" % string) =>
op_atat ok
(if reachable then
acc
else
match ty with
| Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ _ => acc
| _ => ((cons (List.rev path) unreachables), all)
end)
| Some (Field_annot name) =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
(String.length name) 31 then
ok ((cons (List.rev path) unreachables), all)
else
if
Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.mem)
name all then
ok ((cons (List.rev path) unreachables), all)
else
op_gtgtquestion (unparse_ty_no_lwt ctxt ty)
(fun function_parameter =>
let '(unparsed_ty, _) := function_parameter in
ok
(unreachables,
(Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
name ((List.rev path), unparsed_ty) all)))
end in
let fix fold_tree {t : Type}
(t : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) (path :
list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (reachable : bool)
(acc :
(list (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
(Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
((list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
Tezos_raw_protocol_alpha.Alpha_context.Script.node)))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((list (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
(Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
((list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
Tezos_raw_protocol_alpha.Alpha_context.Script.node))) :=
match t with
| Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tl, al) (tr, ar) _ _ =>
op_gtgtquestion
(merge (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left path)
al tl reachable acc)
(fun acc =>
op_gtgtquestion
(merge
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right path)
ar tr reachable acc)
(fun acc =>
op_gtgtquestion
(fold_tree tl
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left
path)
match al with
| Some _ => true
| None => reachable
end acc)
(fun acc =>
fold_tree tr
(cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right
path)
match ar with
| Some _ => true
| None => reachable
end acc)))
| _ => ok acc
end in
op_gtgtquestion (unparse_ty_no_lwt ctxt full)
(fun function_parameter =>
let '(unparsed_full, _) := function_parameter in
let '(init, reachable) :=
match root_name with
| None | Some "" % string =>
(Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.empty),
false)
| Some name =>
((Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.singleton)
name ([], unparsed_full)), true)
end in
fold_tree full [] reachable ([], init)).
Fixpoint unparse_data {a : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(mode : unparsing_mode) (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
(a : a)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.Script.node *
Tezos_raw_protocol_alpha.Alpha_context.context)) :=
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.cycle))
(fun ctxt =>
match (ty, a) with
| (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _, tt) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.unit))
(fun ctxt =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
(-1) Tezos_raw_protocol_alpha.Alpha_context.Script.D_Unit [] []),
ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _, v) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt (Unparse_costs.int v)))
(fun ctxt =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Int (-1)
(Script_int.to_zint v)), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _, v) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt (Unparse_costs.int v)))
(fun ctxt =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Int (-1)
(Script_int.to_zint v)), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.String_t _, s) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Unparse_costs.string s)))
(fun ctxt =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.String
(-1) s), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _, s) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Unparse_costs.bytes s)))
(fun ctxt =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
(-1) s), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _, true) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.bool))
(fun ctxt =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
(-1) Tezos_raw_protocol_alpha.Alpha_context.Script.D_True [] []),
ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _, false) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.bool))
(fun ctxt =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
(-1) Tezos_raw_protocol_alpha.Alpha_context.Script.D_False [] []),
ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _, t) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Unparse_costs.timestamp t)))
(fun ctxt =>
match mode with
| Optimized =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Int
(-1) (Script_timestamp.to_zint t)), ctxt)
| Readable =>
match Script_timestamp.to_notation t with
| None =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Int
(-1) (Script_timestamp.to_zint t)), ctxt)
| Some s =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.String
(-1) s), ctxt)
end
end)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _, (c, entrypoint))
=>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Unparse_costs.contract))
(fun ctxt =>
match mode with
| Optimized =>
let entrypoint :=
match entrypoint with
| "default" % string => "" % string
| name => name
end in
let bytes :=
Data_encoding.Binary.to_bytes_exn
(tup2 Contract.encoding Variable.string) (c, entrypoint) in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
(-1) string), ctxt)
| Readable =>
let notation :=
match entrypoint with
| "default" % string => Contract.to_b58check c
| entrypoint =>
op_caret (Contract.to_b58check c)
(op_caret "%" % string entrypoint)
end in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.String
(-1) notation), ctxt)
end)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _,
(_, (c, entrypoint))) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Unparse_costs.contract))
(fun ctxt =>
match mode with
| Optimized =>
let entrypoint :=
match entrypoint with
| "default" % string => "" % string
| name => name
end in
let bytes :=
Data_encoding.Binary.to_bytes_exn
(tup2 Contract.encoding Variable.string) (c, entrypoint) in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
(-1) string), ctxt)
| Readable =>
let notation :=
match entrypoint with
| "default" % string => Contract.to_b58check c
| entrypoint =>
op_caret (Contract.to_b58check c)
(op_caret "%" % string entrypoint)
end in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.String
(-1) notation), ctxt)
end)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _, s) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Unparse_costs.signature))
(fun ctxt =>
match mode with
| Optimized =>
let bytes :=
Data_encoding.Binary.to_bytes_exn Signature.encoding s in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
(-1) string), ctxt)
| Readable =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.String
(-1) (Signature.to_b58check s)), ctxt)
end)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _, v) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.tez))
(fun ctxt =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Int (-1)
(Z.of_int64 (Tez.to_mutez v))), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _, k) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.key))
(fun ctxt =>
match mode with
| Optimized =>
let bytes :=
Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding
k in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
(-1) string), ctxt)
| Readable =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.String
(-1) (Signature.Public_key.to_b58check k)), ctxt)
end)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _, k) =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Unparse_costs.key_hash))
(fun ctxt =>
match mode with
| Optimized =>
let bytes :=
Data_encoding.Binary.to_bytes_exn
Signature.Public_key_hash.encoding k in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
(-1) string), ctxt)
| Readable =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.String
(-1) (Signature.Public_key_hash.to_b58check k)), ctxt)
end)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _,
(op, _big_map_diff)) =>
let bytes :=
Data_encoding.Binary.to_bytes_exn
Operation.internal_operation_encoding op in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Unparse_costs.operation string)))
(fun ctxt =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
(-1) string), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _, chain_id) =>
let bytes :=
Data_encoding.Binary.to_bytes_exn
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)
chain_id in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Unparse_costs.chain_id string)))
(fun ctxt =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
(-1) string), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (tl, _, _) (tr, _, _) _
_, (l, r)) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.pair))
(fun ctxt =>
op_gtgteqquestion (unparse_data ctxt mode tl l)
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
op_gtgteqquestion (unparse_data ctxt mode tr r)
(fun function_parameter =>
let '(r, ctxt) := function_parameter in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
(-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Pair
(cons l (cons r [])) []), ctxt))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tl, _) _ _ _,
Tezos_raw_protocol_alpha.Script_typed_ir.L l) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.union))
(fun ctxt =>
op_gtgteqquestion (unparse_data ctxt mode tl l)
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
(-1) Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left
(cons l []) []), ctxt)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ (tr, _) _ _,
Tezos_raw_protocol_alpha.Script_typed_ir.R r) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.union))
(fun ctxt =>
op_gtgteqquestion (unparse_data ctxt mode tr r)
(fun function_parameter =>
let '(r, ctxt) := function_parameter in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
(-1) Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right
(cons r []) []), ctxt)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t _ _, Some v) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.some))
(fun ctxt =>
op_gtgteqquestion (unparse_data ctxt mode t v)
(fun function_parameter =>
let '(v, ctxt) := function_parameter in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
(-1) Tezos_raw_protocol_alpha.Alpha_context.Script.D_Some
(cons v []) []), ctxt)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ _, None) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.none))
(fun ctxt =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
(-1) Tezos_raw_protocol_alpha.Alpha_context.Script.D_None [] []),
ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.List_t t _ _, items) =>
op_gtgteqquestion
(fold_left_s
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
fun element =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Unparse_costs.list_element))
(fun ctxt =>
op_gtgteqquestion (unparse_data ctxt mode t element)
(fun function_parameter =>
let '(unparsed, ctxt) := function_parameter in
_return ((cons unparsed l), ctxt)))) ([], ctxt) items)
(fun function_parameter =>
let '(items, ctxt) := function_parameter in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Seq (-1)
(List.rev items)), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t t _, set) =>
let t := ty_of_comparable_ty t in
op_gtgteqquestion
(fold_left_s
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
fun item =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Unparse_costs.set_element))
(fun ctxt =>
op_gtgteqquestion (unparse_data ctxt mode t item)
(fun function_parameter =>
let '(item, ctxt) := function_parameter in
_return ((cons item l), ctxt)))) ([], ctxt)
(set_fold (fun e => fun acc => cons e acc) set []))
(fun function_parameter =>
let '(items, ctxt) := function_parameter in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Seq (-1)
items), ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t kt vt _ _, map) =>
let kt := ty_of_comparable_ty kt in
op_gtgteqquestion
(fold_left_s
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
fun function_parameter =>
let '(k, v) := function_parameter in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Unparse_costs.map_element))
(fun ctxt =>
op_gtgteqquestion (unparse_data ctxt mode kt k)
(fun function_parameter =>
let '(key, ctxt) := function_parameter in
op_gtgteqquestion (unparse_data ctxt mode vt v)
(fun function_parameter =>
let '(value, ctxt) := function_parameter in
_return
((cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
(-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Elt
(cons key (cons value [])) []) l), ctxt)))))
([], ctxt)
(map_fold (fun k => fun v => fun acc => cons (k, v) acc) map []))
(fun function_parameter =>
let '(items, ctxt) := function_parameter in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Seq (-1)
items), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t kt vt _, {|
id := None; diff := Diff |}) =>
let Diff := projT2 Diff in
let kt := ty_of_comparable_ty kt in
op_gtgteqquestion
(fold_left_s
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
fun function_parameter =>
let '(k, v) := function_parameter in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Unparse_costs.map_element))
(fun ctxt =>
op_gtgteqquestion (unparse_data ctxt mode kt k)
(fun function_parameter =>
let '(key, ctxt) := function_parameter in
op_gtgteqquestion (unparse_data ctxt mode vt v)
(fun function_parameter =>
let '(value, ctxt) := function_parameter in
_return
((cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
(-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.D_Elt
(cons key (cons value [])) []) l), ctxt)))))
([], ctxt)
(Diff.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.fold)
(fun k =>
fun v =>
fun acc =>
match v with
| None => acc
| Some v => cons (k, v) acc
end)
(fst
Diff.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed))
[]))
(fun function_parameter =>
let '(items, ctxt) := function_parameter in
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Seq (-1)
items), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _kt _kv _, {|
id := Some id; diff := Diff |}) =>
let Diff := projT2 Diff in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(Diff.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.cardinal)
(fst
Diff.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)))
0 then
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Int (-1)
id), ctxt)
else
(* ❌ Assert instruction is not handled. *)
assert false
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t _ _ _,
Tezos_raw_protocol_alpha.Script_typed_ir.Lam _ original_code) =>
unparse_code ctxt mode original_code
end)
with unparse_code
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(mode : unparsing_mode)
: Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_protocol_environment_alpha__Environment.Micheline.node Z
Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
Tezos_raw_protocol_alpha__Alpha_context.context)) :=
let legacy := true in
fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_PUSH
(cons ty (cons data [])) annot =>
op_gtgteqquestion (Lwt._return (parse_packable_ty ctxt legacy ty))
(fun function_parameter =>
let '(Ex_ty t, ctxt) := function_parameter in
op_gtgteqquestion (parse_data None ctxt legacy t data)
(fun function_parameter =>
let '(data, ctxt) := function_parameter in
op_gtgteqquestion (unparse_data ctxt mode t data)
(fun function_parameter =>
let '(data, ctxt) := function_parameter in
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)))
(fun ctxt =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
loc
Tezos_raw_protocol_alpha.Alpha_context.Script.I_PUSH
(cons ty (cons data [])) annot), ctxt)))))
| Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc items =>
op_gtgteqquestion
(fold_left_s
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
fun item =>
op_gtgteqquestion (unparse_code ctxt mode item)
(fun function_parameter =>
let '(item, ctxt) := function_parameter in
_return ((cons item l), ctxt))) ([], ctxt) items)
(fun function_parameter =>
let '(items, ctxt) := function_parameter in
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))))
(fun ctxt =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Seq
loc (List.rev items)), ctxt)))
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc prim
items annot =>
op_gtgteqquestion
(fold_left_s
(fun function_parameter =>
let '(l, ctxt) := function_parameter in
fun item =>
op_gtgteqquestion (unparse_code ctxt mode item)
(fun function_parameter =>
let '(item, ctxt) := function_parameter in
_return ((cons item l), ctxt))) ([], ctxt) items)
(fun function_parameter =>
let '(items, ctxt) := function_parameter in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)))
(fun ctxt =>
_return
((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
loc prim (List.rev items) annot), ctxt)))
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Int _ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.String _ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ _) as
atom => _return (atom, ctxt)
end.
Definition unparse_script {A B : Type}
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(mode : unparsing_mode)
(function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.script A B)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.Script.t *
Tezos_raw_protocol_alpha__Alpha_context.context)) :=
let '{|
code := code;
arg_type := arg_type;
storage := storage;
storage_type := storage_type;
root_name := root_name
|} := function_parameter in
let 'Tezos_raw_protocol_alpha.Script_typed_ir.Lam _ original_code := code in
op_gtgteqquestion (unparse_code ctxt mode original_code)
(fun function_parameter =>
let '(code, ctxt) := function_parameter in
op_gtgteqquestion (unparse_data ctxt mode storage_type storage)
(fun function_parameter =>
let '(storage, ctxt) := function_parameter in
op_gtgteqquestion (unparse_ty ctxt arg_type)
(fun function_parameter =>
let '(arg_type, ctxt) := function_parameter in
op_gtgteqquestion (unparse_ty ctxt storage_type)
(fun function_parameter =>
let '(storage_type, ctxt) := function_parameter in
let arg_type :=
add_field_annot
(Option.map
(fun n =>
(* ❌ Variants not supported *)
variant) root_name) None arg_type in
let code :=
Tezos_protocol_environment_alpha__Environment.Micheline.Seq
(-1)
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
(-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter
(cons arg_type []) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
(-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage
(cons storage_type []) [])
(cons
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim
(-1)
Tezos_raw_protocol_alpha.Alpha_context.Script.K_code
(cons code []) []) []))) in
op_gtgteqquestion
(Lwt._return
(op_gtgtquestion
(Gas.consume ctxt (Unparse_costs.seq_cost 3))
(fun ctxt =>
op_gtgtquestion
(Gas.consume ctxt (Unparse_costs.prim_cost 1 []))
(fun ctxt =>
op_gtgtquestion
(Gas.consume ctxt (Unparse_costs.prim_cost 1 []))
(fun ctxt =>
Gas.consume ctxt
(Unparse_costs.prim_cost 1 []))))))
(fun ctxt =>
_return
({| code := lazy_expr (strip_locations code);
storage := lazy_expr (strip_locations storage) |},
ctxt)))))).
Definition pack_data {A : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(typ : Tezos_raw_protocol_alpha.Script_typed_ir.ty A) (data : A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_protocol_environment_alpha__Environment.MBytes.t *
Tezos_raw_protocol_alpha__Alpha_context.context)) :=
op_gtgteqquestion (unparse_data ctxt Optimized typ data)
(fun function_parameter =>
let '(unparsed, ctxt) := function_parameter in
let bytes :=
Data_encoding.Binary.to_bytes_exn expr_encoding
(Micheline.strip_locations unparsed) in
op_gtgteqquestion
(op_atat Lwt._return (Gas.consume ctxt (Script.serialized_cost string)))
(fun ctxt =>
let bytes :=
MBytes.concat "" % string
(cons (MBytes.of_string "" % string) (cons string [])) in
op_gtgteqquestion
(op_atat Lwt._return
(Gas.consume ctxt (Script.serialized_cost string)))
(fun ctxt => _return (string, ctxt)))).
Definition hash_data {A : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(typ : Tezos_raw_protocol_alpha.Script_typed_ir.ty A) (data : A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Script_expr_hash.t *
Tezos_raw_protocol_alpha__Alpha_context.context)) :=
op_gtgteqquestion (pack_data ctxt typ data)
(fun function_parameter =>
let '(bytes, ctxt) := function_parameter in
op_gtgteqquestion
(op_atat Lwt._return
(Gas.consume ctxt
(Michelson_v1_gas.Cost_of.Legacy.hash string Script_expr_hash.size)))
(fun ctxt => _return ((hash_bytes None (cons string [])), ctxt))).
Definition empty_big_map {A B : Type}
(tk : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty A)
(tv : Tezos_raw_protocol_alpha.Script_typed_ir.ty B)
: Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B :=
{| id := None; diff := empty_map tk; key_type := ty_of_comparable_ty tk;
value_type := tv |}.
Definition big_map_mem {A B : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (key : A)
(function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(bool * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let '{| id := id; diff := diff; key_type := key_type |} := function_parameter
in
match ((map_get key diff), id) with
| (None, None) => _return (false, ctxt)
| (None, Some id) =>
op_gtgteqquestion (hash_data ctxt key_type key)
(fun function_parameter =>
let '(hash, ctxt) := function_parameter in
op_gtgteqquestion (Alpha_context.Big_map.mem ctxt id hash)
(fun function_parameter =>
let '(ctxt, res) := function_parameter in
_return (res, ctxt)))
| (Some None, _) => _return (false, ctxt)
| (Some (Some _), _) => _return (true, ctxt)
end.
Definition big_map_get {A B : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (key : A)
(function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((option B) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let '{|
id := id;
diff := diff;
key_type := key_type;
value_type := value_type
|} := function_parameter in
match ((map_get key diff), id) with
| (Some x, _) => _return (x, ctxt)
| (None, None) => _return (None, ctxt)
| (None, Some id) =>
op_gtgteqquestion (hash_data ctxt key_type key)
(fun function_parameter =>
let '(hash, ctxt) := function_parameter in
op_gtgteqquestion (Alpha_context.Big_map.get_opt ctxt id hash)
(fun function_parameter =>
match function_parameter with
| (ctxt, None) => _return (None, ctxt)
| (ctxt, Some value) =>
op_gtgteqquestion
(parse_data None ctxt true value_type (Micheline.root value))
(fun function_parameter =>
let '(x, ctxt) := function_parameter in
_return ((Some x), ctxt))
end))
end.
Definition big_map_update {A B : Type}
(key : A) (value : option B)
(function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B)
: Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B :=
let '{| diff := diff |} as map := function_parameter in
(* ❌ Record substitution not handled *)
record_substitution.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition big_map_ids :=
Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t).
Definition no_big_map_id
: Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t) :=
Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.empty).
Definition diff_of_big_map {A B : Type}
(ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
(fresh :
Tezos_raw_protocol_alpha__Alpha_context.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha__Alpha_context.context *
Tezos_raw_protocol_alpha__Alpha_context.Big_map.id)))
(mode : unparsing_mode)
(ids : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
(function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((list Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff_item)
* Tezos_raw_protocol_alpha__Alpha_context.Big_map.id *
Tezos_raw_protocol_alpha__Alpha_context.context)) :=
let '{|
id := id;
diff := diff;
key_type := key_type;
value_type := value_type
|} := function_parameter in
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list diff)))
(fun ctxt =>
op_gtgteqquestion
match id with
| Some id =>
if
Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.mem) id ids
then
op_gtgteqquestion (fresh ctxt)
(fun function_parameter =>
let '(ctxt, duplicate) := function_parameter in
_return
(ctxt,
(cons
(Tezos_raw_protocol_alpha.Alpha_context.Contract.Copy id
duplicate) []), duplicate))
else
_return (ctxt, [], id)
| None =>
op_gtgteqquestion (fresh ctxt)
(fun function_parameter =>
let '(ctxt, id) := function_parameter in
op_gtgteqquestion (unparse_ty ctxt key_type)
(fun function_parameter =>
let '(kt, ctxt) := function_parameter in
op_gtgteqquestion (unparse_ty ctxt value_type)
(fun function_parameter =>
let '(kv, ctxt) := function_parameter in
_return
(ctxt,
(cons
(Tezos_raw_protocol_alpha.Alpha_context.Contract.Alloc
{| big_map := id;
key_type := Micheline.strip_locations kt;
value_type := Micheline.strip_locations kv |})
[]), id))))
end
(fun function_parameter =>
let '(ctxt, init, big_map) := function_parameter in
let pairs :=
map_fold (fun key => fun value => fun acc => cons (key, value) acc)
diff [] in
op_gtgteqquestion
(fold_left_s
(fun function_parameter =>
let '(acc, ctxt) := function_parameter in
fun function_parameter =>
let '(key, value) := function_parameter in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
op_gtgteqquestion (hash_data ctxt key_type key)
(fun function_parameter =>
let '(diff_key_hash, ctxt) := function_parameter in
op_gtgteqquestion
(unparse_data ctxt mode key_type key)
(fun function_parameter =>
let '(key_node, ctxt) := function_parameter in
let diff_key := Micheline.strip_locations key_node
in
op_gtgteqquestion
match value with
| None => _return (None, ctxt)
| Some x =>
op_gtgteqquestion
(unparse_data ctxt mode value_type x)
(fun function_parameter =>
let '(node, ctxt) := function_parameter in
_return
((Some (Micheline.strip_locations node)),
ctxt))
end
(fun function_parameter =>
let '(diff_value, ctxt) := function_parameter
in
let diff_item :=
Tezos_raw_protocol_alpha.Alpha_context.Contract.Update
{| big_map := big_map;
diff_key := diff_key;
diff_key_hash := diff_key_hash;
diff_value := diff_value |} in
_return ((cons diff_item acc), ctxt))))))
([], ctxt) pairs)
(fun function_parameter =>
let '(diff, ctxt) := function_parameter in
_return ((op_at init diff), big_map, ctxt)))).
Fixpoint extract_big_map_updates {a : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(fresh :
Tezos_raw_protocol_alpha.Alpha_context.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.context *
Tezos_raw_protocol_alpha.Alpha_context.Big_map.id)))
(mode : unparsing_mode)
(ids : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
(acc : list Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff)
(ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty a) (x : a)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Alpha_context.context * a *
Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t) *
(list Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
match (ty, x) with
| (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _ _ _, map) =>
op_gtgteqquestion (diff_of_big_map ctxt fresh mode ids map)
(fun function_parameter =>
let '(diff, id, ctxt) := function_parameter in
let Map := diff map in
let Map := projT2 Map in
let map :=
(* ❌ Record substitution not handled *)
record_substitution in
_return
(ctxt, map,
(Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.add) id
ids), (cons diff acc)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (tyl, _, _) (tyr, _, _) _
true, (xl, xr)) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
op_gtgteqquestion
(extract_big_map_updates ctxt fresh mode ids acc tyl xl)
(fun function_parameter =>
let '(ctxt, xl, ids, acc) := function_parameter in
op_gtgteqquestion
(extract_big_map_updates ctxt fresh mode ids acc tyr xr)
(fun function_parameter =>
let '(ctxt, xr, ids, acc) := function_parameter in
_return (ctxt, (xl, xr), ids, acc))))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (ty, _) (_, _) _ true,
Tezos_raw_protocol_alpha.Script_typed_ir.L x) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
op_gtgteqquestion (extract_big_map_updates ctxt fresh mode ids acc ty x)
(fun function_parameter =>
let '(ctxt, x, ids, acc) := function_parameter in
_return
(ctxt, (Tezos_raw_protocol_alpha.Script_typed_ir.L x), ids, acc)))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (_, _) (ty, _) _ true,
Tezos_raw_protocol_alpha.Script_typed_ir.R x) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
op_gtgteqquestion (extract_big_map_updates ctxt fresh mode ids acc ty x)
(fun function_parameter =>
let '(ctxt, x, ids, acc) := function_parameter in
_return
(ctxt, (Tezos_raw_protocol_alpha.Script_typed_ir.R x), ids, acc)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t ty _ true, Some x) =>
op_gtgteqquestion (Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
op_gtgteqquestion (extract_big_map_updates ctxt fresh mode ids acc ty x)
(fun function_parameter =>
let '(ctxt, x, ids, acc) := function_parameter in
_return (ctxt, (Some x), ids, acc)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.List_t ty _ true, l) =>
op_gtgteqquestion
(fold_left_s
(fun function_parameter =>
let '(ctxt, l, ids, acc) := function_parameter in
fun x =>
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
op_gtgteqquestion
(extract_big_map_updates ctxt fresh mode ids acc ty x)
(fun function_parameter =>
let '(ctxt, x, ids, acc) := function_parameter in
_return (ctxt, (cons x l), ids, acc)))) (ctxt, [], ids, acc)
l)
(fun function_parameter =>
let '(ctxt, l, ids, acc) := function_parameter in
_return (ctxt, (List.rev l), ids, acc))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ ty _ true, M as m) =>
let M := projT2 M in
op_gtgteqquestion
(Lwt._return
(Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list m)))
(fun ctxt =>
op_gtgteqquestion
(fold_left_s
(fun function_parameter =>
let '(ctxt, m, ids, acc) := function_parameter in
fun function_parameter =>
let '(k, x) := function_parameter in
op_gtgteqquestion
(Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
(fun ctxt =>
op_gtgteqquestion
(extract_big_map_updates ctxt fresh mode ids acc ty x)
(fun function_parameter =>
let '(ctxt, x, ids, acc) := function_parameter in
_return
(ctxt,
(M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
k x m), ids, acc))))
(ctxt,
M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.empty),
ids, acc)
(M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.bindings)
(fst M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed))))
(fun function_parameter =>
let '(ctxt, m, ids, acc) := function_parameter in
let M :=
(* ❌ The signature name of this module could not be found *)
existT _ _
{|
unknown_signature_name.OPS :=
M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS);
unknown_signature_name.key_ty :=
M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty);
unknown_signature_name.boxed :=
(m,
(snd
M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)))
|} in
_return (ctxt, M, ids, acc)))
| (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ true, None) =>
_return (ctxt, None, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.List_t _ _ false, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ _ _ false, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ false, None) =>
_return (ctxt, None, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t _ _ _ false, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ false, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ false, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t _ _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.String_t _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t _ _ _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _, v) =>
_return (ctxt, v, ids, acc)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _, _) =>
(* ❌ Assert instruction is not handled. *)
assert false
end.
Definition collect_big_maps {A : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A) (x : A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t) *
Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let fix collect {a : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (ty :
Tezos_raw_protocol_alpha.Script_typed_ir.ty a) (x : a) (acc :
Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t) *
Tezos_raw_protocol_alpha.Alpha_context.context) :=
match (ty, x) with
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _ _ _, {|
id := Some id |}) =>
op_gtgtquestion (Gas.consume ctxt Typecheck_costs.cycle)
(fun ctxt =>
ok
((Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.add) id
acc), ctxt))
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (tyl, _, _) (tyr, _, _) _
true, (xl, xr)) =>
op_gtgtquestion (collect ctxt tyl xl acc)
(fun function_parameter =>
let '(acc, ctxt) := function_parameter in
collect ctxt tyr xr acc)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (ty, _) (_, _) _ true,
Tezos_raw_protocol_alpha.Script_typed_ir.L x) => collect ctxt ty x acc
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (_, _) (ty, _) _ true,
Tezos_raw_protocol_alpha.Script_typed_ir.R x) => collect ctxt ty x acc
| (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t ty _ true, Some x) =>
collect ctxt ty x acc
| (Tezos_raw_protocol_alpha.Script_typed_ir.List_t ty _ true, l) =>
List.fold_left
(fun acc =>
fun x =>
op_gtgtquestion acc
(fun function_parameter =>
let '(acc, ctxt) := function_parameter in
collect ctxt ty x acc)) (ok (acc, ctxt)) l
| (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ ty _ true, m) =>
map_fold
(fun function_parameter =>
let '_ := function_parameter in
fun v =>
fun acc =>
op_gtgtquestion acc
(fun function_parameter =>
let '(acc, ctxt) := function_parameter in
collect ctxt ty v acc)) m (ok (acc, ctxt))
| (Tezos_raw_protocol_alpha.Script_typed_ir.List_t _ _ false, _) =>
ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ _ _ false, _) =>
ok (acc, ctxt)
|
(Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _ _ _, {|
id := None |}) => ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ true, None) =>
ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ false, _) =>
ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ false, _) =>
ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t _ _ _ false, _) =>
ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _, _) =>
ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t _ _, _) => ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _, _) => ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _, _) => ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _, _) => ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _, _) =>
ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.String_t _, _) => ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _, _) => ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _, _) => ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _, _) =>
ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _, _) => ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _, _) =>
ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _, _) =>
ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _, _) => ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t _ _ _, _) =>
ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _, _) =>
ok (acc, ctxt)
| (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _, _) =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
Lwt._return (collect ctxt ty x no_big_map_id).
Definition extract_big_map_diff {A : Type}
(ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
(mode : unparsing_mode) (temporary : bool)
(to_duplicate : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
(to_update : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
(ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A) (v : A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(A *
(option
(list
Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff_item))
* Tezos_raw_protocol_alpha.Alpha_context.context)) :=
let to_duplicate :=
Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.diff) to_duplicate
to_update in
let fresh :=
if temporary then
fun c => _return (Big_map.fresh_temporary c)
else
Big_map.fresh in
op_gtgteqquestion
(extract_big_map_updates ctxt fresh mode to_duplicate [] ty v)
(fun function_parameter =>
let '(ctxt, v, alive, diffs) := function_parameter in
let diffs :=
if temporary then
diffs
else
let dead :=
Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.diff)
to_update alive in
cons
(Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.fold)
(fun id =>
fun acc =>
cons
(Tezos_raw_protocol_alpha.Alpha_context.Contract.Clear id)
acc) dead []) diffs in
match diffs with
| [] => _return (v, None, ctxt)
| diffs => _return (v, (Some (List.flatten diffs)), ctxt)
end).
Definition list_of_big_map_ids
(ids : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
: list Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.elt) :=
Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.elements) ids.
src/proto_alpha/lib_protocol/script_repr.ml 6 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type location = Micheline.canonical_location
let location_encoding = Micheline.canonical_location_encoding
type annot = Micheline.annot
type expr = Michelson_v1_primitives.prim Micheline.canonical
type lazy_expr = expr Data_encoding.lazy_t
type node = (location, Michelson_v1_primitives.prim) Micheline.node
let expr_encoding =
Micheline.canonical_encoding_v1
~variant:"michelson_v1"
Michelson_v1_primitives.prim_encoding
type error += Lazy_script_decode (* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"invalid_binary_format"
~title:"Invalid binary format"
~description:
"Could not deserialize some piece of data from its binary representation"
Data_encoding.empty
(function Lazy_script_decode -> Some () | _ -> None)
(fun () -> Lazy_script_decode)
let lazy_expr_encoding = Data_encoding.lazy_encoding expr_encoding
let lazy_expr expr = Data_encoding.make_lazy expr_encoding expr
type t = {code : lazy_expr; storage : lazy_expr}
let encoding =
let open Data_encoding in
def "scripted.contracts"
@@ conv
(fun {code; storage} -> (code, storage))
(fun (code, storage) -> {code; storage})
(obj2 (req "code" lazy_expr_encoding) (req "storage" lazy_expr_encoding))
let int_node_size_of_numbits n = (1, 1 + ((n + 63) / 64))
let int_node_size n = int_node_size_of_numbits (Z.numbits n)
let string_node_size_of_length s = (1, 1 + ((s + 7) / 8))
let string_node_size s = string_node_size_of_length (String.length s)
let bytes_node_size_of_length s =
(* approx cost of indirection to the C heap *)
(2, 1 + ((s + 7) / 8) + 12)
let bytes_node_size s = bytes_node_size_of_length (MBytes.length s)
let prim_node_size_nonrec_of_lengths n_args annots =
let annots_length =
List.fold_left (fun acc s -> acc + String.length s) 0 annots
in
if Compare.Int.(annots_length = 0) then (1 + n_args, 2 + (2 * n_args))
else (2 + n_args, 4 + (2 * n_args) + ((annots_length + 7) / 8))
let prim_node_size_nonrec args annots =
let n_args = List.length args in
prim_node_size_nonrec_of_lengths n_args annots
let seq_node_size_nonrec_of_length n_args = (1 + n_args, 2 + (2 * n_args))
let seq_node_size_nonrec args =
let n_args = List.length args in
seq_node_size_nonrec_of_length n_args
let rec node_size node =
let open Micheline in
match node with
| Int (_, n) ->
int_node_size n
| String (_, s) ->
string_node_size s
| Bytes (_, s) ->
bytes_node_size s
| Prim (_, _, args, annot) ->
List.fold_left
(fun (blocks, words) node ->
let (nblocks, nwords) = node_size node in
(blocks + nblocks, words + nwords))
(prim_node_size_nonrec args annot)
args
| Seq (_, args) ->
List.fold_left
(fun (blocks, words) node ->
let (nblocks, nwords) = node_size node in
(blocks + nblocks, words + nwords))
(seq_node_size_nonrec args)
args
let expr_size expr = node_size (Micheline.root expr)
let traversal_cost node =
let (blocks, _words) = node_size node in
Gas_limit_repr.step_cost blocks
let cost_of_size (blocks, words) =
let open Gas_limit_repr in
(Compare.Int.max 0 (blocks - 1) *@ alloc_cost 0)
+@ alloc_cost words +@ step_cost blocks
let node_cost node = cost_of_size (node_size node)
let int_node_cost n = cost_of_size (int_node_size n)
let int_node_cost_of_numbits n = cost_of_size (int_node_size_of_numbits n)
let string_node_cost s = cost_of_size (string_node_size s)
let string_node_cost_of_length s = cost_of_size (string_node_size_of_length s)
let bytes_node_cost s = cost_of_size (bytes_node_size s)
let bytes_node_cost_of_length s = cost_of_size (bytes_node_size_of_length s)
let prim_node_cost_nonrec args annot =
cost_of_size (prim_node_size_nonrec args annot)
let prim_node_cost_nonrec_of_length n_args annot =
cost_of_size (prim_node_size_nonrec_of_lengths n_args annot)
let seq_node_cost_nonrec args = cost_of_size (seq_node_size_nonrec args)
let seq_node_cost_nonrec_of_length n_args =
cost_of_size (seq_node_size_nonrec_of_length n_args)
let deserialized_cost expr = cost_of_size (expr_size expr)
let serialized_cost bytes =
let open Gas_limit_repr in
alloc_mbytes_cost (MBytes.length bytes)
let force_decode lexpr =
let account_deserialization_cost =
Data_encoding.apply_lazy
~fun_value:(fun _ -> false)
~fun_bytes:(fun _ -> true)
~fun_combine:(fun _ _ -> false)
lexpr
in
match Data_encoding.force_decode lexpr with
| Some v ->
if account_deserialization_cost then ok (v, deserialized_cost v)
else ok (v, Gas_limit_repr.free)
| None ->
error Lazy_script_decode
let force_bytes expr =
let open Gas_limit_repr in
let account_serialization_cost =
Data_encoding.apply_lazy
~fun_value:(fun v -> Some v)
~fun_bytes:(fun _ -> None)
~fun_combine:(fun _ _ -> None)
expr
in
match Data_encoding.force_bytes expr with
| bytes -> (
match account_serialization_cost with
| Some v ->
ok (bytes, traversal_cost (Micheline.root v) +@ serialized_cost bytes)
| None ->
ok (bytes, Gas_limit_repr.free) )
| exception _ ->
error Lazy_script_decode
let minimal_deserialize_cost lexpr =
Data_encoding.apply_lazy
~fun_value:(fun _ -> Gas_limit_repr.free)
~fun_bytes:(fun b -> serialized_cost b)
~fun_combine:(fun c_free _ -> c_free)
lexpr
let unit =
Micheline.strip_locations (Prim (0, Michelson_v1_primitives.D_Unit, [], []))
let unit_parameter = lazy_expr unit
let is_unit_parameter =
let unit_bytes = Data_encoding.force_bytes unit_parameter in
Data_encoding.apply_lazy
~fun_value:(fun v ->
match Micheline.root v with
| Prim (_, Michelson_v1_primitives.D_Unit, [], []) ->
true
| _ ->
false)
~fun_bytes:(fun b -> MBytes.( = ) b unit_bytes)
~fun_combine:(fun res _ -> res)
let rec strip_annotations node =
let open Micheline in
match node with
| (Int (_, _) | String (_, _) | Bytes (_, _)) as leaf ->
leaf
| Prim (loc, name, args, _) ->
Prim (loc, name, List.map strip_annotations args, [])
| Seq (loc, args) ->
Seq (loc, List.map strip_annotations args)
src/proto_alpha/lib_protocol/script_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition location :=
Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location.
Definition location_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location :=
Micheline.canonical_location_encoding.
Definition annot :=
Tezos_protocol_environment_alpha__Environment.Micheline.annot.
Definition expr :=
Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim.
Definition lazy_expr :=
Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t expr.
Definition node :=
Tezos_protocol_environment_alpha__Environment.Micheline.node location
Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim.
Definition expr_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) :=
Micheline.canonical_encoding_v1 "michelson_v1" % string
Michelson_v1_primitives.prim_encoding.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition lazy_expr_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
(Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) :=
Data_encoding.lazy_encoding expr_encoding.
Definition lazy_expr
(expr :
Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)
: Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
(Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) :=
Data_encoding.make_lazy expr_encoding expr.
Record t := {
code : lazy_expr;
storage : lazy_expr }.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
op_atat
(let arg := def "scripted.contracts" % string in
fun eta => arg None None eta)
(conv
(fun function_parameter =>
let '{| code := code; storage := storage |} := function_parameter in
(code, storage))
(fun function_parameter =>
let '(code, storage) := function_parameter in
{| code := code; storage := storage |}) None
(obj2 (req None None "code" % string lazy_expr_encoding)
(req None None "storage" % string lazy_expr_encoding))).
Definition int_node_size_of_numbits (n : Z) : Z * Z :=
(1, (op_plus 1 (op_div (op_plus n 63) 64))).
Definition int_node_size (n : Tezos_protocol_environment_alpha__Environment.Z.t)
: Z * Z := int_node_size_of_numbits (Z.numbits n).
Definition string_node_size_of_length (s : Z) : Z * Z :=
(1, (op_plus 1 (op_div (op_plus s 7) 8))).
Definition string_node_size (s : string) : Z * Z :=
string_node_size_of_length (String.length s).
Definition bytes_node_size_of_length (s : Z) : Z * Z :=
(2, (op_plus (op_plus 1 (op_div (op_plus s 7) 8)) 12)).
Definition bytes_node_size
(s : Tezos_protocol_environment_alpha__Environment.MBytes.t) : Z * Z :=
bytes_node_size_of_length (MBytes.length s).
Definition prim_node_size_nonrec_of_lengths (n_args : Z) (annots : list string)
: Z * Z :=
let annots_length :=
List.fold_left (fun acc => fun s => op_plus acc (String.length s)) 0 annots
in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
annots_length 0 then
((op_plus 1 n_args), (op_plus 2 (op_star 2 n_args)))
else
((op_plus 2 n_args),
(op_plus (op_plus 4 (op_star 2 n_args))
(op_div (op_plus annots_length 7) 8))).
Definition prim_node_size_nonrec {A : Type}
(args : list A) (annots : list string) : Z * Z :=
let n_args := List.length args in
prim_node_size_nonrec_of_lengths n_args annots.
Definition seq_node_size_nonrec_of_length (n_args : Z) : Z * Z :=
((op_plus 1 n_args), (op_plus 2 (op_star 2 n_args))).
Definition seq_node_size_nonrec {A : Type} (args : list A) : Z * Z :=
let n_args := List.length args in
seq_node_size_nonrec_of_length n_args.
Fixpoint node_size {A B : Type}
(node : Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
: Z * Z :=
match node with
| Tezos_protocol_environment_alpha__Environment.Micheline.Int _ n =>
int_node_size n
| Tezos_protocol_environment_alpha__Environment.Micheline.String _ s =>
string_node_size s
| Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ s =>
bytes_node_size s
| Tezos_protocol_environment_alpha__Environment.Micheline.Prim _ _ args annot
=>
List.fold_left
(fun function_parameter =>
let '(blocks, words) := function_parameter in
fun node =>
let '(nblocks, nwords) := node_size node in
((op_plus blocks nblocks), (op_plus words nwords)))
(prim_node_size_nonrec args annot) args
| Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ args =>
List.fold_left
(fun function_parameter =>
let '(blocks, words) := function_parameter in
fun node =>
let '(nblocks, nwords) := node_size node in
((op_plus blocks nblocks), (op_plus words nwords)))
(seq_node_size_nonrec args) args
end.
Definition expr_size {A : Type}
(expr : Tezos_protocol_environment_alpha__Environment.Micheline.canonical A)
: Z * Z := node_size (Micheline.root expr).
Definition traversal_cost {A B : Type}
(node : Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
let '(blocks, _words) := node_size node in
Gas_limit_repr.step_cost blocks.
Definition cost_of_size (function_parameter : Z * Z)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
let '(blocks, words) := function_parameter in
op_plusat
(op_plusat
(op_starat
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
0 (op_minus blocks 1)) (alloc_cost 0)) (alloc_cost words))
(step_cost blocks).
Definition node_cost {A B : Type}
(node : Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
cost_of_size (node_size node).
Definition int_node_cost (n : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
cost_of_size (int_node_size n).
Definition int_node_cost_of_numbits (n : Z)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
cost_of_size (int_node_size_of_numbits n).
Definition string_node_cost (s : string)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
cost_of_size (string_node_size s).
Definition string_node_cost_of_length (s : Z)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
cost_of_size (string_node_size_of_length s).
Definition bytes_node_cost
(s : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
cost_of_size (bytes_node_size s).
Definition bytes_node_cost_of_length (s : Z)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
cost_of_size (bytes_node_size_of_length s).
Definition prim_node_cost_nonrec {A : Type}
(args : list A) (annot : list string)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
cost_of_size (prim_node_size_nonrec args annot).
Definition prim_node_cost_nonrec_of_length (n_args : Z) (annot : list string)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
cost_of_size (prim_node_size_nonrec_of_lengths n_args annot).
Definition seq_node_cost_nonrec {A : Type} (args : list A)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
cost_of_size (seq_node_size_nonrec args).
Definition seq_node_cost_nonrec_of_length (n_args : Z)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
cost_of_size (seq_node_size_nonrec_of_length n_args).
Definition deserialized_cost {A : Type}
(expr : Tezos_protocol_environment_alpha__Environment.Micheline.canonical A)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
cost_of_size (expr_size expr).
Definition serialized_cost
(bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
alloc_mbytes_cost (MBytes.length string).
Definition force_decode {A : Type}
(lexpr :
Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
(Tezos_protocol_environment_alpha__Environment.Micheline.canonical A))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((Tezos_protocol_environment_alpha__Environment.Micheline.canonical A) *
Tezos_raw_protocol_alpha.Gas_limit_repr.cost) :=
let account_deserialization_cost :=
Data_encoding.apply_lazy
(fun function_parameter =>
let '_ := function_parameter in
false)
(fun function_parameter =>
let '_ := function_parameter in
true)
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
false) lexpr in
match Data_encoding.force_decode lexpr with
| Some v =>
if account_deserialization_cost then
ok (v, (deserialized_cost v))
else
ok (v, Gas_limit_repr.free)
| None =>
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Lazy_script_decode
end.
Definition force_bytes {A : Type}
(expr :
Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
(Tezos_protocol_environment_alpha__Environment.Micheline.canonical A))
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_protocol_environment_alpha__Environment.MBytes.t *
Tezos_raw_protocol_alpha.Gas_limit_repr.cost) :=
let account_serialization_cost :=
Data_encoding.apply_lazy (fun v => Some v)
(fun function_parameter =>
let '_ := function_parameter in
None)
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
None) expr in
let 'bytes := Data_encoding.force_bytes expr in
match account_serialization_cost with
| Some v =>
ok
(string,
(op_plusat (traversal_cost (Micheline.root v)) (serialized_cost string)))
| None => ok (string, Gas_limit_repr.free)
end.
Definition minimal_deserialize_cost {A : Type}
(lexpr : Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t A)
: Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
Data_encoding.apply_lazy
(fun function_parameter =>
let '_ := function_parameter in
Gas_limit_repr.free) (fun b => serialized_cost b)
(fun c_free =>
fun function_parameter =>
let '_ := function_parameter in
c_free) lexpr.
Definition unit
: Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim :=
Micheline.strip_locations
(Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
Tezos_raw_protocol_alpha.Michelson_v1_primitives.D_Unit [] []).
Definition unit_parameter
: Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
(Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) := lazy_expr unit.
Definition is_unit_parameter
: (Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
(Tezos_protocol_environment_alpha__Environment.Micheline.canonical
Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) -> bool :=
let unit_bytes := Data_encoding.force_bytes unit_parameter in
Data_encoding.apply_lazy
(fun v =>
match Micheline.root v with
|
Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
Tezos_raw_protocol_alpha.Michelson_v1_primitives.D_Unit [] [] => true
| _ => false
end) (fun b => MBytes.op_eq b unit_bytes)
(fun res =>
fun function_parameter =>
let '_ := function_parameter in
res).
Fixpoint strip_annotations {A B : Type}
(node : Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
: Tezos_protocol_environment_alpha__Environment.Micheline.node A B :=
match node with
|
(Tezos_protocol_environment_alpha__Environment.Micheline.Int _ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.String _ _ |
Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ _) as leaf
=> leaf
| Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc name args _
=>
Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc name
(List.map strip_annotations args) []
| Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc args =>
Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc
(List.map strip_annotations args)
end.
src/proto_alpha/lib_protocol/script_tc_errors.ml 49 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
open Script
(* ---- Error definitions ---------------------------------------------------*)
(* Auxiliary types for error documentation *)
type namespace =
| Type_namespace
| Constant_namespace
| Instr_namespace
| Keyword_namespace
type kind = Int_kind | String_kind | Bytes_kind | Prim_kind | Seq_kind
type unparsed_stack_ty = (Script.expr * Script.annot) list
type type_map = (int * (unparsed_stack_ty * unparsed_stack_ty)) list
(* Structure errors *)
type error += Invalid_arity of Script.location * prim * int * int
type error +=
| Invalid_namespace of Script.location * prim * namespace * namespace
type error += Invalid_primitive of Script.location * prim list * prim
type error += Invalid_kind of Script.location * kind list * kind
type error += Missing_field of prim
type error += Duplicate_field of Script.location * prim
type error += Unexpected_big_map of Script.location
type error += Unexpected_operation of Script.location
type error += Unexpected_contract of Script.location
type error += No_such_entrypoint of string
type error += Duplicate_entrypoint of string
type error += Unreachable_entrypoint of prim list
type error += Entrypoint_name_too_long of string
(* Instruction typing errors *)
type error += Fail_not_in_tail_position of Script.location
type error +=
| Undefined_binop :
Script.location * prim * Script.expr * Script.expr
-> error
type error += Undefined_unop : Script.location * prim * Script.expr -> error
type error +=
| Bad_return : Script.location * unparsed_stack_ty * Script.expr -> error
type error +=
| Bad_stack : Script.location * prim * int * unparsed_stack_ty -> error
type error +=
| Unmatched_branches :
Script.location * unparsed_stack_ty * unparsed_stack_ty
-> error
type error += Self_in_lambda of Script.location
type error += Bad_stack_length
type error += Bad_stack_item of int
type error += Inconsistent_annotations of string * string
type error +=
| Inconsistent_type_annotations :
Script.location * Script.expr * Script.expr
-> error
type error += Inconsistent_field_annotations of string * string
type error += Unexpected_annotation of Script.location
type error += Ungrouped_annotations of Script.location
type error += Invalid_map_body : Script.location * unparsed_stack_ty -> error
type error += Invalid_map_block_fail of Script.location
type error +=
| Invalid_iter_body :
Script.location * unparsed_stack_ty * unparsed_stack_ty
-> error
type error += Type_too_large : Script.location * int * int -> error
(* Value typing errors *)
type error +=
| Invalid_constant : Script.location * Script.expr * Script.expr -> error
type error +=
| Invalid_syntactic_constant :
Script.location * Script.expr * string
-> error
type error += Invalid_contract of Script.location * Contract.t
type error += Invalid_big_map of Script.location * Big_map.id
type error +=
| Comparable_type_expected : Script.location * Script.expr -> error
type error += Inconsistent_types : Script.expr * Script.expr -> error
type error += Unordered_map_keys of Script.location * Script.expr
type error += Unordered_set_values of Script.location * Script.expr
type error += Duplicate_map_keys of Script.location * Script.expr
type error += Duplicate_set_values of Script.location * Script.expr
(* Toplevel errors *)
type error +=
| Ill_typed_data : string option * Script.expr * Script.expr -> error
type error +=
| Ill_formed_type of string option * Script.expr * Script.location
type error += Ill_typed_contract : Script.expr * type_map -> error
(* Gas related errors *)
type error += Cannot_serialize_error
(* Deprecation errors *)
type error += Deprecated_instruction of prim
src/proto_alpha/lib_protocol/script_tc_errors.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Import Script.
Inductive namespace : Type :=
| Type_namespace : namespace
| Constant_namespace : namespace
| Instr_namespace : namespace
| Keyword_namespace : namespace.
Inductive kind : Type :=
| Int_kind : kind
| String_kind : kind
| Bytes_kind : kind
| Prim_kind : kind
| Seq_kind : kind.
Definition unparsed_stack_ty :=
list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
Tezos_raw_protocol_alpha.Alpha_context.Script.annot).
Definition type_map := list (Z * (unparsed_stack_ty * unparsed_stack_ty)).
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
src/proto_alpha/lib_protocol/script_tc_errors_registration.ml 9 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
open Script
open Script_tc_errors
(* Helpers for encoding *)
let type_map_enc =
let open Data_encoding in
let stack_enc = list (tup2 Script.expr_encoding (list string)) in
list
(conv
(fun (loc, (bef, aft)) -> (loc, bef, aft))
(fun (loc, bef, aft) -> (loc, (bef, aft)))
(obj3
(req "location" Script.location_encoding)
(req "stack_before" stack_enc)
(req "stack_after" stack_enc)))
let stack_ty_enc =
let open Data_encoding in
list (obj2 (req "type" Script.expr_encoding) (dft "annots" (list string) []))
(* main registration *)
let () =
let open Data_encoding in
let located enc =
merge_objs (obj1 (req "location" Script.location_encoding)) enc
in
let arity_enc = int8 in
let namespace_enc =
def
"primitiveNamespace"
~title:"Primitive namespace"
~description:
"One of the three possible namespaces of primitive (data constructor, \
type name or instruction)."
@@ string_enum
[ ("type", Type_namespace);
("constant", Constant_namespace);
("instruction", Instr_namespace) ]
in
let kind_enc =
def
"expressionKind"
~title:"Expression kind"
~description:
"One of the four possible kinds of expression (integer, string, \
primitive application or sequence)."
@@ string_enum
[ ("integer", Int_kind);
("string", String_kind);
("bytes", Bytes_kind);
("primitiveApplication", Prim_kind);
("sequence", Seq_kind) ]
in
(* -- Structure errors ---------------------- *)
(* Invalid arity *)
register_error_kind
`Permanent
~id:"michelson_v1.invalid_arity"
~title:"Invalid arity"
~description:
"In a script or data expression, a primitive was applied to an \
unsupported number of arguments."
(located
(obj3
(req "primitive_name" Script.prim_encoding)
(req "expected_arity" arity_enc)
(req "wrong_arity" arity_enc)))
(function
| Invalid_arity (loc, name, exp, got) ->
Some (loc, (name, exp, got))
| _ ->
None)
(fun (loc, (name, exp, got)) -> Invalid_arity (loc, name, exp, got)) ;
(* Missing field *)
register_error_kind
`Permanent
~id:"michelson_v1.missing_script_field"
~title:"Script is missing a field (parse error)"
~description:"When parsing script, a field was expected, but not provided"
(obj1 (req "prim" prim_encoding))
(function Missing_field prim -> Some prim | _ -> None)
(fun prim -> Missing_field prim) ;
(* Invalid primitive *)
register_error_kind
`Permanent
~id:"michelson_v1.invalid_primitive"
~title:"Invalid primitive"
~description:"In a script or data expression, a primitive was unknown."
(located
(obj2
(dft "expected_primitive_names" (list prim_encoding) [])
(req "wrong_primitive_name" prim_encoding)))
(function
| Invalid_primitive (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None)
(fun (loc, (exp, got)) -> Invalid_primitive (loc, exp, got)) ;
(* Invalid kind *)
register_error_kind
`Permanent
~id:"michelson_v1.invalid_expression_kind"
~title:"Invalid expression kind"
~description:
"In a script or data expression, an expression was of the wrong kind \
(for instance a string where only a primitive applications can appear)."
(located
(obj2 (req "expected_kinds" (list kind_enc)) (req "wrong_kind" kind_enc)))
(function
| Invalid_kind (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None)
(fun (loc, (exp, got)) -> Invalid_kind (loc, exp, got)) ;
(* Invalid namespace *)
register_error_kind
`Permanent
~id:"michelson_v1.invalid_primitive_namespace"
~title:"Invalid primitive namespace"
~description:
"In a script or data expression, a primitive was of the wrong namespace."
(located
(obj3
(req "primitive_name" prim_encoding)
(req "expected_namespace" namespace_enc)
(req "wrong_namespace" namespace_enc)))
(function
| Invalid_namespace (loc, name, exp, got) ->
Some (loc, (name, exp, got))
| _ ->
None)
(fun (loc, (name, exp, got)) -> Invalid_namespace (loc, name, exp, got)) ;
(* Duplicate field *)
register_error_kind
`Permanent
~id:"michelson_v1.duplicate_script_field"
~title:"Script has a duplicated field (parse error)"
~description:"When parsing script, a field was found more than once"
(obj2 (req "loc" location_encoding) (req "prim" prim_encoding))
(function Duplicate_field (loc, prim) -> Some (loc, prim) | _ -> None)
(fun (loc, prim) -> Duplicate_field (loc, prim)) ;
(* Unexpected big_map *)
register_error_kind
`Permanent
~id:"michelson_v1.unexpected_bigmap"
~title:"Big map in unauthorized position (type error)"
~description:
"When parsing script, a big_map type was found in a position where it \
could end up stored inside a big_map, which is forbidden for now."
(obj1 (req "loc" location_encoding))
(function Unexpected_big_map loc -> Some loc | _ -> None)
(fun loc -> Unexpected_big_map loc) ;
(* Unexpected operation *)
register_error_kind
`Permanent
~id:"michelson_v1.unexpected_operation"
~title:"Operation in unauthorized position (type error)"
~description:
"When parsing script, an operation type was found in the storage or \
parameter field."
(obj1 (req "loc" location_encoding))
(function Unexpected_operation loc -> Some loc | _ -> None)
(fun loc -> Unexpected_operation loc) ;
(* No such entrypoint *)
register_error_kind
`Permanent
~id:"michelson_v1.no_such_entrypoint"
~title:"No such entrypoint (type error)"
~description:"An entrypoint was not found when calling a contract."
(obj1 (req "entrypoint" string))
(function No_such_entrypoint entrypoint -> Some entrypoint | _ -> None)
(fun entrypoint -> No_such_entrypoint entrypoint) ;
(* Unreachable entrypoint *)
register_error_kind
`Permanent
~id:"michelson_v1.unreachable_entrypoint"
~title:"Unreachable entrypoint (type error)"
~description:"An entrypoint in the contract is not reachable."
(obj1 (req "path" (list prim_encoding)))
(function Unreachable_entrypoint path -> Some path | _ -> None)
(fun path -> Unreachable_entrypoint path) ;
(* Duplicate entrypoint *)
register_error_kind
`Permanent
~id:"michelson_v1.duplicate_entrypoint"
~title:"Duplicate entrypoint (type error)"
~description:"Two entrypoints have the same name."
(obj1 (req "path" string))
(function Duplicate_entrypoint entrypoint -> Some entrypoint | _ -> None)
(fun entrypoint -> Duplicate_entrypoint entrypoint) ;
(* Entrypoint name too long *)
register_error_kind
`Permanent
~id:"michelson_v1.entrypoint_name_too_long"
~title:"Entrypoint name too long (type error)"
~description:
"An entrypoint name exceeds the maximum length of 31 characters."
(obj1 (req "name" string))
(function
| Entrypoint_name_too_long entrypoint -> Some entrypoint | _ -> None)
(fun entrypoint -> Entrypoint_name_too_long entrypoint) ;
(* Unexpected contract *)
register_error_kind
`Permanent
~id:"michelson_v1.unexpected_contract"
~title:"Contract in unauthorized position (type error)"
~description:
"When parsing script, a contract type was found in the storage or \
parameter field."
(obj1 (req "loc" location_encoding))
(function Unexpected_contract loc -> Some loc | _ -> None)
(fun loc -> Unexpected_contract loc) ;
(* -- Value typing errors ---------------------- *)
(* Unordered map keys *)
register_error_kind
`Permanent
~id:"michelson_v1.unordered_map_literal"
~title:"Invalid map key order"
~description:"Map keys must be in strictly increasing order"
(obj2
(req "location" Script.location_encoding)
(req "item" Script.expr_encoding))
(function Unordered_map_keys (loc, expr) -> Some (loc, expr) | _ -> None)
(fun (loc, expr) -> Unordered_map_keys (loc, expr)) ;
(* Duplicate map keys *)
register_error_kind
`Permanent
~id:"michelson_v1.duplicate_map_keys"
~title:"Duplicate map keys"
~description:"Map literals cannot contain duplicated keys"
(obj2
(req "location" Script.location_encoding)
(req "item" Script.expr_encoding))
(function Duplicate_map_keys (loc, expr) -> Some (loc, expr) | _ -> None)
(fun (loc, expr) -> Duplicate_map_keys (loc, expr)) ;
(* Unordered set values *)
register_error_kind
`Permanent
~id:"michelson_v1.unordered_set_literal"
~title:"Invalid set value order"
~description:"Set values must be in strictly increasing order"
(obj2
(req "location" Script.location_encoding)
(req "value" Script.expr_encoding))
(function
| Unordered_set_values (loc, expr) -> Some (loc, expr) | _ -> None)
(fun (loc, expr) -> Unordered_set_values (loc, expr)) ;
(* Duplicate set values *)
register_error_kind
`Permanent
~id:"michelson_v1.duplicate_set_values_in_literal"
~title:"Sets literals cannot contain duplicate elements"
~description:
"Set literals cannot contain duplicate elements, but a duplicae was \
found while parsing."
(obj2
(req "location" Script.location_encoding)
(req "value" Script.expr_encoding))
(function
| Duplicate_set_values (loc, expr) -> Some (loc, expr) | _ -> None)
(fun (loc, expr) -> Duplicate_set_values (loc, expr)) ;
(* -- Instruction typing errors ------------- *)
(* Fail not in tail position *)
register_error_kind
`Permanent
~id:"michelson_v1.fail_not_in_tail_position"
~title:"FAIL not in tail position"
~description:"There is non trivial garbage code after a FAIL instruction."
(located empty)
(function Fail_not_in_tail_position loc -> Some (loc, ()) | _ -> None)
(fun (loc, ()) -> Fail_not_in_tail_position loc) ;
(* Undefined binary operation *)
register_error_kind
`Permanent
~id:"michelson_v1.undefined_binop"
~title:"Undefined binop"
~description:
"A binary operation is called on operands of types over which it is not \
defined."
(located
(obj3
(req "operator_name" prim_encoding)
(req "wrong_left_operand_type" Script.expr_encoding)
(req "wrong_right_operand_type" Script.expr_encoding)))
(function
| Undefined_binop (loc, n, tyl, tyr) ->
Some (loc, (n, tyl, tyr))
| _ ->
None)
(fun (loc, (n, tyl, tyr)) -> Undefined_binop (loc, n, tyl, tyr)) ;
(* Undefined unary operation *)
register_error_kind
`Permanent
~id:"michelson_v1.undefined_unop"
~title:"Undefined unop"
~description:
"A unary operation is called on an operand of type over which it is not \
defined."
(located
(obj2
(req "operator_name" prim_encoding)
(req "wrong_operand_type" Script.expr_encoding)))
(function Undefined_unop (loc, n, ty) -> Some (loc, (n, ty)) | _ -> None)
(fun (loc, (n, ty)) -> Undefined_unop (loc, n, ty)) ;
(* Bad return *)
register_error_kind
`Permanent
~id:"michelson_v1.bad_return"
~title:"Bad return"
~description:"Unexpected stack at the end of a lambda or script."
(located
(obj2
(req "expected_return_type" Script.expr_encoding)
(req "wrong_stack_type" stack_ty_enc)))
(function Bad_return (loc, sty, ty) -> Some (loc, (ty, sty)) | _ -> None)
(fun (loc, (ty, sty)) -> Bad_return (loc, sty, ty)) ;
(* Bad stack *)
register_error_kind
`Permanent
~id:"michelson_v1.bad_stack"
~title:"Bad stack"
~description:"The stack has an unexpected length or contents."
(located
(obj3
(req "primitive_name" prim_encoding)
(req "relevant_stack_portion" int16)
(req "wrong_stack_type" stack_ty_enc)))
(function
| Bad_stack (loc, name, s, sty) -> Some (loc, (name, s, sty)) | _ -> None)
(fun (loc, (name, s, sty)) -> Bad_stack (loc, name, s, sty)) ;
(* Inconsistent annotations *)
register_error_kind
`Permanent
~id:"michelson_v1.inconsistent_annotations"
~title:"Annotations inconsistent between branches"
~description:"The annotations on two types could not be merged"
(obj2 (req "annot1" string) (req "annot2" string))
(function
| Inconsistent_annotations (annot1, annot2) ->
Some (annot1, annot2)
| _ ->
None)
(fun (annot1, annot2) -> Inconsistent_annotations (annot1, annot2)) ;
(* Inconsistent field annotations *)
register_error_kind
`Permanent
~id:"michelson_v1.inconsistent_field_annotations"
~title:"Annotations for field accesses is inconsistent"
~description:
"The specified field does not match the field annotation in the type"
(obj2 (req "annot1" string) (req "annot2" string))
(function
| Inconsistent_field_annotations (annot1, annot2) ->
Some (annot1, annot2)
| _ ->
None)
(fun (annot1, annot2) -> Inconsistent_field_annotations (annot1, annot2)) ;
(* Inconsistent type annotations *)
register_error_kind
`Permanent
~id:"michelson_v1.inconsistent_type_annotations"
~title:"Types contain inconsistent annotations"
~description:"The two types contain annotations that do not match"
(located
(obj2
(req "type1" Script.expr_encoding)
(req "type2" Script.expr_encoding)))
(function
| Inconsistent_type_annotations (loc, ty1, ty2) ->
Some (loc, (ty1, ty2))
| _ ->
None)
(fun (loc, (ty1, ty2)) -> Inconsistent_type_annotations (loc, ty1, ty2)) ;
(* Unexpected annotation *)
register_error_kind
`Permanent
~id:"michelson_v1.unexpected_annotation"
~title:"An annotation was encountered where no annotation is expected"
~description:"A node in the syntax tree was impropperly annotated"
(located empty)
(function Unexpected_annotation loc -> Some (loc, ()) | _ -> None)
(fun (loc, ()) -> Unexpected_annotation loc) ;
(* Ungrouped annotations *)
register_error_kind
`Permanent
~id:"michelson_v1.ungrouped_annotations"
~title:"Annotations of the same kind were found spread apart"
~description:"Annotations of the same kind must be grouped"
(located empty)
(function Ungrouped_annotations loc -> Some (loc, ()) | _ -> None)
(fun (loc, ()) -> Ungrouped_annotations loc) ;
(* Unmatched branches *)
register_error_kind
`Permanent
~id:"michelson_v1.unmatched_branches"
~title:"Unmatched branches"
~description:
"At the join point at the end of two code branches the stacks have \
inconsistent lengths or contents."
(located
(obj2
(req "first_stack_type" stack_ty_enc)
(req "other_stack_type" stack_ty_enc)))
(function
| Unmatched_branches (loc, stya, styb) ->
Some (loc, (stya, styb))
| _ ->
None)
(fun (loc, (stya, styb)) -> Unmatched_branches (loc, stya, styb)) ;
(* Bad stack item *)
register_error_kind
`Permanent
~id:"michelson_v1.bad_stack_item"
~title:"Bad stack item"
~description:
"The type of a stack item is unexpected (this error is always \
accompanied by a more precise one)."
(obj1 (req "item_level" int16))
(function Bad_stack_item n -> Some n | _ -> None)
(fun n -> Bad_stack_item n) ;
(* SELF in lambda *)
register_error_kind
`Permanent
~id:"michelson_v1.self_in_lambda"
~title:"SELF instruction in lambda"
~description:"A SELF instruction was encountered in a lambda expression."
(located empty)
(function Self_in_lambda loc -> Some (loc, ()) | _ -> None)
(fun (loc, ()) -> Self_in_lambda loc) ;
(* Bad stack length *)
register_error_kind
`Permanent
~id:"michelson_v1.inconsistent_stack_lengths"
~title:"Inconsistent stack lengths"
~description:
"A stack was of an unexpected length (this error is always in the \
context of a located error)."
empty
(function Bad_stack_length -> Some () | _ -> None)
(fun () -> Bad_stack_length) ;
(* -- Value typing errors ------------------- *)
(* Invalid constant *)
register_error_kind
`Permanent
~id:"michelson_v1.invalid_constant"
~title:"Invalid constant"
~description:"A data expression was invalid for its expected type."
(located
(obj2
(req "expected_type" Script.expr_encoding)
(req "wrong_expression" Script.expr_encoding)))
(function
| Invalid_constant (loc, expr, ty) -> Some (loc, (ty, expr)) | _ -> None)
(fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ;
(* Invalid syntactic constant *)
register_error_kind
`Permanent
~id:"invalidSyntacticConstantError"
~title:"Invalid constant (parse error)"
~description:"A compile-time constant was invalid for its expected form."
(located
(obj2
(req "expectedForm" Script.expr_encoding)
(req "wrongExpression" Script.expr_encoding)))
(function
| Invalid_constant (loc, expr, ty) -> Some (loc, (ty, expr)) | _ -> None)
(fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ;
(* Invalid contract *)
register_error_kind
`Permanent
~id:"michelson_v1.invalid_contract"
~title:"Invalid contract"
~description:
"A script or data expression references a contract that does not exist \
or assumes a wrong type for an existing contract."
(located (obj1 (req "contract" Contract.encoding)))
(function Invalid_contract (loc, c) -> Some (loc, c) | _ -> None)
(fun (loc, c) -> Invalid_contract (loc, c)) ;
(* Invalid big_map *)
register_error_kind
`Permanent
~id:"michelson_v1.invalid_big_map"
~title:"Invalid big_map"
~description:
"A script or data expression references a big_map that does not exist \
or assumes a wrong type for an existing big_map."
(located (obj1 (req "big_map" z)))
(function Invalid_big_map (loc, c) -> Some (loc, c) | _ -> None)
(fun (loc, c) -> Invalid_big_map (loc, c)) ;
(* Comparable type expected *)
register_error_kind
`Permanent
~id:"michelson_v1.comparable_type_expected"
~title:"Comparable type expected"
~description:
"A non comparable type was used in a place where only comparable types \
are accepted."
(located (obj1 (req "wrong_type" Script.expr_encoding)))
(function
| Comparable_type_expected (loc, ty) -> Some (loc, ty) | _ -> None)
(fun (loc, ty) -> Comparable_type_expected (loc, ty)) ;
(* Inconsistent types *)
register_error_kind
`Permanent
~id:"michelson_v1.inconsistent_types"
~title:"Inconsistent types"
~description:
"This is the basic type clash error, that appears in several places \
where the equality of two types have to be proven, it is always \
accompanied with another error that provides more context."
(obj2
(req "first_type" Script.expr_encoding)
(req "other_type" Script.expr_encoding))
(function Inconsistent_types (tya, tyb) -> Some (tya, tyb) | _ -> None)
(fun (tya, tyb) -> Inconsistent_types (tya, tyb)) ;
(* -- Instruction typing errors ------------------- *)
(* Invalid map body *)
register_error_kind
`Permanent
~id:"michelson_v1.invalid_map_body"
~title:"Invalid map body"
~description:"The body of a map block did not match the expected type"
(obj2 (req "loc" Script.location_encoding) (req "body_type" stack_ty_enc))
(function Invalid_map_body (loc, stack) -> Some (loc, stack) | _ -> None)
(fun (loc, stack) -> Invalid_map_body (loc, stack)) ;
(* Invalid map block FAIL *)
register_error_kind
`Permanent
~id:"michelson_v1.invalid_map_block_fail"
~title:"FAIL instruction occurred as body of map block"
~description:
"FAIL cannot be the only instruction in the body. The propper type of \
the return list cannot be inferred."
(obj1 (req "loc" Script.location_encoding))
(function Invalid_map_block_fail loc -> Some loc | _ -> None)
(fun loc -> Invalid_map_block_fail loc) ;
(* Invalid ITER body *)
register_error_kind
`Permanent
~id:"michelson_v1.invalid_iter_body"
~title:"ITER body returned wrong stack type"
~description:
"The body of an ITER instruction must result in the same stack type as \
before the ITER."
(obj3
(req "loc" Script.location_encoding)
(req "bef_stack" stack_ty_enc)
(req "aft_stack" stack_ty_enc))
(function
| Invalid_iter_body (loc, bef, aft) -> Some (loc, bef, aft) | _ -> None)
(fun (loc, bef, aft) -> Invalid_iter_body (loc, bef, aft)) ;
(* Type too large *)
register_error_kind
`Permanent
~id:"michelson_v1.type_too_large"
~title:"Stack item type too large"
~description:"An instruction generated a type larger than the limit."
(obj3
(req "loc" Script.location_encoding)
(req "type_size" uint16)
(req "maximum_type_size" uint16))
(function
| Type_too_large (loc, ts, maxts) -> Some (loc, ts, maxts) | _ -> None)
(fun (loc, ts, maxts) -> Type_too_large (loc, ts, maxts)) ;
(* -- Toplevel errors ------------------- *)
(* Ill typed data *)
register_error_kind
`Permanent
~id:"michelson_v1.ill_typed_data"
~title:"Ill typed data"
~description:
"The toplevel error thrown when trying to typecheck a data expression \
against a given type (always followed by more precise errors)."
(obj3
(opt "identifier" string)
(req "expected_type" Script.expr_encoding)
(req "ill_typed_expression" Script.expr_encoding))
(function
| Ill_typed_data (name, expr, ty) -> Some (name, ty, expr) | _ -> None)
(fun (name, ty, expr) -> Ill_typed_data (name, expr, ty)) ;
(* Ill formed type *)
register_error_kind
`Permanent
~id:"michelson_v1.ill_formed_type"
~title:"Ill formed type"
~description:
"The toplevel error thrown when trying to parse a type expression \
(always followed by more precise errors)."
(obj3
(opt "identifier" string)
(req "ill_formed_expression" Script.expr_encoding)
(req "location" Script.location_encoding))
(function
| Ill_formed_type (name, expr, loc) -> Some (name, expr, loc) | _ -> None)
(fun (name, expr, loc) -> Ill_formed_type (name, expr, loc)) ;
(* Ill typed contract *)
register_error_kind
`Permanent
~id:"michelson_v1.ill_typed_contract"
~title:"Ill typed contract"
~description:
"The toplevel error thrown when trying to typecheck a contract code \
against given input, output and storage types (always followed by more \
precise errors)."
(obj2
(req "ill_typed_code" Script.expr_encoding)
(req "type_map" type_map_enc))
(function
| Ill_typed_contract (expr, type_map) ->
Some (expr, type_map)
| _ ->
None)
(fun (expr, type_map) -> Ill_typed_contract (expr, type_map)) ;
(* Cannot serialize error *)
register_error_kind
`Temporary
~id:"michelson_v1.cannot_serialize_error"
~title:"Not enough gas to serialize error"
~description:"The error was too big to be serialized with the provided gas"
Data_encoding.empty
(function Cannot_serialize_error -> Some () | _ -> None)
(fun () -> Cannot_serialize_error) ;
(* Deprecated instruction *)
register_error_kind
`Permanent
~id:"michelson_v1.deprecated_instruction"
~title:"Script is using a deprecated instruction"
~description:
"A deprecated instruction usage is disallowed in newly created contracts"
(obj1 (req "prim" prim_encoding))
(function Deprecated_instruction prim -> Some prim | _ -> None)
(fun prim -> Deprecated_instruction prim)
src/proto_alpha/lib_protocol/script_tc_errors_registration.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Import Script.
Import Script_tc_errors.
Definition type_map_enc
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.location *
((list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (list string)))
*
(list
(Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (list string)))))) :=
let stack_enc := list None (tup2 Script.expr_encoding (list None string)) in
list None
(conv
(fun function_parameter =>
let '(loc, (bef, aft)) := function_parameter in
(loc, bef, aft))
(fun function_parameter =>
let '(loc, bef, aft) := function_parameter in
(loc, (bef, aft))) None
(obj3 (req None None "location" % string Script.location_encoding)
(req None None "stack_before" % string stack_enc)
(req None None "stack_after" % string stack_enc))).
Definition stack_ty_enc
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(list (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (list string))) :=
list None
(obj2 (req None None "type" % string Script.expr_encoding)
(dft None None "annots" % string (list None string) [])).
src/proto_alpha/lib_protocol/script_timestamp_repr.ml 3 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = Z.t
let compare = Z.compare
let of_int64 = Z.of_int64
let of_string x =
match Time_repr.of_notation x with
| None -> (
try Some (Z.of_string x) with _ -> None )
| Some time ->
Some (of_int64 (Time_repr.to_seconds time))
let to_notation x =
try
let notation = Time_repr.to_notation (Time.of_seconds (Z.to_int64 x)) in
if String.equal notation "out_of_range" then None else Some notation
with _ -> None
let to_num_str = Z.to_string
let to_string x = match to_notation x with None -> to_num_str x | Some s -> s
let diff x y = Script_int_repr.of_zint @@ Z.sub x y
let sub_delta t delta = Z.sub t (Script_int_repr.to_zint delta)
let add_delta t delta = Z.add t (Script_int_repr.to_zint delta)
let to_zint x = x
let of_zint x = x
src/proto_alpha/lib_protocol/script_timestamp_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := Tezos_protocol_environment_alpha__Environment.Z.t.
Definition compare
: Tezos_protocol_environment_alpha__Environment.Z.t ->
Tezos_protocol_environment_alpha__Environment.Z.t -> Z := Z.compare.
Definition of_int64
: int64 -> Tezos_protocol_environment_alpha__Environment.Z.t := Z.of_int64.
Definition of_string (x : string)
: option Tezos_protocol_environment_alpha__Environment.Z.t :=
match Time_repr.of_notation x with
| None =>
(* ❌ Try-with are not handled *)
try (Some (Z.of_string x))
| Some time => Some (of_int64 (Time_repr.to_seconds time))
end.
Definition to_notation (x : Tezos_protocol_environment_alpha__Environment.Z.t)
: option string :=
(* ❌ Try-with are not handled *)
try
(let notation := Time_repr.to_notation (Time.of_seconds (Z.to_int64 x)) in
if String.equal notation "out_of_range" % string then
None
else
Some notation).
Definition to_num_str
: Tezos_protocol_environment_alpha__Environment.Z.t -> string := Z.to_string.
Definition to_string (x : Tezos_protocol_environment_alpha__Environment.Z.t)
: string :=
match to_notation x with
| None => to_num_str x
| Some s => s
end.
Definition diff
(x : Tezos_protocol_environment_alpha__Environment.Z.t)
(y : Tezos_protocol_environment_alpha__Environment.Z.t)
: Tezos_raw_protocol_alpha.Script_int_repr.num
Tezos_raw_protocol_alpha.Script_int_repr.z :=
op_atat Script_int_repr.of_zint (Z.sub x y).
Definition sub_delta {A : Type}
(t : Tezos_protocol_environment_alpha__Environment.Z.t)
(delta : Tezos_raw_protocol_alpha.Script_int_repr.num A)
: Tezos_protocol_environment_alpha__Environment.Z.t :=
Z.sub t (Script_int_repr.to_zint delta).
Definition add_delta {A : Type}
(t : Tezos_protocol_environment_alpha__Environment.Z.t)
(delta : Tezos_raw_protocol_alpha.Script_int_repr.num A)
: Tezos_protocol_environment_alpha__Environment.Z.t :=
Z.add t (Script_int_repr.to_zint delta).
Definition to_zint {A : Type} (x : A) : A := x.
Definition of_zint {A : Type} (x : A) : A := x.
src/proto_alpha/lib_protocol/script_typed_ir.ml 256 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
open Script_int
(* ---- Auxiliary types -----------------------------------------------------*)
type var_annot = [`Var_annot of string]
type type_annot = [`Type_annot of string]
type field_annot = [`Field_annot of string]
type annot = [var_annot | type_annot | field_annot]
type address = Contract.t * string
type ('a, 'b) pair = 'a * 'b
type ('a, 'b) union = L of 'a | R of 'b
type comb = Comb
type leaf = Leaf
type (_, _) comparable_struct =
| Int_key : type_annot option -> (z num, _) comparable_struct
| Nat_key : type_annot option -> (n num, _) comparable_struct
| String_key : type_annot option -> (string, _) comparable_struct
| Bytes_key : type_annot option -> (MBytes.t, _) comparable_struct
| Mutez_key : type_annot option -> (Tez.t, _) comparable_struct
| Bool_key : type_annot option -> (bool, _) comparable_struct
| Key_hash_key : type_annot option -> (public_key_hash, _) comparable_struct
| Timestamp_key :
type_annot option
-> (Script_timestamp.t, _) comparable_struct
| Address_key : type_annot option -> (address, _) comparable_struct
| Pair_key :
(('a, leaf) comparable_struct * field_annot option)
* (('b, _) comparable_struct * field_annot option)
* type_annot option
-> (('a, 'b) pair, comb) comparable_struct
type 'a comparable_ty = ('a, comb) comparable_struct
module type Boxed_set = sig
type elt
val elt_ty : elt comparable_ty
module OPS : S.SET with type elt = elt
val boxed : OPS.t
val size : int
end
type 'elt set = (module Boxed_set with type elt = 'elt)
module type Boxed_map = sig
type key
type value
val key_ty : key comparable_ty
module OPS : S.MAP with type key = key
val boxed : value OPS.t * int
end
type ('key, 'value) map =
(module Boxed_map with type key = 'key and type value = 'value)
type operation = packed_internal_operation * Contract.big_map_diff option
type ('arg, 'storage) script = {
code : (('arg, 'storage) pair, (operation list, 'storage) pair) lambda;
arg_type : 'arg ty;
storage : 'storage;
storage_type : 'storage ty;
root_name : string option;
}
and end_of_stack = unit
and ('arg, 'ret) lambda =
| Lam :
('arg * end_of_stack, 'ret * end_of_stack) descr * Script.node
-> ('arg, 'ret) lambda
and 'arg typed_contract = 'arg ty * address
and 'ty ty =
| Unit_t : type_annot option -> unit ty
| Int_t : type_annot option -> z num ty
| Nat_t : type_annot option -> n num ty
| Signature_t : type_annot option -> signature ty
| String_t : type_annot option -> string ty
| Bytes_t : type_annot option -> MBytes.t ty
| Mutez_t : type_annot option -> Tez.t ty
| Key_hash_t : type_annot option -> public_key_hash ty
| Key_t : type_annot option -> public_key ty
| Timestamp_t : type_annot option -> Script_timestamp.t ty
| Address_t : type_annot option -> address ty
| Bool_t : type_annot option -> bool ty
| Pair_t :
('a ty * field_annot option * var_annot option)
* ('b ty * field_annot option * var_annot option)
* type_annot option
* bool
-> ('a, 'b) pair ty
| Union_t :
('a ty * field_annot option)
* ('b ty * field_annot option)
* type_annot option
* bool
-> ('a, 'b) union ty
| Lambda_t : 'arg ty * 'ret ty * type_annot option -> ('arg, 'ret) lambda ty
| Option_t : 'v ty * type_annot option * bool -> 'v option ty
| List_t : 'v ty * type_annot option * bool -> 'v list ty
| Set_t : 'v comparable_ty * type_annot option -> 'v set ty
| Map_t :
'k comparable_ty * 'v ty * type_annot option * bool
-> ('k, 'v) map ty
| Big_map_t :
'k comparable_ty * 'v ty * type_annot option
-> ('k, 'v) big_map ty
| Contract_t : 'arg ty * type_annot option -> 'arg typed_contract ty
| Operation_t : type_annot option -> operation ty
| Chain_id_t : type_annot option -> Chain_id.t ty
and 'ty stack_ty =
| Item_t :
'ty ty * 'rest stack_ty * var_annot option
-> ('ty * 'rest) stack_ty
| Empty_t : end_of_stack stack_ty
and ('key, 'value) big_map = {
id : Z.t option;
diff : ('key, 'value option) map;
key_type : 'key ty;
value_type : 'value ty;
}
(* ---- Instructions --------------------------------------------------------*)
(* The low-level, typed instructions, as a GADT whose parameters
encode the typing rules.
The left parameter is the typed shape of the stack before the
instruction, the right one the shape after. Any program whose
construction is accepted by OCaml's type-checker is guaranteed to
be type-safe. Overloadings of the concrete syntax are already
resolved in this representation, either by using different
constructors or type witness parameters. *)
and ('bef, 'aft) instr =
(* stack ops *)
| Drop : (_ * 'rest, 'rest) instr
| Dup : ('top * 'rest, 'top * ('top * 'rest)) instr
| Swap : ('tip * ('top * 'rest), 'top * ('tip * 'rest)) instr
| Const : 'ty -> ('rest, 'ty * 'rest) instr
(* pairs *)
| Cons_pair : ('car * ('cdr * 'rest), ('car, 'cdr) pair * 'rest) instr
| Car : (('car, _) pair * 'rest, 'car * 'rest) instr
| Cdr : ((_, 'cdr) pair * 'rest, 'cdr * 'rest) instr
(* options *)
| Cons_some : ('v * 'rest, 'v option * 'rest) instr
| Cons_none : 'a ty -> ('rest, 'a option * 'rest) instr
| If_none :
('bef, 'aft) descr * ('a * 'bef, 'aft) descr
-> ('a option * 'bef, 'aft) instr
(* unions *)
| Left : ('l * 'rest, ('l, 'r) union * 'rest) instr
| Right : ('r * 'rest, ('l, 'r) union * 'rest) instr
| If_left :
('l * 'bef, 'aft) descr * ('r * 'bef, 'aft) descr
-> (('l, 'r) union * 'bef, 'aft) instr
(* lists *)
| Cons_list : ('a * ('a list * 'rest), 'a list * 'rest) instr
| Nil : ('rest, 'a list * 'rest) instr
| If_cons :
('a * ('a list * 'bef), 'aft) descr * ('bef, 'aft) descr
-> ('a list * 'bef, 'aft) instr
| List_map :
('a * 'rest, 'b * 'rest) descr
-> ('a list * 'rest, 'b list * 'rest) instr
| List_iter : ('a * 'rest, 'rest) descr -> ('a list * 'rest, 'rest) instr
| List_size : ('a list * 'rest, n num * 'rest) instr
(* sets *)
| Empty_set : 'a comparable_ty -> ('rest, 'a set * 'rest) instr
| Set_iter : ('a * 'rest, 'rest) descr -> ('a set * 'rest, 'rest) instr
| Set_mem : ('elt * ('elt set * 'rest), bool * 'rest) instr
| Set_update : ('elt * (bool * ('elt set * 'rest)), 'elt set * 'rest) instr
| Set_size : ('a set * 'rest, n num * 'rest) instr
(* maps *)
| Empty_map : 'a comparable_ty * 'v ty -> ('rest, ('a, 'v) map * 'rest) instr
| Map_map :
(('a * 'v) * 'rest, 'r * 'rest) descr
-> (('a, 'v) map * 'rest, ('a, 'r) map * 'rest) instr
| Map_iter :
(('a * 'v) * 'rest, 'rest) descr
-> (('a, 'v) map * 'rest, 'rest) instr
| Map_mem : ('a * (('a, 'v) map * 'rest), bool * 'rest) instr
| Map_get : ('a * (('a, 'v) map * 'rest), 'v option * 'rest) instr
| Map_update
: ('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr
| Map_size : (('a, 'b) map * 'rest, n num * 'rest) instr
(* big maps *)
| Empty_big_map :
'a comparable_ty * 'v ty
-> ('rest, ('a, 'v) big_map * 'rest) instr
| Big_map_mem : ('a * (('a, 'v) big_map * 'rest), bool * 'rest) instr
| Big_map_get : ('a * (('a, 'v) big_map * 'rest), 'v option * 'rest) instr
| Big_map_update
: ( 'key * ('value option * (('key, 'value) big_map * 'rest)),
('key, 'value) big_map * 'rest )
instr
(* string operations *)
| Concat_string : (string list * 'rest, string * 'rest) instr
| Concat_string_pair : (string * (string * 'rest), string * 'rest) instr
| Slice_string
: (n num * (n num * (string * 'rest)), string option * 'rest) instr
| String_size : (string * 'rest, n num * 'rest) instr
(* bytes operations *)
| Concat_bytes : (MBytes.t list * 'rest, MBytes.t * 'rest) instr
| Concat_bytes_pair : (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) instr
| Slice_bytes
: (n num * (n num * (MBytes.t * 'rest)), MBytes.t option * 'rest) instr
| Bytes_size : (MBytes.t * 'rest, n num * 'rest) instr
(* timestamp operations *)
| Add_seconds_to_timestamp
: ( z num * (Script_timestamp.t * 'rest),
Script_timestamp.t * 'rest )
instr
| Add_timestamp_to_seconds
: ( Script_timestamp.t * (z num * 'rest),
Script_timestamp.t * 'rest )
instr
| Sub_timestamp_seconds
: ( Script_timestamp.t * (z num * 'rest),
Script_timestamp.t * 'rest )
instr
| Diff_timestamps
: ( Script_timestamp.t * (Script_timestamp.t * 'rest),
z num * 'rest )
instr
(* tez operations *)
| Add_tez : (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr
| Sub_tez : (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr
| Mul_teznat : (Tez.t * (n num * 'rest), Tez.t * 'rest) instr
| Mul_nattez : (n num * (Tez.t * 'rest), Tez.t * 'rest) instr
| Ediv_teznat
: (Tez.t * (n num * 'rest), (Tez.t, Tez.t) pair option * 'rest) instr
| Ediv_tez
: (Tez.t * (Tez.t * 'rest), (n num, Tez.t) pair option * 'rest) instr
(* boolean operations *)
| Or : (bool * (bool * 'rest), bool * 'rest) instr
| And : (bool * (bool * 'rest), bool * 'rest) instr
| Xor : (bool * (bool * 'rest), bool * 'rest) instr
| Not : (bool * 'rest, bool * 'rest) instr
(* integer operations *)
| Is_nat : (z num * 'rest, n num option * 'rest) instr
| Neg_nat : (n num * 'rest, z num * 'rest) instr
| Neg_int : (z num * 'rest, z num * 'rest) instr
| Abs_int : (z num * 'rest, n num * 'rest) instr
| Int_nat : (n num * 'rest, z num * 'rest) instr
| Add_intint : (z num * (z num * 'rest), z num * 'rest) instr
| Add_intnat : (z num * (n num * 'rest), z num * 'rest) instr
| Add_natint : (n num * (z num * 'rest), z num * 'rest) instr
| Add_natnat : (n num * (n num * 'rest), n num * 'rest) instr
| Sub_int : ('s num * ('t num * 'rest), z num * 'rest) instr
| Mul_intint : (z num * (z num * 'rest), z num * 'rest) instr
| Mul_intnat : (z num * (n num * 'rest), z num * 'rest) instr
| Mul_natint : (n num * (z num * 'rest), z num * 'rest) instr
| Mul_natnat : (n num * (n num * 'rest), n num * 'rest) instr
| Ediv_intint
: (z num * (z num * 'rest), (z num, n num) pair option * 'rest) instr
| Ediv_intnat
: (z num * (n num * 'rest), (z num, n num) pair option * 'rest) instr
| Ediv_natint
: (n num * (z num * 'rest), (z num, n num) pair option * 'rest) instr
| Ediv_natnat
: (n num * (n num * 'rest), (n num, n num) pair option * 'rest) instr
| Lsl_nat : (n num * (n num * 'rest), n num * 'rest) instr
| Lsr_nat : (n num * (n num * 'rest), n num * 'rest) instr
| Or_nat : (n num * (n num * 'rest), n num * 'rest) instr
| And_nat : (n num * (n num * 'rest), n num * 'rest) instr
| And_int_nat : (z num * (n num * 'rest), n num * 'rest) instr
| Xor_nat : (n num * (n num * 'rest), n num * 'rest) instr
| Not_nat : (n num * 'rest, z num * 'rest) instr
| Not_int : (z num * 'rest, z num * 'rest) instr
(* control *)
| Seq : ('bef, 'trans) descr * ('trans, 'aft) descr -> ('bef, 'aft) instr
| If : ('bef, 'aft) descr * ('bef, 'aft) descr -> (bool * 'bef, 'aft) instr
| Loop : ('rest, bool * 'rest) descr -> (bool * 'rest, 'rest) instr
| Loop_left :
('a * 'rest, ('a, 'b) union * 'rest) descr
-> (('a, 'b) union * 'rest, 'b * 'rest) instr
| Dip : ('bef, 'aft) descr -> ('top * 'bef, 'top * 'aft) instr
| Exec : ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr
| Apply :
'arg ty
-> ( 'arg * (('arg * 'remaining, 'ret) lambda * 'rest),
('remaining, 'ret) lambda * 'rest )
instr
| Lambda : ('arg, 'ret) lambda -> ('rest, ('arg, 'ret) lambda * 'rest) instr
| Failwith : 'a ty -> ('a * 'rest, 'aft) instr
| Nop : ('rest, 'rest) instr
(* comparison *)
| Compare : 'a comparable_ty -> ('a * ('a * 'rest), z num * 'rest) instr
(* comparators *)
| Eq : (z num * 'rest, bool * 'rest) instr
| Neq : (z num * 'rest, bool * 'rest) instr
| Lt : (z num * 'rest, bool * 'rest) instr
| Gt : (z num * 'rest, bool * 'rest) instr
| Le : (z num * 'rest, bool * 'rest) instr
| Ge : (z num * 'rest, bool * 'rest) instr
(* protocol *)
| Address : (_ typed_contract * 'rest, address * 'rest) instr
| Contract :
'p ty * string
-> (address * 'rest, 'p typed_contract option * 'rest) instr
| Transfer_tokens
: ( 'arg * (Tez.t * ('arg typed_contract * 'rest)),
operation * 'rest )
instr
| Create_account
: ( public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))),
operation * (address * 'rest) )
instr
| Implicit_account
: (public_key_hash * 'rest, unit typed_contract * 'rest) instr
| Create_contract :
'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option
-> ( public_key_hash
* (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))),
operation * (address * 'rest) )
instr
| Create_contract_2 :
'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option
-> ( public_key_hash option * (Tez.t * ('g * 'rest)),
operation * (address * 'rest) )
instr
| Set_delegate : (public_key_hash option * 'rest, operation * 'rest) instr
| Now : ('rest, Script_timestamp.t * 'rest) instr
| Balance : ('rest, Tez.t * 'rest) instr
| Check_signature
: (public_key * (signature * (MBytes.t * 'rest)), bool * 'rest) instr
| Hash_key : (public_key * 'rest, public_key_hash * 'rest) instr
| Pack : 'a ty -> ('a * 'rest, MBytes.t * 'rest) instr
| Unpack : 'a ty -> (MBytes.t * 'rest, 'a option * 'rest) instr
| Blake2b : (MBytes.t * 'rest, MBytes.t * 'rest) instr
| Sha256 : (MBytes.t * 'rest, MBytes.t * 'rest) instr
| Sha512 : (MBytes.t * 'rest, MBytes.t * 'rest) instr
| Steps_to_quota
: (* TODO: check that it always returns a nat *)
('rest, n num * 'rest) instr
| Source : ('rest, address * 'rest) instr
| Sender : ('rest, address * 'rest) instr
| Self : 'p ty * string -> ('rest, 'p typed_contract * 'rest) instr
| Amount : ('rest, Tez.t * 'rest) instr
| Dig :
int * ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness
-> ('bef, 'x * 'aft) instr
| Dug :
int * ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness
-> ('x * 'bef, 'aft) instr
| Dipn :
int
* ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness
* ('fbef, 'faft) descr
-> ('bef, 'aft) instr
| Dropn :
int * ('rest, 'rest, 'bef, _) stack_prefix_preservation_witness
-> ('bef, 'rest) instr
| ChainId : ('rest, Chain_id.t * 'rest) instr
(* Type witness for operations that work deep in the stack ignoring
(and preserving) a prefix.
The two right parameters are the shape of the stack with the (same)
prefix before and after the transformation. The two left
parameters are the shape of the stack without the prefix before and
after. The inductive definition makes it so by construction. *)
and ('bef, 'aft, 'bef_suffix, 'aft_suffix) stack_prefix_preservation_witness =
| Prefix :
('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness
-> ('fbef, 'faft, 'x * 'bef, 'x * 'aft) stack_prefix_preservation_witness
| Rest : ('bef, 'aft, 'bef, 'aft) stack_prefix_preservation_witness
and ('bef, 'aft) descr = {
loc : Script.location;
bef : 'bef stack_ty;
aft : 'aft stack_ty;
instr : ('bef, 'aft) instr;
}
type ex_big_map = Ex_bm : ('key, 'value) big_map -> ex_big_map
src/proto_alpha/lib_protocol/script_typed_ir.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Import Script_int.
Definition var_annot := variant.
Definition type_annot := variant.
Definition field_annot := variant.
Definition annot := variant.
Definition address :=
Tezos_raw_protocol_alpha.Alpha_context.Contract.t * string.
Definition pair (a b : Type) := a * b.
Inductive union (a b : Type) : Type :=
| L : a -> union a b
| R : b -> union a b.
Arguments L {_ _}.
Arguments R {_ _}.
Inductive comb : Type :=
| Comb : comb.
Inductive leaf : Type :=
| Leaf : leaf.
Inductive comparable_struct : forall (_ _ : Type), Type :=
| Int_key : forall {A : Type}, (option type_annot) ->
comparable_struct
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) A
| Nat_key : forall {A : Type}, (option type_annot) ->
comparable_struct
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) A
| String_key : forall {A : Type}, (option type_annot) ->
comparable_struct string A
| Bytes_key : forall {A : Type}, (option type_annot) ->
comparable_struct Tezos_protocol_environment_alpha__Environment.MBytes.t A
| Mutez_key : forall {A : Type}, (option type_annot) ->
comparable_struct Tezos_raw_protocol_alpha.Alpha_context.Tez.t A
| Bool_key : forall {A : Type}, (option type_annot) -> comparable_struct bool A
| Key_hash_key : forall {A : Type}, (option type_annot) ->
comparable_struct Tezos_raw_protocol_alpha.Alpha_context.public_key_hash A
| Timestamp_key : forall {A : Type}, (option type_annot) ->
comparable_struct Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t A
| Address_key : forall {A : Type}, (option type_annot) ->
comparable_struct address A
| Pair_key : forall {C a b : Type},
((comparable_struct a leaf) * (option field_annot)) ->
((comparable_struct b C) * (option field_annot)) -> (option type_annot) ->
comparable_struct (pair a b) comb.
Definition comparable_ty (a : Type) := comparable_struct a comb.
Module Boxed_set.
Record signature {elt OPS_t : Type} := {
elt := elt;
elt_ty : comparable_ty elt;
OPS : S.SET.signature elt OPS_t;
boxed : OPS.(Tezos_protocol_environment_alpha__Environment.SET.S.t);
size : Z;
}.
Arguments signature : clear implicits.
End Boxed_set.
Definition set (elt : Type) := {OPS_t : _ & Boxed_set.signature elt OPS_t}.
Module Boxed_map.
Record signature {key value OPS_t : Type} := {
key := key;
value := value;
key_ty : comparable_ty key;
OPS : S.MAP.signature key OPS_t;
boxed : (OPS.(Tezos_protocol_environment_alpha__Environment.MAP.S.t) value)
* Z;
}.
Arguments signature : clear implicits.
End Boxed_map.
Definition map (key value : Type) :=
{OPS_t : _ & Boxed_map.signature key value OPS_t}.
Definition operation :=
Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation *
(option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff).
Reserved Notation "'end_of_stack".
Reserved Notation "'typed_contract".
Inductive lambda (arg ret : Type) : Type :=
| Lam : (descr (arg * 'end_of_stack) (ret * 'end_of_stack)) ->
Tezos_raw_protocol_alpha.Alpha_context.Script.node -> lambda arg ret
with ty : forall (ty : Type), Type :=
| Unit_t : (option type_annot) -> ty unit
| Int_t : (option type_annot) ->
ty
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z)
| Nat_t : (option type_annot) ->
ty
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n)
| Signature_t : (option type_annot) ->
ty Tezos_raw_protocol_alpha.Alpha_context.signature
| String_t : (option type_annot) -> ty string
| Bytes_t : (option type_annot) ->
ty Tezos_protocol_environment_alpha__Environment.MBytes.t
| Mutez_t : (option type_annot) ->
ty Tezos_raw_protocol_alpha.Alpha_context.Tez.t
| Key_hash_t : (option type_annot) ->
ty Tezos_raw_protocol_alpha.Alpha_context.public_key_hash
| Key_t : (option type_annot) ->
ty Tezos_raw_protocol_alpha.Alpha_context.public_key
| Timestamp_t : (option type_annot) ->
ty Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t
| Address_t : (option type_annot) -> ty address
| Bool_t : (option type_annot) -> ty bool
| Pair_t : forall {a b : Type},
((ty a) * (option field_annot) * (option var_annot)) ->
((ty b) * (option field_annot) * (option var_annot)) -> (option type_annot) ->
bool -> ty (pair a b)
| Union_t : forall {a b : Type}, ((ty a) * (option field_annot)) ->
((ty b) * (option field_annot)) -> (option type_annot) -> bool ->
ty (union a b)
| Lambda_t : forall {arg ret : Type}, (ty arg) -> (ty ret) ->
(option type_annot) -> ty (lambda arg ret)
| Option_t : forall {v : Type}, (ty v) -> (option type_annot) -> bool ->
ty (option v)
| List_t : forall {v : Type}, (ty v) -> (option type_annot) -> bool ->
ty (list v)
| Set_t : forall {v : Type}, (comparable_ty v) -> (option type_annot) ->
ty (set v)
| Map_t : forall {k v : Type}, (comparable_ty k) -> (ty v) ->
(option type_annot) -> bool -> ty (map k v)
| Big_map_t : forall {k v : Type}, (comparable_ty k) -> (ty v) ->
(option type_annot) -> ty (big_map k v)
| Contract_t : forall {arg : Type}, (ty arg) -> (option type_annot) ->
ty ('typed_contract arg)
| Operation_t : (option type_annot) -> ty operation
| Chain_id_t : (option type_annot) ->
ty
Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
with stack_ty : forall (ty : Type), Type :=
| Item_t : forall {rest ty : Type}, (ty ty) -> (stack_ty rest) ->
(option var_annot) -> stack_ty (ty * rest)
| Empty_t : stack_ty 'end_of_stack
with instr : forall (bef aft : Type), Type :=
| Drop : forall {A rest : Type}, instr (A * rest) rest
| Dup : forall {rest top : Type}, instr (top * rest) (top * (top * rest))
| Swap : forall {rest tip top : Type},
instr (tip * (top * rest)) (top * (tip * rest))
| Const : forall {rest ty : Type}, ty -> instr rest (ty * rest)
| Cons_pair : forall {car cdr rest : Type},
instr (car * (cdr * rest)) ((pair car cdr) * rest)
| Car : forall {B car rest : Type}, instr ((pair car B) * rest) (car * rest)
| Cdr : forall {A cdr rest : Type}, instr ((pair A cdr) * rest) (cdr * rest)
| Cons_some : forall {rest v : Type}, instr (v * rest) ((option v) * rest)
| Cons_none : forall {a rest : Type}, (ty a) -> instr rest ((option a) * rest)
| If_none : forall {a aft bef : Type}, (descr bef aft) -> (descr (a * bef) aft)
-> instr ((option a) * bef) aft
| Left : forall {l r rest : Type}, instr (l * rest) ((union l r) * rest)
| Right : forall {l r rest : Type}, instr (r * rest) ((union l r) * rest)
| If_left : forall {aft bef l r : Type}, (descr (l * bef) aft) ->
(descr (r * bef) aft) -> instr ((union l r) * bef) aft
| Cons_list : forall {a rest : Type},
instr (a * ((list a) * rest)) ((list a) * rest)
| Nil : forall {a rest : Type}, instr rest ((list a) * rest)
| If_cons : forall {a aft bef : Type}, (descr (a * ((list a) * bef)) aft) ->
(descr bef aft) -> instr ((list a) * bef) aft
| List_map : forall {a b rest : Type}, (descr (a * rest) (b * rest)) ->
instr ((list a) * rest) ((list b) * rest)
| List_iter : forall {a rest : Type}, (descr (a * rest) rest) ->
instr ((list a) * rest) rest
| List_size : forall {a rest : Type},
instr ((list a) * rest)
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Empty_set : forall {a rest : Type}, (comparable_ty a) ->
instr rest ((set a) * rest)
| Set_iter : forall {a rest : Type}, (descr (a * rest) rest) ->
instr ((set a) * rest) rest
| Set_mem : forall {elt rest : Type},
instr (elt * ((set elt) * rest)) (bool * rest)
| Set_update : forall {elt rest : Type},
instr (elt * (bool * ((set elt) * rest))) ((set elt) * rest)
| Set_size : forall {a rest : Type},
instr ((set a) * rest)
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Empty_map : forall {a rest v : Type}, (comparable_ty a) -> (ty v) ->
instr rest ((map a v) * rest)
| Map_map : forall {a r rest v : Type}, (descr ((a * v) * rest) (r * rest)) ->
instr ((map a v) * rest) ((map a r) * rest)
| Map_iter : forall {a rest v : Type}, (descr ((a * v) * rest) rest) ->
instr ((map a v) * rest) rest
| Map_mem : forall {a rest v : Type},
instr (a * ((map a v) * rest)) (bool * rest)
| Map_get : forall {a rest v : Type},
instr (a * ((map a v) * rest)) ((option v) * rest)
| Map_update : forall {a rest v : Type},
instr (a * ((option v) * ((map a v) * rest))) ((map a v) * rest)
| Map_size : forall {a b rest : Type},
instr ((map a b) * rest)
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Empty_big_map : forall {a rest v : Type}, (comparable_ty a) -> (ty v) ->
instr rest ((big_map a v) * rest)
| Big_map_mem : forall {a rest v : Type},
instr (a * ((big_map a v) * rest)) (bool * rest)
| Big_map_get : forall {a rest v : Type},
instr (a * ((big_map a v) * rest)) ((option v) * rest)
| Big_map_update : forall {key rest value : Type},
instr (key * ((option value) * ((big_map key value) * rest)))
((big_map key value) * rest)
| Concat_string : forall {rest : Type},
instr ((list string) * rest) (string * rest)
| Concat_string_pair : forall {rest : Type},
instr (string * (string * rest)) (string * rest)
| Slice_string : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * (string * rest)))
((option string) * rest)
| String_size : forall {rest : Type},
instr (string * rest)
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Concat_bytes : forall {rest : Type},
instr ((list Tezos_protocol_environment_alpha__Environment.MBytes.t) * rest)
(Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Concat_bytes_pair : forall {rest : Type},
instr
(Tezos_protocol_environment_alpha__Environment.MBytes.t *
(Tezos_protocol_environment_alpha__Environment.MBytes.t * rest))
(Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Slice_bytes : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
(Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)))
((option Tezos_protocol_environment_alpha__Environment.MBytes.t) * rest)
| Bytes_size : forall {rest : Type},
instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Add_seconds_to_timestamp : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
(Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest))
(Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest)
| Add_timestamp_to_seconds : forall {rest : Type},
instr
(Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
(Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest)
| Sub_timestamp_seconds : forall {rest : Type},
instr
(Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
(Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest)
| Diff_timestamps : forall {rest : Type},
instr
(Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t *
(Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_tez : forall {rest : Type},
instr
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Sub_tez : forall {rest : Type},
instr
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Mul_teznat : forall {rest : Type},
instr
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Mul_nattez : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Ediv_teznat : forall {rest : Type},
instr
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
((option
(pair Tezos_raw_protocol_alpha.Alpha_context.Tez.t
Tezos_raw_protocol_alpha.Alpha_context.Tez.t)) * rest)
| Ediv_tez : forall {rest : Type},
instr
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))
((option
(pair
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n)
Tezos_raw_protocol_alpha.Alpha_context.Tez.t)) * rest)
| Or : forall {rest : Type}, instr (bool * (bool * rest)) (bool * rest)
| And : forall {rest : Type}, instr (bool * (bool * rest)) (bool * rest)
| Xor : forall {rest : Type}, instr (bool * (bool * rest)) (bool * rest)
| Not : forall {rest : Type}, instr (bool * rest) (bool * rest)
| Is_nat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
((option
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n)) * rest)
| Neg_nat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Neg_int : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Abs_int : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Int_nat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_intint : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_intnat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_natint : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_natnat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Sub_int : forall {rest s t : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num s) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num t) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Mul_intint : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Mul_intnat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Mul_natint : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Mul_natnat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Ediv_intint : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
((option
(pair
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z)
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest)
| Ediv_intnat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
((option
(pair
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z)
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest)
| Ediv_natint : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
((option
(pair
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z)
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest)
| Ediv_natnat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
((option
(pair
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n)
(Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest)
| Lsl_nat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Lsr_nat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Or_nat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| And_nat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| And_int_nat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Xor_nat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Not_nat : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Not_int : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Seq : forall {aft bef trans : Type}, (descr bef trans) -> (descr trans aft) ->
instr bef aft
| If : forall {aft bef : Type}, (descr bef aft) -> (descr bef aft) ->
instr (bool * bef) aft
| Loop : forall {rest : Type}, (descr rest (bool * rest)) ->
instr (bool * rest) rest
| Loop_left : forall {a b rest : Type}, (descr (a * rest) ((union a b) * rest))
-> instr ((union a b) * rest) (b * rest)
| Dip : forall {aft bef top : Type}, (descr bef aft) ->
instr (top * bef) (top * aft)
| Exec : forall {arg rest ret : Type},
instr (arg * ((lambda arg ret) * rest)) (ret * rest)
| Apply : forall {arg remaining rest ret : Type}, (ty arg) ->
instr (arg * ((lambda (arg * remaining) ret) * rest))
((lambda remaining ret) * rest)
| Lambda : forall {arg rest ret : Type}, (lambda arg ret) ->
instr rest ((lambda arg ret) * rest)
| Failwith : forall {a aft rest : Type}, (ty a) -> instr (a * rest) aft
| Nop : forall {rest : Type}, instr rest rest
| Compare : forall {a rest : Type}, (comparable_ty a) ->
instr (a * (a * rest))
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Eq : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Neq : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Lt : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Gt : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Le : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Ge : forall {rest : Type},
instr
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Address : forall {A rest : Type},
instr (('typed_contract A) * rest) (address * rest)
| Contract : forall {p rest : Type}, (ty p) -> string ->
instr (address * rest) ((option ('typed_contract p)) * rest)
| Transfer_tokens : forall {arg rest : Type},
instr
(arg *
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
(('typed_contract arg) * rest))) (operation * rest)
| Create_account : forall {rest : Type},
instr
(Tezos_raw_protocol_alpha.Alpha_context.public_key_hash *
((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) *
(bool * (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))))
(operation * (address * rest))
| Implicit_account : forall {rest : Type},
instr (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash * rest)
(('typed_contract unit) * rest)
| Create_contract : forall {g p rest : Type}, (ty g) -> (ty p) ->
(lambda (p * g) ((list operation) * g)) -> (option string) ->
instr
(Tezos_raw_protocol_alpha.Alpha_context.public_key_hash *
((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) *
(bool *
(bool * (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * (g * rest))))))
(operation * (address * rest))
| Create_contract_2 : forall {g p rest : Type}, (ty g) -> (ty p) ->
(lambda (p * g) ((list operation) * g)) -> (option string) ->
instr
((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) *
(Tezos_raw_protocol_alpha.Alpha_context.Tez.t * (g * rest)))
(operation * (address * rest))
| Set_delegate : forall {rest : Type},
instr ((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) * rest)
(operation * rest)
| Now : forall {rest : Type},
instr rest (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest)
| Balance : forall {rest : Type},
instr rest (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Check_signature : forall {rest : Type},
instr
(Tezos_raw_protocol_alpha.Alpha_context.public_key *
(Tezos_raw_protocol_alpha.Alpha_context.signature *
(Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)))
(bool * rest)
| Hash_key : forall {rest : Type},
instr (Tezos_raw_protocol_alpha.Alpha_context.public_key * rest)
(Tezos_raw_protocol_alpha.Alpha_context.public_key_hash * rest)
| Pack : forall {a rest : Type}, (ty a) ->
instr (a * rest)
(Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Unpack : forall {a rest : Type}, (ty a) ->
instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
((option a) * rest)
| Blake2b : forall {rest : Type},
instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
(Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Sha256 : forall {rest : Type},
instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
(Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Sha512 : forall {rest : Type},
instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
(Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Steps_to_quota : forall {rest : Type},
instr rest
((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Source : forall {rest : Type}, instr rest (address * rest)
| Sender : forall {rest : Type}, instr rest (address * rest)
| Self : forall {p rest : Type}, (ty p) -> string ->
instr rest (('typed_contract p) * rest)
| Amount : forall {rest : Type},
instr rest (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Dig : forall {aft bef rest x : Type}, Z ->
(stack_prefix_preservation_witness (x * rest) rest bef aft) ->
instr bef (x * aft)
| Dug : forall {aft bef rest x : Type}, Z ->
(stack_prefix_preservation_witness rest (x * rest) bef aft) ->
instr (x * bef) aft
| Dipn : forall {aft bef faft fbef : Type}, Z ->
(stack_prefix_preservation_witness fbef faft bef aft) -> (descr fbef faft) ->
instr bef aft
| Dropn : forall {C bef rest : Type}, Z ->
(stack_prefix_preservation_witness rest rest bef C) -> instr bef rest
| ChainId : forall {rest : Type},
instr rest
(Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
* rest)
with stack_prefix_preservation_witness : forall
(bef aft bef_suffix aft_suffix : Type), Type :=
| Prefix : forall {aft bef faft fbef x : Type},
(stack_prefix_preservation_witness fbef faft bef aft) ->
stack_prefix_preservation_witness fbef faft (x * bef) (x * aft)
| Rest : forall {aft bef : Type},
stack_prefix_preservation_witness bef aft bef aft
where "'end_of_stack" := ( unit)
and "'typed_contract" := (fun (arg : Type) => (ty arg) * address).
Definition end_of_stack := 'end_of_stack.
Definition typed_contract := 'typed_contract.
Arguments Lam {_ _}.
Inductive ex_big_map : Type :=
| Ex_bm : forall {key value : Type}, (big_map key value) -> ex_big_map.
src/proto_alpha/lib_protocol/seed_repr.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Tezos Protocol Implementation - Random number generation *)
type seed = B of State_hash.t
type t = T of State_hash.t
type sequence = S of State_hash.t
type nonce = MBytes.t
let nonce_encoding = Data_encoding.Fixed.bytes Constants_repr.nonce_length
let init = "Laissez-faire les proprietaires."
let zero_bytes = MBytes.of_string (String.make Nonce_hash.size '\000')
let state_hash_encoding =
let open Data_encoding in
conv
State_hash.to_bytes
State_hash.of_bytes_exn
(Fixed.bytes Nonce_hash.size)
let seed_encoding =
let open Data_encoding in
conv (fun (B b) -> b) (fun b -> B b) state_hash_encoding
let empty = B (State_hash.hash_bytes [MBytes.of_string init])
let nonce (B state) nonce =
B (State_hash.hash_bytes [State_hash.to_bytes state; nonce])
let initialize_new (B state) append =
T (State_hash.hash_bytes (State_hash.to_bytes state :: zero_bytes :: append))
let xor_higher_bits i b =
let higher = MBytes.get_int32 b 0 in
let r = Int32.logxor higher i in
let res = MBytes.copy b in
MBytes.set_int32 res 0 r ; res
let sequence (T state) n =
State_hash.to_bytes state |> xor_higher_bits n
|> fun b -> S (State_hash.hash_bytes [b])
let take (S state) =
let b = State_hash.to_bytes state in
let h = State_hash.hash_bytes [b] in
(State_hash.to_bytes h, S h)
let take_int32 s bound =
if Compare.Int32.(bound <= 0l) then invalid_arg "Seed_repr.take_int32"
(* FIXME *)
else
let rec loop s =
let (bytes, s) = take s in
let r = Int32.abs (MBytes.get_int32 bytes 0) in
let drop_if_over =
Int32.sub Int32.max_int (Int32.rem Int32.max_int bound)
in
if Compare.Int32.(r >= drop_if_over) then loop s
else
let v = Int32.rem r bound in
(v, s)
in
loop s
type error += Unexpected_nonce_length (* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"unexpected_nonce_length"
~title:"Unexpected nonce length"
~description:"Nonce length is incorrect."
~pp:(fun ppf () ->
Format.fprintf
ppf
"Nonce length is not %i bytes long as it should."
Constants_repr.nonce_length)
Data_encoding.empty
(function Unexpected_nonce_length -> Some () | _ -> None)
(fun () -> Unexpected_nonce_length)
let make_nonce nonce =
if Compare.Int.(MBytes.length nonce <> Constants_repr.nonce_length) then
error Unexpected_nonce_length
else ok nonce
let hash nonce = Nonce_hash.hash_bytes [nonce]
let check_hash nonce hash =
Compare.Int.(MBytes.length nonce = Constants_repr.nonce_length)
&& Nonce_hash.equal (Nonce_hash.hash_bytes [nonce]) hash
let nonce_hash_key_part = Nonce_hash.to_path
let initial_nonce_0 = zero_bytes
let initial_nonce_hash_0 = hash initial_nonce_0
let deterministic_seed seed = nonce seed zero_bytes
let initial_seeds n =
let rec loop acc elt i =
if Compare.Int.(i = 1) then List.rev (elt :: acc)
else loop (elt :: acc) (deterministic_seed elt) (i - 1)
in
loop [] (B (State_hash.hash_bytes [])) n
src/proto_alpha/lib_protocol/seed_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Inductive seed : Type :=
| B : Tezos_raw_protocol_alpha.State_hash.t -> seed.
Inductive t : Type :=
| T : Tezos_raw_protocol_alpha.State_hash.t -> t.
Inductive sequence : Type :=
| S : Tezos_raw_protocol_alpha.State_hash.t -> sequence.
Definition nonce := Tezos_protocol_environment_alpha__Environment.MBytes.t.
Definition nonce_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
Tezos_protocol_environment_alpha__Environment.MBytes.t :=
Data_encoding.Fixed.bytes Constants_repr.nonce_length.
Definition init : string := "Laissez-faire les proprietaires." % string.
Definition zero_bytes
: Tezos_protocol_environment_alpha__Environment.MBytes.t :=
MBytes.of_string (String.make Nonce_hash.size "000" % char).
Definition state_hash_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
Tezos_raw_protocol_alpha.State_hash.t :=
conv State_hash.to_bytes State_hash.of_bytes_exn None
(Fixed.bytes Nonce_hash.size).
Definition seed_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding seed :=
conv
(fun function_parameter =>
let 'B b := function_parameter in
b) (fun b => B b) None state_hash_encoding.
Definition empty : seed :=
B (State_hash.hash_bytes None (cons (MBytes.of_string init) [])).
Definition nonce (function_parameter : seed)
: Tezos_protocol_environment_alpha__Environment.MBytes.t -> seed :=
let 'B state := function_parameter in
fun nonce =>
B
(State_hash.hash_bytes None
(cons (State_hash.to_bytes state) (cons nonce []))).
Definition initialize_new (function_parameter : seed)
: (list Tezos_protocol_environment_alpha__Environment.MBytes.t) -> t :=
let 'B state := function_parameter in
fun append =>
T
(State_hash.hash_bytes None
(cons (State_hash.to_bytes state) (cons zero_bytes append))).
Definition xor_higher_bits
(i : int32) (b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_protocol_environment_alpha__Environment.MBytes.t :=
let higher := MBytes.get_int32 b 0 in
let r := Int32.logxor higher i in
let res := MBytes.copy b in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := MBytes.set_int32 res 0 r in
res.
Definition sequence (function_parameter : t) : int32 -> sequence :=
let 'T state := function_parameter in
fun n =>
op_pipegt (op_pipegt (State_hash.to_bytes state) (xor_higher_bits n))
(fun b => S (State_hash.hash_bytes None (cons b []))).
Definition take (function_parameter : sequence)
: Tezos_protocol_environment_alpha__Environment.MBytes.t * sequence :=
let 'S state := function_parameter in
let b := State_hash.to_bytes state in
let h := State_hash.hash_bytes None (cons b []) in
((State_hash.to_bytes h), (S h)).
Definition take_int32
(s : sequence)
(bound :
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: int32 * sequence :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
bound
(* ❌ Constant of type int32 is converted to int *)
0 then
invalid_arg "Seed_repr.take_int32" % string
else
let fix loop (s : sequence) : int32 * sequence :=
let '(bytes, s) := take s in
let r := Int32.abs (MBytes.get_int32 string 0) in
let drop_if_over :=
Int32.sub Int32.max_int (Int32.rem Int32.max_int bound) in
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
r drop_if_over then
loop s
else
let v := Int32.rem r bound in
(v, s) in
loop s.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition make_nonce
(nonce : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_protocol_environment_alpha__Environment.MBytes.t :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt)
(MBytes.length nonce) Constants_repr.nonce_length then
error
Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_nonce_length
else
ok nonce.
Definition hash (nonce : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_raw_protocol_alpha.Nonce_hash.t :=
Nonce_hash.hash_bytes None (cons nonce []).
Definition check_hash
(nonce : Tezos_protocol_environment_alpha__Environment.MBytes.t)
(hash : Tezos_raw_protocol_alpha.Nonce_hash.t) : bool :=
op_andand
(Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(MBytes.length nonce) Constants_repr.nonce_length)
(Nonce_hash.equal (Nonce_hash.hash_bytes None (cons nonce [])) hash).
Definition nonce_hash_key_part
: Tezos_raw_protocol_alpha.Nonce_hash.t -> (list string) -> list string :=
Nonce_hash.to_path.
Definition initial_nonce_0
: Tezos_protocol_environment_alpha__Environment.MBytes.t := zero_bytes.
Definition initial_nonce_hash_0 : Tezos_raw_protocol_alpha.Nonce_hash.t :=
hash initial_nonce_0.
Definition deterministic_seed (seed : seed) : seed := nonce seed zero_bytes.
Definition initial_seeds
(n :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: list seed :=
let fix loop
(acc : list seed) (elt : seed) (i :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: list seed :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
i 1 then
List.rev (cons elt acc)
else
loop (cons elt acc) (deterministic_seed elt) (op_minus i 1) in
loop [] (B (State_hash.hash_bytes None [])) n.
src/proto_alpha/lib_protocol/seed_storage.ml 22 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Misc
type error +=
| Unknown of {
oldest : Cycle_repr.t;
cycle : Cycle_repr.t;
latest : Cycle_repr.t;
}
(* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"seed.unknown_seed"
~title:"Unknown seed"
~description:"The requested seed is not available"
~pp:(fun ppf (oldest, cycle, latest) ->
if Cycle_repr.(cycle < oldest) then
Format.fprintf
ppf
"The seed for cycle %a has been cleared from the context (oldest \
known seed is for cycle %a)"
Cycle_repr.pp
cycle
Cycle_repr.pp
oldest
else
Format.fprintf
ppf
"The seed for cycle %a has not been computed yet (latest known \
seed is for cycle %a)"
Cycle_repr.pp
cycle
Cycle_repr.pp
latest)
Data_encoding.(
obj3
(req "oldest" Cycle_repr.encoding)
(req "requested" Cycle_repr.encoding)
(req "latest" Cycle_repr.encoding))
(function
| Unknown {oldest; cycle; latest} ->
Some (oldest, cycle, latest)
| _ ->
None)
(fun (oldest, cycle, latest) -> Unknown {oldest; cycle; latest})
let compute_for_cycle c ~revealed cycle =
match Cycle_repr.pred cycle with
| None ->
assert false (* should not happen *)
| Some previous_cycle ->
let levels = Level_storage.levels_with_commitments_in_cycle c revealed in
let combine (c, random_seed, unrevealed) level =
Storage.Seed.Nonce.get c level
>>=? function
| Revealed nonce ->
Storage.Seed.Nonce.delete c level
>>=? fun c ->
return (c, Seed_repr.nonce random_seed nonce, unrevealed)
| Unrevealed u ->
Storage.Seed.Nonce.delete c level
>>=? fun c -> return (c, random_seed, u :: unrevealed)
in
Storage.Seed.For_cycle.get c previous_cycle
>>=? fun prev_seed ->
let seed = Seed_repr.deterministic_seed prev_seed in
fold_left_s combine (c, seed, []) levels
>>=? fun (c, seed, unrevealed) ->
Storage.Seed.For_cycle.init c cycle seed
>>=? fun c -> return (c, unrevealed)
let for_cycle ctxt cycle =
let preserved = Constants_storage.preserved_cycles ctxt in
let current_level = Level_storage.current ctxt in
let current_cycle = current_level.cycle in
let latest =
if Cycle_repr.(current_cycle = root) then
Cycle_repr.add current_cycle (preserved + 1)
else Cycle_repr.add current_cycle preserved
in
let oldest =
match Cycle_repr.sub current_cycle preserved with
| None ->
Cycle_repr.root
| Some oldest ->
oldest
in
fail_unless
Cycle_repr.(oldest <= cycle && cycle <= latest)
(Unknown {oldest; cycle; latest})
>>=? fun () -> Storage.Seed.For_cycle.get ctxt cycle
let clear_cycle c cycle = Storage.Seed.For_cycle.delete c cycle
let init ctxt =
let preserved = Constants_storage.preserved_cycles ctxt in
List.fold_left2
(fun ctxt c seed ->
ctxt
>>=? fun ctxt ->
let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in
Storage.Seed.For_cycle.init ctxt cycle seed)
(return ctxt)
(0 --> (preserved + 1))
(Seed_repr.initial_seeds (preserved + 2))
let cycle_end ctxt last_cycle =
let preserved = Constants_storage.preserved_cycles ctxt in
( match Cycle_repr.sub last_cycle preserved with
| None ->
return ctxt
| Some cleared_cycle ->
clear_cycle ctxt cleared_cycle )
>>=? fun ctxt ->
match Cycle_repr.pred last_cycle with
| None ->
return (ctxt, [])
| Some revealed ->
(* cycle with revelations *)
let inited_seed_cycle = Cycle_repr.add last_cycle (preserved + 1) in
compute_for_cycle ctxt ~revealed inited_seed_cycle
src/proto_alpha/lib_protocol/seed_storage.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Misc.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition compute_for_cycle
(c : Tezos_raw_protocol_alpha.Raw_context.t)
(revealed : Tezos_raw_protocol_alpha.Cycle_repr.t)
(cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t *
(list Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce))) :=
match Cycle_repr.pred cycle with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some previous_cycle =>
let levels := Level_storage.levels_with_commitments_in_cycle c revealed in
let combine
(function_parameter :
Tezos_raw_protocol_alpha.Storage.Seed.Nonce.context *
Tezos_raw_protocol_alpha.Seed_repr.seed *
(list Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce))
: Tezos_raw_protocol_alpha.Level_repr.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t *
Tezos_raw_protocol_alpha.Seed_repr.seed *
(list Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce))) :=
let '(c, random_seed, unrevealed) := function_parameter in
fun level =>
op_gtgteqquestion (Storage.Seed.Nonce.get c level)
(fun function_parameter =>
match function_parameter with
| Tezos_raw_protocol_alpha__Storage.Seed.Revealed nonce =>
op_gtgteqquestion (Storage.Seed.Nonce.delete c level)
(fun c =>
_return (c, (Seed_repr.nonce random_seed nonce), unrevealed))
| Tezos_raw_protocol_alpha__Storage.Seed.Unrevealed u =>
op_gtgteqquestion (Storage.Seed.Nonce.delete c level)
(fun c => _return (c, random_seed, (cons u unrevealed)))
end) in
op_gtgteqquestion (Storage.Seed.For_cycle.get c previous_cycle)
(fun prev_seed =>
let seed := Seed_repr.deterministic_seed prev_seed in
op_gtgteqquestion (fold_left_s combine (c, seed, []) levels)
(fun function_parameter =>
let '(c, seed, unrevealed) := function_parameter in
op_gtgteqquestion (Storage.Seed.For_cycle.init c cycle seed)
(fun c => _return (c, unrevealed))))
end.
Definition for_cycle
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
(cycle : Tezos_raw_protocol_alpha.Cycle_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Seed_repr.seed) :=
let preserved := Constants_storage.preserved_cycles ctxt in
let current_level := Level_storage.current ctxt in
let current_cycle := cycle current_level in
let latest :=
if op_eq current_cycle root then
Cycle_repr.add current_cycle (op_plus preserved 1)
else
Cycle_repr.add current_cycle preserved in
let oldest :=
match Cycle_repr.sub current_cycle preserved with
| None => Cycle_repr.root
| Some oldest => oldest
end in
op_gtgteqquestion
(fail_unless (op_andand (op_lteq oldest cycle) (op_lteq cycle latest))
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unknown
{| oldest := oldest; cycle := cycle; latest := latest |}))
(fun function_parameter =>
let 'tt := function_parameter in
Storage.Seed.For_cycle.get ctxt cycle).
Definition clear_cycle
(c : Tezos_raw_protocol_alpha.Raw_context.t)
(cycle : Tezos_raw_protocol_alpha.Cycle_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
Storage.Seed.For_cycle.delete c cycle.
Definition init (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let preserved := Constants_storage.preserved_cycles ctxt in
List.fold_left2
(fun ctxt =>
fun c =>
fun seed =>
op_gtgteqquestion ctxt
(fun ctxt =>
let cycle := Cycle_repr.of_int32_exn (Int32.of_int c) in
Storage.Seed.For_cycle.init ctxt cycle seed)) (_return ctxt)
(op_minusminusgt 0 (op_plus preserved 1))
(Seed_repr.initial_seeds (op_plus preserved 2)).
Definition cycle_end
(ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
(last_cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.context *
(list Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce))) :=
let preserved := Constants_storage.preserved_cycles ctxt in
op_gtgteqquestion
match Cycle_repr.sub last_cycle preserved with
| None => _return ctxt
| Some cleared_cycle => clear_cycle ctxt cleared_cycle
end
(fun ctxt =>
match Cycle_repr.pred last_cycle with
| None => _return (ctxt, [])
| Some revealed =>
let inited_seed_cycle := Cycle_repr.add last_cycle (op_plus preserved 1)
in
compute_for_cycle ctxt revealed inited_seed_cycle
end).
src/proto_alpha/lib_protocol/services_registration.ml 13 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
type rpc_context = {
block_hash : Block_hash.t;
block_header : Block_header.shell_header;
context : Alpha_context.t;
}
let rpc_init ({block_hash; block_header; context} : Updater.rpc_context) =
let level = block_header.level in
let timestamp = block_header.timestamp in
let fitness = block_header.fitness in
Alpha_context.prepare
~level
~predecessor_timestamp:timestamp
~timestamp
~fitness
context
>>=? fun context -> return {block_hash; block_header; context}
let rpc_services =
ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t)
let register0_fullctxt s f =
rpc_services :=
RPC_directory.register !rpc_services s (fun ctxt q i ->
rpc_init ctxt >>=? fun ctxt -> f ctxt q i)
let opt_register0_fullctxt s f =
rpc_services :=
RPC_directory.opt_register !rpc_services s (fun ctxt q i ->
rpc_init ctxt >>=? fun ctxt -> f ctxt q i)
let register0 s f = register0_fullctxt s (fun {context; _} -> f context)
let register0_noctxt s f =
rpc_services := RPC_directory.register !rpc_services s (fun _ q i -> f q i)
let register1_fullctxt s f =
rpc_services :=
RPC_directory.register !rpc_services s (fun (ctxt, arg) q i ->
rpc_init ctxt >>=? fun ctxt -> f ctxt arg q i)
let register1 s f = register1_fullctxt s (fun {context; _} x -> f context x)
let register1_noctxt s f =
rpc_services :=
RPC_directory.register !rpc_services s (fun (_, arg) q i -> f arg q i)
let register2_fullctxt s f =
rpc_services :=
RPC_directory.register !rpc_services s (fun ((ctxt, arg1), arg2) q i ->
rpc_init ctxt >>=? fun ctxt -> f ctxt arg1 arg2 q i)
let register2 s f =
register2_fullctxt s (fun {context; _} a1 a2 q i -> f context a1 a2 q i)
let get_rpc_services () =
let p =
RPC_directory.map
(fun c ->
rpc_init c
>>= function Error _ -> assert false | Ok c -> Lwt.return c.context)
(Storage_description.build_directory Alpha_context.description)
in
RPC_directory.register_dynamic_directory
!rpc_services
RPC_path.(open_root / "context" / "raw" / "json")
(fun _ -> Lwt.return p)
src/proto_alpha/lib_protocol/services_registration.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Record rpc_context := {
block_hash :
Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t);
block_header :
Tezos_raw_protocol_alpha.Alpha_context.Block_header.shell_header;
context : Tezos_raw_protocol_alpha.Alpha_context.t }.
Definition rpc_init
(function_parameter :
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
rpc_context) :=
let '{|
block_hash := block_hash;
block_header := block_header;
context := context
|} := function_parameter in
let level := level block_header in
let timestamp := timestamp block_header in
let fitness := fitness block_header in
op_gtgteqquestion
(Alpha_context.prepare context level timestamp timestamp fitness)
(fun context =>
_return
{| block_hash := block_hash; block_header := block_header;
context := context |}).
Definition rpc_services
: Tezos_protocol_environment_alpha__Environment.Pervasives.ref
(Tezos_protocol_environment_alpha__Environment.RPC_directory.t
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context) :=
ref RPC_directory.empty.
Definition register0_fullctxt {A B C : Type}
(s :
Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context A B C)
(f :
rpc_context ->
A ->
B ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
C)) : unit :=
op_coloneq rpc_services
(RPC_directory.register (op_exclamation rpc_services) s
(fun ctxt =>
fun q =>
fun i => op_gtgteqquestion (rpc_init ctxt) (fun ctxt => f ctxt q i))).
Definition opt_register0_fullctxt {A B C : Type}
(s :
Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context A B C)
(f :
rpc_context ->
A ->
B ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option C))) : unit :=
op_coloneq rpc_services
(RPC_directory.opt_register (op_exclamation rpc_services) s
(fun ctxt =>
fun q =>
fun i => op_gtgteqquestion (rpc_init ctxt) (fun ctxt => f ctxt q i))).
Definition register0 {A B C : Type}
(s :
Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context A B C)
(f :
Tezos_raw_protocol_alpha.Alpha_context.t ->
A ->
B ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
C)) : unit :=
register0_fullctxt s
(fun function_parameter =>
let '{| context := context |} := function_parameter in
f context).
Definition register0_noctxt {A B C D : Type}
(s :
Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context A B C D)
(f :
B ->
C ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult D))
: unit :=
op_coloneq rpc_services
(RPC_directory.register (op_exclamation rpc_services) s
(fun function_parameter =>
let '_ := function_parameter in
fun q => fun i => f q i)).
Definition register1_fullctxt {A B C D : Type}
(s :
Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context * A) B
C D)
(f :
rpc_context ->
A ->
B ->
C ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
D)) : unit :=
op_coloneq rpc_services
(RPC_directory.register (op_exclamation rpc_services) s
(fun function_parameter =>
let '(ctxt, arg) := function_parameter in
fun q =>
fun i =>
op_gtgteqquestion (rpc_init ctxt) (fun ctxt => f ctxt arg q i))).
Definition register1 {A B C D : Type}
(s :
Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
(Tezos_protocol_environment_alpha__Environment.Updater.rpc_context * A) B
C D)
(f :
Tezos_raw_protocol_alpha.Alpha_context.t ->
A ->
B ->
C ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
D)) : unit :=
register1_fullctxt s
(fun function_parameter =>
let '{| context := context |} := function_parameter in
fun x => f context x).
Definition register1_noctxt {A B C D E : Type}
(s :
Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context (A * B)
C D E)
(f :
B ->
C ->
D ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
E)) : unit :=
op_coloneq rpc_services
(RPC_directory.register (op_exclamation rpc_services) s
(fun function_parameter =>
let '(_, arg) := function_parameter in
fun q => fun i => f arg q i)).
Definition register2_fullctxt {A B C D E : Type}
(s :
Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
((Tezos_protocol_environment_alpha__Environment.Updater.rpc_context * A) *
B) C D E)
(f :
rpc_context ->
A ->
B ->
C ->
D ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
E)) : unit :=
op_coloneq rpc_services
(RPC_directory.register (op_exclamation rpc_services) s
(fun function_parameter =>
let '((ctxt, arg1), arg2) := function_parameter in
fun q =>
fun i =>
op_gtgteqquestion (rpc_init ctxt) (fun ctxt => f ctxt arg1 arg2 q i))).
Definition register2 {A B C D E : Type}
(s :
Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
((Tezos_protocol_environment_alpha__Environment.Updater.rpc_context * A) *
B) C D E)
(f :
Tezos_raw_protocol_alpha.Alpha_context.t ->
A ->
B ->
C ->
D ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
E)) : unit :=
register2_fullctxt s
(fun function_parameter =>
let '{| context := context |} := function_parameter in
fun a1 => fun a2 => fun q => fun i => f context a1 a2 q i).
Definition get_rpc_services (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.RPC_directory.directory
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
let 'tt := function_parameter in
let p :=
RPC_directory.map
(fun c =>
op_gtgteq (rpc_init c)
(fun function_parameter =>
match function_parameter with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Error _
=>
(* ❌ Assert instruction is not handled. *)
assert false
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok c =>
Lwt._return (context c)
end))
(Storage_description.build_directory Alpha_context.description) in
RPC_directory.register_dynamic_directory None (op_exclamation rpc_services)
(op_div (op_div (op_div open_root "context" % string) "raw" % string)
"json" % string)
(fun function_parameter =>
let '_ := function_parameter in
Lwt._return p).
src/proto_alpha/lib_protocol/storage.ml 103 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Storage_functors
module Int = struct
type t = int
let encoding = Data_encoding.uint16
end
module Int32 = struct
type t = Int32.t
let encoding = Data_encoding.int32
end
module Z = struct
include Z
let encoding = Data_encoding.z
end
module Int_index = struct
type t = int
let path_length = 1
let to_path c l = string_of_int c :: l
let of_path = function
| [] | _ :: _ :: _ ->
None
| [c] ->
int_of_string_opt c
type 'a ipath = 'a * t
let args =
Storage_description.One
{
rpc_arg = RPC_arg.int;
encoding = Data_encoding.int31;
compare = Compare.Int.compare;
}
end
module Make_index (H : Storage_description.INDEX) :
INDEX with type t = H.t and type 'a ipath = 'a * H.t = struct
include H
type 'a ipath = 'a * t
let args = Storage_description.One {rpc_arg; encoding; compare}
end
module Block_priority =
Make_single_data_storage (Registered) (Raw_context)
(struct
let name = ["block_priority"]
end)
(Int)
(** Contracts handling *)
module Contract = struct
module Raw_context =
Make_subcontext (Registered) (Raw_context)
(struct
let name = ["contracts"]
end)
module Global_counter =
Make_single_data_storage (Registered) (Raw_context)
(struct
let name = ["global_counter"]
end)
(Z)
module Indexed_context =
Make_indexed_subcontext
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["index"]
end))
(Make_index (Contract_repr.Index))
let fold = Indexed_context.fold_keys
let list = Indexed_context.keys
module Balance =
Indexed_context.Make_map
(struct
let name = ["balance"]
end)
(Tez_repr)
module Frozen_balance_index =
Make_indexed_subcontext
(Make_subcontext (Registered) (Indexed_context.Raw_context)
(struct
let name = ["frozen_balance"]
end))
(Make_index (Cycle_repr.Index))
module Frozen_deposits =
Frozen_balance_index.Make_map
(struct
let name = ["deposits"]
end)
(Tez_repr)
module Frozen_fees =
Frozen_balance_index.Make_map
(struct
let name = ["fees"]
end)
(Tez_repr)
module Frozen_rewards =
Frozen_balance_index.Make_map
(struct
let name = ["rewards"]
end)
(Tez_repr)
module Manager =
Indexed_context.Make_map
(struct
let name = ["manager"]
end)
(Manager_repr)
module Delegate =
Indexed_context.Make_map
(struct
let name = ["delegate"]
end)
(Signature.Public_key_hash)
module Inactive_delegate =
Indexed_context.Make_set
(Registered)
(struct
let name = ["inactive_delegate"]
end)
module Delegate_desactivation =
Indexed_context.Make_map
(struct
let name = ["delegate_desactivation"]
end)
(Cycle_repr)
module Delegated =
Make_data_set_storage
(Make_subcontext (Registered) (Indexed_context.Raw_context)
(struct
let name = ["delegated"]
end))
(Make_index (Contract_repr.Index))
module Counter =
Indexed_context.Make_map
(struct
let name = ["counter"]
end)
(Z)
(* Consume gas for serilization and deserialization of expr in this
module *)
module Make_carbonated_map_expr (N : Storage_sigs.NAME) = struct
module I =
Indexed_context.Make_carbonated_map
(N)
(struct
type t = Script_repr.lazy_expr
let encoding = Script_repr.lazy_expr_encoding
end)
type context = I.context
type key = I.key
type value = I.value
let mem = I.mem
let delete = I.delete
let remove = I.remove
let consume_deserialize_gas ctxt value =
Lwt.return
@@ ( Raw_context.check_enough_gas
ctxt
(Script_repr.minimal_deserialize_cost value)
>>? fun () ->
Script_repr.force_decode value
>>? fun (_value, value_cost) ->
Raw_context.consume_gas ctxt value_cost )
let consume_serialize_gas ctxt value =
Lwt.return
@@ ( Script_repr.force_bytes value
>>? fun (_value, value_cost) ->
Raw_context.consume_gas ctxt value_cost )
let get ctxt contract =
I.get ctxt contract
>>=? fun (ctxt, value) ->
consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value)
let get_option ctxt contract =
I.get_option ctxt contract
>>=? fun (ctxt, value_opt) ->
match value_opt with
| None ->
return (ctxt, None)
| Some value ->
consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value_opt)
let set ctxt contract value =
consume_serialize_gas ctxt value
>>=? fun ctxt -> I.set ctxt contract value
let set_option ctxt contract value_opt =
match value_opt with
| None ->
I.set_option ctxt contract None
| Some value ->
consume_serialize_gas ctxt value
>>=? fun ctxt -> I.set_option ctxt contract value_opt
let init ctxt contract value =
consume_serialize_gas ctxt value
>>=? fun ctxt -> I.init ctxt contract value
let init_set ctxt contract value =
consume_serialize_gas ctxt value
>>=? fun ctxt -> I.init_set ctxt contract value
end
module Code = Make_carbonated_map_expr (struct
let name = ["code"]
end)
module Storage = Make_carbonated_map_expr (struct
let name = ["storage"]
end)
module Paid_storage_space =
Indexed_context.Make_map
(struct
let name = ["paid_bytes"]
end)
(Z)
module Used_storage_space =
Indexed_context.Make_map
(struct
let name = ["used_bytes"]
end)
(Z)
module Roll_list =
Indexed_context.Make_map
(struct
let name = ["roll_list"]
end)
(Roll_repr)
module Change =
Indexed_context.Make_map
(struct
let name = ["change"]
end)
(Tez_repr)
end
(** Big maps handling *)
module Big_map = struct
module Raw_context =
Make_subcontext (Registered) (Raw_context)
(struct
let name = ["big_maps"]
end)
module Next = struct
include Make_single_data_storage (Registered) (Raw_context)
(struct
let name = ["next"]
end)
(Z)
let incr ctxt =
get ctxt
>>=? fun i -> set ctxt (Z.succ i) >>=? fun ctxt -> return (ctxt, i)
let init ctxt = init ctxt Z.zero
end
module Index = struct
type t = Z.t
let rpc_arg =
let construct = Z.to_string in
let destruct hash =
match Z.of_string hash with
| exception _ ->
Error "Cannot parse big map id"
| id ->
Ok id
in
RPC_arg.make
~descr:"A big map identifier"
~name:"big_map_id"
~construct
~destruct
()
let encoding =
Data_encoding.def
"big_map_id"
~title:"Big map identifier"
~description:"A big map identifier"
Z.encoding
let compare = Compare.Z.compare
let path_length = 7
let to_path c l =
let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
String.sub index_key 0 2 :: String.sub index_key 2 2
:: String.sub index_key 4 2 :: String.sub index_key 6 2
:: String.sub index_key 8 2 :: String.sub index_key 10 2 :: Z.to_string c
:: l
let of_path = function
| []
| [_]
| [_; _]
| [_; _; _]
| [_; _; _; _]
| [_; _; _; _; _]
| [_; _; _; _; _; _]
| _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ ->
None
| [index1; index2; index3; index4; index5; index6; key] ->
let c = Z.of_string key in
let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
assert (Compare.String.(String.sub index_key 0 2 = index1)) ;
assert (Compare.String.(String.sub index_key 2 2 = index2)) ;
assert (Compare.String.(String.sub index_key 4 2 = index3)) ;
assert (Compare.String.(String.sub index_key 6 2 = index4)) ;
assert (Compare.String.(String.sub index_key 8 2 = index5)) ;
assert (Compare.String.(String.sub index_key 10 2 = index6)) ;
Some c
end
module Indexed_context =
Make_indexed_subcontext
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["index"]
end))
(Make_index (Index))
let rpc_arg = Index.rpc_arg
let fold = Indexed_context.fold_keys
let list = Indexed_context.keys
let remove_rec ctxt n = Indexed_context.remove_rec ctxt n
let copy ctxt ~from ~to_ = Indexed_context.copy ctxt ~from ~to_
type key = Raw_context.t * Z.t
module Total_bytes =
Indexed_context.Make_map
(struct
let name = ["total_bytes"]
end)
(Z)
module Key_type =
Indexed_context.Make_map
(struct
let name = ["key_type"]
end)
(struct
type t = Script_repr.expr
let encoding = Script_repr.expr_encoding
end)
module Value_type =
Indexed_context.Make_map
(struct
let name = ["value_type"]
end)
(struct
type t = Script_repr.expr
let encoding = Script_repr.expr_encoding
end)
module Contents = struct
module I =
Storage_functors.Make_indexed_carbonated_data_storage
(Make_subcontext (Registered) (Indexed_context.Raw_context)
(struct
let name = ["contents"]
end))
(Make_index (Script_expr_hash))
(struct
type t = Script_repr.expr
let encoding = Script_repr.expr_encoding
end)
type context = I.context
type key = I.key
type value = I.value
let mem = I.mem
let delete = I.delete
let remove = I.remove
let set = I.set
let set_option = I.set_option
let init = I.init
let init_set = I.init_set
let consume_deserialize_gas ctxt value =
Lwt.return
@@ Raw_context.consume_gas ctxt (Script_repr.deserialized_cost value)
let get ctxt contract =
I.get ctxt contract
>>=? fun (ctxt, value) ->
consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value)
let get_option ctxt contract =
I.get_option ctxt contract
>>=? fun (ctxt, value_opt) ->
match value_opt with
| None ->
return (ctxt, None)
| Some value ->
consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value_opt)
end
end
module Delegates =
Make_data_set_storage
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["delegates"]
end))
(Make_index (Signature.Public_key_hash))
module Active_delegates_with_rolls =
Make_data_set_storage
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["active_delegates_with_rolls"]
end))
(Make_index (Signature.Public_key_hash))
module Delegates_with_frozen_balance_index =
Make_indexed_subcontext
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["delegates_with_frozen_balance"]
end))
(Make_index (Cycle_repr.Index))
module Delegates_with_frozen_balance =
Make_data_set_storage
(Delegates_with_frozen_balance_index.Raw_context)
(Make_index (Signature.Public_key_hash))
(** Rolls *)
module Cycle = struct
module Indexed_context =
Make_indexed_subcontext
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["cycle"]
end))
(Make_index (Cycle_repr.Index))
module Last_roll =
Make_indexed_data_storage
(Make_subcontext (Registered) (Indexed_context.Raw_context)
(struct
let name = ["last_roll"]
end))
(Int_index)
(Roll_repr)
module Roll_snapshot =
Indexed_context.Make_map
(struct
let name = ["roll_snapshot"]
end)
(Int)
type unrevealed_nonce = {
nonce_hash : Nonce_hash.t;
delegate : Signature.Public_key_hash.t;
rewards : Tez_repr.t;
fees : Tez_repr.t;
}
type nonce_status =
| Unrevealed of unrevealed_nonce
| Revealed of Seed_repr.nonce
let nonce_status_encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Unrevealed"
(tup4
Nonce_hash.encoding
Signature.Public_key_hash.encoding
Tez_repr.encoding
Tez_repr.encoding)
(function
| Unrevealed {nonce_hash; delegate; rewards; fees} ->
Some (nonce_hash, delegate, rewards, fees)
| _ ->
None)
(fun (nonce_hash, delegate, rewards, fees) ->
Unrevealed {nonce_hash; delegate; rewards; fees});
case
(Tag 1)
~title:"Revealed"
Seed_repr.nonce_encoding
(function Revealed nonce -> Some nonce | _ -> None)
(fun nonce -> Revealed nonce) ]
module Nonce =
Make_indexed_data_storage
(Make_subcontext (Registered) (Indexed_context.Raw_context)
(struct
let name = ["nonces"]
end))
(Make_index (Raw_level_repr.Index))
(struct
type t = nonce_status
let encoding = nonce_status_encoding
end)
module Seed =
Indexed_context.Make_map
(struct
let name = ["random_seed"]
end)
(struct
type t = Seed_repr.seed
let encoding = Seed_repr.seed_encoding
end)
end
module Roll = struct
module Raw_context =
Make_subcontext (Registered) (Raw_context)
(struct
let name = ["rolls"]
end)
module Indexed_context =
Make_indexed_subcontext
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["index"]
end))
(Make_index (Roll_repr.Index))
module Next =
Make_single_data_storage (Registered) (Raw_context)
(struct
let name = ["next"]
end)
(Roll_repr)
module Limbo =
Make_single_data_storage (Registered) (Raw_context)
(struct
let name = ["limbo"]
end)
(Roll_repr)
module Delegate_roll_list =
Wrap_indexed_data_storage
(Contract.Roll_list)
(struct
type t = Signature.Public_key_hash.t
let wrap = Contract_repr.implicit_contract
let unwrap = Contract_repr.is_implicit
end)
module Successor =
Indexed_context.Make_map
(struct
let name = ["successor"]
end)
(Roll_repr)
module Delegate_change =
Wrap_indexed_data_storage
(Contract.Change)
(struct
type t = Signature.Public_key_hash.t
let wrap = Contract_repr.implicit_contract
let unwrap = Contract_repr.is_implicit
end)
module Snapshoted_owner_index = struct
type t = Cycle_repr.t * int
let path_length = Cycle_repr.Index.path_length + 1
let to_path (c, n) s = Cycle_repr.Index.to_path c (string_of_int n :: s)
let of_path l =
match Misc.take Cycle_repr.Index.path_length l with
| None | Some (_, ([] | _ :: _ :: _)) ->
None
| Some (l1, [l2]) -> (
match (Cycle_repr.Index.of_path l1, int_of_string_opt l2) with
| (None, _) | (_, None) ->
None
| (Some c, Some i) ->
Some (c, i) )
type 'a ipath = ('a * Cycle_repr.t) * int
let left_args =
Storage_description.One
{
rpc_arg = Cycle_repr.rpc_arg;
encoding = Cycle_repr.encoding;
compare = Cycle_repr.compare;
}
let right_args =
Storage_description.One
{
rpc_arg = RPC_arg.int;
encoding = Data_encoding.int31;
compare = Compare.Int.compare;
}
let args = Storage_description.(Pair (left_args, right_args))
end
module Owner =
Make_indexed_data_snapshotable_storage
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["owner"]
end))
(Snapshoted_owner_index)
(Make_index (Roll_repr.Index))
(Signature.Public_key)
module Snapshot_for_cycle = Cycle.Roll_snapshot
module Last_for_snapshot = Cycle.Last_roll
let clear = Indexed_context.clear
end
(** Votes *)
module Vote = struct
module Raw_context =
Make_subcontext (Registered) (Raw_context)
(struct
let name = ["votes"]
end)
module Current_period_kind =
Make_single_data_storage (Registered) (Raw_context)
(struct
let name = ["current_period_kind"]
end)
(struct
type t = Voting_period_repr.kind
let encoding = Voting_period_repr.kind_encoding
end)
module Participation_ema =
Make_single_data_storage (Registered) (Raw_context)
(struct
let name = ["participation_ema"]
end)
(Int32)
module Current_proposal =
Make_single_data_storage (Registered) (Raw_context)
(struct
let name = ["current_proposal"]
end)
(Protocol_hash)
module Listings_size =
Make_single_data_storage (Registered) (Raw_context)
(struct
let name = ["listings_size"]
end)
(Int32)
module Listings =
Make_indexed_data_storage
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["listings"]
end))
(Make_index (Signature.Public_key_hash))
(Int32)
module Proposals =
Make_data_set_storage
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["proposals"]
end))
(Pair
(Make_index
(Protocol_hash))
(Make_index (Signature.Public_key_hash)))
module Proposals_count =
Make_indexed_data_storage
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["proposals_count"]
end))
(Make_index (Signature.Public_key_hash))
(Int)
module Ballots =
Make_indexed_data_storage
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["ballots"]
end))
(Make_index (Signature.Public_key_hash))
(struct
type t = Vote_repr.ballot
let encoding = Vote_repr.ballot_encoding
end)
end
(** Seed *)
module Seed = struct
type unrevealed_nonce = Cycle.unrevealed_nonce = {
nonce_hash : Nonce_hash.t;
delegate : Signature.Public_key_hash.t;
rewards : Tez_repr.t;
fees : Tez_repr.t;
}
type nonce_status = Cycle.nonce_status =
| Unrevealed of unrevealed_nonce
| Revealed of Seed_repr.nonce
module Nonce = struct
open Level_repr
type context = Raw_context.t
let mem ctxt l = Cycle.Nonce.mem (ctxt, l.cycle) l.level
let get ctxt l = Cycle.Nonce.get (ctxt, l.cycle) l.level
let get_option ctxt l = Cycle.Nonce.get_option (ctxt, l.cycle) l.level
let set ctxt l v = Cycle.Nonce.set (ctxt, l.cycle) l.level v
let init ctxt l v = Cycle.Nonce.init (ctxt, l.cycle) l.level v
let init_set ctxt l v = Cycle.Nonce.init_set (ctxt, l.cycle) l.level v
let set_option ctxt l v = Cycle.Nonce.set_option (ctxt, l.cycle) l.level v
let delete ctxt l = Cycle.Nonce.delete (ctxt, l.cycle) l.level
let remove ctxt l = Cycle.Nonce.remove (ctxt, l.cycle) l.level
end
module For_cycle = Cycle.Seed
end
(** Commitments *)
module Commitments =
Make_indexed_data_storage
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["commitments"]
end))
(Make_index (Blinded_public_key_hash.Index))
(Tez_repr)
(** Ramp up security deposits... *)
module Ramp_up = struct
module Rewards =
Make_indexed_data_storage
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["ramp_up"; "rewards"]
end))
(Make_index (Cycle_repr.Index))
(struct
type t = Tez_repr.t * Tez_repr.t
let encoding =
Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding
end)
module Security_deposits =
Make_indexed_data_storage
(Make_subcontext (Registered) (Raw_context)
(struct
let name = ["ramp_up"; "deposits"]
end))
(Make_index (Cycle_repr.Index))
(struct
type t = Tez_repr.t * Tez_repr.t
let encoding =
Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding
end)
end
src/proto_alpha/lib_protocol/storage.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Storage_functors.
Module Int.
Definition t := Z.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding Z :=
Data_encoding.uint16.
End Int.
Module Int32.
Definition t := Tezos_protocol_environment_alpha__Environment.Int32.t.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
Data_encoding.int32.
End Int32.
Module Z.
(* ❌ Structure item `include` not handled. *)
include
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
Tezos_protocol_environment_alpha__Environment.Z.t := Data_encoding.z.
End Z.
Module Int_index.
Definition t := Z.
Definition path_length : Z := 1.
Definition to_path (c : Z) (l : list string) : list string :=
cons (string_of_int c) l.
Definition of_path (function_parameter : list string) : option Z :=
match function_parameter with
| [] | cons _ (cons _ _) => None
| cons c [] => int_of_string_opt c
end.
Definition ipath (a : Type) := a * t.
Definition args {A : Type}
: Tezos_raw_protocol_alpha.Storage_description.args A
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
(A *
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)) :=
Tezos_raw_protocol_alpha.Storage_description.One
{| rpc_arg := RPC_arg.int; encoding := Data_encoding.int31;
compare :=
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
|}.
End Int_index.
(* ❌ Functors are not handled. *)
functor
(* ❌ Applications of functors are not handled. *)
functor_application
Module Contract.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Definition fold {A : Type}
: Indexed_context.context ->
A ->
(Indexed_context.key ->
A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
Indexed_context.fold_keys.
Definition list
: Indexed_context.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(list Indexed_context.key) := Indexed_context.keys.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Functors are not handled. *)
functor
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
End Contract.
Module Big_map.
(* ❌ Applications of functors are not handled. *)
functor_application
Module Next.
(* ❌ Structure item `include` not handled. *)
include
Definition incr (ctxt : context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * value)) :=
op_gtgteqquestion (get ctxt)
(fun i =>
op_gtgteqquestion (set ctxt (Z.succ i))
(fun ctxt => _return (ctxt, i))).
Definition init (ctxt : context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) := init ctxt Z.zero.
End Next.
Module Index.
Definition t := Z.t.
Definition rpc_arg
: Tezos_protocol_environment_alpha__Environment.RPC_arg.arg Z.t :=
let construct := Z.to_string in
let destruct (hash : string)
: Tezos_protocol_environment_alpha__Environment.Pervasives.result Z.t
string :=
let 'id := Z.of_string hash in
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok id in
RPC_arg.make (Some "A big map identifier" % string) "big_map_id" % string
destruct construct tt.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
Tezos_protocol_environment_alpha__Environment.Z.t :=
Data_encoding.def "big_map_id" % string
(Some "Big map identifier" % string)
(Some "A big map identifier" % string) Z.encoding.
Definition compare
: Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
->
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
-> Z :=
Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare).
Definition path_length : Z := 7.
Definition to_path
(c : Tezos_protocol_environment_alpha__Environment.Z.t) (l : list string)
: list string :=
let raw_key := Data_encoding.Binary.to_bytes_exn encoding c in
let 'Hex index_key := MBytes.to_hex (Raw_hashes.blake2b raw_key) in
cons (String.sub index_key 0 2)
(cons (String.sub index_key 2 2)
(cons (String.sub index_key 4 2)
(cons (String.sub index_key 6 2)
(cons (String.sub index_key 8 2)
(cons (String.sub index_key 10 2) (cons (Z.to_string c) l)))))).
Definition of_path
(function_parameter :
list
Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: option Z.t :=
match function_parameter with
|
[] | cons _ [] | cons _ (cons _ []) | cons _ (cons _ (cons _ [])) |
cons _ (cons _ (cons _ (cons _ []))) |
cons _ (cons _ (cons _ (cons _ (cons _ [])))) |
cons _ (cons _ (cons _ (cons _ (cons _ (cons _ []))))) |
cons _
(cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ _))))))) =>
None
|
cons index1
(cons index2
(cons index3 (cons index4 (cons index5 (cons index6 (cons key []))))))
=>
let c := Z.of_string key in
let raw_key := Data_encoding.Binary.to_bytes_exn encoding c in
let 'Hex index_key := MBytes.to_hex (Raw_hashes.blake2b raw_key) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.sub index_key 0 2) index1) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.sub index_key 2 2) index2) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.sub index_key 4 2) index3) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.sub index_key 6 2) index4) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.sub index_key 8 2) index5) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(String.sub index_key 10 2) index6) in
Some c
end.
End Index.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition rpc_arg
: Tezos_protocol_environment_alpha__Environment.RPC_arg.arg Z.t :=
Index.rpc_arg.
Definition fold {A : Type}
: Indexed_context.context ->
A ->
(Indexed_context.key ->
A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
Indexed_context.fold_keys.
Definition list
: Indexed_context.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(list Indexed_context.key) := Indexed_context.keys.
Definition remove_rec
(ctxt : Indexed_context.context) (n : Indexed_context.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
Indexed_context.context := Indexed_context.remove_rec ctxt n.
Definition copy
(ctxt : Indexed_context.context) (from : Indexed_context.key)
(to_ : Indexed_context.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Indexed_context.context) := Indexed_context.copy ctxt from to_.
Definition key := Raw_context.t * Z.t.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Module Contents.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition context := I.context.
Definition key := I.key.
Definition value := I.value.
Definition mem
: I.context ->
I.key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * bool)) := I.mem.
Definition delete
: I.context ->
I.key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z)) := I.delete.
Definition remove
: I.context ->
I.key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z * bool)) := I.remove.
Definition set
: I.context ->
I.key ->
I.value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z)) := I.set.
Definition set_option
: I.context ->
I.key ->
(option I.value) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z * bool)) :=
I.set_option.
Definition init
: I.context ->
I.key ->
I.value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z)) := I.init.
Definition init_set
: I.context ->
I.key ->
I.value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z * bool)) :=
I.init_set.
Definition consume_deserialize_gas
(ctxt : Raw_context.context)
(value : Tezos_raw_protocol_alpha.Script_repr.expr)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Raw_context.context) :=
op_atat Lwt._return
(Raw_context.consume_gas ctxt (Script_repr.deserialized_cost value)).
Definition get (ctxt : I.context) (contract : I.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Raw_context.context * I.value)) :=
op_gtgteqquestion (I.get ctxt contract)
(fun function_parameter =>
let '(ctxt, value) := function_parameter in
op_gtgtpipequestion (consume_deserialize_gas ctxt value)
(fun ctxt => (ctxt, value))).
Definition get_option (ctxt : I.context) (contract : I.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * (option I.value))) :=
op_gtgteqquestion (I.get_option ctxt contract)
(fun function_parameter =>
let '(ctxt, value_opt) := function_parameter in
match value_opt with
| None => _return (ctxt, None)
| Some value =>
op_gtgtpipequestion (consume_deserialize_gas ctxt value)
(fun ctxt => (ctxt, value_opt))
end).
End Contents.
End Big_map.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Module Cycle.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Record unrevealed_nonce := {
nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t;
delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
rewards : Tezos_raw_protocol_alpha.Tez_repr.t;
fees : Tezos_raw_protocol_alpha.Tez_repr.t }.
Inductive nonce_status : Type :=
| Unrevealed : unrevealed_nonce -> nonce_status
| Revealed : Tezos_raw_protocol_alpha.Seed_repr.nonce -> nonce_status.
Definition nonce_status_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
nonce_status :=
union None
(cons
(case "Unrevealed" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
(tup4 Nonce_hash.encoding Signature.Public_key_hash.encoding
Tez_repr.encoding Tez_repr.encoding)
(fun function_parameter =>
match function_parameter with
|
Unrevealed {|
nonce_hash := nonce_hash;
delegate := delegate;
rewards := rewards;
fees := fees
|} => Some (nonce_hash, delegate, rewards, fees)
| _ => None
end)
(fun function_parameter =>
let '(nonce_hash, delegate, rewards, fees) := function_parameter in
Unrevealed
{| nonce_hash := nonce_hash; delegate := delegate;
rewards := rewards; fees := fees |}))
(cons
(case "Revealed" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
Seed_repr.nonce_encoding
(fun function_parameter =>
match function_parameter with
| Revealed nonce => Some nonce
| _ => None
end) (fun nonce => Revealed nonce)) [])).
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
End Cycle.
Module Roll.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
Module Snapshoted_owner_index.
Definition t := Tezos_raw_protocol_alpha.Cycle_repr.t * Z.
Definition path_length : Z := op_plus Cycle_repr.Index.path_length 1.
Definition to_path
(function_parameter : Tezos_raw_protocol_alpha.Cycle_repr.Index.t * Z)
: (list string) -> list string :=
let '(c, n) := function_parameter in
fun s => Cycle_repr.Index.to_path c (cons (string_of_int n) s).
Definition of_path (l : list string)
: option (Tezos_raw_protocol_alpha.Cycle_repr.Index.t * Z) :=
match Misc.take Cycle_repr.Index.path_length l with
| None | Some (_, [] | cons _ (cons _ _)) => None
| Some (l1, cons l2 []) =>
match ((Cycle_repr.Index.of_path l1), (int_of_string_opt l2)) with
| (None, _) | (_, None) => None
| (Some c, Some i) => Some (c, i)
end
end.
Definition ipath (a : Type) :=
(a * Tezos_raw_protocol_alpha.Cycle_repr.t) * Z.
Definition left_args {A : Type}
: Tezos_raw_protocol_alpha.Storage_description.args A
Tezos_raw_protocol_alpha.Cycle_repr.cycle
(A * Tezos_raw_protocol_alpha.Cycle_repr.cycle) :=
Tezos_raw_protocol_alpha.Storage_description.One
{| rpc_arg := Cycle_repr.rpc_arg; encoding := Cycle_repr.encoding;
compare := Cycle_repr.compare |}.
Definition right_args {A : Type}
: Tezos_raw_protocol_alpha.Storage_description.args A
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
(A *
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)) :=
Tezos_raw_protocol_alpha.Storage_description.One
{| rpc_arg := RPC_arg.int; encoding := Data_encoding.int31;
compare :=
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
|}.
Definition args {A : Type}
: Tezos_raw_protocol_alpha.Storage_description.args A
(Tezos_raw_protocol_alpha.Cycle_repr.cycle *
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
((A * Tezos_raw_protocol_alpha.Cycle_repr.cycle) *
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)) :=
Tezos_raw_protocol_alpha.Storage_description.Pair left_args right_args.
End Snapshoted_owner_index.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ This kind of module is not handled. *)
unhandled_module
(* ❌ This kind of module is not handled. *)
unhandled_module
Definition clear
: Indexed_context.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t := Indexed_context.clear.
End Roll.
Module Vote.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
End Vote.
Module Seed.
Record unrevealed_nonce := {
nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t;
delegate :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
rewards : Tezos_raw_protocol_alpha.Tez_repr.t;
fees : Tezos_raw_protocol_alpha.Tez_repr.t }.
Inductive nonce_status : Type :=
| Unrevealed : unrevealed_nonce -> nonce_status
| Revealed : Tezos_raw_protocol_alpha.Seed_repr.nonce -> nonce_status.
Module Nonce.
Import Level_repr.
Definition context := Tezos_raw_protocol_alpha.Raw_context.t.
Definition mem
(ctxt : Cycle.Indexed_context.t)
(l : Tezos_raw_protocol_alpha.Level_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
Cycle.Nonce.mem (ctxt, (cycle l)) (level l).
Definition get
(ctxt : Cycle.Indexed_context.t)
(l : Tezos_raw_protocol_alpha.Level_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Cycle.Nonce.value) := Cycle.Nonce.get (ctxt, (cycle l)) (level l).
Definition get_option
(ctxt : Cycle.Indexed_context.t)
(l : Tezos_raw_protocol_alpha.Level_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option Cycle.Nonce.value)) :=
Cycle.Nonce.get_option (ctxt, (cycle l)) (level l).
Definition set
(ctxt : Cycle.Indexed_context.t)
(l : Tezos_raw_protocol_alpha.Level_repr.t) (v : Cycle.Nonce.value)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
Cycle.Nonce.set (ctxt, (cycle l)) (level l) v.
Definition init
(ctxt : Cycle.Indexed_context.t)
(l : Tezos_raw_protocol_alpha.Level_repr.t) (v : Cycle.Nonce.value)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
Cycle.Nonce.init (ctxt, (cycle l)) (level l) v.
Definition init_set
(ctxt : Cycle.Indexed_context.t)
(l : Tezos_raw_protocol_alpha.Level_repr.t) (v : Cycle.Nonce.value)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t :=
Cycle.Nonce.init_set (ctxt, (cycle l)) (level l) v.
Definition set_option
(ctxt : Cycle.Indexed_context.t)
(l : Tezos_raw_protocol_alpha.Level_repr.t) (v : option Cycle.Nonce.value)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t :=
Cycle.Nonce.set_option (ctxt, (cycle l)) (level l) v.
Definition delete
(ctxt : Cycle.Indexed_context.t)
(l : Tezos_raw_protocol_alpha.Level_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
Cycle.Nonce.delete (ctxt, (cycle l)) (level l).
Definition remove
(ctxt : Cycle.Indexed_context.t)
(l : Tezos_raw_protocol_alpha.Level_repr.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t :=
Cycle.Nonce.remove (ctxt, (cycle l)) (level l).
End Nonce.
(* ❌ This kind of module is not handled. *)
unhandled_module
End Seed.
(* ❌ Applications of functors are not handled. *)
functor_application
Module Ramp_up.
(* ❌ Applications of functors are not handled. *)
functor_application
(* ❌ Applications of functors are not handled. *)
functor_application
End Ramp_up.
src/proto_alpha/lib_protocol/storage_description.ml 27 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module StringMap = Map.Make (String)
type 'key t = 'key description ref
and 'key description =
| Empty : 'key description
| Value : {
get : 'key -> 'a option tzresult Lwt.t;
encoding : 'a Data_encoding.t;
}
-> 'key description
| NamedDir : 'key t StringMap.t -> 'key description
| IndexedDir : {
arg : 'a RPC_arg.t;
arg_encoding : 'a Data_encoding.t;
list : 'key -> 'a list tzresult Lwt.t;
subdir : ('key * 'a) t;
}
-> 'key description
let rec register_named_subcontext : type r. r t -> string list -> r t =
fun dir names ->
match (!dir, names) with
| (_, []) ->
dir
| (Value _, _) ->
invalid_arg ""
| (IndexedDir _, _) ->
invalid_arg ""
| (Empty, name :: names) ->
let subdir = ref Empty in
dir := NamedDir (StringMap.singleton name subdir) ;
register_named_subcontext subdir names
| (NamedDir map, name :: names) ->
let subdir =
match StringMap.find_opt name map with
| Some subdir ->
subdir
| None ->
let subdir = ref Empty in
dir := NamedDir (StringMap.add name subdir map) ;
subdir
in
register_named_subcontext subdir names
type (_, _, _) args =
| One : {
rpc_arg : 'a RPC_arg.t;
encoding : 'a Data_encoding.t;
compare : 'a -> 'a -> int;
}
-> ('key, 'a, 'key * 'a) args
| Pair :
('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args
-> ('key, 'a * 'b, 'sub_key) args
let rec unpack : type a b c. (a, b, c) args -> c -> a * b = function
| One _ ->
fun x -> x
| Pair (l, r) ->
let unpack_l = unpack l in
let unpack_r = unpack r in
fun x ->
let (c, d) = unpack_r x in
let (b, a) = unpack_l c in
(b, (a, d))
let rec pack : type a b c. (a, b, c) args -> a -> b -> c = function
| One _ ->
fun b a -> (b, a)
| Pair (l, r) ->
let pack_l = pack l in
let pack_r = pack r in
fun b (a, d) ->
let c = pack_l b a in
pack_r c d
let rec compare : type a b c. (a, b, c) args -> b -> b -> int = function
| One {compare; _} ->
compare
| Pair (l, r) -> (
let compare_l = compare l in
let compare_r = compare r in
fun (a1, b1) (a2, b2) ->
match compare_l a1 a2 with 0 -> compare_r b1 b2 | x -> x )
let destutter equal l =
match l with
| [] ->
[]
| (i, _) :: l ->
let rec loop acc i = function
| [] ->
acc
| (j, _) :: l ->
if equal i j then loop acc i l else loop (j :: acc) j l
in
loop [i] i l
let rec register_indexed_subcontext :
type r a b.
r t -> list:(r -> a list tzresult Lwt.t) -> (r, a, b) args -> b t =
fun dir ~list path ->
match path with
| Pair (left, right) ->
let compare_left = compare left in
let equal_left x y = Compare.Int.(compare_left x y = 0) in
let list_left r = list r >>=? fun l -> return (destutter equal_left l) in
let list_right r =
let (a, k) = unpack left r in
list a
>>=? fun l ->
return (List.map snd (List.filter (fun (x, _) -> equal_left x k) l))
in
register_indexed_subcontext
(register_indexed_subcontext dir ~list:list_left left)
~list:list_right
right
| One {rpc_arg = arg; encoding = arg_encoding; _} -> (
match !dir with
| Value _ ->
invalid_arg ""
| NamedDir _ ->
invalid_arg ""
| Empty ->
let subdir = ref Empty in
dir := IndexedDir {arg; arg_encoding; list; subdir} ;
subdir
| IndexedDir {arg = inner_arg; subdir; _} -> (
match RPC_arg.eq arg inner_arg with
| None ->
invalid_arg ""
| Some RPC_arg.Eq ->
subdir ) )
let register_value :
type a b.
a t -> get:(a -> b option tzresult Lwt.t) -> b Data_encoding.t -> unit =
fun dir ~get encoding ->
match !dir with Empty -> dir := Value {get; encoding} | _ -> invalid_arg ""
let create () = ref Empty
let rec pp : type a. Format.formatter -> a t -> unit =
fun ppf dir ->
match !dir with
| Empty ->
Format.fprintf ppf "EMPTY"
| Value _e ->
Format.fprintf ppf "Value"
| NamedDir map ->
Format.fprintf
ppf
"@[<v>%a@]"
(Format.pp_print_list pp_item)
(StringMap.bindings map)
| IndexedDir {arg; subdir; _} ->
let name = Format.asprintf "<%s>" (RPC_arg.descr arg).name in
pp_item ppf (name, subdir)
and pp_item : type a. Format.formatter -> string * a t -> unit =
fun ppf (name, dir) -> Format.fprintf ppf "@[<v 2>%s@ %a@]" name pp dir
module type INDEX = sig
type t
val path_length : int
val to_path : t -> string list -> string list
val of_path : string list -> t option
val rpc_arg : t RPC_arg.t
val encoding : t Data_encoding.t
val compare : t -> t -> int
end
type _ handler =
| Handler : {
encoding : 'a Data_encoding.t;
get : 'key -> int -> 'a tzresult Lwt.t;
}
-> 'key handler
type _ opt_handler =
| Opt_handler : {
encoding : 'a Data_encoding.t;
get : 'key -> int -> 'a option tzresult Lwt.t;
}
-> 'key opt_handler
let rec combine_object = function
| [] ->
Handler {encoding = Data_encoding.unit; get = (fun _ _ -> return_unit)}
| (name, Opt_handler handler) :: fields ->
let (Handler handlers) = combine_object fields in
Handler
{
encoding =
Data_encoding.merge_objs
Data_encoding.(obj1 (opt name (dynamic_size handler.encoding)))
handlers.encoding;
get =
(fun k i ->
handler.get k i
>>=? fun v1 -> handlers.get k i >>=? fun v2 -> return (v1, v2));
}
type query = {depth : int}
let depth_query =
let open RPC_query in
query (fun depth -> {depth})
|+ field "depth" RPC_arg.int 0 (fun t -> t.depth)
|> seal
let build_directory : type key. key t -> key RPC_directory.t =
fun dir ->
let rpc_dir = ref (RPC_directory.empty : key RPC_directory.t) in
let register : type ikey. (key, ikey) RPC_path.t -> ikey opt_handler -> unit
=
fun path (Opt_handler {encoding; get}) ->
let service =
RPC_service.get_service ~query:depth_query ~output:encoding path
in
rpc_dir :=
RPC_directory.register !rpc_dir service (fun k q () ->
get k (q.depth + 1)
>>=? function None -> raise Not_found | Some x -> return x)
in
let rec build_handler :
type ikey. ikey t -> (key, ikey) RPC_path.t -> ikey opt_handler =
fun dir path ->
match !dir with
| Empty ->
Opt_handler
{encoding = Data_encoding.unit; get = (fun _ _ -> return_none)}
| Value {get; encoding} ->
let handler =
Opt_handler
{
encoding;
get =
(fun k i -> if Compare.Int.(i < 0) then return_none else get k);
}
in
register path handler ; handler
| NamedDir map ->
let fields = StringMap.bindings map in
let fields =
List.map
(fun (name, dir) ->
(name, build_handler dir RPC_path.(path / name)))
fields
in
let (Handler handler) = combine_object fields in
let handler =
Opt_handler
{
encoding = handler.encoding;
get =
(fun k i ->
if Compare.Int.(i < 0) then return_none
else handler.get k (i - 1) >>=? fun v -> return_some v);
}
in
register path handler ; handler
| IndexedDir {arg; arg_encoding; list; subdir} ->
let (Opt_handler handler) =
build_handler subdir RPC_path.(path /: arg)
in
let encoding =
let open Data_encoding in
union
[ case
(Tag 0)
~title:"Leaf"
(dynamic_size arg_encoding)
(function (key, None) -> Some key | _ -> None)
(fun key -> (key, None));
case
(Tag 1)
~title:"Dir"
(tup2
(dynamic_size arg_encoding)
(dynamic_size handler.encoding))
(function (key, Some value) -> Some (key, value) | _ -> None)
(fun (key, value) -> (key, Some value)) ]
in
let get k i =
if Compare.Int.(i < 0) then return_none
else if Compare.Int.(i = 0) then return_some []
else
list k
>>=? fun keys ->
map_s
(fun key ->
if Compare.Int.(i = 1) then return (key, None)
else
handler.get (k, key) (i - 1)
>>=? fun value -> return (key, value))
keys
>>=? fun values -> return_some values
in
let handler =
Opt_handler
{encoding = Data_encoding.(list (dynamic_size encoding)); get}
in
register path handler ; handler
in
ignore (build_handler dir RPC_path.open_root : key opt_handler) ;
!rpc_dir
src/proto_alpha/lib_protocol/storage_description.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Applications of functors are not handled. *)
functor_application
Reserved Notation "'t".
Inductive description (key : Type) : Type :=
| Empty : description key
| Value : forall {a : Type},
(key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option a))) ->
(Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
description key
| NamedDir :
(StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.t) ('t key))
-> description key
| IndexedDir : forall {a : Type},
(Tezos_protocol_environment_alpha__Environment.RPC_arg.t a) ->
(Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
(key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list a))) -> ('t (key * a)) -> description key
where "'t" := (fun (key : Type) =>
Tezos_protocol_environment_alpha__Environment.Pervasives.ref (description key)).
Definition t := 't.
Arguments Empty {_}.
Arguments Value {_}.
Arguments NamedDir {_}.
Arguments IndexedDir {_}.
Fixpoint register_named_subcontext {r : Type} (dir : t r) (names : list string)
: t r :=
match ((op_exclamation dir), names) with
| (_, []) => dir
| (Value _, _) => invalid_arg "" % string
| (IndexedDir _, _) => invalid_arg "" % string
| (Empty, cons name names) =>
let subdir := ref Empty in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_coloneq dir
(NamedDir
(StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.singleton)
name subdir)) in
register_named_subcontext subdir names
| (NamedDir map, cons name names) =>
let subdir :=
match
StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.find_opt)
name map with
| Some subdir => subdir
| None =>
let subdir := ref Empty in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_coloneq dir
(NamedDir
(StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
name subdir map)) in
subdir
end in
register_named_subcontext subdir names
end.
Inductive args : forall (_ _ _ : Type), Type :=
| One : forall {a key : Type},
(Tezos_protocol_environment_alpha__Environment.RPC_arg.t a) ->
(Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
(a -> a -> Z) -> args key a (key * a)
| Pair : forall {a b inter_key key sub_key : Type}, (args key a inter_key) ->
(args inter_key b sub_key) -> args key (a * b) sub_key.
Fixpoint unpack {a b c : Type} (function_parameter : args a b c) : c -> a * b :=
match function_parameter with
| One _ => fun x => x
| Pair l r =>
let unpack_l := unpack l in
let unpack_r := unpack r in
fun x =>
let '(c, d) := unpack_r x in
let '(b, a) := unpack_l c in
(b, (a, d))
end.
Fixpoint pack {a b c : Type} (function_parameter : args a b c) : a -> b -> c :=
match function_parameter with
| One _ => fun b => fun a => (b, a)
| Pair l r =>
let pack_l := pack l in
let pack_r := pack r in
fun b =>
fun function_parameter =>
let '(a, d) := function_parameter in
let c := pack_l b a in
pack_r c d
end.
Fixpoint compare {a b c : Type} (function_parameter : args a b c)
: b -> b -> Z :=
match function_parameter with
| One {| compare := compare |} => compare
| Pair l r =>
let compare_l := compare l in
let compare_r := compare r in
fun function_parameter =>
let '(a1, b1) := function_parameter in
fun function_parameter =>
let '(a2, b2) := function_parameter in
match compare_l a1 a2 with
| 0 => compare_r b1 b2
| x => x
end
end.
Definition destutter {A B : Type} (equal : A -> A -> bool) (l : list (A * B))
: list A :=
match l with
| [] => []
| cons (i, _) l =>
let fix loop {C : Type}
(acc : list A) (i : A) (function_parameter : list (A * C)) : list A :=
match function_parameter with
| [] => acc
| cons (j, _) l =>
if equal i j then
loop acc i l
else
loop (cons j acc) j l
end in
loop (cons i []) i l
end.
Fixpoint register_indexed_subcontext {a b r : Type}
(dir : t r)
(list :
r ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list a))) (path : args r a b) : t b :=
match path with
| Pair left right =>
let compare_left := compare left in
let equal_left (x : op_dollar0) (y : op_dollar0) : bool :=
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
(compare_left x y) 0 in
let list_left (r : r)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list op_dollar0)) :=
op_gtgteqquestion (list r) (fun l => _return (destutter equal_left l)) in
let list_right (r : op_dollarPair_'inter_key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list op_dollar1)) :=
let '(a, k) := unpack left r in
op_gtgteqquestion (list a)
(fun l =>
_return
(List.map snd
(List.filter
(fun function_parameter =>
let '(x, _) := function_parameter in
equal_left x k) l))) in
register_indexed_subcontext (register_indexed_subcontext dir list_left left)
list_right right
| One {| rpc_arg := arg; encoding := arg_encoding |} =>
match op_exclamation dir with
| Value _ => invalid_arg "" % string
| NamedDir _ => invalid_arg "" % string
| Empty =>
let subdir := ref Empty in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_coloneq dir
(IndexedDir
{| arg := arg; arg_encoding := arg_encoding; list := list;
subdir := subdir |}) in
subdir
| IndexedDir {| arg := inner_arg; subdir := subdir |} =>
match RPC_arg.eq arg inner_arg with
| None => invalid_arg "" % string
| Some Tezos_protocol_environment_alpha__Environment.RPC_arg.Eq => subdir
end
end
end.
Definition register_value {a b : Type}
(dir : t a)
(get :
a ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option b)))
(encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t b)
: unit :=
match op_exclamation dir with
| Empty => op_coloneq dir (Value {| get := get; encoding := encoding |})
| _ => invalid_arg "" % string
end.
Definition create {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Pervasives.ref (description A) :=
let 'tt := function_parameter in
ref Empty.
Fixpoint pp {a : Type}
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
(dir : t a) : unit :=
match op_exclamation dir with
| Empty =>
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"EMPTY" % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
"EMPTY" % string)
| Value _e =>
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"Value" % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
"Value" % string)
| NamedDir map =>
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_gen
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Open_box
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"<v>" % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
"<v>" % string))
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Alpha
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_lit
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Close_box
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
"@[<v>%a@]" % string) (Format.pp_print_list None pp_item)
(StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.bindings)
map)
| IndexedDir {| arg := arg; subdir := subdir |} =>
let name :=
Format.asprintf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Char_literal
"<" % char
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Char_literal
">" % char
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
"<%s>" % string) (name (RPC_arg.descr arg)) in
pp_item ppf (name, subdir)
end
with pp_item {a : Type}
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
(function_parameter : string * (t a)) : unit :=
let '(name, dir) := function_parameter in
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_gen
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Open_box
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"<v 2>" % string
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
"<v 2>" % string))
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_lit
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Break
"@ " % string 1 0)
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Alpha
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_lit
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Close_box
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))))
"@[<v 2>%s@ %a@]" % string) name pp dir.
Module INDEX.
Record signature {t : Type} := {
t := t;
path_length : Z;
to_path : t -> (list string) -> list string;
of_path : (list string) -> option t;
rpc_arg : Tezos_protocol_environment_alpha__Environment.RPC_arg.t t;
encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t t;
compare : t -> t -> Z;
}.
Arguments signature : clear implicits.
End INDEX.
Inductive handler : forall (_ : Type), Type :=
| Handler : forall {a key : Type},
(Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
(key ->
Z ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult a))
-> handler key.
Inductive opt_handler : forall (_ : Type), Type :=
| Opt_handler : forall {a key : Type},
(Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
(key ->
Z ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option a))) -> opt_handler key.
Fixpoint combine_object {A : Type}
(function_parameter : list (string * (opt_handler A))) : handler A :=
match function_parameter with
| [] =>
Handler
{| encoding := Data_encoding.unit;
get :=
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
return_unit |}
| cons (name, Opt_handler handler) fields =>
let 'Handler handlers := combine_object fields in
Handler
{|
encoding :=
Data_encoding.merge_objs
(obj1 (opt None None name (dynamic_size None (encoding handler))))
(encoding handlers);
get :=
fun k =>
fun i =>
op_gtgteqquestion ((get handler) k i)
(fun v1 =>
op_gtgteqquestion ((get handlers) k i)
(fun v2 => _return (v1, v2))) |}
end.
Record query := {
depth : Z }.
Definition depth_query
: Tezos_protocol_environment_alpha__Environment.RPC_query.t query :=
op_pipegt
(op_pipeplus (query (fun depth => {| depth := depth |}))
(field None "depth" % string RPC_arg.int 0 (fun t => depth t))) seal.
Definition build_directory {key : Type} (dir : t key)
: Tezos_protocol_environment_alpha__Environment.RPC_directory.t key :=
let rpc_dir := ref RPC_directory.empty in
let register {ikey : Type}
(path : Tezos_protocol_environment_alpha__Environment.RPC_path.t key ikey)
(function_parameter : opt_handler ikey) : unit :=
let 'Opt_handler {| encoding := encoding; get := get |} :=
function_parameter in
let service := RPC_service.get_service None depth_query encoding path in
op_coloneq rpc_dir
(RPC_directory.register (op_exclamation rpc_dir) service
(fun k =>
fun q =>
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (get k (op_plus (depth q) 1))
(fun function_parameter =>
match function_parameter with
| None => raise OCaml.Not_found
| Some x => _return x
end))) in
let fix build_handler {ikey : Type}
(dir : t ikey) (path :
Tezos_protocol_environment_alpha__Environment.RPC_path.t key ikey)
: opt_handler ikey :=
match op_exclamation dir with
| Empty =>
Opt_handler
{| encoding := Data_encoding.unit;
get :=
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
return_none |}
| Value {| get := get; encoding := encoding |} =>
let handler :=
Opt_handler
{| encoding := encoding;
get :=
fun k =>
fun i =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
i 0 then
return_none
else
get k |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := register path handler in
handler
| NamedDir map =>
let fields :=
StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.bindings)
map in
let fields :=
List.map
(fun function_parameter =>
let '(name, dir) := function_parameter in
(name, (build_handler dir (op_div path name)))) fields in
let 'Handler handler := combine_object fields in
let handler :=
Opt_handler
{| encoding := encoding handler;
get :=
fun k =>
fun i =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
i 0 then
return_none
else
op_gtgteqquestion ((get handler) k (op_minus i 1))
(fun v => return_some v) |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := register path handler in
handler
|
IndexedDir {|
arg := arg;
arg_encoding := arg_encoding;
list := list;
subdir := subdir
|} =>
let 'Opt_handler handler := build_handler subdir (op_divcolon path arg) in
let encoding :=
union None
(cons
(case "Leaf" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
(dynamic_size None arg_encoding)
(fun function_parameter =>
match function_parameter with
| (key, None) => Some key
| _ => None
end) (fun key => (key, None)))
(cons
(case "Dir" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag
1)
(tup2 (dynamic_size None arg_encoding)
(dynamic_size None (encoding handler)))
(fun function_parameter =>
match function_parameter with
| (key, Some value) => Some (key, value)
| _ => None
end)
(fun function_parameter =>
let '(key, value) := function_parameter in
(key, (Some value)))) [])) in
let get
(k : ikey) (i :
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option
(list (op_dollarIndexedDir_'a * (option op_dollarOpt_handler_'a1))))) :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
i 0 then
return_none
else
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
i 0 then
return_some []
else
op_gtgteqquestion (list k)
(fun keys =>
op_gtgteqquestion
(map_s
(fun key =>
if
Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
i 1 then
_return (key, None)
else
op_gtgteqquestion
((get handler) (k, key) (op_minus i 1))
(fun value => _return (key, value))) keys)
(fun values => return_some values)) in
let handler :=
Opt_handler
{| encoding := list None (dynamic_size None encoding); get := get |}
in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := register path handler in
handler
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := ignore (build_handler dir RPC_path.open_root) in
op_exclamation rpc_dir.
src/proto_alpha/lib_protocol/storage_functors.ml 18 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Storage_sigs
module Registered = struct
let ghost = false
end
module Ghost = struct
let ghost = true
end
module Make_encoder (V : VALUE) = struct
let of_bytes ~key b =
match Data_encoding.Binary.of_bytes V.encoding b with
| None ->
error (Raw_context.Storage_error (Corrupted_data key))
| Some v ->
Ok v
let to_bytes v =
match Data_encoding.Binary.to_bytes V.encoding v with
| Some b ->
b
| None ->
MBytes.create 0
end
let len_name = "len"
let data_name = "data"
let encode_len_value bytes =
let length = MBytes.length bytes in
Data_encoding.(Binary.to_bytes_exn int31) length
let decode_len_value key len =
match Data_encoding.(Binary.of_bytes int31) len with
| None ->
fail (Raw_context.Storage_error (Corrupted_data key))
| Some len ->
return len
let map_key f = function `Key k -> `Key (f k) | `Dir k -> `Dir (f k)
module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) :
Raw_context.T with type t = C.t = struct
type t = C.t
type context = t
let name_length = List.length N.name
let to_key k = N.name @ k
let of_key k = Misc.remove_elem_from_list name_length k
let mem t k = C.mem t (to_key k)
let dir_mem t k = C.dir_mem t (to_key k)
let get t k = C.get t (to_key k)
let get_option t k = C.get_option t (to_key k)
let init t k v = C.init t (to_key k) v
let set t k v = C.set t (to_key k) v
let init_set t k v = C.init_set t (to_key k) v
let set_option t k v = C.set_option t (to_key k) v
let delete t k = C.delete t (to_key k)
let remove t k = C.remove t (to_key k)
let remove_rec t k = C.remove_rec t (to_key k)
let copy t ~from ~to_ = C.copy t ~from:(to_key from) ~to_:(to_key to_)
let fold t k ~init ~f =
C.fold t (to_key k) ~init ~f:(fun k acc -> f (map_key of_key k) acc)
let keys t k = C.keys t (to_key k) >|= fun keys -> List.map of_key keys
let fold_keys t k ~init ~f =
C.fold_keys t (to_key k) ~init ~f:(fun k acc -> f (of_key k) acc)
let project = C.project
let absolute_key c k = C.absolute_key c (to_key k)
let consume_gas = C.consume_gas
let check_enough_gas = C.check_enough_gas
let description =
let description =
if R.ghost then Storage_description.create () else C.description
in
Storage_description.register_named_subcontext description N.name
end
module Make_single_data_storage
(R : REGISTER)
(C : Raw_context.T)
(N : NAME)
(V : VALUE) : Single_data_storage with type t = C.t and type value = V.t =
struct
type t = C.t
type context = t
type value = V.t
let mem t = C.mem t N.name
include Make_encoder (V)
let get t =
C.get t N.name
>>=? fun b ->
let key = C.absolute_key t N.name in
Lwt.return (of_bytes ~key b)
let get_option t =
C.get_option t N.name
>>= function
| None ->
return_none
| Some b -> (
let key = C.absolute_key t N.name in
match of_bytes ~key b with
| Ok v ->
return_some v
| Error _ as err ->
Lwt.return err )
let init t v =
C.init t N.name (to_bytes v) >>=? fun t -> return (C.project t)
let set t v = C.set t N.name (to_bytes v) >>=? fun t -> return (C.project t)
let init_set t v =
C.init_set t N.name (to_bytes v) >>= fun t -> Lwt.return (C.project t)
let set_option t v =
C.set_option t N.name (Option.map ~f:to_bytes v)
>>= fun t -> Lwt.return (C.project t)
let remove t = C.remove t N.name >>= fun t -> Lwt.return (C.project t)
let delete t = C.delete t N.name >>=? fun t -> return (C.project t)
let () =
let open Storage_description in
let description =
if R.ghost then Storage_description.create () else C.description
in
register_value
~get:get_option
(register_named_subcontext description N.name)
V.encoding
end
module type INDEX = sig
type t
val path_length : int
val to_path : t -> string list -> string list
val of_path : string list -> t option
type 'a ipath
val args : ('a, t, 'a ipath) Storage_description.args
end
module Pair (I1 : INDEX) (I2 : INDEX) : INDEX with type t = I1.t * I2.t =
struct
type t = I1.t * I2.t
let path_length = I1.path_length + I2.path_length
let to_path (x, y) l = I1.to_path x (I2.to_path y l)
let of_path l =
match Misc.take I1.path_length l with
| None ->
None
| Some (l1, l2) -> (
match (I1.of_path l1, I2.of_path l2) with
| (Some x, Some y) ->
Some (x, y)
| _ ->
None )
type 'a ipath = 'a I1.ipath I2.ipath
let args = Storage_description.Pair (I1.args, I2.args)
end
module Make_data_set_storage (C : Raw_context.T) (I : INDEX) :
Data_set_storage with type t = C.t and type elt = I.t = struct
type t = C.t
type context = t
type elt = I.t
let inited = MBytes.of_string "inited"
let mem s i = C.mem s (I.to_path i [])
let add s i =
C.init_set s (I.to_path i []) inited >>= fun t -> Lwt.return (C.project t)
let del s i =
C.remove s (I.to_path i []) >>= fun t -> Lwt.return (C.project t)
let set s i = function true -> add s i | false -> del s i
let clear s = C.remove_rec s [] >>= fun t -> Lwt.return (C.project t)
let fold s ~init ~f =
let rec dig i path acc =
if Compare.Int.(i <= 1) then
C.fold s path ~init:acc ~f:(fun k acc ->
match k with
| `Dir _ ->
Lwt.return acc
| `Key file -> (
match I.of_path file with
| None ->
assert false
| Some p ->
f p acc ))
else
C.fold s path ~init:acc ~f:(fun k acc ->
match k with
| `Dir k ->
dig (i - 1) k acc
| `Key _ ->
Lwt.return acc)
in
dig I.path_length [] init
let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
let () =
let open Storage_description in
let unpack = unpack I.args in
register_value (* TODO fixme 'elements...' *)
~get:(fun c ->
let (c, k) = unpack c in
mem c k >>= function true -> return_some true | false -> return_none)
(register_indexed_subcontext
~list:(fun c -> elements c >>= return)
C.description
I.args)
Data_encoding.bool
end
module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) :
Indexed_data_storage
with type t = C.t
and type key = I.t
and type value = V.t = struct
type t = C.t
type context = t
type key = I.t
type value = V.t
include Make_encoder (V)
let mem s i = C.mem s (I.to_path i [])
let get s i =
C.get s (I.to_path i [])
>>=? fun b ->
let key = C.absolute_key s (I.to_path i []) in
Lwt.return (of_bytes ~key b)
let get_option s i =
C.get_option s (I.to_path i [])
>>= function
| None ->
return_none
| Some b -> (
let key = C.absolute_key s (I.to_path i []) in
match of_bytes ~key b with
| Ok v ->
return_some v
| Error _ as err ->
Lwt.return err )
let set s i v =
C.set s (I.to_path i []) (to_bytes v) >>=? fun t -> return (C.project t)
let init s i v =
C.init s (I.to_path i []) (to_bytes v) >>=? fun t -> return (C.project t)
let init_set s i v =
C.init_set s (I.to_path i []) (to_bytes v)
>>= fun t -> Lwt.return (C.project t)
let set_option s i v =
C.set_option s (I.to_path i []) (Option.map ~f:to_bytes v)
>>= fun t -> Lwt.return (C.project t)
let remove s i =
C.remove s (I.to_path i []) >>= fun t -> Lwt.return (C.project t)
let delete s i =
C.delete s (I.to_path i []) >>=? fun t -> return (C.project t)
let clear s = C.remove_rec s [] >>= fun t -> Lwt.return (C.project t)
let fold_keys s ~init ~f =
let rec dig i path acc =
if Compare.Int.(i <= 1) then
C.fold s path ~init:acc ~f:(fun k acc ->
match k with
| `Dir _ ->
Lwt.return acc
| `Key file -> (
match I.of_path file with
| None ->
assert false
| Some path ->
f path acc ))
else
C.fold s path ~init:acc ~f:(fun k acc ->
match k with
| `Dir k ->
dig (i - 1) k acc
| `Key _ ->
Lwt.return acc)
in
dig I.path_length [] init
let fold s ~init ~f =
let f path acc =
get s path
>>= function
| Error _ ->
(* FIXME: silently ignore unparsable data *)
Lwt.return acc
| Ok v ->
f path v acc
in
fold_keys s ~init ~f
let bindings s =
fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))
let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
let () =
let open Storage_description in
let unpack = unpack I.args in
register_value
~get:(fun c ->
let (c, k) = unpack c in
get_option c k)
(register_indexed_subcontext
~list:(fun c -> keys c >>= return)
C.description
I.args)
V.encoding
end
module Make_indexed_carbonated_data_storage
(C : Raw_context.T)
(I : INDEX)
(V : VALUE) :
Non_iterable_indexed_carbonated_data_storage
with type t = C.t
and type key = I.t
and type value = V.t = struct
type t = C.t
type context = t
type key = I.t
type value = V.t
include Make_encoder (V)
let data_key i = I.to_path i [data_name]
let len_key i = I.to_path i [len_name]
let consume_mem_gas c =
Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))
let existing_size c i =
C.get_option c (len_key i)
>>= function
| None ->
return (0, false)
| Some len ->
decode_len_value (len_key i) len >>=? fun len -> return (len, true)
let consume_read_gas get c i =
get c (len_key i)
>>=? fun len ->
decode_len_value (len_key i) len
>>=? fun len ->
Lwt.return
(C.consume_gas c (Gas_limit_repr.read_bytes_cost (Z.of_int len)))
let consume_serialize_write_gas set c i v =
let bytes = to_bytes v in
let len = MBytes.length bytes in
Lwt.return (C.consume_gas c (Gas_limit_repr.alloc_mbytes_cost len))
>>=? fun c ->
Lwt.return
(C.consume_gas c (Gas_limit_repr.write_bytes_cost (Z.of_int len)))
>>=? fun c ->
set c (len_key i) (encode_len_value bytes) >>=? fun c -> return (c, bytes)
let consume_remove_gas del c i =
Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero))
>>=? fun c -> del c (len_key i)
let mem s i =
consume_mem_gas s
>>=? fun s ->
C.mem s (data_key i) >>= fun exists -> return (C.project s, exists)
let get s i =
consume_read_gas C.get s i
>>=? fun s ->
C.get s (data_key i)
>>=? fun b ->
let key = C.absolute_key s (data_key i) in
Lwt.return (of_bytes ~key b) >>=? fun v -> return (C.project s, v)
let get_option s i =
consume_mem_gas s
>>=? fun s ->
C.mem s (data_key i)
>>= fun exists ->
if exists then get s i >>=? fun (s, v) -> return (s, Some v)
else return (C.project s, None)
let set s i v =
existing_size s i
>>=? fun (prev_size, _) ->
consume_serialize_write_gas C.set s i v
>>=? fun (s, bytes) ->
C.set s (data_key i) bytes
>>=? fun t ->
let size_diff = MBytes.length bytes - prev_size in
return (C.project t, size_diff)
let init s i v =
consume_serialize_write_gas C.init s i v
>>=? fun (s, bytes) ->
C.init s (data_key i) bytes
>>=? fun t ->
let size = MBytes.length bytes in
return (C.project t, size)
let init_set s i v =
let init_set s i v = C.init_set s i v >>= return in
existing_size s i
>>=? fun (prev_size, existed) ->
consume_serialize_write_gas init_set s i v
>>=? fun (s, bytes) ->
init_set s (data_key i) bytes
>>=? fun t ->
let size_diff = MBytes.length bytes - prev_size in
return (C.project t, size_diff, existed)
let remove s i =
let remove s i = C.remove s i >>= return in
existing_size s i
>>=? fun (prev_size, existed) ->
consume_remove_gas remove s i
>>=? fun s ->
remove s (data_key i) >>=? fun t -> return (C.project t, prev_size, existed)
let delete s i =
existing_size s i
>>=? fun (prev_size, _) ->
consume_remove_gas C.delete s i
>>=? fun s ->
C.delete s (data_key i) >>=? fun t -> return (C.project t, prev_size)
let set_option s i v =
match v with None -> remove s i | Some v -> init_set s i v
let fold_keys_unaccounted s ~init ~f =
let rec dig i path acc =
if Compare.Int.(i <= 0) then
C.fold s path ~init:acc ~f:(fun k acc ->
match k with
| `Dir _ ->
Lwt.return acc
| `Key file -> (
match List.rev file with
| last :: _ when Compare.String.(last = len_name) ->
Lwt.return acc
| last :: rest when Compare.String.(last = data_name) -> (
let file = List.rev rest in
match I.of_path file with
| None ->
assert false
| Some path ->
f path acc )
| _ ->
assert false ))
else
C.fold s path ~init:acc ~f:(fun k acc ->
match k with
| `Dir k ->
dig (i - 1) k acc
| `Key _ ->
Lwt.return acc)
in
dig I.path_length [] init
let keys_unaccounted s =
fold_keys_unaccounted s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
let () =
let open Storage_description in
let unpack = unpack I.args in
register_value (* TODO export consumed gas ?? *)
~get:(fun c ->
let (c, k) = unpack c in
get_option c k >>=? fun (_, v) -> return v)
(register_indexed_subcontext
~list:(fun c -> keys_unaccounted c >>= return)
C.description
I.args)
V.encoding
end
module Make_indexed_data_snapshotable_storage
(C : Raw_context.T)
(Snapshot_index : INDEX)
(I : INDEX)
(V : VALUE) :
Indexed_data_snapshotable_storage
with type t = C.t
and type snapshot = Snapshot_index.t
and type key = I.t
and type value = V.t = struct
type snapshot = Snapshot_index.t
let data_name = ["current"]
let snapshot_name = ["snapshot"]
module C_data =
Make_subcontext (Registered) (C)
(struct
let name = data_name
end)
module C_snapshot =
Make_subcontext (Registered) (C)
(struct
let name = snapshot_name
end)
include Make_indexed_data_storage (C_data) (I) (V)
module Snapshot =
Make_indexed_data_storage (C_snapshot) (Pair (Snapshot_index) (I)) (V)
let snapshot_path id = snapshot_name @ Snapshot_index.to_path id []
let snapshot_exists s id = C.dir_mem s (snapshot_path id)
let snapshot s id =
C.copy s ~from:data_name ~to_:(snapshot_path id)
>>=? fun t -> return (C.project t)
let delete_snapshot s id =
C.remove_rec s (snapshot_path id) >>= fun t -> Lwt.return (C.project t)
end
module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) :
Indexed_raw_context
with type t = C.t
and type key = I.t
and type 'a ipath = 'a I.ipath = struct
type t = C.t
type context = t
type key = I.t
type 'a ipath = 'a I.ipath
let clear t = C.remove_rec t [] >>= fun t -> Lwt.return (C.project t)
let fold_keys t ~init ~f =
let rec dig i path acc =
if Compare.Int.(i <= 0) then
match I.of_path path with
| None ->
assert false
| Some path ->
f path acc
else
C.fold t path ~init:acc ~f:(fun k acc ->
match k with
| `Dir k ->
dig (i - 1) k acc
| `Key _ ->
Lwt.return acc)
in
dig I.path_length [] init
let keys t = fold_keys t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc))
let list t k = C.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))
let remove_rec t k = C.remove_rec t (I.to_path k [])
let copy t ~from ~to_ =
C.copy t ~from:(I.to_path from []) ~to_:(I.to_path to_ [])
let description =
Storage_description.register_indexed_subcontext
~list:(fun c -> keys c >>= return)
C.description
I.args
let unpack = Storage_description.unpack I.args
let pack = Storage_description.pack I.args
module Raw_context = struct
type t = C.t I.ipath
type context = t
let to_key i k = I.to_path i k
let of_key k = Misc.remove_elem_from_list I.path_length k
let mem c k =
let (t, i) = unpack c in
C.mem t (to_key i k)
let dir_mem c k =
let (t, i) = unpack c in
C.dir_mem t (to_key i k)
let get c k =
let (t, i) = unpack c in
C.get t (to_key i k)
let get_option c k =
let (t, i) = unpack c in
C.get_option t (to_key i k)
let init c k v =
let (t, i) = unpack c in
C.init t (to_key i k) v >>=? fun t -> return (pack t i)
let set c k v =
let (t, i) = unpack c in
C.set t (to_key i k) v >>=? fun t -> return (pack t i)
let init_set c k v =
let (t, i) = unpack c in
C.init_set t (to_key i k) v >>= fun t -> Lwt.return (pack t i)
let set_option c k v =
let (t, i) = unpack c in
C.set_option t (to_key i k) v >>= fun t -> Lwt.return (pack t i)
let delete c k =
let (t, i) = unpack c in
C.delete t (to_key i k) >>=? fun t -> return (pack t i)
let remove c k =
let (t, i) = unpack c in
C.remove t (to_key i k) >>= fun t -> Lwt.return (pack t i)
let remove_rec c k =
let (t, i) = unpack c in
C.remove_rec t (to_key i k) >>= fun t -> Lwt.return (pack t i)
let copy c ~from ~to_ =
let (t, i) = unpack c in
C.copy t ~from:(to_key i from) ~to_:(to_key i to_)
>>=? fun t -> return (pack t i)
let fold c k ~init ~f =
let (t, i) = unpack c in
C.fold t (to_key i k) ~init ~f:(fun k acc -> f (map_key of_key k) acc)
let keys c k =
let (t, i) = unpack c in
C.keys t (to_key i k) >|= fun keys -> List.map of_key keys
let fold_keys c k ~init ~f =
let (t, i) = unpack c in
C.fold_keys t (to_key i k) ~init ~f:(fun k acc -> f (of_key k) acc)
let project c =
let (t, _) = unpack c in
C.project t
let absolute_key c k =
let (t, i) = unpack c in
C.absolute_key t (to_key i k)
let consume_gas c g =
let (t, i) = unpack c in
C.consume_gas t g >>? fun t -> ok (pack t i)
let check_enough_gas c g =
let (t, _i) = unpack c in
C.check_enough_gas t g
let description = description
end
let resolve t prefix =
let rec loop i prefix = function
| [] when Compare.Int.(i = I.path_length) -> (
match I.of_path prefix with
| None ->
assert false
| Some path ->
Lwt.return [path] )
| [] ->
list t prefix
>>= fun prefixes ->
Lwt_list.map_s
(function `Key prefix | `Dir prefix -> loop (i + 1) prefix [])
prefixes
>|= List.flatten
| [d] when Compare.Int.(i = I.path_length - 1) ->
if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ;
list t prefix
>>= fun prefixes ->
Lwt_list.map_s
(function
| `Key prefix | `Dir prefix -> (
match
Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix))
with
| None ->
Lwt.return_nil
| Some _ ->
loop (i + 1) prefix [] ))
prefixes
>|= List.flatten
| "" :: ds ->
list t prefix
>>= fun prefixes ->
Lwt_list.map_s
(function `Key prefix | `Dir prefix -> loop (i + 1) prefix ds)
prefixes
>|= List.flatten
| d :: ds -> (
if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ;
C.dir_mem t (prefix @ [d])
>>= function
| true -> loop (i + 1) (prefix @ [d]) ds | false -> Lwt.return_nil )
in
loop 0 [] prefix
module Make_set (R : REGISTER) (N : NAME) = struct
type t = C.t
type context = t
type elt = I.t
let inited = MBytes.of_string "inited"
let mem s i = Raw_context.mem (pack s i) N.name
let add s i =
Raw_context.init_set (pack s i) N.name inited
>>= fun c ->
let (s, _) = unpack c in
Lwt.return (C.project s)
let del s i =
Raw_context.remove (pack s i) N.name
>>= fun c ->
let (s, _) = unpack c in
Lwt.return (C.project s)
let set s i = function true -> add s i | false -> del s i
let clear s =
fold_keys s ~init:s ~f:(fun i s ->
Raw_context.remove (pack s i) N.name
>>= fun c ->
let (s, _) = unpack c in
Lwt.return s)
>>= fun t -> Lwt.return (C.project t)
let fold s ~init ~f =
fold_keys s ~init ~f:(fun i acc ->
mem s i >>= function true -> f i acc | false -> Lwt.return acc)
let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
let () =
let open Storage_description in
let unpack = unpack I.args in
let description =
if R.ghost then Storage_description.create ()
else Raw_context.description
in
register_value
~get:(fun c ->
let (c, k) = unpack c in
mem c k
>>= function true -> return_some true | false -> return_none)
(register_named_subcontext description N.name)
Data_encoding.bool
end
module Make_map (N : NAME) (V : VALUE) = struct
type t = C.t
type context = t
type key = I.t
type value = V.t
include Make_encoder (V)
let mem s i = Raw_context.mem (pack s i) N.name
let get s i =
Raw_context.get (pack s i) N.name
>>=? fun b ->
let key = Raw_context.absolute_key (pack s i) N.name in
Lwt.return (of_bytes ~key b)
let get_option s i =
Raw_context.get_option (pack s i) N.name
>>= function
| None ->
return_none
| Some b -> (
let key = Raw_context.absolute_key (pack s i) N.name in
match of_bytes ~key b with
| Ok v ->
return_some v
| Error _ as err ->
Lwt.return err )
let set s i v =
Raw_context.set (pack s i) N.name (to_bytes v)
>>=? fun c ->
let (s, _) = unpack c in
return (C.project s)
let init s i v =
Raw_context.init (pack s i) N.name (to_bytes v)
>>=? fun c ->
let (s, _) = unpack c in
return (C.project s)
let init_set s i v =
Raw_context.init_set (pack s i) N.name (to_bytes v)
>>= fun c ->
let (s, _) = unpack c in
Lwt.return (C.project s)
let set_option s i v =
Raw_context.set_option (pack s i) N.name (Option.map ~f:to_bytes v)
>>= fun c ->
let (s, _) = unpack c in
Lwt.return (C.project s)
let remove s i =
Raw_context.remove (pack s i) N.name
>>= fun c ->
let (s, _) = unpack c in
Lwt.return (C.project s)
let delete s i =
Raw_context.delete (pack s i) N.name
>>=? fun c ->
let (s, _) = unpack c in
return (C.project s)
let clear s =
fold_keys s ~init:s ~f:(fun i s ->
Raw_context.remove (pack s i) N.name
>>= fun c ->
let (s, _) = unpack c in
Lwt.return s)
>>= fun t -> Lwt.return (C.project t)
let fold s ~init ~f =
fold_keys s ~init ~f:(fun i acc ->
get s i >>= function Error _ -> Lwt.return acc | Ok v -> f i v acc)
let bindings s =
fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))
let fold_keys s ~init ~f =
fold_keys s ~init ~f:(fun i acc ->
mem s i >>= function false -> Lwt.return acc | true -> f i acc)
let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
let () =
let open Storage_description in
let unpack = unpack I.args in
register_value
~get:(fun c ->
let (c, k) = unpack c in
get_option c k)
(register_named_subcontext Raw_context.description N.name)
V.encoding
end
module Make_carbonated_map (N : NAME) (V : VALUE) = struct
type t = C.t
type context = t
type key = I.t
type value = V.t
include Make_encoder (V)
let len_name = len_name :: N.name
let data_name = data_name :: N.name
let consume_mem_gas c =
Lwt.return
(Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))
let existing_size c =
Raw_context.get_option c len_name
>>= function
| None ->
return (0, false)
| Some len ->
decode_len_value len_name len >>=? fun len -> return (len, true)
let consume_read_gas get c =
get c len_name
>>=? fun len ->
decode_len_value len_name len
>>=? fun len ->
Lwt.return
(Raw_context.consume_gas
c
(Gas_limit_repr.read_bytes_cost (Z.of_int len)))
let consume_write_gas set c v =
let bytes = to_bytes v in
let len = MBytes.length bytes in
Lwt.return
(Raw_context.consume_gas
c
(Gas_limit_repr.write_bytes_cost (Z.of_int len)))
>>=? fun c ->
set c len_name (encode_len_value bytes) >>=? fun c -> return (c, bytes)
let consume_remove_gas del c =
Lwt.return
(Raw_context.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero))
>>=? fun c -> del c len_name
let mem s i =
consume_mem_gas (pack s i)
>>=? fun c ->
Raw_context.mem c data_name
>>= fun res -> return (Raw_context.project c, res)
let get s i =
consume_read_gas Raw_context.get (pack s i)
>>=? fun c ->
Raw_context.get c data_name
>>=? fun b ->
let key = Raw_context.absolute_key c data_name in
Lwt.return (of_bytes ~key b)
>>=? fun v -> return (Raw_context.project c, v)
let get_option s i =
consume_mem_gas (pack s i)
>>=? fun c ->
let (s, _) = unpack c in
Raw_context.mem (pack s i) data_name
>>= fun exists ->
if exists then get s i >>=? fun (s, v) -> return (s, Some v)
else return (C.project s, None)
let set s i v =
existing_size (pack s i)
>>=? fun (prev_size, _) ->
consume_write_gas Raw_context.set (pack s i) v
>>=? fun (c, bytes) ->
Raw_context.set c data_name bytes
>>=? fun c ->
let size_diff = MBytes.length bytes - prev_size in
return (Raw_context.project c, size_diff)
let init s i v =
consume_write_gas Raw_context.init (pack s i) v
>>=? fun (c, bytes) ->
Raw_context.init c data_name bytes
>>=? fun c ->
let size = MBytes.length bytes in
return (Raw_context.project c, size)
let init_set s i v =
let init_set c k v = Raw_context.init_set c k v >>= return in
existing_size (pack s i)
>>=? fun (prev_size, existed) ->
consume_write_gas init_set (pack s i) v
>>=? fun (c, bytes) ->
init_set c data_name bytes
>>=? fun c ->
let size_diff = MBytes.length bytes - prev_size in
return (Raw_context.project c, size_diff, existed)
let remove s i =
let remove c k = Raw_context.remove c k >>= return in
existing_size (pack s i)
>>=? fun (prev_size, existed) ->
consume_remove_gas remove (pack s i)
>>=? fun c ->
remove c data_name
>>=? fun c -> return (Raw_context.project c, prev_size, existed)
let delete s i =
existing_size (pack s i)
>>=? fun (prev_size, _) ->
consume_remove_gas Raw_context.delete (pack s i)
>>=? fun c ->
Raw_context.delete c data_name
>>=? fun c -> return (Raw_context.project c, prev_size)
let set_option s i v =
match v with None -> remove s i | Some v -> init_set s i v
let () =
let open Storage_description in
let unpack = unpack I.args in
register_value
~get:(fun c ->
let (c, k) = unpack c in
get_option c k >>=? fun (_, v) -> return v)
(register_named_subcontext Raw_context.description N.name)
V.encoding
end
end
module Wrap_indexed_data_storage
(C : Indexed_data_storage) (K : sig
type t
val wrap : t -> C.key
val unwrap : C.key -> t option
end) =
struct
type t = C.t
type context = C.t
type key = K.t
type value = C.value
let mem ctxt k = C.mem ctxt (K.wrap k)
let get ctxt k = C.get ctxt (K.wrap k)
let get_option ctxt k = C.get_option ctxt (K.wrap k)
let set ctxt k v = C.set ctxt (K.wrap k) v
let init ctxt k v = C.init ctxt (K.wrap k) v
let init_set ctxt k v = C.init_set ctxt (K.wrap k) v
let set_option ctxt k v = C.set_option ctxt (K.wrap k) v
let delete ctxt k = C.delete ctxt (K.wrap k)
let remove ctxt k = C.remove ctxt (K.wrap k)
let clear ctxt = C.clear ctxt
let fold ctxt ~init ~f =
C.fold ctxt ~init ~f:(fun k v acc ->
match K.unwrap k with None -> Lwt.return acc | Some k -> f k v acc)
let bindings s =
fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))
let fold_keys s ~init ~f =
C.fold_keys s ~init ~f:(fun k acc ->
match K.unwrap k with None -> Lwt.return acc | Some k -> f k acc)
let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
end
src/proto_alpha/lib_protocol/storage_functors.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Storage_sigs.
Module Registered.
Definition ghost : bool := false.
End Registered.
Module Ghost.
Definition ghost : bool := true.
End Ghost.
(* ❌ Functors are not handled. *)
functor
Definition len_name : string := "len" % string.
Definition data_name : string := "data" % string.
Definition encode_len_value
(bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_protocol_environment_alpha__Environment.MBytes.t :=
let length := MBytes.length string in
(Binary.to_bytes_exn int31) length.
Definition decode_len_value
(key : list string)
(len : Tezos_protocol_environment_alpha__Environment.MBytes.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
match (Binary.of_bytes int31) len with
| None =>
fail
(Tezos_protocol_environment_alpha__Environment.Error_monad.Storage_error
(Tezos_raw_protocol_alpha.Raw_context.Corrupted_data key))
| Some len => _return len
end.
Definition map_key {A B : Type} (f : A -> B) (function_parameter : variant)
: variant :=
match function_parameter with
| Key k =>
(* ❌ Variants not supported *)
variant
| Dir k =>
(* ❌ Variants not supported *)
variant
end.
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
Module INDEX.
Record signature {t ipath : Type} := {
t := t;
path_length : Z;
to_path : t -> (list string) -> list string;
of_path : (list string) -> option t;
polymorphic_abstract_type;
args : forall {a : Type}, Tezos_raw_protocol_alpha.Storage_description.args
a t (ipath a);
}.
Arguments signature : clear implicits.
End INDEX.
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
(* ❌ Functors are not handled. *)
functor
src/proto_alpha/lib_protocol/storage_sigs.ml 10 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** {1 Entity Accessor Signatures} *)
(** The generic signature of a single data accessor (a single value
bound to a specific key in the hierarchical (key x value)
database). *)
module type Single_data_storage = sig
type t
type context = t
(** The type of the value *)
type value
(** Tells if the data is already defined *)
val mem : context -> bool Lwt.t
(** Retrieve the value from the storage bucket ; returns a
{!Storage_error} if the key is not set or if the deserialisation
fails *)
val get : context -> value tzresult Lwt.t
(** Retrieves the value from the storage bucket ; returns [None] if
the data is not initialized, or {!Storage_helpers.Storage_error}
if the deserialisation fails *)
val get_option : context -> value option tzresult Lwt.t
(** Allocates the storage bucket and initializes it ; returns a
{!Storage_error Existing_key} if the bucket exists *)
val init : context -> value -> Raw_context.t tzresult Lwt.t
(** Updates the content of the bucket ; returns a {!Storage_Error
Missing_key} if the value does not exists *)
val set : context -> value -> Raw_context.t tzresult Lwt.t
(** Allocates the data and initializes it with a value ; just
updates it if the bucket exists *)
val init_set : context -> value -> Raw_context.t Lwt.t
(** When the value is [Some v], allocates the data and initializes
it with [v] ; just updates it if the bucket exists. When the
valus is [None], delete the storage bucket when the value ; does
nothing if the bucket does not exists. *)
val set_option : context -> value option -> Raw_context.t Lwt.t
(** Delete the storage bucket ; returns a {!Storage_error
Missing_key} if the bucket does not exists *)
val delete : context -> Raw_context.t tzresult Lwt.t
(** Removes the storage bucket and its contents ; does nothing if
the bucket does not exists *)
val remove : context -> Raw_context.t Lwt.t
end
(** Variant of {!Single_data_storage} with gas accounting. *)
module type Single_carbonated_data_storage = sig
type t
type context = t
(** The type of the value *)
type value
(** Tells if the data is already defined.
Consumes [Gas_repr.read_bytes_cost Z.zero]. *)
val mem : context -> (Raw_context.t * bool) tzresult Lwt.t
(** Retrieve the value from the storage bucket ; returns a
{!Storage_error} if the key is not set or if the deserialisation
fails.
Consumes [Gas_repr.read_bytes_cost <size of the value>]. *)
val get : context -> (Raw_context.t * value) tzresult Lwt.t
(** Retrieves the value from the storage bucket ; returns [None] if
the data is not initialized, or {!Storage_helpers.Storage_error}
if the deserialisation fails.
Consumes [Gas_repr.read_bytes_cost <size of the value>] if present
or [Gas_repr.read_bytes_cost Z.zero]. *)
val get_option : context -> (Raw_context.t * value option) tzresult Lwt.t
(** Allocates the storage bucket and initializes it ; returns a
{!Storage_error Missing_key} if the bucket exists.
Consumes [Gas_repr.write_bytes_cost <size of the value>].
Returns the size. *)
val init : context -> value -> (Raw_context.t * int) tzresult Lwt.t
(** Updates the content of the bucket ; returns a {!Storage_Error
Existing_key} if the value does not exists.
Consumes [Gas_repr.write_bytes_cost <size of the new value>].
Returns the difference from the old to the new size. *)
val set : context -> value -> (Raw_context.t * int) tzresult Lwt.t
(** Allocates the data and initializes it with a value ; just
updates it if the bucket exists.
Consumes [Gas_repr.write_bytes_cost <size of the new value>].
Returns the difference from the old (maybe 0) to the new size, and a boolean
indicating if a value was already associated to this key. *)
val init_set :
context -> value -> (Raw_context.t * int * bool) tzresult Lwt.t
(** When the value is [Some v], allocates the data and initializes
it with [v] ; just updates it if the bucket exists. When the
valus is [None], delete the storage bucket when the value ; does
nothing if the bucket does not exists.
Consumes the same gas cost as either {!remove} or {!init_set}.
Returns the difference from the old (maybe 0) to the new size, and a boolean
indicating if a value was already associated to this key. *)
val set_option :
context -> value option -> (Raw_context.t * int * bool) tzresult Lwt.t
(** Delete the storage bucket ; returns a {!Storage_error
Missing_key} if the bucket does not exists.
Consumes [Gas_repr.write_bytes_cost Z.zero].
Returns the freed size. *)
val delete : context -> (Raw_context.t * int) tzresult Lwt.t
(** Removes the storage bucket and its contents ; does nothing if
the bucket does not exists.
Consumes [Gas_repr.write_bytes_cost Z.zero].
Returns the freed size, and a boolean
indicating if a value was already associated to this key. *)
val remove : context -> (Raw_context.t * int * bool) tzresult Lwt.t
end
(** Restricted version of {!Indexed_data_storage} w/o iterators. *)
module type Non_iterable_indexed_data_storage = sig
type t
type context = t
(** An abstract type for keys *)
type key
(** The type of values *)
type value
(** Tells if a given key is already bound to a storage bucket *)
val mem : context -> key -> bool Lwt.t
(** Retrieve a value from the storage bucket at a given key ;
returns {!Storage_error Missing_key} if the key is not set ;
returns {!Storage_error Corrupted_data} if the deserialisation
fails. *)
val get : context -> key -> value tzresult Lwt.t
(** Retrieve a value from the storage bucket at a given key ;
returns [None] if the value is not set ; returns {!Storage_error
Corrupted_data} if the deserialisation fails. *)
val get_option : context -> key -> value option tzresult Lwt.t
(** Updates the content of a bucket ; returns A {!Storage_Error
Missing_key} if the value does not exists. *)
val set : context -> key -> value -> Raw_context.t tzresult Lwt.t
(** Allocates a storage bucket at the given key and initializes it ;
returns a {!Storage_error Existing_key} if the bucket exists. *)
val init : context -> key -> value -> Raw_context.t tzresult Lwt.t
(** Allocates a storage bucket at the given key and initializes it
with a value ; just updates it if the bucket exists. *)
val init_set : context -> key -> value -> Raw_context.t Lwt.t
(** When the value is [Some v], allocates the data and initializes
it with [v] ; just updates it if the bucket exists. When the
valus is [None], delete the storage bucket when the value ; does
nothing if the bucket does not exists. *)
val set_option : context -> key -> value option -> Raw_context.t Lwt.t
(** Delete a storage bucket and its contents ; returns a
{!Storage_error Missing_key} if the bucket does not exists. *)
val delete : context -> key -> Raw_context.t tzresult Lwt.t
(** Removes a storage bucket and its contents ; does nothing if the
bucket does not exists. *)
val remove : context -> key -> Raw_context.t Lwt.t
end
(** Variant of {!Non_iterable_indexed_data_storage} with gas accounting. *)
module type Non_iterable_indexed_carbonated_data_storage = sig
type t
type context = t
(** An abstract type for keys *)
type key
(** The type of values *)
type value
(** Tells if a given key is already bound to a storage bucket.
Consumes [Gas_repr.read_bytes_cost Z.zero]. *)
val mem : context -> key -> (Raw_context.t * bool) tzresult Lwt.t
(** Retrieve a value from the storage bucket at a given key ;
returns {!Storage_error Missing_key} if the key is not set ;
returns {!Storage_error Corrupted_data} if the deserialisation
fails.
Consumes [Gas_repr.read_bytes_cost <size of the value>]. *)
val get : context -> key -> (Raw_context.t * value) tzresult Lwt.t
(** Retrieve a value from the storage bucket at a given key ;
returns [None] if the value is not set ; returns {!Storage_error
Corrupted_data} if the deserialisation fails.
Consumes [Gas_repr.read_bytes_cost <size of the value>] if present
or [Gas_repr.read_bytes_cost Z.zero]. *)
val get_option :
context -> key -> (Raw_context.t * value option) tzresult Lwt.t
(** Updates the content of a bucket ; returns A {!Storage_Error
Missing_key} if the value does not exists.
Consumes serialization cost.
Consumes [Gas_repr.write_bytes_cost <size of the new value>].
Returns the difference from the old to the new size. *)
val set : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t
(** Allocates a storage bucket at the given key and initializes it ;
returns a {!Storage_error Existing_key} if the bucket exists.
Consumes serialization cost.
Consumes [Gas_repr.write_bytes_cost <size of the value>].
Returns the size. *)
val init : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t
(** Allocates a storage bucket at the given key and initializes it
with a value ; just updates it if the bucket exists.
Consumes serialization cost.
Consumes [Gas_repr.write_bytes_cost <size of the new value>].
Returns the difference from the old (maybe 0) to the new size, and a boolean
indicating if a value was already associated to this key. *)
val init_set :
context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t
(** When the value is [Some v], allocates the data and initializes
it with [v] ; just updates it if the bucket exists. When the
valus is [None], delete the storage bucket when the value ; does
nothing if the bucket does not exists.
Consumes serialization cost.
Consumes the same gas cost as either {!remove} or {!init_set}.
Returns the difference from the old (maybe 0) to the new size, and a boolean
indicating if a value was already associated to this key. *)
val set_option :
context ->
key ->
value option ->
(Raw_context.t * int * bool) tzresult Lwt.t
(** Delete a storage bucket and its contents ; returns a
{!Storage_error Missing_key} if the bucket does not exists.
Consumes [Gas_repr.write_bytes_cost Z.zero].
Returns the freed size. *)
val delete : context -> key -> (Raw_context.t * int) tzresult Lwt.t
(** Removes a storage bucket and its contents ; does nothing if the
bucket does not exists.
Consumes [Gas_repr.write_bytes_cost Z.zero].
Returns the freed size, and a boolean
indicating if a value was already associated to this key. *)
val remove : context -> key -> (Raw_context.t * int * bool) tzresult Lwt.t
end
(** The generic signature of indexed data accessors (a set of values
of the same type indexed by keys of the same form in the
hierarchical (key x value) database). *)
module type Indexed_data_storage = sig
include Non_iterable_indexed_data_storage
(** Empties all the keys and associated data. *)
val clear : context -> Raw_context.t Lwt.t
(** Lists all the keys. *)
val keys : context -> key list Lwt.t
(** Lists all the keys and associated data. *)
val bindings : context -> (key * value) list Lwt.t
(** Iterates over all the keys and associated data. *)
val fold :
context -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t
(** Iterate over all the keys. *)
val fold_keys : context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
end
module type Indexed_data_snapshotable_storage = sig
type snapshot
type key
include Indexed_data_storage with type key := key
module Snapshot :
Indexed_data_storage
with type key = snapshot * key
and type value = value
and type t = t
val snapshot_exists : context -> snapshot -> bool Lwt.t
val snapshot : context -> snapshot -> Raw_context.t tzresult Lwt.t
val delete_snapshot : context -> snapshot -> Raw_context.t Lwt.t
end
(** The generic signature of a data set accessor (a set of values
bound to a specific key prefix in the hierarchical (key x value)
database). *)
module type Data_set_storage = sig
type t
type context = t
(** The type of elements. *)
type elt
(** Tells if a elt is a member of the set *)
val mem : context -> elt -> bool Lwt.t
(** Adds a elt is a member of the set *)
val add : context -> elt -> Raw_context.t Lwt.t
(** Removes a elt of the set ; does nothing if not a member *)
val del : context -> elt -> Raw_context.t Lwt.t
(** Adds/Removes a elt of the set *)
val set : context -> elt -> bool -> Raw_context.t Lwt.t
(** Returns the elements of the set, deserialized in a list in no
particular order. *)
val elements : context -> elt list Lwt.t
(** Iterates over the elements of the set. *)
val fold : context -> init:'a -> f:(elt -> 'a -> 'a Lwt.t) -> 'a Lwt.t
(** Removes all elements in the set *)
val clear : context -> Raw_context.t Lwt.t
end
module type NAME = sig
val name : Raw_context.key
end
module type VALUE = sig
type t
val encoding : t Data_encoding.t
end
module type REGISTER = sig
val ghost : bool
end
module type Indexed_raw_context = sig
type t
type context = t
type key
type 'a ipath
val clear : context -> Raw_context.t Lwt.t
val fold_keys : context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
val keys : context -> key list Lwt.t
val resolve : context -> string list -> key list Lwt.t
val remove_rec : context -> key -> context Lwt.t
val copy : context -> from:key -> to_:key -> context tzresult Lwt.t
module Make_set (R : REGISTER) (N : NAME) :
Data_set_storage with type t = t and type elt = key
module Make_map (N : NAME) (V : VALUE) :
Indexed_data_storage
with type t = t
and type key = key
and type value = V.t
module Make_carbonated_map (N : NAME) (V : VALUE) :
Non_iterable_indexed_carbonated_data_storage
with type t = t
and type key = key
and type value = V.t
module Raw_context : Raw_context.T with type t = t ipath
end
src/proto_alpha/lib_protocol/storage_sigs.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Single_data_storage.
Record signature {t value : Type} := {
t := t;
context := t;
value := value;
mem : context -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
get : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
value);
get_option : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option value));
init : context ->
value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t);
set : context ->
value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t);
init_set : context ->
value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t;
set_option : context ->
(option value) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t;
delete : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t);
remove : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t;
}.
Arguments signature : clear implicits.
End Single_data_storage.
Module Single_carbonated_data_storage.
Record signature {t value : Type} := {
t := t;
context := t;
value := value;
mem : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * bool));
get : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * value));
get_option : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * (option value)));
init : context ->
value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z));
set : context ->
value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z));
init_set : context ->
value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
set_option : context ->
(option value) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
delete : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z));
remove : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
}.
Arguments signature : clear implicits.
End Single_carbonated_data_storage.
Module Non_iterable_indexed_data_storage.
Record signature {t key value : Type} := {
t := t;
context := t;
key := key;
value := value;
mem : context ->
key -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
get : context ->
key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
value);
get_option : context ->
key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(option value));
set : context ->
key ->
value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t);
init : context ->
key ->
value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t);
init_set : context ->
key ->
value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t;
set_option : context ->
key ->
(option value) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t;
delete : context ->
key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t);
remove : context ->
key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t;
}.
Arguments signature : clear implicits.
End Non_iterable_indexed_data_storage.
Module Non_iterable_indexed_carbonated_data_storage.
Record signature {t key value : Type} := {
t := t;
context := t;
key := key;
value := value;
mem : context ->
key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * bool));
get : context ->
key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * value));
get_option : context ->
key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * (option value)));
set : context ->
key ->
value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z));
init : context ->
key ->
value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z));
init_set : context ->
key ->
value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
set_option : context ->
key ->
(option value) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
delete : context ->
key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z));
remove : context ->
key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
}.
Arguments signature : clear implicits.
End Non_iterable_indexed_carbonated_data_storage.
Module Indexed_data_storage.
Record signature {t key value : Type} := {
include;
clear : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t;
keys : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t (list key);
bindings : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t (list (key * value));
fold : forall {a : Type}, context ->
a ->
(key ->
value -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a)
-> Tezos_protocol_environment_alpha__Environment.Lwt.t a;
fold_keys : forall {a : Type}, context ->
a ->
(key -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t a;
}.
Arguments signature : clear implicits.
End Indexed_data_storage.
Module Indexed_data_snapshotable_storage.
Record signature {snapshot key t value : Type} := {
snapshot := snapshot;
key := key;
include;
Snapshot : Indexed_data_storage.signature t (snapshot * key) value;
snapshot_exists : context ->
snapshot -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
snapshot : context ->
snapshot ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t);
delete_snapshot : context ->
snapshot ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t;
}.
Arguments signature : clear implicits.
End Indexed_data_snapshotable_storage.
Module Data_set_storage.
Record signature {t elt : Type} := {
t := t;
context := t;
elt := elt;
mem : context ->
elt -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
add : context ->
elt ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t;
del : context ->
elt ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t;
set : context ->
elt ->
bool ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t;
elements : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t (list elt);
fold : forall {a : Type}, context ->
a ->
(elt -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t a;
clear : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t;
}.
Arguments signature : clear implicits.
End Data_set_storage.
Module NAME.
Record signature := {
name : Tezos_raw_protocol_alpha.Raw_context.key;
}.
End NAME.
Module VALUE.
Record signature {t : Type} := {
t := t;
encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t t;
}.
Arguments signature : clear implicits.
End VALUE.
Module REGISTER.
Record signature := {
ghost : bool;
}.
End REGISTER.
Module Indexed_raw_context.
Record signature {t key ipath : Type} := {
t := t;
context := t;
key := key;
polymorphic_abstract_type;
clear : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t;
fold_keys : forall {a : Type}, context ->
a ->
(key -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t a;
keys : context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t (list key);
resolve : context ->
(list string) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t (list key);
remove_rec : context ->
key -> Tezos_protocol_environment_alpha__Environment.Lwt.t context;
copy : context ->
key ->
key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
context);
Make_set : functor;
Make_map : functor;
Make_carbonated_map : functor;
Raw_context : Raw_context.T.signature (ipath t);
}.
Arguments signature : clear implicits.
End Indexed_raw_context.
src/proto_alpha/lib_protocol/test/activation.ml 132 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** The activation operation creates an implicit contract from a
registered commitment present in the context. It is parametrized by
a public key hash (pkh) and a secret.
The commitments are composed of :
- a blinded pkh that can be revealed by the secret ;
- an amount.
The commitments and the secrets are generated from
/scripts/create_genesis/create_genenis.py and should be coherent.
*)
open Protocol
open Alpha_context
open Test_utils
open Test_tez
(* Generated commitments and secrets *)
(* Commitments are hard-coded in {Tezos_proto_alpha_parameters.Default_parameters} *)
(* let commitments =
* List.map (fun (bpkh, a) ->
* Commitment_repr.{
* blinded_public_key_hash=Blinded_public_key_hash.of_b58check_exn bpkh ;
* amount = Tez_repr.of_mutez_exn (Int64.of_string a)}
* )
* [ ( "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ) ;
* ( "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ) ;
* ( "btz1LtoNCjiW23txBTenALaf5H6NKF1L3c1gw", "217487035428349" ) ;
* ( "btz1SUd3mMhEBcWudrn8u361MVAec4WYCcFoy", "4092742372031" ) ;
* ( "btz1MvBXf4orko1tsGmzkjLbpYSgnwUjEe81r", "17590039016550" ) ;
* ( "btz1LoDZ3zsjgG3k3cqTpUMc9bsXbchu9qMXT", "26322312350555" ) ;
* ( "btz1RMfq456hFV5AeDiZcQuZhoMv2dMpb9hpP", "244951387881443" ) ;
* ( "btz1Y9roTh4A7PsMBkp8AgdVFrqUDNaBE59y1", "80065050465525" ) ;
* ( "btz1Q1N2ePwhVw5ED3aaRVek6EBzYs1GDkSVD", "3569618927693" ) ;
* ( "btz1VFFVsVMYHd5WfaDTAt92BeQYGK8Ri4eLy", "9034781424478" ) ;
* ] *)
type secret_account = {
account : public_key_hash;
activation_code : Blinded_public_key_hash.activation_code;
amount : Tez.t;
}
let secrets () =
(* Exported from proto_alpha client - TODO : remove when relocated to lib_crypto *)
let read_key mnemonic email password =
match Bip39.of_words mnemonic with
| None ->
assert false
| Some t ->
(* TODO: unicode normalization (NFKD)... *)
let passphrase =
Bigstring.(concat "" [of_string email; of_string password])
in
let sk = Bip39.to_seed ~passphrase t in
let sk = Bigstring.sub_bytes sk 0 32 in
let sk : Signature.Secret_key.t =
Ed25519
(Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk)
in
let pk = Signature.Secret_key.to_public_key sk in
let pkh = Signature.Public_key.hash pk in
(pkh, pk, sk)
in
List.map
(fun (mnemonic, secret, amount, pkh, password, email) ->
let (pkh', pk, sk) = read_key mnemonic email password in
let pkh = Signature.Public_key_hash.of_b58check_exn pkh in
assert (Signature.Public_key_hash.equal pkh pkh') ;
let account = Account.{pkh; pk; sk} in
Account.add_account account ;
{
account = account.pkh;
activation_code = Blinded_public_key_hash.activation_code_of_hex secret;
amount =
Option.unopt_exn
(Invalid_argument "tez conversion")
(Tez.of_mutez (Int64.of_string amount));
})
[ ( [ "envelope";
"hospital";
"mind";
"sunset";
"cancel";
"muscle";
"leisure";
"thumb";
"wine";
"market";
"exit";
"lucky";
"style";
"picnic";
"success" ],
"0f39ed0b656509c2ecec4771712d9cddefe2afac",
"23932454669343",
"tz1MawerETND6bqJqx8GV3YHUrvMBCDasRBF",
"z0eZHQQGKt",
"cjgfoqmk.wpxnvnup@tezos.example.org" );
( [ "flag";
"quote";
"will";
"valley";
"mouse";
"chat";
"hold";
"prosper";
"silk";
"tent";
"cruel";
"cause";
"demise";
"bottom";
"practice" ],
"41f98b15efc63fa893d61d7d6eee4a2ce9427ac4",
"72954577464032",
"tz1X4maqF9tC1Yn4jULjHRAyzjAtc25Z68TX",
"MHErskWPE6",
"oklmcktr.ztljnpzc@tezos.example.org" );
( [ "library";
"away";
"inside";
"paper";
"wise";
"focus";
"sweet";
"expose";
"require";
"change";
"stove";
"planet";
"zone";
"reflect";
"finger" ],
"411dfef031eeecc506de71c9df9f8e44297cf5ba",
"217487035428348",
"tz1SWBY7rWMutEuWS54Pt33MkzAS6eWkUuTc",
"0AO6BzQNfN",
"ctgnkvqm.kvtiybky@tezos.example.org" );
( [ "cruel";
"fluid";
"damage";
"demand";
"mimic";
"above";
"village";
"alpha";
"vendor";
"staff";
"absent";
"uniform";
"fire";
"asthma";
"milk" ],
"08d7d355bc3391d12d140780b39717d9f46fcf87",
"4092742372031",
"tz1amUjiZaevaxQy5wKn4SSRvVoERCip3nZS",
"9kbZ7fR6im",
"bnyxxzqr.tdszcvqb@tezos.example.org" );
( [ "opera";
"divorce";
"easy";
"myself";
"idea";
"aim";
"dash";
"scout";
"case";
"resource";
"vote";
"humor";
"ticket";
"client";
"edge" ],
"9b7cad042fba557618bdc4b62837c5f125b50e56",
"17590039016550",
"tz1Zaee3QBtD4ErY1SzqUvyYTrENrExu6yQM",
"suxT5H09yY",
"iilkhohu.otnyuvna@tezos.example.org" );
( [ "token";
"similar";
"ginger";
"tongue";
"gun";
"sort";
"piano";
"month";
"hotel";
"vote";
"undo";
"success";
"hobby";
"shell";
"cart" ],
"124c0ca217f11ffc6c7b76a743d867c8932e5afd",
"26322312350555",
"tz1geDUUhfXK1EMj7VQdRjug1MoFe6gHWnCU",
"4odVdLykaa",
"kwhlglvr.slriitzy@tezos.example.org" );
( [ "shield";
"warrior";
"gorilla";
"birth";
"steak";
"neither";
"feel";
"only";
"liberty";
"float";
"oven";
"extend";
"pulse";
"suffer";
"vapor" ],
"ac7a2125beea68caf5266a647f24dce9fea018a7",
"244951387881443",
"tz1h3nY7jcZciJgAwRhWcrEwqfVp7VQoffur",
"A6yeMqBFG8",
"lvrmlbyj.yczltcxn@tezos.example.org" );
( [ "waste";
"open";
"scan";
"tip";
"subway";
"dance";
"rent";
"copper";
"garlic";
"laundry";
"defense";
"clerk";
"another";
"staff";
"liar" ],
"2b3e94be133a960fa0ef87f6c0922c19f9d87ca2",
"80065050465525",
"tz1VzL4Xrb3fL3ckvqCWy6bdGMzU2w9eoRqs",
"oVZqpq60sk",
"rfodmrha.zzdndvyk@tezos.example.org" );
( [ "fiber";
"next";
"property";
"cradle";
"silk";
"obey";
"gossip";
"push";
"key";
"second";
"across";
"minimum";
"nice";
"boil";
"age" ],
"dac31640199f2babc157aadc0021cd71128ca9ea",
"3569618927693",
"tz1RUHg536oRKhPLFfttcB5gSWAhh4E9TWjX",
"FfytQTTVbu",
"owecikdy.gxnyttya@tezos.example.org" );
( [ "print";
"labor";
"budget";
"speak";
"poem";
"diet";
"chunk";
"eternal";
"book";
"saddle";
"pioneer";
"ankle";
"happy";
"only";
"exclude" ],
"bb841227f250a066eb8429e56937ad504d7b34dd",
"9034781424478",
"tz1M1LFbgctcPWxstrao9aLr2ECW1fV4pH5u",
"zknAl3lrX2",
"ettilrvh.zsrqrbud@tezos.example.org" ) ]
let activation_init () =
Context.init ~with_commitments:true 1
>>=? fun (b, cs) -> secrets () |> fun ss -> return (b, cs, ss)
let simple_init_with_commitments () =
activation_init ()
>>=? fun (blk, _contracts, _secrets) ->
Block.bake blk >>=? fun _ -> return_unit
(** A single activation *)
let single_activation () =
activation_init ()
>>=? fun (blk, _contracts, secrets) ->
let ({account; activation_code; amount = expected_amount; _} as _first_one) =
List.hd secrets
in
(* Contract does not exist *)
Assert.balance_is
~loc:__LOC__
(B blk)
(Contract.implicit_contract account)
Tez.zero
>>=? fun () ->
Op.activation (B blk) account activation_code
>>=? fun operation ->
Block.bake ~operation blk
>>=? fun blk ->
(* Contract does exist *)
Assert.balance_is
~loc:__LOC__
(B blk)
(Contract.implicit_contract account)
expected_amount
(** 10 activations, one per bake *)
let multi_activation_1 () =
activation_init ()
>>=? fun (blk, _contracts, secrets) ->
Error_monad.fold_left_s
(fun blk {account; activation_code; amount = expected_amount; _} ->
Op.activation (B blk) account activation_code
>>=? fun operation ->
Block.bake ~operation blk
>>=? fun blk ->
Assert.balance_is
~loc:__LOC__
(B blk)
(Contract.implicit_contract account)
expected_amount
>>=? fun () -> return blk)
blk
secrets
>>=? fun _ -> return_unit
(** All in one bake *)
let multi_activation_2 () =
activation_init ()
>>=? fun (blk, _contracts, secrets) ->
Error_monad.fold_left_s
(fun ops {account; activation_code; _} ->
Op.activation (B blk) account activation_code
>>=? fun op -> return (op :: ops))
[]
secrets
>>=? fun ops ->
Block.bake ~operations:ops blk
>>=? fun blk ->
Error_monad.iter_s
(fun {account; amount = expected_amount; _} ->
(* Contract does exist *)
Assert.balance_is
~loc:__LOC__
(B blk)
(Contract.implicit_contract account)
expected_amount)
secrets
(** Transfer with activated account *)
let activation_and_transfer () =
activation_init ()
>>=? fun (blk, contracts, secrets) ->
let ({account; activation_code; _} as _first_one) = List.hd secrets in
let bootstrap_contract = List.hd contracts in
let first_contract = Contract.implicit_contract account in
Op.activation (B blk) account activation_code
>>=? fun operation ->
Block.bake ~operation blk
>>=? fun blk ->
Context.Contract.balance (B blk) bootstrap_contract
>>=? fun amount ->
Tez.( /? ) amount 2L
>>?= fun half_amount ->
Context.Contract.balance (B blk) first_contract
>>=? fun activated_amount_before ->
Op.transaction (B blk) bootstrap_contract first_contract half_amount
>>=? fun operation ->
Block.bake ~operation blk
>>=? fun blk ->
Assert.balance_was_credited
~loc:__LOC__
(B blk)
(Contract.implicit_contract account)
activated_amount_before
half_amount
(** Transfer to an unactivated account and then activating it *)
let transfer_to_unactivated_then_activate () =
activation_init ()
>>=? fun (blk, contracts, secrets) ->
let ({account; activation_code; amount} as _first_one) = List.hd secrets in
let bootstrap_contract = List.hd contracts in
let unactivated_commitment_contract = Contract.implicit_contract account in
Context.Contract.balance (B blk) bootstrap_contract
>>=? fun b_amount ->
Tez.( /? ) b_amount 2L
>>?= fun b_half_amount ->
Incremental.begin_construction blk
>>=? fun inc ->
Op.transaction
(I inc)
bootstrap_contract
unactivated_commitment_contract
b_half_amount
>>=? fun op ->
Incremental.add_operation inc op
>>=? fun inc ->
Op.activation (I inc) account activation_code
>>=? fun op' ->
Incremental.add_operation inc op'
>>=? fun inc ->
Incremental.finalize_block inc
>>=? fun blk2 ->
Assert.balance_was_credited
~loc:__LOC__
(B blk2)
(Contract.implicit_contract account)
amount
b_half_amount
(****************************************************************)
(* The following test scenarios are supposed to raise errors. *)
(****************************************************************)
(** Invalid pkh activation : expected to fail as the context does not
contain any commitment *)
let invalid_activation_with_no_commitments () =
Context.init 1
>>=? fun (blk, _) ->
let secrets = secrets () in
let ({account; activation_code; _} as _first_one) = List.hd secrets in
Op.activation (B blk) account activation_code
>>=? fun operation ->
Block.bake ~operation blk
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Invalid_activation _ ->
true
| _ ->
false)
(** Wrong activation : wrong secret given in the operation *)
let invalid_activation_wrong_secret () =
activation_init ()
>>=? fun (blk, _, secrets) ->
let ({account; _} as _first_one) = List.nth secrets 0 in
let ({activation_code; _} as _second_one) = List.nth secrets 1 in
Op.activation (B blk) account activation_code
>>=? fun operation ->
Block.bake ~operation blk
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Invalid_activation _ ->
true
| _ ->
false)
(** Invalid pkh activation : expected to fail as the context does not
contain an associated commitment *)
let invalid_activation_inexistent_pkh () =
activation_init ()
>>=? fun (blk, _, secrets) ->
let ({activation_code; _} as _first_one) = List.hd secrets in
let inexistent_pkh =
Signature.Public_key_hash.of_b58check_exn
"tz1PeQHGKPWSpNoozvxgqLN9TFsj6rDqNV3o"
in
Op.activation (B blk) inexistent_pkh activation_code
>>=? fun operation ->
Block.bake ~operation blk
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Invalid_activation _ ->
true
| _ ->
false)
(** Invalid pkh activation : expected to fail as the commitment has
already been claimed *)
let invalid_double_activation () =
activation_init ()
>>=? fun (blk, _, secrets) ->
let ({account; activation_code; _} as _first_one) = List.hd secrets in
Incremental.begin_construction blk
>>=? fun inc ->
Op.activation (I inc) account activation_code
>>=? fun op ->
Incremental.add_operation inc op
>>=? fun inc ->
Op.activation (I inc) account activation_code
>>=? fun op' ->
Incremental.add_operation inc op'
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Invalid_activation _ ->
true
| _ ->
false)
(** Transfer from an unactivated commitment account *)
let invalid_transfer_from_unactived_account () =
activation_init ()
>>=? fun (blk, contracts, secrets) ->
let ({account; _} as _first_one) = List.hd secrets in
let bootstrap_contract = List.hd contracts in
let unactivated_commitment_contract = Contract.implicit_contract account in
(* No activation *)
Op.transaction
(B blk)
unactivated_commitment_contract
bootstrap_contract
Tez.one
>>=? fun operation ->
Block.bake ~operation blk
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Contract_storage.Empty_implicit_contract pkh ->
if pkh = account then true else false
| _ ->
false)
let tests =
[ Test.tztest "init with commitments" `Quick simple_init_with_commitments;
Test.tztest "single activation" `Quick single_activation;
Test.tztest "multi-activation one-by-one" `Quick multi_activation_1;
Test.tztest "multi-activation all at a time" `Quick multi_activation_2;
Test.tztest "activation and transfer" `Quick activation_and_transfer;
Test.tztest
"transfer to unactivated account then activate"
`Quick
transfer_to_unactivated_then_activate;
Test.tztest
"invalid activation with no commitments"
`Quick
invalid_activation_with_no_commitments;
Test.tztest
"invalid activation with commitments"
`Quick
invalid_activation_inexistent_pkh;
Test.tztest "invalid double activation" `Quick invalid_double_activation;
Test.tztest "wrong activation code" `Quick invalid_activation_wrong_secret;
Test.tztest
"invalid transfer from unactivated account"
`Quick
invalid_transfer_from_unactived_account ]
src/proto_alpha/lib_protocol/test/activation.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Record secret_account := {
account : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash;
activation_code :
Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code;
amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t }.
Definition secrets (function_parameter : unit) : list secret_account :=
let 'tt := function_parameter in
let read_key {A : Type}
(mnemonic : list string) (email : string) (password : string)
: Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* A * Stdlib.Bytes.t :=
match op_startypeminuserrorstar mnemonic with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some t =>
let passphrase :=
concat "" % string
(cons (of_string email) (cons (of_string password) [])) in
let sk := op_startypeminuserrorstar passphrase t in
let sk := Bigstring.sub_bytes sk 0 32 in
let '_ := op_startypeminuserrorstar in
let pk := op_startypeminuserrorstar sk in
let pkh := Signature.Public_key.hash pk in
(pkh, pk, sk)
end in
List.map
(fun function_parameter =>
let '(mnemonic, secret, amount, pkh, password, email) :=
function_parameter in
let '(pkh', pk, sk) := read_key mnemonic email password in
let pkh := Signature.Public_key_hash.of_b58check_exn pkh in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (Signature.Public_key_hash.equal pkh pkh') in
let account := op_startypeminuserrorstar in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar account in
{| account := pkh account;
activation_code := Blinded_public_key_hash.activation_code_of_hex secret;
amount :=
op_startypeminuserrorstar
(OCaml.Invalid_argument "tez conversion" % string)
(Tez.of_mutez (Int64.of_string amount)) |})
(cons
((cons "envelope" % string
(cons "hospital" % string
(cons "mind" % string
(cons "sunset" % string
(cons "cancel" % string
(cons "muscle" % string
(cons "leisure" % string
(cons "thumb" % string
(cons "wine" % string
(cons "market" % string
(cons "exit" % string
(cons "lucky" % string
(cons "style" % string
(cons "picnic" % string
(cons "success" % string []))))))))))))))),
"0f39ed0b656509c2ecec4771712d9cddefe2afac" % string,
"23932454669343" % string,
"tz1MawerETND6bqJqx8GV3YHUrvMBCDasRBF" % string, "z0eZHQQGKt" % string,
"cjgfoqmk.wpxnvnup@tezos.example.org" % string)
(cons
((cons "flag" % string
(cons "quote" % string
(cons "will" % string
(cons "valley" % string
(cons "mouse" % string
(cons "chat" % string
(cons "hold" % string
(cons "prosper" % string
(cons "silk" % string
(cons "tent" % string
(cons "cruel" % string
(cons "cause" % string
(cons "demise" % string
(cons "bottom" % string
(cons "practice" % string []))))))))))))))),
"41f98b15efc63fa893d61d7d6eee4a2ce9427ac4" % string,
"72954577464032" % string,
"tz1X4maqF9tC1Yn4jULjHRAyzjAtc25Z68TX" % string,
"MHErskWPE6" % string, "oklmcktr.ztljnpzc@tezos.example.org" % string)
(cons
((cons "library" % string
(cons "away" % string
(cons "inside" % string
(cons "paper" % string
(cons "wise" % string
(cons "focus" % string
(cons "sweet" % string
(cons "expose" % string
(cons "require" % string
(cons "change" % string
(cons "stove" % string
(cons "planet" % string
(cons "zone" % string
(cons "reflect" % string
(cons "finger" % string []))))))))))))))),
"411dfef031eeecc506de71c9df9f8e44297cf5ba" % string,
"217487035428348" % string,
"tz1SWBY7rWMutEuWS54Pt33MkzAS6eWkUuTc" % string,
"0AO6BzQNfN" % string,
"ctgnkvqm.kvtiybky@tezos.example.org" % string)
(cons
((cons "cruel" % string
(cons "fluid" % string
(cons "damage" % string
(cons "demand" % string
(cons "mimic" % string
(cons "above" % string
(cons "village" % string
(cons "alpha" % string
(cons "vendor" % string
(cons "staff" % string
(cons "absent" % string
(cons "uniform" % string
(cons "fire" % string
(cons "asthma" % string
(cons "milk" % string []))))))))))))))),
"08d7d355bc3391d12d140780b39717d9f46fcf87" % string,
"4092742372031" % string,
"tz1amUjiZaevaxQy5wKn4SSRvVoERCip3nZS" % string,
"9kbZ7fR6im" % string,
"bnyxxzqr.tdszcvqb@tezos.example.org" % string)
(cons
((cons "opera" % string
(cons "divorce" % string
(cons "easy" % string
(cons "myself" % string
(cons "idea" % string
(cons "aim" % string
(cons "dash" % string
(cons "scout" % string
(cons "case" % string
(cons "resource" % string
(cons "vote" % string
(cons "humor" % string
(cons "ticket" % string
(cons "client" % string
(cons "edge" % string []))))))))))))))),
"9b7cad042fba557618bdc4b62837c5f125b50e56" % string,
"17590039016550" % string,
"tz1Zaee3QBtD4ErY1SzqUvyYTrENrExu6yQM" % string,
"suxT5H09yY" % string,
"iilkhohu.otnyuvna@tezos.example.org" % string)
(cons
((cons "token" % string
(cons "similar" % string
(cons "ginger" % string
(cons "tongue" % string
(cons "gun" % string
(cons "sort" % string
(cons "piano" % string
(cons "month" % string
(cons "hotel" % string
(cons "vote" % string
(cons "undo" % string
(cons "success" % string
(cons "hobby" % string
(cons "shell" % string
(cons "cart" % string []))))))))))))))),
"124c0ca217f11ffc6c7b76a743d867c8932e5afd" % string,
"26322312350555" % string,
"tz1geDUUhfXK1EMj7VQdRjug1MoFe6gHWnCU" % string,
"4odVdLykaa" % string,
"kwhlglvr.slriitzy@tezos.example.org" % string)
(cons
((cons "shield" % string
(cons "warrior" % string
(cons "gorilla" % string
(cons "birth" % string
(cons "steak" % string
(cons "neither" % string
(cons "feel" % string
(cons "only" % string
(cons "liberty" % string
(cons "float" % string
(cons "oven" % string
(cons "extend" % string
(cons "pulse" % string
(cons "suffer" % string
(cons "vapor" % string []))))))))))))))),
"ac7a2125beea68caf5266a647f24dce9fea018a7" % string,
"244951387881443" % string,
"tz1h3nY7jcZciJgAwRhWcrEwqfVp7VQoffur" % string,
"A6yeMqBFG8" % string,
"lvrmlbyj.yczltcxn@tezos.example.org" % string)
(cons
((cons "waste" % string
(cons "open" % string
(cons "scan" % string
(cons "tip" % string
(cons "subway" % string
(cons "dance" % string
(cons "rent" % string
(cons "copper" % string
(cons "garlic" % string
(cons "laundry" % string
(cons "defense" % string
(cons "clerk" % string
(cons "another" % string
(cons "staff" % string
(cons "liar" % string []))))))))))))))),
"2b3e94be133a960fa0ef87f6c0922c19f9d87ca2" % string,
"80065050465525" % string,
"tz1VzL4Xrb3fL3ckvqCWy6bdGMzU2w9eoRqs" % string,
"oVZqpq60sk" % string,
"rfodmrha.zzdndvyk@tezos.example.org" % string)
(cons
((cons "fiber" % string
(cons "next" % string
(cons "property" % string
(cons "cradle" % string
(cons "silk" % string
(cons "obey" % string
(cons "gossip" % string
(cons "push" % string
(cons "key" % string
(cons "second" % string
(cons "across" % string
(cons "minimum" % string
(cons "nice" % string
(cons "boil" % string
(cons "age" % string []))))))))))))))),
"dac31640199f2babc157aadc0021cd71128ca9ea" % string,
"3569618927693" % string,
"tz1RUHg536oRKhPLFfttcB5gSWAhh4E9TWjX" % string,
"FfytQTTVbu" % string,
"owecikdy.gxnyttya@tezos.example.org" % string)
(cons
((cons "print" % string
(cons "labor" % string
(cons "budget" % string
(cons "speak" % string
(cons "poem" % string
(cons "diet" % string
(cons "chunk" % string
(cons "eternal" % string
(cons "book" % string
(cons "saddle" % string
(cons "pioneer" % string
(cons "ankle" % string
(cons "happy" % string
(cons "only" % string
(cons "exclude" % string []))))))))))))))),
"bb841227f250a066eb8429e56937ad504d7b34dd" % string,
"9034781424478" % string,
"tz1M1LFbgctcPWxstrao9aLr2ECW1fV4pH5u" % string,
"zknAl3lrX2" % string,
"ettilrvh.zsrqrbud@tezos.example.org" % string) [])))))))))).
Definition activation_init {A B : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(A * B * (list secret_account))) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar true 1)
(fun function_parameter =>
let '(b, cs) := function_parameter in
op_pipegt (secrets tt) (fun ss => _return (b, cs, ss))).
Definition simple_init_with_commitments (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (activation_init tt)
(fun function_parameter =>
let '(blk, _contracts, _secrets) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar blk)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)).
Definition single_activation {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (activation_init tt)
(fun function_parameter =>
let '(blk, _contracts, secrets) := function_parameter in
let
'{|
account := account;
activation_code := activation_code;
amount := expected_amount
|} as _first_one := List.hd secrets in
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
(Contract.implicit_contract account) Tez.zero)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar account
activation_code)
(fun operation =>
op_gtgteqquestion (op_startypeminuserrorstar operation blk)
(fun blk =>
op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
(Contract.implicit_contract account) expected_amount)))).
Definition multi_activation_1 (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (activation_init tt)
(fun function_parameter =>
let '(blk, _contracts, secrets) := function_parameter in
op_gtgteqquestion
(Error_monad.fold_left_s
(fun blk =>
fun function_parameter =>
let '{|
account := account;
activation_code := activation_code;
amount := expected_amount
|} := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar account
activation_code)
(fun operation =>
op_gtgteqquestion (op_startypeminuserrorstar operation blk)
(fun blk =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar
(Contract.implicit_contract account) expected_amount)
(fun function_parameter =>
let 'tt := function_parameter in
_return blk)))) blk secrets)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)).
Definition multi_activation_2 (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (activation_init tt)
(fun function_parameter =>
let '(blk, _contracts, secrets) := function_parameter in
op_gtgteqquestion
(Error_monad.fold_left_s
(fun ops =>
fun function_parameter =>
let '{|
account := account; activation_code := activation_code |} :=
function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar account
activation_code) (fun op => _return (cons op ops))) [] secrets)
(fun ops =>
op_gtgteqquestion (op_startypeminuserrorstar ops blk)
(fun blk =>
Error_monad.iter_s
(fun function_parameter =>
let '{| account := account; amount := expected_amount |} :=
function_parameter in
op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
(Contract.implicit_contract account) expected_amount)
secrets))).
Definition activation_and_transfer {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (activation_init tt)
(fun function_parameter =>
let '(blk, contracts, secrets) := function_parameter in
let
'{| account := account; activation_code := activation_code |} as
_first_one := List.hd secrets in
let bootstrap_contract := List.hd contracts in
let first_contract := Contract.implicit_contract account in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar account
activation_code)
(fun operation =>
op_gtgteqquestion (op_startypeminuserrorstar operation blk)
(fun blk =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
bootstrap_contract)
(fun amount =>
op_startypeminuserrorstar
(Tez.op_divquestion amount
(* ❌ Constant of type int64 is converted to int *)
2)
(fun half_amount =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
first_contract)
(fun activated_amount_before =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
bootstrap_contract first_contract half_amount)
(fun operation =>
op_gtgteqquestion
(op_startypeminuserrorstar operation blk)
(fun blk =>
op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar
(Contract.implicit_contract account)
activated_amount_before half_amount)))))))).
Definition transfer_to_unactivated_then_activate {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (activation_init tt)
(fun function_parameter =>
let '(blk, contracts, secrets) := function_parameter in
let
'{|
account := account;
activation_code := activation_code;
amount := amount
|} as _first_one := List.hd secrets in
let bootstrap_contract := List.hd contracts in
let unactivated_commitment_contract := Contract.implicit_contract account
in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap_contract)
(fun b_amount =>
op_startypeminuserrorstar
(Tez.op_divquestion b_amount
(* ❌ Constant of type int64 is converted to int *)
2)
(fun b_half_amount =>
op_gtgteqquestion (op_startypeminuserrorstar blk)
(fun inc =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
bootstrap_contract unactivated_commitment_contract
b_half_amount)
(fun op =>
op_gtgteqquestion (op_startypeminuserrorstar inc op)
(fun inc =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
account activation_code)
(fun op' =>
op_gtgteqquestion
(op_startypeminuserrorstar inc op')
(fun inc =>
op_gtgteqquestion
(op_startypeminuserrorstar inc)
(fun blk2 =>
op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar
(Contract.implicit_contract account)
amount b_half_amount))))))))).
Definition invalid_activation_with_no_commitments {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(blk, _) := function_parameter in
let secrets := secrets tt in
let
'{| account := account; activation_code := activation_code |} as
_first_one := List.hd secrets in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar account
activation_code)
(fun operation =>
op_gtgteq (op_startypeminuserrorstar operation blk)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_activation
_ => true
| _ => false
end)))).
Definition invalid_activation_wrong_secret {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (activation_init tt)
(fun function_parameter =>
let '(blk, _, secrets) := function_parameter in
let '{| account := account |} as _first_one :=
op_startypeminuserrorstar secrets 0 in
let '{| activation_code := activation_code |} as _second_one :=
op_startypeminuserrorstar secrets 1 in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar account
activation_code)
(fun operation =>
op_gtgteq (op_startypeminuserrorstar operation blk)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_activation
_ => true
| _ => false
end)))).
Definition invalid_activation_inexistent_pkh {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (activation_init tt)
(fun function_parameter =>
let '(blk, _, secrets) := function_parameter in
let '{| activation_code := activation_code |} as _first_one :=
List.hd secrets in
let inexistent_pkh :=
Signature.Public_key_hash.of_b58check_exn
"tz1PeQHGKPWSpNoozvxgqLN9TFsj6rDqNV3o" % string in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar inexistent_pkh
activation_code)
(fun operation =>
op_gtgteq (op_startypeminuserrorstar operation blk)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_activation
_ => true
| _ => false
end)))).
Definition invalid_double_activation {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (activation_init tt)
(fun function_parameter =>
let '(blk, _, secrets) := function_parameter in
let
'{| account := account; activation_code := activation_code |} as
_first_one := List.hd secrets in
op_gtgteqquestion (op_startypeminuserrorstar blk)
(fun inc =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar account
activation_code)
(fun op =>
op_gtgteqquestion (op_startypeminuserrorstar inc op)
(fun inc =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar account
activation_code)
(fun op' =>
op_gtgteq (op_startypeminuserrorstar inc op')
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_activation
_ => true
| _ => false
end))))))).
Definition invalid_transfer_from_unactived_account {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (activation_init tt)
(fun function_parameter =>
let '(blk, contracts, secrets) := function_parameter in
let '{| account := account |} as _first_one := List.hd secrets in
let bootstrap_contract := List.hd contracts in
let unactivated_commitment_contract := Contract.implicit_contract account
in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
unactivated_commitment_contract bootstrap_contract Tez.one)
(fun operation =>
op_gtgteq (op_startypeminuserrorstar operation blk)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_implicit_contract
pkh =>
if op_startypeminuserrorstar pkh account then
true
else
false
| _ => false
end)))).
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "init with commitments" % string
(* ❌ Variants not supported *)
variant simple_init_with_commitments)
(cons
(op_startypeminuserrorstar "single activation" % string
(* ❌ Variants not supported *)
variant single_activation)
(cons
(op_startypeminuserrorstar "multi-activation one-by-one" % string
(* ❌ Variants not supported *)
variant multi_activation_1)
(cons
(op_startypeminuserrorstar "multi-activation all at a time" % string
(* ❌ Variants not supported *)
variant multi_activation_2)
(cons
(op_startypeminuserrorstar "activation and transfer" % string
(* ❌ Variants not supported *)
variant activation_and_transfer)
(cons
(op_startypeminuserrorstar
"transfer to unactivated account then activate" % string
(* ❌ Variants not supported *)
variant transfer_to_unactivated_then_activate)
(cons
(op_startypeminuserrorstar
"invalid activation with no commitments" % string
(* ❌ Variants not supported *)
variant invalid_activation_with_no_commitments)
(cons
(op_startypeminuserrorstar
"invalid activation with commitments" % string
(* ❌ Variants not supported *)
variant invalid_activation_inexistent_pkh)
(cons
(op_startypeminuserrorstar
"invalid double activation" % string
(* ❌ Variants not supported *)
variant invalid_double_activation)
(cons
(op_startypeminuserrorstar
"wrong activation code" % string
(* ❌ Variants not supported *)
variant invalid_activation_wrong_secret)
(cons
(op_startypeminuserrorstar
"invalid transfer from unactivated account" % string
(* ❌ Variants not supported *)
variant invalid_transfer_from_unactived_account) [])))))))))).
src/proto_alpha/lib_protocol/test/baking.ml 54 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Test_utils
(** Tests for [bake_n] and [bake_until_end_cycle]. *)
let test_cycle () =
Context.init 5
>>=? fun (b, _) ->
Context.get_constants (B b)
>>=? fun csts ->
let blocks_per_cycle = csts.parametric.blocks_per_cycle in
let pp fmt x = Format.fprintf fmt "%ld" x in
(* Tests that [bake_until_cycle_end] returns a block at
level [blocks_per_cycle]. *)
Block.bake b
>>=? fun b ->
Block.bake_until_cycle_end b
>>=? fun b ->
Context.get_level (B b)
>>=? fun curr_level ->
Assert.equal
~loc:__LOC__
Int32.equal
"not the right level"
pp
(Alpha_context.Raw_level.to_int32 curr_level)
blocks_per_cycle
>>=? fun () ->
(* Tests that [bake_n n] bakes [n] blocks. *)
Context.get_level (B b)
>>=? fun l ->
Block.bake_n 10 b
>>=? fun b ->
Context.get_level (B b)
>>=? fun curr_level ->
Assert.equal
~loc:__LOC__
Int32.equal
"not the right level"
pp
(Alpha_context.Raw_level.to_int32 curr_level)
(Int32.add (Alpha_context.Raw_level.to_int32 l) 10l)
(** Tests the formula introduced in Emmy+ for block reward:
(16/(p+1)) * (0.8 + 0.2 * e / 32)
where p is the block priority and
e is the number of included endorsements *)
let test_block_reward priority () =
( match priority with
| 0 ->
Test_tez.Tez.(of_int 128 /? Int64.of_int 10)
>>?= fun min -> return (Test_tez.Tez.of_int 16, min)
| 1 ->
Test_tez.Tez.(of_int 64 /? Int64.of_int 10)
>>?= fun min -> return (Test_tez.Tez.of_int 8, min)
| 3 ->
Test_tez.Tez.(of_int 32 /? Int64.of_int 10)
>>?= fun min -> return (Test_tez.Tez.of_int 4, min)
| _ ->
fail (invalid_arg "prio should be 0, 1, or 3") )
>>=? fun (expected_reward_max_endo, expected_reward_min_endo) ->
let endorsers_per_block = 32 in
Context.init ~endorsers_per_block 32
>>=? fun (b, _) ->
Context.get_endorsers (B b)
>>=? fun endorsers ->
fold_left_s
(fun ops (endorser : Alpha_services.Delegate.Endorsing_rights.t) ->
let delegate = endorser.delegate in
Op.endorsement ~delegate (B b) ()
>>=? fun op -> return (Operation.pack op :: ops))
[]
endorsers
>>=? fun ops ->
Block.bake ~policy:(By_priority 0) ~operations:ops b
>>=? fun b ->
(* bake a block at priority 0 and 32 endorsements;
the reward is 16 tez *)
Context.get_baking_reward (B b) ~priority ~endorsing_power:32
>>=? fun baking_reward ->
Assert.equal_tez ~loc:__LOC__ baking_reward expected_reward_max_endo
>>=? fun () ->
(* bake a block at priority 0 and 0 endorsements;
the reward is 12.8 tez *)
Context.get_baking_reward (B b) ~priority ~endorsing_power:0
>>=? fun baking_reward ->
Assert.equal_tez ~loc:__LOC__ baking_reward expected_reward_min_endo
let tests =
[ Test.tztest "cycle" `Quick test_cycle;
Test.tztest "block_reward for priority 0" `Quick (test_block_reward 0);
Test.tztest "block_reward for priority 1" `Quick (test_block_reward 1);
Test.tztest "block_reward for priority 3" `Quick (test_block_reward 3) ]
src/proto_alpha/lib_protocol/test/baking.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Definition test_cycle {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 5)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun csts =>
let blocks_per_cycle := blocks_per_cycle (parametric csts) in
let pp
(fmt :
Tezos_protocol_environment_alpha__Environment.Format.formatter) (x :
int32) : unit :=
Format.fprintf fmt
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
"%ld" % string) x in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun curr_level =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ Int32.equal
"not the right level" % string pp
(Alpha_context.Raw_level.to_int32 curr_level)
blocks_per_cycle)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun l =>
op_gtgteqquestion (op_startypeminuserrorstar 10 b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun curr_level =>
op_startypeminuserrorstar __LOC__
Int32.equal
"not the right level" % string pp
(Alpha_context.Raw_level.to_int32
curr_level)
(Int32.add
(Alpha_context.Raw_level.to_int32 l)
(* ❌ Constant of type int32 is converted to int *)
10)))))))))).
Definition test_block_reward {A : Type}
(priority : Z) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion
match priority with
| 0 =>
op_startypeminuserrorstar op_startypeminuserrorstar
(fun min => _return ((op_startypeminuserrorstar 16), min))
| 1 =>
op_startypeminuserrorstar op_startypeminuserrorstar
(fun min => _return ((op_startypeminuserrorstar 8), min))
| 3 =>
op_startypeminuserrorstar op_startypeminuserrorstar
(fun min => _return ((op_startypeminuserrorstar 4), min))
| _ => fail (invalid_arg "prio should be 0, 1, or 3" % string)
end
(fun function_parameter =>
let '(expected_reward_max_endo, expected_reward_min_endo) :=
function_parameter in
let endorsers_per_block := 32 in
op_gtgteqquestion (op_startypeminuserrorstar endorsers_per_block 32)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun endorsers =>
op_gtgteqquestion
(fold_left_s
(fun ops =>
fun endorser =>
let delegate := delegate endorser in
op_gtgteqquestion
(op_startypeminuserrorstar delegate
op_startypeminuserrorstar tt)
(fun op => _return (cons (Operation.pack op) ops))) []
endorsers)
(fun ops =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar ops b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
priority 32)
(fun baking_reward =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ baking_reward
expected_reward_max_endo)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar priority 0)
(fun baking_reward =>
op_startypeminuserrorstar __LOC__
baking_reward expected_reward_min_endo)))))))).
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "cycle" % string
(* ❌ Variants not supported *)
variant test_cycle)
(cons
(op_startypeminuserrorstar "block_reward for priority 0" % string
(* ❌ Variants not supported *)
variant (test_block_reward 0))
(cons
(op_startypeminuserrorstar "block_reward for priority 1" % string
(* ❌ Variants not supported *)
variant (test_block_reward 1))
(cons
(op_startypeminuserrorstar "block_reward for priority 3" % string
(* ❌ Variants not supported *)
variant (test_block_reward 3)) []))).
src/proto_alpha/lib_protocol/test/combined_operations.ml 137 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Multiple operations can be grouped in one ensuring their
derministic application.
If an invalid operation is present in this group of operation, the
previous applied operations are backtracked leaving the context
unchanged and the following operations are skipped. Fees attributed
to the operations are collected by the baker nonetheless.
Only manager operations are allowed in multiple transactions.
They must all belong to the same manager as there is only one signature. *)
open Protocol
open Test_tez
open Test_utils
let ten_tez = Tez.of_int 10
(** Groups ten transactions between the same parties. *)
let multiple_transfers () =
Context.init 3
>>=? fun (blk, contracts) ->
let c1 = List.nth contracts 0 in
let c2 = List.nth contracts 1 in
let c3 = List.nth contracts 2 in
map_s (fun _ -> Op.transaction (B blk) c1 c2 Tez.one) (1 -- 10)
>>=? fun ops ->
Op.combine_operations ~source:c1 (B blk) ops
>>=? fun operation ->
Context.Contract.balance (B blk) c1
>>=? fun c1_old_balance ->
Context.Contract.balance (B blk) c2
>>=? fun c2_old_balance ->
Context.Contract.pkh c3
>>=? fun baker_pkh ->
Block.bake ~policy:(By_account baker_pkh) ~operation blk
>>=? fun blk ->
Assert.balance_was_debited
~loc:__LOC__
(B blk)
c1
c1_old_balance
(Tez.of_int 10)
>>=? fun () ->
Assert.balance_was_credited
~loc:__LOC__
(B blk)
c2
c2_old_balance
(Tez.of_int 10)
>>=? fun () -> return_unit
(** Groups ten delegated originations. *)
let multiple_origination_and_delegation () =
Context.init 2
>>=? fun (blk, contracts) ->
let c1 = List.nth contracts 0 in
let c2 = List.nth contracts 1 in
let n = 10 in
Context.get_constants (B blk)
>>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
Context.Contract.pkh c2
>>=? fun delegate_pkh ->
(* Deploy n smart contracts with dummy scripts from c1 *)
map_s
(fun i ->
Op.origination
~delegate:delegate_pkh
~counter:(Z.of_int i)
~fee:Tez.zero
~script:Op.dummy_script
~credit:(Tez.of_int 10)
(B blk)
c1)
(1 -- n)
>>=? fun originations ->
(* These computed originated contracts are not the ones really created *)
(* We will extract them from the tickets *)
let (originations_operations, _) = List.split originations in
Op.combine_operations ~source:c1 (B blk) originations_operations
>>=? fun operation ->
Context.Contract.balance (B blk) c1
>>=? fun c1_old_balance ->
Incremental.begin_construction blk
>>=? fun inc ->
Incremental.add_operation inc operation
>>=? fun inc ->
(* To retrieve the originated contracts, it is easier to extract them
from the tickets. Else, we could (could we ?) hash each combined
operation individually. *)
let tickets = Incremental.rev_tickets inc in
let open Apply_results in
let tickets =
List.fold_left
(fun acc -> function No_operation_metadata -> assert false
| Operation_metadata {contents} ->
to_list (Contents_result_list contents) @ acc)
[]
tickets
|> List.rev
in
let new_contracts =
List.map
(function
| Contents_result
(Manager_operation_result
{ operation_result =
Applied (Origination_result {originated_contracts = [h]; _});
_ }) ->
h
| _ ->
assert false)
tickets
in
(* Previous balance - (Credit (n * 10tz) + Origination cost (n tz)) *)
Tez.(cost_per_byte *? Int64.of_int origination_size)
>>?= fun origination_burn ->
Tez.(origination_burn *? Int64.of_int n)
>>?= fun origination_total_cost ->
Lwt.return
( Tez.( *? ) Op.dummy_script_cost 10L
>>? Tez.( +? ) (Tez.of_int (10 * n))
>>? Tez.( +? ) origination_total_cost )
>>=? fun total_cost ->
Assert.balance_was_debited ~loc:__LOC__ (I inc) c1 c1_old_balance total_cost
>>=? fun () ->
iter_s
(fun c -> Assert.balance_is ~loc:__LOC__ (I inc) c (Tez.of_int 10))
new_contracts
>>=? fun () -> return_unit
let expect_balance_too_low = function
| Environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ ->
return_unit
| _ ->
failwith
"Contract should not have a sufficient balance : operation expected \
to fail."
(** Groups three operations, the midlle one failing.
Checks that the receipt is consistent.
Variant without fees. *)
let failing_operation_in_the_middle () =
Context.init 2
>>=? fun (blk, contracts) ->
let c1 = List.nth contracts 0 in
let c2 = List.nth contracts 1 in
Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.one
>>=? fun op1 ->
Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.max_tez
>>=? fun op2 ->
Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.one
>>=? fun op3 ->
let operations = [op1; op2; op3] in
Op.combine_operations ~source:c1 (B blk) operations
>>=? fun operation ->
Context.Contract.balance (B blk) c1
>>=? fun c1_old_balance ->
Context.Contract.balance (B blk) c2
>>=? fun c2_old_balance ->
Incremental.begin_construction blk
>>=? fun inc ->
Incremental.add_operation
~expect_failure:expect_balance_too_low
inc
operation
>>=? fun inc ->
let tickets = Incremental.rev_tickets inc in
let open Apply_results in
let tickets =
List.fold_left
(fun acc -> function No_operation_metadata -> assert false
| Operation_metadata {contents} ->
to_list (Contents_result_list contents) @ acc)
[]
tickets
in
( match tickets with
| Contents_result
(Manager_operation_result {operation_result = Backtracked _; _})
:: Contents_result
(Manager_operation_result
{ operation_result = Failed (_, [Contract_storage.Balance_too_low _]);
_ })
:: Contents_result
(Manager_operation_result {operation_result = Skipped _; _})
:: _ ->
()
| _ ->
assert false ) ;
Assert.balance_is ~loc:__LOC__ (I inc) c1 c1_old_balance
>>=? fun () ->
Assert.balance_is ~loc:__LOC__ (I inc) c2 c2_old_balance
>>=? fun () -> return_unit
(** Groups three operations, the midlle one failing.
Checks that the receipt is consistent.
Variant with fees, that should be spent even in case of failure. *)
let failing_operation_in_the_middle_with_fees () =
Context.init 2
>>=? fun (blk, contracts) ->
let c1 = List.nth contracts 0 in
let c2 = List.nth contracts 1 in
Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one
>>=? fun op1 ->
Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.max_tez
>>=? fun op2 ->
Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one
>>=? fun op3 ->
let operations = [op1; op2; op3] in
Op.combine_operations ~source:c1 (B blk) operations
>>=? fun operation ->
Context.Contract.balance (B blk) c1
>>=? fun c1_old_balance ->
Context.Contract.balance (B blk) c2
>>=? fun c2_old_balance ->
Incremental.begin_construction blk
>>=? fun inc ->
Incremental.add_operation
~expect_failure:expect_balance_too_low
inc
operation
>>=? fun inc ->
let tickets = Incremental.rev_tickets inc in
let open Apply_results in
let tickets =
List.fold_left
(fun acc -> function No_operation_metadata -> assert false
| Operation_metadata {contents} ->
to_list (Contents_result_list contents) @ acc)
[]
tickets
in
( match tickets with
| Contents_result
(Manager_operation_result {operation_result = Backtracked _; _})
:: Contents_result
(Manager_operation_result
{ operation_result = Failed (_, [Contract_storage.Balance_too_low _]);
_ })
:: Contents_result
(Manager_operation_result {operation_result = Skipped _; _})
:: _ ->
()
| _ ->
assert false ) ;
(* In the presence of a failure, all the fees are collected. Even for skipped operations. *)
Assert.balance_was_debited
~loc:__LOC__
(I inc)
c1
c1_old_balance
(Tez.of_int 3)
>>=? fun () ->
Assert.balance_is ~loc:__LOC__ (I inc) c2 c2_old_balance
>>=? fun () -> return_unit
let tests =
[ Test.tztest "multiple transfers" `Quick multiple_transfers;
Test.tztest
"multiple originations and delegations"
`Quick
multiple_origination_and_delegation;
Test.tztest
"Failing operation in the middle"
`Quick
failing_operation_in_the_middle;
Test.tztest
"Failing operation in the middle (with fees)"
`Quick
failing_operation_in_the_middle_with_fees ]
src/proto_alpha/lib_protocol/test/combined_operations.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Definition ten_tez {A : Type} : A := op_startypeminuserrorstar 10.
Definition multiple_transfers (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 3)
(fun function_parameter =>
let '(blk, contracts) := function_parameter in
let c1 := op_startypeminuserrorstar contracts 0 in
let c2 := op_startypeminuserrorstar contracts 1 in
let c3 := op_startypeminuserrorstar contracts 2 in
op_gtgteqquestion
(map_s
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar op_startypeminuserrorstar c1 c2
op_startypeminuserrorstar) (op_startypeminuserrorstar 1 10))
(fun ops =>
op_gtgteqquestion
(op_startypeminuserrorstar c1 op_startypeminuserrorstar ops)
(fun operation =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar c1)
(fun c1_old_balance =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar c2)
(fun c2_old_balance =>
op_gtgteqquestion (op_startypeminuserrorstar c3)
(fun baker_pkh =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
operation blk)
(fun blk =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar c1 c1_old_balance
(op_startypeminuserrorstar 10))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar c2
c2_old_balance
(op_startypeminuserrorstar 10))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))))))).
Definition multiple_origination_and_delegation {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(blk, contracts) := function_parameter in
let c1 := op_startypeminuserrorstar contracts 0 in
let c2 := op_startypeminuserrorstar contracts 1 in
let n := 10 in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar c2)
(fun delegate_pkh =>
op_gtgteqquestion
(map_s
(fun i =>
op_startypeminuserrorstar delegate_pkh (Z.of_int i)
op_startypeminuserrorstar op_startypeminuserrorstar
(op_startypeminuserrorstar 10) op_startypeminuserrorstar
c1) (op_startypeminuserrorstar 1 n))
(fun originations =>
let '(originations_operations, _) := List.split originations
in
op_gtgteqquestion
(op_startypeminuserrorstar c1 op_startypeminuserrorstar
originations_operations)
(fun operation =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar c1)
(fun c1_old_balance =>
op_gtgteqquestion (op_startypeminuserrorstar blk)
(fun inc =>
op_gtgteqquestion
(op_startypeminuserrorstar inc operation)
(fun inc =>
let tickets := op_startypeminuserrorstar inc
in
let tickets :=
op_pipegt
(List.fold_left
(fun acc =>
fun function_parameter =>
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Apply_results.No_operation_metadata
=>
(* ❌ Assert instruction is not handled. *)
assert false
|
Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata
{| contents := contents |} =>
op_at
(to_list
(Tezos_protocol_alpha.Protocol.Apply_results.Contents_result_list
contents)) acc
end) [] tickets) List.rev in
let new_contracts :=
List.map
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Apply_results.Contents_result
(Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
{|
operation_result :=
Tezos_protocol_alpha.Protocol.Apply_results.Applied
(Tezos_protocol_alpha.Protocol.Apply_results.Origination_result
{|
originated_contracts := cons h []
|})
|}) => h
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end) tickets in
op_startypeminuserrorstar
op_startypeminuserrorstar
(fun origination_burn =>
op_startypeminuserrorstar
op_startypeminuserrorstar
(fun origination_total_cost =>
op_gtgteqquestion
(Lwt._return
(op_gtgtquestion
(op_gtgtquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
(* ❌ Constant of type int64 is converted to int *)
10)
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_star 10 n))))
(op_startypeminuserrorstar
origination_total_cost)))
(fun total_cost =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar c1
c1_old_balance total_cost)
(fun function_parameter =>
let 'tt := function_parameter
in
op_gtgteqquestion
(iter_s
(fun c =>
op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
c
(op_startypeminuserrorstar
10)) new_contracts)
(fun function_parameter =>
let 'tt :=
function_parameter in
return_unit))))))))))))).
Definition expect_balance_too_low
(function_parameter : list Tezos_base__TzPervasives.Error_monad.error)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
match function_parameter with
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _)) _ => return_unit
| _ =>
failwith
"Contract should not have a sufficient balance : operation expected to fail."
% string
end.
Definition failing_operation_in_the_middle (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(blk, contracts) := function_parameter in
let c1 := op_startypeminuserrorstar contracts 0 in
let c2 := op_startypeminuserrorstar contracts 1 in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar c1 c2 op_startypeminuserrorstar)
(fun op1 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar c1 c2 op_startypeminuserrorstar)
(fun op2 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar c1 c2 op_startypeminuserrorstar)
(fun op3 =>
let operations := cons op1 (cons op2 (cons op3 [])) in
op_gtgteqquestion
(op_startypeminuserrorstar c1 op_startypeminuserrorstar
operations)
(fun operation =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar c1)
(fun c1_old_balance =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
c2)
(fun c2_old_balance =>
op_gtgteqquestion (op_startypeminuserrorstar blk)
(fun inc =>
op_gtgteqquestion
(op_startypeminuserrorstar
expect_balance_too_low inc operation)
(fun inc =>
let tickets :=
op_startypeminuserrorstar inc in
let tickets :=
List.fold_left
(fun acc =>
fun function_parameter =>
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Apply_results.No_operation_metadata
=>
(* ❌ Assert instruction is not handled. *)
assert false
|
Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata
{| contents := contents |} =>
op_at
(to_list
(Tezos_protocol_alpha.Protocol.Apply_results.Contents_result_list
contents)) acc
end) [] tickets in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match tickets with
|
cons
(Tezos_protocol_alpha.Protocol.Apply_results.Contents_result
(Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
{|
operation_result :=
Tezos_protocol_alpha.Protocol.Apply_results.Backtracked
_
_
|}))
(cons
(Tezos_protocol_alpha.Protocol.Apply_results.Contents_result
(Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
{|
operation_result :=
Tezos_protocol_alpha.Protocol.Apply_results.Failed
_
(cons
(Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_
_
_)
[])
|}))
(cons
(Tezos_protocol_alpha.Protocol.Apply_results.Contents_result
(Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
{|
operation_result := Tezos_protocol_alpha.Protocol.Apply_results.Skipped _
|})) _)) => tt
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar c1
c1_old_balance)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar c2
c2_old_balance)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))))))))).
Definition failing_operation_in_the_middle_with_fees (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(blk, contracts) := function_parameter in
let c1 := op_startypeminuserrorstar contracts 0 in
let c2 := op_startypeminuserrorstar contracts 1 in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar c1 c2 op_startypeminuserrorstar)
(fun op1 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar c1 c2 op_startypeminuserrorstar)
(fun op2 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar c1 c2 op_startypeminuserrorstar)
(fun op3 =>
let operations := cons op1 (cons op2 (cons op3 [])) in
op_gtgteqquestion
(op_startypeminuserrorstar c1 op_startypeminuserrorstar
operations)
(fun operation =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar c1)
(fun c1_old_balance =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
c2)
(fun c2_old_balance =>
op_gtgteqquestion (op_startypeminuserrorstar blk)
(fun inc =>
op_gtgteqquestion
(op_startypeminuserrorstar
expect_balance_too_low inc operation)
(fun inc =>
let tickets :=
op_startypeminuserrorstar inc in
let tickets :=
List.fold_left
(fun acc =>
fun function_parameter =>
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Apply_results.No_operation_metadata
=>
(* ❌ Assert instruction is not handled. *)
assert false
|
Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata
{| contents := contents |} =>
op_at
(to_list
(Tezos_protocol_alpha.Protocol.Apply_results.Contents_result_list
contents)) acc
end) [] tickets in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match tickets with
|
cons
(Tezos_protocol_alpha.Protocol.Apply_results.Contents_result
(Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
{|
operation_result :=
Tezos_protocol_alpha.Protocol.Apply_results.Backtracked
_
_
|}))
(cons
(Tezos_protocol_alpha.Protocol.Apply_results.Contents_result
(Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
{|
operation_result :=
Tezos_protocol_alpha.Protocol.Apply_results.Failed
_
(cons
(Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_
_
_)
[])
|}))
(cons
(Tezos_protocol_alpha.Protocol.Apply_results.Contents_result
(Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
{|
operation_result := Tezos_protocol_alpha.Protocol.Apply_results.Skipped _
|})) _)) => tt
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar c1
c1_old_balance
(op_startypeminuserrorstar 3))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar c2
c2_old_balance)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))))))))).
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "multiple transfers" % string
(* ❌ Variants not supported *)
variant multiple_transfers)
(cons
(op_startypeminuserrorstar
"multiple originations and delegations" % string
(* ❌ Variants not supported *)
variant multiple_origination_and_delegation)
(cons
(op_startypeminuserrorstar "Failing operation in the middle" % string
(* ❌ Variants not supported *)
variant failing_operation_in_the_middle)
(cons
(op_startypeminuserrorstar
"Failing operation in the middle (with fees)" % string
(* ❌ Variants not supported *)
variant failing_operation_in_the_middle_with_fees) []))).
src/proto_alpha/lib_protocol/test/delegation.ml 1063 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Test_tez
open Test_utils
(**************************************************************************)
(* bootstrap contracts *)
(**************************************************************************)
(* Bootstrap contracts are heavily used in other tests. It is helpful
to test some properties of these contracts, so we can correctly
interpret the other tests that use them. *)
let expect_error err = function
| err0 :: _ when err = err0 ->
return_unit
| _ ->
failwith "Unexpected successful result"
let expect_alpha_error err = expect_error (Environment.Ecoproto_error err)
let expect_no_change_registered_delegate_pkh pkh = function
| Environment.Ecoproto_error (Delegate_storage.No_deletion pkh0) :: _
when pkh0 = pkh ->
return_unit
| _ ->
failwith "Delegate can not be deleted and operation should fail."
(** bootstrap contracts delegate to themselves *)
let bootstrap_manager_is_bootstrap_delegate () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
let bootstrap0 = List.hd bootstrap_contracts in
Context.Contract.delegate (B b) bootstrap0
>>=? fun delegate0 ->
Context.Contract.manager (B b) bootstrap0
>>=? fun manager0 -> Assert.equal_pkh ~loc:__LOC__ delegate0 manager0.pkh
(** bootstrap contracts cannot change their delegate *)
let bootstrap_delegate_cannot_change ~fee () =
Context.init 2
>>=? fun (b, bootstrap_contracts) ->
let bootstrap0 = List.nth bootstrap_contracts 0 in
let bootstrap1 = List.nth bootstrap_contracts 1 in
Context.Contract.pkh bootstrap0
>>=? fun pkh1 ->
Incremental.begin_construction b ~policy:(Block.Excluding [pkh1])
>>=? fun i ->
Context.Contract.manager (I i) bootstrap1
>>=? fun manager1 ->
Context.Contract.balance (I i) bootstrap0
>>=? fun balance0 ->
Context.Contract.delegate (I i) bootstrap0
>>=? fun delegate0 ->
(* change delegation to bootstrap1 *)
Op.delegation ~fee (I i) bootstrap0 (Some manager1.pkh)
>>=? fun set_delegate ->
if fee > balance0 then
Incremental.add_operation i set_delegate
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
Incremental.add_operation
~expect_failure:(expect_no_change_registered_delegate_pkh delegate0)
i
set_delegate
>>=? fun i ->
Incremental.finalize_block i
>>=? fun b ->
(* bootstrap0 still has same delegate *)
Context.Contract.delegate (B b) bootstrap0
>>=? fun delegate0_after ->
Assert.equal_pkh ~loc:__LOC__ delegate0_after delegate0
>>=? fun () ->
(* fee has been debited *)
Assert.balance_was_debited ~loc:__LOC__ (B b) bootstrap0 balance0 fee
(** bootstrap contracts cannot delete their delegation *)
let bootstrap_delegate_cannot_be_removed ~fee () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
let bootstrap = List.hd bootstrap_contracts in
Incremental.begin_construction b
>>=? fun i ->
Context.Contract.balance (I i) bootstrap
>>=? fun balance ->
Context.Contract.delegate (I i) bootstrap
>>=? fun delegate ->
Context.Contract.manager (I i) bootstrap
>>=? fun manager ->
(* remove delegation *)
Op.delegation ~fee (I i) bootstrap None
>>=? fun set_delegate ->
if fee > balance then
Incremental.add_operation i set_delegate
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
Incremental.add_operation
~expect_failure:(expect_no_change_registered_delegate_pkh manager.pkh)
i
set_delegate
>>=? fun i ->
(* delegate has not changed *)
Context.Contract.delegate (I i) bootstrap
>>=? fun delegate_after ->
Assert.equal_pkh ~loc:__LOC__ delegate delegate_after
>>=? fun () ->
(* fee has been debited *)
Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee
(** contracts not registered as delegate can change their delegation *)
let delegate_can_be_changed_from_unregistered_contract ~fee () =
Context.init 2
>>=? fun (b, bootstrap_contracts) ->
let bootstrap0 = List.hd bootstrap_contracts in
let bootstrap1 = List.nth bootstrap_contracts 1 in
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
let unregistered = Contract.implicit_contract unregistered_pkh in
Incremental.begin_construction b
>>=? fun i ->
Context.Contract.manager (I i) bootstrap0
>>=? fun manager0 ->
Context.Contract.manager (I i) bootstrap1
>>=? fun manager1 ->
let credit = Tez.of_int 10 in
Op.transaction ~fee:Tez.zero (I i) bootstrap0 unregistered credit
>>=? fun credit_contract ->
Context.Contract.balance (I i) bootstrap0
>>=? fun balance ->
Incremental.add_operation i credit_contract
>>=? fun i ->
(* delegate to bootstrap0 *)
Op.delegation ~fee:Tez.zero (I i) unregistered (Some manager0.pkh)
>>=? fun set_delegate ->
Incremental.add_operation i set_delegate
>>=? fun i ->
Context.Contract.delegate (I i) unregistered
>>=? fun delegate ->
Assert.equal_pkh ~loc:__LOC__ delegate manager0.pkh
>>=? fun () ->
(* change delegation to bootstrap1 *)
Op.delegation ~fee (I i) unregistered (Some manager1.pkh)
>>=? fun change_delegate ->
if fee > balance then
Incremental.add_operation i change_delegate
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
Incremental.add_operation i change_delegate
>>=? fun i ->
(* delegate has changed *)
Context.Contract.delegate (I i) unregistered
>>=? fun delegate_after ->
Assert.equal_pkh ~loc:__LOC__ delegate_after manager1.pkh
>>=? fun () ->
(* fee has been debited *)
Assert.balance_was_debited ~loc:__LOC__ (I i) unregistered credit fee
(** contracts not registered as delegate can delete their delegation *)
let delegate_can_be_removed_from_unregistered_contract ~fee () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
let bootstrap = List.hd bootstrap_contracts in
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
let unregistered = Contract.implicit_contract unregistered_pkh in
Incremental.begin_construction b
>>=? fun i ->
Context.Contract.manager (I i) bootstrap
>>=? fun manager ->
let credit = Tez.of_int 10 in
Op.transaction ~fee:Tez.zero (I i) bootstrap unregistered credit
>>=? fun credit_contract ->
Context.Contract.balance (I i) bootstrap
>>=? fun balance ->
Incremental.add_operation i credit_contract
>>=? fun i ->
(* delegate to bootstrap *)
Op.delegation ~fee:Tez.zero (I i) unregistered (Some manager.pkh)
>>=? fun set_delegate ->
Incremental.add_operation i set_delegate
>>=? fun i ->
Context.Contract.delegate (I i) unregistered
>>=? fun delegate ->
Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh
>>=? fun () ->
(* remove delegation *)
Op.delegation ~fee (I i) unregistered None
>>=? fun delete_delegate ->
if fee > balance then
Incremental.add_operation i delete_delegate
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
Incremental.add_operation i delete_delegate
>>=? fun i ->
(* the delegate has been removed *)
Context.Contract.delegate_opt (I i) unregistered
>>=? (function
| None ->
return_unit
| Some _ ->
failwith "Expected delegate to be removed")
>>=? fun () ->
(* fee has been debited *)
Assert.balance_was_debited ~loc:__LOC__ (I i) unregistered credit fee
(** bootstrap keys are already registered as delegate keys *)
let bootstrap_manager_already_registered_delegate ~fee () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
Context.Contract.manager (I i) bootstrap
>>=? fun manager ->
let pkh = manager.pkh in
let impl_contract = Contract.implicit_contract pkh in
Context.Contract.balance (I i) impl_contract
>>=? fun balance ->
Op.delegation ~fee (I i) impl_contract (Some pkh)
>>=? fun sec_reg ->
if fee > balance then
Incremental.add_operation i sec_reg
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
Incremental.add_operation
~expect_failure:(function
| Environment.Ecoproto_error Delegate_storage.Active_delegate :: _ ->
return_unit
| _ ->
failwith "Delegate is already active and operation should fail.")
i
sec_reg
>>=? fun i ->
(* fee has been debited *)
Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee
(** bootstrap manager can be set as delegate of an originated contract
(through origination operation) *)
let delegate_to_bootstrap_by_origination ~fee () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
Context.Contract.manager (I i) bootstrap
>>=? fun manager ->
Context.Contract.balance (I i) bootstrap
>>=? fun balance ->
(* originate a contract with bootstrap's manager as delegate *)
Op.origination
~fee
~credit:Tez.zero
~delegate:manager.pkh
(I i)
bootstrap
~script:Op.dummy_script
>>=? fun (op, orig_contract) ->
Context.get_constants (I i)
>>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
(* 0.257tz *)
Tez.(cost_per_byte *? Int64.of_int origination_size)
>>?= fun origination_burn ->
Lwt.return
(Tez.( +? ) fee origination_burn >>? Tez.( +? ) Op.dummy_script_cost)
>>=? fun total_fee ->
if fee > balance then
Incremental.add_operation i op
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else if total_fee > balance && balance >= fee then
(* origination did not proceed; fee has been debited *)
Incremental.add_operation
i
~expect_failure:(function
| Environment.Ecoproto_error (Contract.Balance_too_low _) :: _ ->
return_unit
| _ ->
failwith
"Not enough balance for origination burn: operation should fail.")
op
>>=? fun i ->
(* fee was taken *)
Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee
>>=? fun () ->
(* originated contract has not been created *)
Context.Contract.balance (I i) orig_contract
>>= fun err ->
Assert.error ~loc:__LOC__ err (function
| RPC_context.Not_found _ ->
true
| _ ->
false)
else
(* bootstrap is delegate, fee + origination burn have been debited *)
Incremental.add_operation i op
>>=? fun i ->
Context.Contract.delegate (I i) orig_contract
>>=? fun delegate ->
Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh
>>=? fun () ->
Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance total_fee
let tests_bootstrap_contracts =
[ Test.tztest
"bootstrap contracts delegate to themselves"
`Quick
bootstrap_manager_is_bootstrap_delegate;
Test.tztest
"bootstrap contracts can change their delegate (small fee)"
`Quick
(bootstrap_delegate_cannot_change ~fee:Tez.one_mutez);
Test.tztest
"bootstrap contracts can change their delegate (max fee)"
`Quick
(bootstrap_delegate_cannot_change ~fee:Tez.max_tez);
Test.tztest
"bootstrap contracts cannot remove their delegation (small fee)"
`Quick
(bootstrap_delegate_cannot_be_removed ~fee:Tez.one_mutez);
Test.tztest
"bootstrap contracts cannot remove their delegation (max fee)"
`Quick
(bootstrap_delegate_cannot_be_removed ~fee:Tez.max_tez);
Test.tztest
"contracts not registered as delegate can remove their delegation \
(small fee)"
`Quick
(delegate_can_be_changed_from_unregistered_contract ~fee:Tez.one_mutez);
Test.tztest
"contracts not registered as delegate can remove their delegation (max \
fee)"
`Quick
(delegate_can_be_changed_from_unregistered_contract ~fee:Tez.max_tez);
Test.tztest
"contracts not registered as delegate can remove their delegation \
(small fee)"
`Quick
(delegate_can_be_removed_from_unregistered_contract ~fee:Tez.one_mutez);
Test.tztest
"contracts not registered as delegate can remove their delegation (max \
fee)"
`Quick
(delegate_can_be_removed_from_unregistered_contract ~fee:Tez.max_tez);
Test.tztest
"bootstrap keys are already registered as delegate keys (small fee)"
`Quick
(bootstrap_manager_already_registered_delegate ~fee:Tez.one_mutez);
Test.tztest
"bootstrap keys are already registered as delegate keys (max fee)"
`Quick
(bootstrap_manager_already_registered_delegate ~fee:Tez.max_tez);
Test.tztest
"bootstrap manager can be delegate (init origination, small fee)"
`Quick
(delegate_to_bootstrap_by_origination ~fee:Tez.one_mutez);
(* balance enough for fee but not for fee + origination burn + dummy script storage cost *)
Test.tztest
"bootstrap manager can be delegate (init origination, edge case)"
`Quick
(delegate_to_bootstrap_by_origination
~fee:(Tez.of_mutez_exn 3_999_999_705_000L));
(* fee bigger than bootstrap's initial balance*)
Test.tztest
"bootstrap manager can be delegate (init origination, large fee)"
`Quick
(delegate_to_bootstrap_by_origination ~fee:(Tez.of_int 10_000_000)) ]
(**************************************************************************)
(* delegate registration *)
(**************************************************************************)
(* A delegate is a pkh. Delegates must be registered. Registration is
done via the self-delegation of the implicit contract corresponding
to the pkh. The implicit contract must be credited when the
self-delegation is done. Furthermore, trying to register an already
registered key raises an error.
In this series of tests, we verify that
1- unregistered delegate keys cannot be delegated to,
2- registered keys can be delegated to,
3- registering an already registered key raises an error.
We consider three scenarios for setting a delegate:
- through origination,
- through delegation when the implicit contract has no delegate yet,
- through delegation when the implicit contract already has a delegate.
We also test that emptying the implicit contract linked to a
registered delegate key does not unregister the delegate key.
*)
(*
Valid registration
Unregistered key:
- contract not credited and no self-delegation
- contract credited but no self-delegation
- contract not credited and self-delegation
Not credited:
- no credit operation
- credit operation of 1Î¼ê© and then debit operation of 1μê©
*)
(** A- unregistered delegate keys cannot be used for delegation *)
(* Two main series of tests: without self-delegation, and with a failed attempt at self-delegation
1- no self-delegation
a- no credit
- no token transfer
- credit of 1Î¼ê© and then debit of 1μê©
b- with credit of 1μê©.
For every scenario, we try three different ways of delegating:
- through origination (init origination)
- through delegation when no delegate was assigned (init delegation)
- through delegation when a delegate was assigned (switch delegation).
2- Self-delegation fails if the contract has no credit. We try the
two possibilities of 1a for non-credited contracts.
*)
let expect_unregistered_key pkh = function
| Environment.Ecoproto_error (Roll_storage.Unregistered_delegate pkh0) :: _
when pkh = pkh0 ->
return_unit
| _ ->
failwith "Delegate key is not registered: operation should fail."
(* A1: no self-delegation *)
(* no token transfer, no self-delegation *)
let unregistered_delegate_key_init_origination ~fee () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
(* origination with delegate argument *)
Op.origination
~fee
~delegate:unregistered_pkh
(I i)
bootstrap
~script:Op.dummy_script
>>=? fun (op, orig_contract) ->
Context.get_constants (I i)
>>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
Tez.(cost_per_byte *? Int64.of_int origination_size)
>>?= fun origination_burn ->
Lwt.return (Tez.( +? ) fee origination_burn)
>>=? fun _total_fee ->
(* FIXME unused variable *)
Context.Contract.balance (I i) bootstrap
>>=? fun balance ->
if fee > balance then
Incremental.add_operation i op
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
(* origination did not proceed; fee has been debited *)
Incremental.add_operation
~expect_failure:(expect_unregistered_key unregistered_pkh)
i
op
>>=? fun i ->
Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee
>>=? fun () ->
(* originated contract has not been created *)
Context.Contract.balance (I i) orig_contract
>>= fun err ->
Assert.error ~loc:__LOC__ err (function
| RPC_context.Not_found _ ->
true
| _ ->
false)
let unregistered_delegate_key_init_delegation ~fee () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
let impl_contract = Contract.implicit_contract unregistered_pkh in
let unregistered_delegate_account = Account.new_account () in
let unregistered_delegate_pkh =
Account.(unregistered_delegate_account.pkh)
in
(* initial credit for the delegated contract *)
let credit = Tez.of_int 10 in
Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
>>=? fun credit_contract ->
Incremental.add_operation i credit_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit
>>=? fun _ ->
(* try to delegate *)
Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
>>=? fun delegate_op ->
if fee > credit then
Incremental.add_operation i delegate_op
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
(* fee has been debited; no delegate *)
Incremental.add_operation
i
~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
delegate_op
>>=? fun i ->
Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee
>>=? fun () ->
(* implicit contract has no delegate *)
Context.Contract.delegate (I i) impl_contract
>>= fun err ->
Assert.error ~loc:__LOC__ err (function
| RPC_context.Not_found _ ->
true
| _ ->
false)
let unregistered_delegate_key_switch_delegation ~fee () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let bootstrap_pkh =
Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__
in
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
let impl_contract = Contract.implicit_contract unregistered_pkh in
let unregistered_delegate_account = Account.new_account () in
let unregistered_delegate_pkh =
Account.(unregistered_delegate_account.pkh)
in
(* initial credit for the delegated contract *)
let credit = Tez.of_int 10 in
Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
>>=? fun init_credit ->
Incremental.add_operation i init_credit
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit
>>=? fun _ ->
(* set and check the initial delegate *)
Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh)
>>=? fun delegate_op ->
Incremental.add_operation i delegate_op
>>=? fun i ->
Context.Contract.delegate (I i) bootstrap
>>=? fun delegate_pkh ->
Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh
>>=? fun () ->
(* try to delegate *)
Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
>>=? fun delegate_op ->
if fee > credit then
Incremental.add_operation i delegate_op
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
(* fee has been debited; no delegate *)
Incremental.add_operation
i
~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
delegate_op
>>=? fun i ->
Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee
>>=? fun () ->
(* implicit contract delegate has not changed *)
Context.Contract.delegate (I i) bootstrap
>>=? fun delegate_pkh_after ->
Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate_pkh_after
(* credit of some amount, no self-delegation *)
let unregistered_delegate_key_init_origination_credit ~fee ~amount () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
let impl_contract = Contract.implicit_contract unregistered_pkh in
(* credit + check balance *)
Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
>>=? fun _ ->
(* origination with delegate argument *)
Context.Contract.balance (I i) bootstrap
>>=? fun balance ->
Op.origination
~fee
~delegate:unregistered_pkh
(I i)
bootstrap
~script:Op.dummy_script
>>=? fun (op, orig_contract) ->
if fee > balance then
Incremental.add_operation i op
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
(* origination not done, fee taken *)
Incremental.add_operation
~expect_failure:(expect_unregistered_key unregistered_pkh)
i
op
>>=? fun i ->
Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee
>>=? fun () ->
Context.Contract.balance (I i) orig_contract
>>= fun err ->
Assert.error ~loc:__LOC__ err (function
| RPC_context.Not_found _ ->
true
| _ ->
false)
let unregistered_delegate_key_init_delegation_credit ~fee ~amount () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
let impl_contract = Contract.implicit_contract unregistered_pkh in
let unregistered_delegate_account = Account.new_account () in
let unregistered_delegate_pkh =
Account.(unregistered_delegate_account.pkh)
in
(* credit + check balance *)
Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
>>=? fun _ ->
(* initial credit for the delegated contract *)
let credit = Tez.of_int 10 in
Lwt.return Tez.(credit +? amount)
>>=? fun balance ->
Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
>>=? fun init_credit ->
Incremental.add_operation i init_credit
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract balance
>>=? fun _ ->
(* try to delegate *)
Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
>>=? fun delegate_op ->
if fee > credit then
Incremental.add_operation i delegate_op
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
(* fee has been taken, no delegate for contract *)
Incremental.add_operation
~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
i
delegate_op
>>=? fun i ->
Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee
>>=? fun () ->
Context.Contract.delegate (I i) impl_contract
>>= fun err ->
Assert.error ~loc:__LOC__ err (function
| RPC_context.Not_found _ ->
true
| _ ->
false)
let unregistered_delegate_key_switch_delegation_credit ~fee ~amount () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let bootstrap_pkh =
Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__
in
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
let impl_contract = Contract.implicit_contract unregistered_pkh in
let unregistered_delegate_account = Account.new_account () in
let unregistered_delegate_pkh =
Account.(unregistered_delegate_account.pkh)
in
(* credit + check balance *)
Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
>>=? fun _ ->
(* initial credit for the delegated contract *)
let credit = Tez.of_int 10 in
Lwt.return Tez.(credit +? amount)
>>=? fun balance ->
Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
>>=? fun init_credit ->
Incremental.add_operation i init_credit
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract balance
>>=? fun _ ->
(* set and check the initial delegate *)
Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh)
>>=? fun delegate_op ->
Incremental.add_operation i delegate_op
>>=? fun i ->
Context.Contract.delegate (I i) bootstrap
>>=? fun delegate_pkh ->
Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh
>>=? fun () ->
(* switch delegate through delegation *)
Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
>>=? fun delegate_op ->
if fee > credit then
Incremental.add_operation i delegate_op
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
(* fee has been taken, delegate for contract has not changed *)
Incremental.add_operation
~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
i
delegate_op
>>=? fun i ->
Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee
>>=? fun () ->
Context.Contract.delegate (I i) impl_contract
>>=? fun delegate ->
Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_delegate_pkh
>>=? fun () -> Assert.equal_pkh ~loc:__LOC__ delegate bootstrap_pkh
(* a credit of some amount followed by a debit of the same amount, no self-delegation *)
let unregistered_delegate_key_init_origination_credit_debit ~fee ~amount () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
let impl_contract = Contract.implicit_contract unregistered_pkh in
(* credit + check balance *)
Op.transaction (I i) bootstrap impl_contract amount
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
>>=? fun _ ->
(* debit + check balance *)
Op.transaction (I i) impl_contract bootstrap amount
>>=? fun debit_contract ->
Incremental.add_operation i debit_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
>>=? fun _ ->
(* origination with delegate argument *)
Context.Contract.balance (I i) bootstrap
>>=? fun balance ->
Op.origination
~fee
~delegate:unregistered_pkh
(I i)
bootstrap
~script:Op.dummy_script
>>=? fun (op, orig_contract) ->
if fee > balance then
Incremental.add_operation i op
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
(* fee taken, origination not processed *)
Incremental.add_operation
~expect_failure:(expect_unregistered_key unregistered_pkh)
i
op
>>=? fun i ->
Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee
>>=? fun () ->
Context.Contract.balance (I i) orig_contract
>>= fun err ->
Assert.error ~loc:__LOC__ err (function
| RPC_context.Not_found _ ->
true
| _ ->
false)
let unregistered_delegate_key_init_delegation_credit_debit ~amount ~fee () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
let impl_contract = Contract.implicit_contract unregistered_pkh in
let unregistered_delegate_account = Account.new_account () in
let unregistered_delegate_pkh =
Account.(unregistered_delegate_account.pkh)
in
(* credit + check balance *)
Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
>>=? fun _ ->
(* debit + check balance *)
Op.transaction ~fee:Tez.zero (I i) impl_contract bootstrap amount
>>=? fun debit_contract ->
Incremental.add_operation i debit_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
>>=? fun _ ->
(* initial credit for the delegated contract *)
let credit = Tez.of_int 10 in
Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
>>=? fun credit_contract ->
Incremental.add_operation i credit_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit
>>=? fun _ ->
(* try to delegate *)
Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
>>=? fun delegate_op ->
if fee > credit then
Incremental.add_operation i delegate_op
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
(* fee has been taken, no delegate for contract *)
Incremental.add_operation
~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
i
delegate_op
>>=? fun i ->
Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee
>>=? fun () ->
Context.Contract.delegate (I i) impl_contract
>>= fun err ->
Assert.error ~loc:__LOC__ err (function
| RPC_context.Not_found _ ->
true
| _ ->
false)
let unregistered_delegate_key_switch_delegation_credit_debit ~fee ~amount () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let bootstrap_pkh =
Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__
in
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
let impl_contract = Contract.implicit_contract unregistered_pkh in
let unregistered_delegate_account = Account.new_account () in
let unregistered_delegate_pkh =
Account.(unregistered_delegate_account.pkh)
in
(* credit + check balance *)
Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
>>=? fun _ ->
(* debit + check balance *)
Op.transaction (I i) impl_contract bootstrap amount
>>=? fun debit_contract ->
Incremental.add_operation i debit_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
>>=? fun _ ->
(* delegation - initial credit for the delegated contract *)
let credit = Tez.of_int 10 in
Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
>>=? fun credit_contract ->
Incremental.add_operation i credit_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit
>>=? fun _ ->
(* set and check the initial delegate *)
Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh)
>>=? fun delegate_op ->
Incremental.add_operation i delegate_op
>>=? fun i ->
Context.Contract.delegate (I i) bootstrap
>>=? fun delegate_pkh ->
Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh
>>=? fun () ->
(* switch delegate through delegation *)
Op.delegation (I i) ~fee impl_contract (Some unregistered_delegate_pkh)
>>=? fun delegate_op ->
if fee > credit then
Incremental.add_operation i delegate_op
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
(* fee has been taken, delegate for contract has not changed *)
Incremental.add_operation
~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
i
delegate_op
>>=? fun i ->
Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee
>>=? fun () ->
Context.Contract.delegate (I i) impl_contract
>>=? fun delegate ->
Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_delegate_pkh
(* A2- self-delegation to an empty contract fails *)
let failed_self_delegation_no_transaction () =
Context.init 1
>>=? fun (b, _) ->
Incremental.begin_construction b
>>=? fun i ->
let account = Account.new_account () in
let unregistered_pkh = Account.(account.pkh) in
let impl_contract = Contract.implicit_contract unregistered_pkh in
(* check balance *)
Context.Contract.balance (I i) impl_contract
>>=? fun balance ->
Assert.equal_tez ~loc:__LOC__ Tez.zero balance
>>=? fun _ ->
(* self delegation fails *)
Op.delegation (I i) impl_contract (Some unregistered_pkh)
>>=? fun self_delegation ->
Incremental.add_operation i self_delegation
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Empty_implicit_contract pkh ->
if pkh = unregistered_pkh then true else false
| _ ->
false)
let failed_self_delegation_emptied_implicit_contract amount () =
(* create an implicit contract *)
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let account = Account.new_account () in
let unregistered_pkh = Account.(account.pkh) in
let impl_contract = Contract.implicit_contract unregistered_pkh in
(* credit implicit contract and check balance *)
Op.transaction (I i) bootstrap impl_contract amount
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
>>=? fun _ ->
(* empty implicit contract and check balance *)
Op.transaction (I i) impl_contract bootstrap amount
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
>>=? fun _ ->
(* self delegation fails *)
Op.delegation (I i) impl_contract (Some unregistered_pkh)
>>=? fun self_delegation ->
Incremental.add_operation i self_delegation
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Empty_implicit_contract pkh ->
if pkh = unregistered_pkh then true else false
| _ ->
false)
(** B- valid registration:
- credit implicit contract with some ê© + verification of balance
- self delegation + verification
- empty contract + verification of balance + verification of not being erased / self-delegation
- create delegator implicit contract w first implicit contract as delegate + verification of delegation *)
let valid_delegate_registration_init_delegation_credit amount () =
(* create an implicit contract *)
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let delegate_account = Account.new_account () in
let delegate_pkh = Account.(delegate_account.pkh) in
let impl_contract = Contract.implicit_contract delegate_pkh in
(* credit > 0ê© + check balance *)
Op.transaction (I i) bootstrap impl_contract amount
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
>>=? fun _ ->
(* self delegation + verification *)
Op.delegation (I i) impl_contract (Some delegate_pkh)
>>=? fun self_delegation ->
Incremental.add_operation i self_delegation
>>=? fun i ->
Context.Contract.delegate (I i) impl_contract
>>=? fun delegate ->
Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh
>>=? fun _ ->
(* create an implicit contract with no delegate *)
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
let delegator = Contract.implicit_contract unregistered_pkh in
Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one
>>=? fun credit_contract ->
Incremental.add_operation i credit_contract
>>=? fun i ->
(* check no delegate for delegator contract *)
Context.Contract.delegate (I i) delegator
>>= fun err ->
Assert.error ~loc:__LOC__ err (function
| RPC_context.Not_found _ ->
true
| _ ->
false)
>>=? fun _ ->
(* delegation to the newly registered key *)
Op.delegation (I i) delegator (Some delegate_account.pkh)
>>=? fun delegation ->
Incremental.add_operation i delegation
>>=? fun i ->
(* check delegation *)
Context.Contract.delegate (I i) delegator
>>=? fun delegator_delegate ->
Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh
let valid_delegate_registration_switch_delegation_credit amount () =
(* create an implicit contract *)
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let delegate_account = Account.new_account () in
let delegate_pkh = Account.(delegate_account.pkh) in
let impl_contract = Contract.implicit_contract delegate_pkh in
(* credit > 0ê© + check balance *)
Op.transaction (I i) bootstrap impl_contract amount
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
>>=? fun _ ->
(* self delegation + verification *)
Op.delegation (I i) impl_contract (Some delegate_pkh)
>>=? fun self_delegation ->
Incremental.add_operation i self_delegation
>>=? fun i ->
Context.Contract.delegate (I i) impl_contract
>>=? fun delegate ->
Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh
>>=? fun _ ->
(* create an implicit contract with bootstrap's account as delegate *)
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
let delegator = Contract.implicit_contract unregistered_pkh in
Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one
>>=? fun credit_contract ->
Incremental.add_operation i credit_contract
>>=? fun i ->
Context.Contract.manager (I i) bootstrap
>>=? fun bootstrap_manager ->
Op.delegation (I i) delegator (Some bootstrap_manager.pkh)
>>=? fun delegation ->
Incremental.add_operation i delegation
>>=? fun i ->
(* test delegate of new contract is bootstrap *)
Context.Contract.delegate (I i) delegator
>>=? fun delegator_delegate ->
Assert.equal_pkh ~loc:__LOC__ delegator_delegate bootstrap_manager.pkh
>>=? fun _ ->
(* delegation with newly registered key *)
Op.delegation (I i) delegator (Some delegate_account.pkh)
>>=? fun delegation ->
Incremental.add_operation i delegation
>>=? fun i ->
Context.Contract.delegate (I i) delegator
>>=? fun delegator_delegate ->
Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh
let valid_delegate_registration_init_delegation_credit_debit amount () =
(* create an implicit contract *)
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let delegate_account = Account.new_account () in
let delegate_pkh = Account.(delegate_account.pkh) in
let impl_contract = Contract.implicit_contract delegate_pkh in
(* credit > 0ê©+ check balance *)
Op.transaction (I i) bootstrap impl_contract amount
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
>>=? fun _ ->
(* self delegation + verification *)
Op.delegation (I i) impl_contract (Some delegate_pkh)
>>=? fun self_delegation ->
Incremental.add_operation i self_delegation
>>=? fun i ->
Context.Contract.delegate (I i) impl_contract
>>=? fun delegate ->
Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate
>>=? fun _ ->
(* empty implicit contracts are usually deleted but they are kept if
they were registered as delegates. we empty the contract in
order to verify this. *)
Op.transaction (I i) impl_contract bootstrap amount
>>=? fun empty_contract ->
Incremental.add_operation i empty_contract
>>=? fun i ->
(* impl_contract is empty *)
Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
>>=? fun _ ->
(* verify self-delegation after contract is emptied *)
Context.Contract.delegate (I i) impl_contract
>>=? fun delegate ->
Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate
>>=? fun _ ->
(* create an implicit contract with no delegate *)
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
let delegator = Contract.implicit_contract unregistered_pkh in
Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one
>>=? fun credit_contract ->
Incremental.add_operation i credit_contract
>>=? fun i ->
(* check no delegate for delegator contract *)
Context.Contract.delegate (I i) delegator
>>= fun err ->
Assert.error ~loc:__LOC__ err (function
| RPC_context.Not_found _ ->
true
| _ ->
false)
>>=? fun _ ->
(* delegation to the newly registered key *)
Op.delegation (I i) delegator (Some delegate_account.pkh)
>>=? fun delegation ->
Incremental.add_operation i delegation
>>=? fun i ->
(* check delegation *)
Context.Contract.delegate (I i) delegator
>>=? fun delegator_delegate ->
Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh
let valid_delegate_registration_switch_delegation_credit_debit amount () =
(* create an implicit contract *)
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let delegate_account = Account.new_account () in
let delegate_pkh = Account.(delegate_account.pkh) in
let impl_contract = Contract.implicit_contract delegate_pkh in
(* credit > 0ê© + check balance *)
Op.transaction (I i) bootstrap impl_contract amount
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
>>=? fun _ ->
(* self delegation + verification *)
Op.delegation (I i) impl_contract (Some delegate_pkh)
>>=? fun self_delegation ->
Incremental.add_operation i self_delegation
>>=? fun i ->
Context.Contract.delegate (I i) impl_contract
>>=? fun delegate ->
Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate
>>=? fun _ ->
(* empty implicit contracts are usually deleted but they are kept if
they were registered as delegates. we empty the contract in
order to verify this. *)
Op.transaction (I i) impl_contract bootstrap amount
>>=? fun empty_contract ->
Incremental.add_operation i empty_contract
>>=? fun i ->
(* impl_contract is empty *)
Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
>>=? fun _ ->
(* create an implicit contract with bootstrap's account as delegate *)
let unregistered_account = Account.new_account () in
let unregistered_pkh = Account.(unregistered_account.pkh) in
let delegator = Contract.implicit_contract unregistered_pkh in
Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one
>>=? fun credit_contract ->
Incremental.add_operation i credit_contract
>>=? fun i ->
Context.Contract.manager (I i) bootstrap
>>=? fun bootstrap_manager ->
Op.delegation (I i) delegator (Some bootstrap_manager.pkh)
>>=? fun delegation ->
Incremental.add_operation i delegation
>>=? fun i ->
(* test delegate of new contract is bootstrap *)
Context.Contract.delegate (I i) delegator
>>=? fun delegator_delegate ->
Assert.equal_pkh ~loc:__LOC__ delegator_delegate bootstrap_manager.pkh
>>=? fun _ ->
(* delegation with newly registered key *)
Op.delegation (I i) delegator (Some delegate_account.pkh)
>>=? fun delegation ->
Incremental.add_operation i delegation
>>=? fun i ->
Context.Contract.delegate (I i) delegator
>>=? fun delegator_delegate ->
Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh
(* with implicit contract with some credit *)
(** C- a second self-delegation should raise an `Active_delegate` error *)
let double_registration () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let account = Account.new_account () in
let pkh = Account.(account.pkh) in
let impl_contract = Contract.implicit_contract pkh in
(* credit 1μê©+ check balance *)
Op.transaction (I i) bootstrap impl_contract Tez.one_mutez
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez
>>=? fun _ ->
(* self-delegation *)
Op.delegation (I i) impl_contract (Some pkh)
>>=? fun self_delegation ->
Incremental.add_operation i self_delegation
>>=? fun i ->
(* second self-delegation *)
Op.delegation (I i) impl_contract (Some pkh)
>>=? fun second_registration ->
Incremental.add_operation i second_registration
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Delegate_storage.Active_delegate ->
true
| _ ->
false)
(* with implicit contract emptied after first self-delegation *)
let double_registration_when_empty () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let account = Account.new_account () in
let pkh = Account.(account.pkh) in
let impl_contract = Contract.implicit_contract pkh in
(* credit 1μê©+ check balance *)
Op.transaction (I i) bootstrap impl_contract Tez.one_mutez
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez
>>=? fun _ ->
(* self delegation *)
Op.delegation (I i) impl_contract (Some pkh)
>>=? fun self_delegation ->
Incremental.add_operation i self_delegation
>>=? fun i ->
(* empty the delegate account *)
Op.transaction (I i) impl_contract bootstrap Tez.one_mutez
>>=? fun empty_contract ->
Incremental.add_operation i empty_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
>>=? fun _ ->
(* second self-delegation *)
Op.delegation (I i) impl_contract (Some pkh)
>>=? fun second_registration ->
Incremental.add_operation i second_registration
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Delegate_storage.Active_delegate ->
true
| _ ->
false)
(* with implicit contract emptied then recredited after first self-delegation *)
let double_registration_when_recredited () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let account = Account.new_account () in
let pkh = Account.(account.pkh) in
let impl_contract = Contract.implicit_contract pkh in
(* credit 1μê©+ check balance *)
Op.transaction (I i) bootstrap impl_contract Tez.one_mutez
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez
>>=? fun _ ->
(* self delegation *)
Op.delegation (I i) impl_contract (Some pkh)
>>=? fun self_delegation ->
Incremental.add_operation i self_delegation
>>=? fun i ->
(* empty the delegate account *)
Op.transaction (I i) impl_contract bootstrap Tez.one_mutez
>>=? fun empty_contract ->
Incremental.add_operation i empty_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
>>=? fun _ ->
(* credit 1μê©+ check balance *)
Op.transaction (I i) bootstrap impl_contract Tez.one_mutez
>>=? fun create_contract ->
Incremental.add_operation i create_contract
>>=? fun i ->
Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez
>>=? fun _ ->
(* second self-delegation *)
Op.delegation (I i) impl_contract (Some pkh)
>>=? fun second_registration ->
Incremental.add_operation i second_registration
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Delegate_storage.Active_delegate ->
true
| _ ->
false)
(* self-delegation on unrevealed contract *)
let unregistered_and_unrevealed_self_delegate_key_init_delegation ~fee () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let {Account.pkh; _} = Account.new_account () in
let {Account.pkh = delegate_pkh; _} = Account.new_account () in
let contract = Alpha_context.Contract.implicit_contract pkh in
Op.transaction (I i) bootstrap contract (Tez.of_int 10)
>>=? fun op ->
Incremental.add_operation i op
>>=? fun i ->
Op.delegation ~fee (I i) contract (Some delegate_pkh)
>>=? fun op ->
Context.Contract.balance (I i) contract
>>=? fun balance ->
if fee > balance then
Incremental.add_operation i op
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
(* origination did not proceed; fee has been debited *)
Incremental.add_operation
~expect_failure:(expect_unregistered_key delegate_pkh)
i
op
>>=? fun i ->
Assert.balance_was_debited ~loc:__LOC__ (I i) contract balance fee
(* self-delegation on revelead but not registered contract *)
let unregistered_and_revealed_self_delegate_key_init_delegation ~fee () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let {Account.pkh; pk; _} = Account.new_account () in
let {Account.pkh = delegate_pkh; _} = Account.new_account () in
let contract = Alpha_context.Contract.implicit_contract pkh in
Op.transaction (I i) bootstrap contract (Tez.of_int 10)
>>=? fun op ->
Incremental.add_operation i op
>>=? fun i ->
Op.revelation (I i) pk
>>=? fun op ->
Incremental.add_operation i op
>>=? fun i ->
Op.delegation ~fee (I i) contract (Some delegate_pkh)
>>=? fun op ->
Context.Contract.balance (I i) contract
>>=? fun balance ->
if fee > balance then
Incremental.add_operation i op
>>= fun err ->
Assert.proto_error ~loc:__LOC__ err (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
else
(* origination did not proceed; fee has been debited *)
Incremental.add_operation
~expect_failure:(expect_unregistered_key delegate_pkh)
i
op
>>=? fun i ->
Assert.balance_was_debited ~loc:__LOC__ (I i) contract balance fee
(* self-delegation on revealed and registered contract *)
let registered_self_delegate_key_init_delegation () =
Context.init 1
>>=? fun (b, bootstrap_contracts) ->
Incremental.begin_construction b
>>=? fun i ->
let bootstrap = List.hd bootstrap_contracts in
let {Account.pkh; _} = Account.new_account () in
let {Account.pkh = delegate_pkh; pk = delegate_pk; _} =
Account.new_account ()
in
let contract = Alpha_context.Contract.implicit_contract pkh in
let delegate_contract =
Alpha_context.Contract.implicit_contract delegate_pkh
in
Op.transaction (I i) bootstrap contract (Tez.of_int 10)
>>=? fun op ->
Incremental.add_operation i op
>>=? fun i ->
Op.transaction (I i) bootstrap delegate_contract (Tez.of_int 1)
>>=? fun op ->
Incremental.add_operation i op
>>=? fun i ->
Op.revelation (I i) delegate_pk
>>=? fun op ->
Incremental.add_operation i op
>>=? fun i ->
Op.delegation (I i) delegate_contract (Some delegate_pkh)
>>=? fun op ->
Incremental.add_operation i op
>>=? fun i ->
Op.delegation (I i) contract (Some delegate_pkh)
>>=? fun op ->
Incremental.add_operation i op
>>=? fun i ->
Context.Contract.delegate (I i) contract
>>=? fun delegate ->
Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh
>>=? fun () -> return_unit
let tests_delegate_registration =
[ (*** unregistered delegate key: no self-delegation ***)
(* no token transfer, no self-delegation *)
Test.tztest
"unregistered delegate key (origination, small fee)"
`Quick
(unregistered_delegate_key_init_origination ~fee:Tez.one_mutez);
Test.tztest
"unregistered delegate key (origination, edge case fee)"
`Quick
(unregistered_delegate_key_init_origination ~fee:(Tez.of_int 3_999_488));
Test.tztest
"unregistered delegate key (origination, large fee)"
`Quick
(unregistered_delegate_key_init_origination ~fee:(Tez.of_int 10_000_000));
Test.tztest
"unregistered delegate key (init with delegation, small fee)"
`Quick
(unregistered_delegate_key_init_delegation ~fee:Tez.one_mutez);
Test.tztest
"unregistered delegate key (init with delegation, max fee)"
`Quick
(unregistered_delegate_key_init_delegation ~fee:Tez.max_tez);
Test.tztest
"unregistered delegate key (switch with delegation, small fee)"
`Quick
(unregistered_delegate_key_switch_delegation ~fee:Tez.one_mutez);
Test.tztest
"unregistered delegate key (switch with delegation, max fee)"
`Quick
(unregistered_delegate_key_switch_delegation ~fee:Tez.max_tez);
(* credit/debit 1μê©, no self-delegation *)
Test.tztest
"unregistered delegate key - credit/debit 1Î¼ê© (origination, small fee)"
`Quick
(unregistered_delegate_key_init_origination_credit_debit
~fee:Tez.one_mutez
~amount:Tez.one_mutez);
Test.tztest
"unregistered delegate key - credit/debit 1Î¼ê© (origination, large fee)"
`Quick
(unregistered_delegate_key_init_origination_credit_debit
~fee:Tez.max_tez
~amount:Tez.one_mutez);
Test.tztest
"unregistered delegate key - credit/debit 1Î¼ê© (init with delegation, \
small fee)"
`Quick
(unregistered_delegate_key_init_delegation_credit_debit
~amount:Tez.one_mutez
~fee:Tez.one_mutez);
Test.tztest
"unregistered delegate key - credit/debit 1Î¼ê© (init with delegation, \
large fee)"
`Quick
(unregistered_delegate_key_init_delegation_credit_debit
~amount:Tez.one_mutez
~fee:Tez.max_tez);
Test.tztest
"unregistered delegate key - credit/debit 1Î¼ê© (switch with \
delegation, small fee)"
`Quick
(unregistered_delegate_key_switch_delegation_credit_debit
~amount:Tez.one_mutez
~fee:Tez.one_mutez);
Test.tztest
"unregistered delegate key - credit/debit 1Î¼ê© (switch with \
delegation, large fee)"
`Quick
(unregistered_delegate_key_switch_delegation_credit_debit
~amount:Tez.one_mutez
~fee:Tez.max_tez);
(* credit 1μê©, no self-delegation *)
Test.tztest
"unregistered delegate key - credit 1Î¼ê© (origination, small fee)"
`Quick
(unregistered_delegate_key_init_origination_credit
~fee:Tez.one_mutez
~amount:Tez.one_mutez);
Test.tztest
"unregistered delegate key - credit 1Î¼ê© (origination, edge case fee)"
`Quick
(unregistered_delegate_key_init_origination_credit
~fee:(Tez.of_int 3_999_488)
~amount:Tez.one_mutez);
Test.tztest
"unregistered delegate key - credit 1Î¼ê© (origination, large fee)"
`Quick
(unregistered_delegate_key_init_origination_credit
~fee:(Tez.of_int 10_000_000)
~amount:Tez.one_mutez);
Test.tztest
"unregistered delegate key - credit 1Î¼ê© (init with delegation, small \
fee)"
`Quick
(unregistered_delegate_key_init_delegation_credit
~amount:Tez.one_mutez
~fee:Tez.one_mutez);
Test.tztest
"unregistered delegate key - credit 1Î¼ê© (init with delegation, large \
fee)"
`Quick
(unregistered_delegate_key_init_delegation_credit
~amount:Tez.one_mutez
~fee:Tez.max_tez);
Test.tztest
"unregistered delegate key - credit 1Î¼ê© (switch with delegation, \
small fee)"
`Quick
(unregistered_delegate_key_switch_delegation_credit
~amount:Tez.one_mutez
~fee:Tez.one_mutez);
Test.tztest
"unregistered delegate key - credit 1Î¼ê© (switch with delegation, \
large fee)"
`Quick
(unregistered_delegate_key_switch_delegation_credit
~amount:Tez.one_mutez
~fee:Tez.max_tez);
(* self delegation on unrevealed and unregistered contract *)
Test.tztest
"unregistered and unrevealed self-delegation (small fee)"
`Quick
(unregistered_and_unrevealed_self_delegate_key_init_delegation
~fee:Tez.one_mutez);
Test.tztest
"unregistered and unrevealed self-delegation (large fee)"
`Quick
(unregistered_and_unrevealed_self_delegate_key_init_delegation
~fee:Tez.max_tez);
(* self delegation on unregistered contract *)
Test.tztest
"unregistered and revealed self-delegation (small fee)"
`Quick
(unregistered_and_revealed_self_delegate_key_init_delegation
~fee:Tez.one_mutez);
Test.tztest
"unregistered and revealed self-delegation large fee)"
`Quick
(unregistered_and_revealed_self_delegate_key_init_delegation
~fee:Tez.max_tez);
(* self delegation on registered contract *)
Test.tztest
"registered and revelead self-delegation"
`Quick
registered_self_delegate_key_init_delegation;
(*** unregistered delegate key: failed self-delegation ***)
(* no token transfer, self-delegation *)
Test.tztest
"failed self-delegation: no transaction"
`Quick
failed_self_delegation_no_transaction;
(* credit 1μtz, debit 1μtz, self-delegation *)
Test.tztest
"failed self-delegation: credit & debit 1μê©"
`Quick
(failed_self_delegation_emptied_implicit_contract Tez.one_mutez);
(*** valid registration ***)
(* valid registration: credit 1 μê©, self delegation *)
Test.tztest
"valid delegate registration: credit 1μê©, self delegation (init with \
delegation)"
`Quick
(valid_delegate_registration_init_delegation_credit Tez.one_mutez);
Test.tztest
"valid delegate registration: credit 1μê©, self delegation (switch \
with delegation)"
`Quick
(valid_delegate_registration_switch_delegation_credit Tez.one_mutez);
(* valid registration: credit 1 μê©, self delegation, debit 1Î¼ê© *)
Test.tztest
"valid delegate registration: credit 1μê©, self delegation, debit \
1Î¼ê© (init with delegation)"
`Quick
(valid_delegate_registration_init_delegation_credit_debit Tez.one_mutez);
Test.tztest
"valid delegate registration: credit 1μê©, self delegation, debit \
1Î¼ê© (switch with delegation)"
`Quick
(valid_delegate_registration_switch_delegation_credit_debit Tez.one_mutez);
(*** double registration ***)
Test.tztest "double registration" `Quick double_registration;
Test.tztest
"double registration when delegate account is emptied"
`Quick
double_registration_when_empty;
Test.tztest
"double registration when delegate account is emptied and then recredited"
`Quick
double_registration_when_recredited ]
(******************************************************************************)
(* Main *)
(******************************************************************************)
let tests = tests_bootstrap_contracts @ tests_delegate_registration
src/proto_alpha/lib_protocol/test/delegation.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Definition expect_error {A B : Type} (err : A) (function_parameter : list B)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
match function_parameter with
| cons err0 _ => return_unit
| _ => failwith "Unexpected successful result" % string
end.
Definition expect_alpha_error {A : Type}
(err : Tezos_protocol_alpha.Protocol.Environment.Error_monad.error)
: (list A) ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
expect_error (Tezos_base__TzPervasives.Error_monad.Ecoproto_error err).
Definition expect_no_change_registered_delegate_pkh {A : Type}
(pkh : A)
(function_parameter : list Tezos_base__TzPervasives.Error_monad.error)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
match function_parameter with
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.No_deletion
pkh0)) _ => return_unit
| _ =>
failwith "Delegate can not be deleted and operation should fail." % string
end.
Definition bootstrap_manager_is_bootstrap_delegate {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
let bootstrap0 := List.hd bootstrap_contracts in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap0)
(fun delegate0 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap0)
(fun manager0 =>
op_startypeminuserrorstar __LOC__ delegate0 (pkh manager0)))).
Definition bootstrap_delegate_cannot_change {A B : Type}
(fee : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
let bootstrap0 := op_startypeminuserrorstar bootstrap_contracts 0 in
let bootstrap1 := op_startypeminuserrorstar bootstrap_contracts 1 in
op_gtgteqquestion (op_startypeminuserrorstar bootstrap0)
(fun pkh1 =>
op_gtgteqquestion
(op_startypeminuserrorstar b op_startypeminuserrorstar)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap1)
(fun manager1 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
bootstrap0)
(fun balance0 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
bootstrap0)
(fun delegate0 =>
op_gtgteqquestion
(op_startypeminuserrorstar fee
op_startypeminuserrorstar bootstrap0
(Some (pkh manager1)))
(fun set_delegate =>
if op_startypeminuserrorstar fee balance0 then
op_gtgteq
(op_startypeminuserrorstar i set_delegate)
(fun err =>
op_startypeminuserrorstar __LOC__ err
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar
(expect_no_change_registered_delegate_pkh
delegate0) i set_delegate)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar i)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar bootstrap0)
(fun delegate0_after =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
delegate0_after delegate0)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
bootstrap0 balance0 fee))))))))))).
Definition bootstrap_delegate_cannot_be_removed {A B : Type}
(fee : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
let bootstrap := List.hd bootstrap_contracts in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap)
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap)
(fun delegate =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
bootstrap)
(fun manager =>
op_gtgteqquestion
(op_startypeminuserrorstar fee op_startypeminuserrorstar
bootstrap None)
(fun set_delegate =>
if op_startypeminuserrorstar fee balance then
op_gtgteq (op_startypeminuserrorstar i set_delegate)
(fun err =>
op_startypeminuserrorstar __LOC__ err
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar
(expect_no_change_registered_delegate_pkh
(pkh manager)) i set_delegate)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar bootstrap)
(fun delegate_after =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
delegate delegate_after)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar bootstrap
balance fee))))))))).
Definition delegate_can_be_changed_from_unregistered_contract {A B : Type}
(fee : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
let bootstrap0 := List.hd bootstrap_contracts in
let bootstrap1 := op_startypeminuserrorstar bootstrap_contracts 1 in
let unregistered_account := op_startypeminuserrorstar tt in
let unregistered_pkh := op_startypeminuserrorstar in
let unregistered := Contract.implicit_contract unregistered_pkh in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap0)
(fun manager0 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap1)
(fun manager1 =>
let credit := op_startypeminuserrorstar 10 in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero
op_startypeminuserrorstar bootstrap0 unregistered credit)
(fun credit_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
bootstrap0)
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar i credit_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero
op_startypeminuserrorstar unregistered
(Some (pkh manager0)))
(fun set_delegate =>
op_gtgteqquestion
(op_startypeminuserrorstar i set_delegate)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar unregistered)
(fun delegate =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
delegate (pkh manager0))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar fee
op_startypeminuserrorstar
unregistered
(Some (pkh manager1)))
(fun change_delegate =>
if
op_startypeminuserrorstar
fee balance then
op_gtgteq
(op_startypeminuserrorstar
i change_delegate)
(fun err =>
op_startypeminuserrorstar
__LOC__ err
(fun
function_parameter
=>
match
function_parameter
with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar
i change_delegate)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
unregistered)
(fun delegate_after =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
delegate_after
(pkh manager1))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
unregistered
credit fee))))))))))))))).
Definition delegate_can_be_removed_from_unregistered_contract {A B : Type}
(fee : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
let bootstrap := List.hd bootstrap_contracts in
let unregistered_account := op_startypeminuserrorstar tt in
let unregistered_pkh := op_startypeminuserrorstar in
let unregistered := Contract.implicit_contract unregistered_pkh in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap)
(fun manager =>
let credit := op_startypeminuserrorstar 10 in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
bootstrap unregistered credit)
(fun credit_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
bootstrap)
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar i credit_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero
op_startypeminuserrorstar unregistered
(Some (pkh manager)))
(fun set_delegate =>
op_gtgteqquestion
(op_startypeminuserrorstar i set_delegate)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar unregistered)
(fun delegate =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
delegate (pkh manager))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar fee
op_startypeminuserrorstar
unregistered None)
(fun delete_delegate =>
if
op_startypeminuserrorstar fee
balance then
op_gtgteq
(op_startypeminuserrorstar i
delete_delegate)
(fun err =>
op_startypeminuserrorstar
__LOC__ err
(fun function_parameter =>
match function_parameter
with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar i
delete_delegate)
(fun i =>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
unregistered)
(fun function_parameter
=>
match
function_parameter
with
| None => return_unit
| Some _ =>
failwith
"Expected delegate to be removed"
% string
end))
(fun function_parameter =>
let 'tt :=
function_parameter in
op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
unregistered credit
fee))))))))))))).
Definition bootstrap_manager_already_registered_delegate {A B : Type}
(fee : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap)
(fun manager =>
let pkh := pkh manager in
let impl_contract := Contract.implicit_contract pkh in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
impl_contract)
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar fee op_startypeminuserrorstar
impl_contract (Some pkh))
(fun sec_reg =>
if op_startypeminuserrorstar fee balance then
op_gtgteq (op_startypeminuserrorstar i sec_reg)
(fun err =>
op_startypeminuserrorstar __LOC__ err
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar
(fun function_parameter =>
match function_parameter with
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
Tezos_protocol_environment_alpha__Environment.Error_monad.Active_delegate)
_ => return_unit
| _ =>
failwith
"Delegate is already active and operation should fail."
% string
end) i sec_reg)
(fun i =>
op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar impl_contract balance
fee)))))).
Definition delegate_to_bootstrap_by_origination {A : Type}
(fee : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap)
(fun manager =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap)
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar fee Tez.zero (pkh manager)
op_startypeminuserrorstar bootstrap
op_startypeminuserrorstar)
(fun function_parameter =>
let '(op, orig_contract) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_starquestion op_startypeminuserrorstar
(Int64.of_int op_startypeminuserrorstar))
(fun origination_burn =>
op_gtgteqquestion
(Lwt._return
(op_gtgtquestion
(Tez.op_plusquestion fee origination_burn)
(Tez.op_plusquestion
op_startypeminuserrorstar)))
(fun total_fee =>
if op_startypeminuserrorstar fee balance then
op_gtgteq (op_startypeminuserrorstar i op)
(fun err =>
op_startypeminuserrorstar __LOC__ err
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
if
op_andand
(op_startypeminuserrorstar total_fee
balance)
(op_startypeminuserrorstar balance fee)
then
op_gtgteqquestion
(op_startypeminuserrorstar i
(fun function_parameter =>
match function_parameter with
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _)) _ => return_unit
| _ =>
failwith
"Not enough balance for origination burn: operation should fail."
% string
end) op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar
bootstrap balance fee)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_startypeminuserrorstar
op_startypeminuserrorstar
orig_contract)
(fun err =>
op_startypeminuserrorstar
__LOC__ err
(fun function_parameter =>
match function_parameter
with
| _ => true
| _ => false
end))))
else
op_gtgteqquestion
(op_startypeminuserrorstar i op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
orig_contract)
(fun delegate =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__ delegate (pkh manager))
(fun function_parameter =>
let 'tt := function_parameter
in
op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
bootstrap balance total_fee))))))))))).
Definition tests_bootstrap_contracts {A : Type} : list A :=
cons
(op_startypeminuserrorstar
"bootstrap contracts delegate to themselves" % string
(* ❌ Variants not supported *)
variant bootstrap_manager_is_bootstrap_delegate)
(cons
(op_startypeminuserrorstar
"bootstrap contracts can change their delegate (small fee)" % string
(* ❌ Variants not supported *)
variant (bootstrap_delegate_cannot_change Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"bootstrap contracts can change their delegate (max fee)" % string
(* ❌ Variants not supported *)
variant (bootstrap_delegate_cannot_change op_startypeminuserrorstar))
(cons
(op_startypeminuserrorstar
"bootstrap contracts cannot remove their delegation (small fee)" %
string
(* ❌ Variants not supported *)
variant (bootstrap_delegate_cannot_be_removed Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"bootstrap contracts cannot remove their delegation (max fee)" %
string
(* ❌ Variants not supported *)
variant
(bootstrap_delegate_cannot_be_removed op_startypeminuserrorstar))
(cons
(op_startypeminuserrorstar
"contracts not registered as delegate can remove their delegation (small fee)"
% string
(* ❌ Variants not supported *)
variant
(delegate_can_be_changed_from_unregistered_contract
Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"contracts not registered as delegate can remove their delegation (max fee)"
% string
(* ❌ Variants not supported *)
variant
(delegate_can_be_changed_from_unregistered_contract
op_startypeminuserrorstar))
(cons
(op_startypeminuserrorstar
"contracts not registered as delegate can remove their delegation (small fee)"
% string
(* ❌ Variants not supported *)
variant
(delegate_can_be_removed_from_unregistered_contract
Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"contracts not registered as delegate can remove their delegation (max fee)"
% string
(* ❌ Variants not supported *)
variant
(delegate_can_be_removed_from_unregistered_contract
op_startypeminuserrorstar))
(cons
(op_startypeminuserrorstar
"bootstrap keys are already registered as delegate keys (small fee)"
% string
(* ❌ Variants not supported *)
variant
(bootstrap_manager_already_registered_delegate
Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"bootstrap keys are already registered as delegate keys (max fee)"
% string
(* ❌ Variants not supported *)
variant
(bootstrap_manager_already_registered_delegate
op_startypeminuserrorstar))
(cons
(op_startypeminuserrorstar
"bootstrap manager can be delegate (init origination, small fee)"
% string
(* ❌ Variants not supported *)
variant
(delegate_to_bootstrap_by_origination Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"bootstrap manager can be delegate (init origination, edge case)"
% string
(* ❌ Variants not supported *)
variant
(delegate_to_bootstrap_by_origination
(op_startypeminuserrorstar
(* ❌ Constant of type int64 is converted to int *)
3999999705000)))
(cons
(op_startypeminuserrorstar
"bootstrap manager can be delegate (init origination, large fee)"
% string
(* ❌ Variants not supported *)
variant
(delegate_to_bootstrap_by_origination
(op_startypeminuserrorstar 10000000))) []))))))))))))).
Definition expect_unregistered_key {A : Type}
(pkh : A)
(function_parameter : list Tezos_base__TzPervasives.Error_monad.error)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
match function_parameter with
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Unregistered_delegate
pkh0)) _ => return_unit
| _ =>
failwith "Delegate key is not registered: operation should fail." % string
end.
Definition unregistered_delegate_key_init_origination {A : Type}
(fee : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let unregistered_account := op_startypeminuserrorstar tt in
let unregistered_pkh := op_startypeminuserrorstar in
op_gtgteqquestion
(op_startypeminuserrorstar fee unregistered_pkh
op_startypeminuserrorstar bootstrap op_startypeminuserrorstar)
(fun function_parameter =>
let '(op, orig_contract) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_starquestion op_startypeminuserrorstar
(Int64.of_int op_startypeminuserrorstar))
(fun origination_burn =>
op_gtgteqquestion
(Lwt._return (Tez.op_plusquestion fee origination_burn))
(fun _total_fee =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
bootstrap)
(fun balance =>
if op_startypeminuserrorstar fee balance then
op_gtgteq (op_startypeminuserrorstar i op)
(fun err =>
op_startypeminuserrorstar __LOC__ err
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar
(expect_unregistered_key unregistered_pkh) i
op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar bootstrap
balance fee)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_startypeminuserrorstar
op_startypeminuserrorstar
orig_contract)
(fun err =>
op_startypeminuserrorstar __LOC__
err
(fun function_parameter =>
match function_parameter with
| _ => true
| _ => false
end))))))))))).
Definition unregistered_delegate_key_init_delegation {A B : Type}
(fee : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let unregistered_account := op_startypeminuserrorstar tt in
let unregistered_pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract unregistered_pkh in
let unregistered_delegate_account := op_startypeminuserrorstar tt in
let unregistered_delegate_pkh := op_startypeminuserrorstar in
let credit := op_startypeminuserrorstar 10 in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
bootstrap impl_contract credit)
(fun credit_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i credit_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract credit)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar fee op_startypeminuserrorstar
impl_contract (Some unregistered_delegate_pkh))
(fun delegate_op =>
if op_startypeminuserrorstar fee credit then
op_gtgteq (op_startypeminuserrorstar i delegate_op)
(fun err =>
op_startypeminuserrorstar __LOC__ err
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar i
(expect_unregistered_key
unregistered_delegate_pkh) delegate_op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar impl_contract
credit fee)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_startypeminuserrorstar
op_startypeminuserrorstar impl_contract)
(fun err =>
op_startypeminuserrorstar __LOC__ err
(fun function_parameter =>
match function_parameter with
| _ => true
| _ => false
end)))))))))).
Definition unregistered_delegate_key_switch_delegation {A B : Type}
(fee : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let bootstrap_pkh :=
op_pipegt (Contract.is_implicit bootstrap)
(op_startypeminuserrorstar __POS__) in
let unregistered_account := op_startypeminuserrorstar tt in
let unregistered_pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract unregistered_pkh in
let unregistered_delegate_account := op_startypeminuserrorstar tt in
let unregistered_delegate_pkh := op_startypeminuserrorstar in
let credit := op_startypeminuserrorstar 10 in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
bootstrap impl_contract credit)
(fun init_credit =>
op_gtgteqquestion (op_startypeminuserrorstar i init_credit)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract credit)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero
op_startypeminuserrorstar impl_contract
(Some bootstrap_pkh))
(fun delegate_op =>
op_gtgteqquestion
(op_startypeminuserrorstar i delegate_op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar bootstrap)
(fun delegate_pkh =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
bootstrap_pkh delegate_pkh)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar fee
op_startypeminuserrorstar
impl_contract
(Some unregistered_delegate_pkh))
(fun delegate_op =>
if
op_startypeminuserrorstar fee credit
then
op_gtgteq
(op_startypeminuserrorstar i
delegate_op)
(fun err =>
op_startypeminuserrorstar
__LOC__ err
(fun function_parameter =>
match function_parameter
with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar i
(expect_unregistered_key
unregistered_delegate_pkh)
delegate_op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
impl_contract credit fee)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
bootstrap)
(fun delegate_pkh_after =>
op_startypeminuserrorstar
__LOC__ delegate_pkh
delegate_pkh_after))))))))))))).
Definition unregistered_delegate_key_init_origination_credit {A B C : Type}
(fee : A) (amount : B) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let unregistered_account := op_startypeminuserrorstar tt in
let unregistered_pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract unregistered_pkh in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
bootstrap impl_contract amount)
(fun create_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract amount)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
bootstrap)
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar fee unregistered_pkh
op_startypeminuserrorstar bootstrap
op_startypeminuserrorstar)
(fun function_parameter =>
let '(op, orig_contract) := function_parameter in
if op_startypeminuserrorstar fee balance then
op_gtgteq (op_startypeminuserrorstar i op)
(fun err =>
op_startypeminuserrorstar __LOC__ err
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar
(expect_unregistered_key unregistered_pkh) i
op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar bootstrap
balance fee)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq
(op_startypeminuserrorstar
op_startypeminuserrorstar
orig_contract)
(fun err =>
op_startypeminuserrorstar __LOC__
err
(fun function_parameter =>
match function_parameter with
| _ => true
| _ => false
end))))))))))).
Definition unregistered_delegate_key_init_delegation_credit {A B : Type}
(fee : A) (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let unregistered_account := op_startypeminuserrorstar tt in
let unregistered_pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract unregistered_pkh in
let unregistered_delegate_account := op_startypeminuserrorstar tt in
let unregistered_delegate_pkh := op_startypeminuserrorstar in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
bootstrap impl_contract amount)
(fun create_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract amount)
(fun function_parameter =>
let '_ := function_parameter in
let credit := op_startypeminuserrorstar 10 in
op_gtgteqquestion
(Lwt._return (op_plusquestion credit amount))
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero
op_startypeminuserrorstar bootstrap impl_contract
credit)
(fun init_credit =>
op_gtgteqquestion
(op_startypeminuserrorstar i init_credit)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar impl_contract
balance)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar fee
op_startypeminuserrorstar
impl_contract
(Some unregistered_delegate_pkh))
(fun delegate_op =>
if
op_startypeminuserrorstar fee credit
then
op_gtgteq
(op_startypeminuserrorstar i
delegate_op)
(fun err =>
op_startypeminuserrorstar
__LOC__ err
(fun function_parameter =>
match function_parameter
with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar
(expect_unregistered_key
unregistered_delegate_pkh) i
delegate_op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
impl_contract balance fee)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteq
(op_startypeminuserrorstar
op_startypeminuserrorstar
impl_contract)
(fun err =>
op_startypeminuserrorstar
__LOC__ err
(fun
function_parameter
=>
match
function_parameter
with
| _ => true
| _ => false
end)))))))))))))).
Definition unregistered_delegate_key_switch_delegation_credit {A B : Type}
(fee : A) (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let bootstrap_pkh :=
op_pipegt (Contract.is_implicit bootstrap)
(op_startypeminuserrorstar __POS__) in
let unregistered_account := op_startypeminuserrorstar tt in
let unregistered_pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract unregistered_pkh in
let unregistered_delegate_account := op_startypeminuserrorstar tt in
let unregistered_delegate_pkh := op_startypeminuserrorstar in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
bootstrap impl_contract amount)
(fun create_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract amount)
(fun function_parameter =>
let '_ := function_parameter in
let credit := op_startypeminuserrorstar 10 in
op_gtgteqquestion
(Lwt._return (op_plusquestion credit amount))
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero
op_startypeminuserrorstar bootstrap impl_contract
credit)
(fun init_credit =>
op_gtgteqquestion
(op_startypeminuserrorstar i init_credit)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar impl_contract
balance)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero
op_startypeminuserrorstar
impl_contract (Some bootstrap_pkh))
(fun delegate_op =>
op_gtgteqquestion
(op_startypeminuserrorstar i
delegate_op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
bootstrap)
(fun delegate_pkh =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__ bootstrap_pkh
delegate_pkh)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
fee
op_startypeminuserrorstar
impl_contract
(Some
unregistered_delegate_pkh))
(fun delegate_op =>
if
op_startypeminuserrorstar
fee credit then
op_gtgteq
(op_startypeminuserrorstar
i delegate_op)
(fun err =>
op_startypeminuserrorstar
__LOC__ err
(fun
function_parameter
=>
match
function_parameter
with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ =>
true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar
(expect_unregistered_key
unregistered_delegate_pkh)
i delegate_op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
impl_contract
balance fee)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
impl_contract)
(fun
delegate
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
delegate
unregistered_delegate_pkh)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
__LOC__
delegate
bootstrap_pkh)))))))))))))))))).
Definition unregistered_delegate_key_init_origination_credit_debit
{A B C : Type} (fee : A) (amount : B) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let unregistered_account := op_startypeminuserrorstar tt in
let unregistered_pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract unregistered_pkh in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
impl_contract amount)
(fun create_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract amount)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
impl_contract bootstrap amount)
(fun debit_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar i debit_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar impl_contract
Tez.zero)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar bootstrap)
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar fee
unregistered_pkh
op_startypeminuserrorstar bootstrap
op_startypeminuserrorstar)
(fun function_parameter =>
let '(op, orig_contract) :=
function_parameter in
if
op_startypeminuserrorstar fee
balance then
op_gtgteq
(op_startypeminuserrorstar i op)
(fun err =>
op_startypeminuserrorstar
__LOC__ err
(fun function_parameter =>
match function_parameter
with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar
(expect_unregistered_key
unregistered_pkh) i op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
bootstrap balance fee)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteq
(op_startypeminuserrorstar
op_startypeminuserrorstar
orig_contract)
(fun err =>
op_startypeminuserrorstar
__LOC__ err
(fun
function_parameter
=>
match
function_parameter
with
| _ => true
| _ => false
end)))))))))))))).
Definition unregistered_delegate_key_init_delegation_credit_debit {A B C : Type}
(amount : A) (fee : B) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let unregistered_account := op_startypeminuserrorstar tt in
let unregistered_pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract unregistered_pkh in
let unregistered_delegate_account := op_startypeminuserrorstar tt in
let unregistered_delegate_pkh := op_startypeminuserrorstar in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
bootstrap impl_contract amount)
(fun create_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract amount)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero
op_startypeminuserrorstar impl_contract bootstrap
amount)
(fun debit_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar i debit_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar impl_contract
Tez.zero)
(fun function_parameter =>
let '_ := function_parameter in
let credit := op_startypeminuserrorstar 10 in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero
op_startypeminuserrorstar bootstrap
impl_contract credit)
(fun credit_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar i
credit_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar
impl_contract credit)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar fee
op_startypeminuserrorstar
impl_contract
(Some
unregistered_delegate_pkh))
(fun delegate_op =>
if
op_startypeminuserrorstar
fee credit then
op_gtgteq
(op_startypeminuserrorstar
i delegate_op)
(fun err =>
op_startypeminuserrorstar
__LOC__ err
(fun
function_parameter
=>
match
function_parameter
with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar
(expect_unregistered_key
unregistered_delegate_pkh)
i delegate_op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
impl_contract credit
fee)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteq
(op_startypeminuserrorstar
op_startypeminuserrorstar
impl_contract)
(fun err =>
op_startypeminuserrorstar
__LOC__ err
(fun
function_parameter
=>
match
function_parameter
with
| _ => true
| _ => false
end)))))))))))))))).
Definition unregistered_delegate_key_switch_delegation_credit_debit
{A B C : Type} (fee : A) (amount : B) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let bootstrap_pkh :=
op_pipegt (Contract.is_implicit bootstrap)
(op_startypeminuserrorstar __POS__) in
let unregistered_account := op_startypeminuserrorstar tt in
let unregistered_pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract unregistered_pkh in
let unregistered_delegate_account := op_startypeminuserrorstar tt in
let unregistered_delegate_pkh := op_startypeminuserrorstar in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
bootstrap impl_contract amount)
(fun create_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract amount)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
impl_contract bootstrap amount)
(fun debit_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar i debit_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar impl_contract
Tez.zero)
(fun function_parameter =>
let '_ := function_parameter in
let credit := op_startypeminuserrorstar 10 in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero
op_startypeminuserrorstar bootstrap
impl_contract credit)
(fun credit_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar i
credit_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar
impl_contract credit)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
Tez.zero
op_startypeminuserrorstar
impl_contract
(Some bootstrap_pkh))
(fun delegate_op =>
op_gtgteqquestion
(op_startypeminuserrorstar i
delegate_op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
bootstrap)
(fun delegate_pkh =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
bootstrap_pkh
delegate_pkh)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
fee
impl_contract
(Some
unregistered_delegate_pkh))
(fun delegate_op
=>
if
op_startypeminuserrorstar
fee credit
then
op_gtgteq
(op_startypeminuserrorstar
i
delegate_op)
(fun err
=>
op_startypeminuserrorstar
__LOC__
err
(fun
function_parameter
=>
match
function_parameter
with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_
_
_
=>
true
| _
=>
false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar
(expect_unregistered_key
unregistered_delegate_pkh)
i
delegate_op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
impl_contract
credit
fee)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
impl_contract)
(fun
delegate
=>
op_startypeminuserrorstar
__LOC__
delegate
unregistered_delegate_pkh))))))))))))))))))).
Definition failed_self_delegation_no_transaction {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let account := op_startypeminuserrorstar tt in
let unregistered_pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract unregistered_pkh in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar impl_contract)
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ Tez.zero balance)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
impl_contract (Some unregistered_pkh))
(fun self_delegation =>
op_gtgteq (op_startypeminuserrorstar i self_delegation)
(fun err =>
op_startypeminuserrorstar __LOC__ err
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_implicit_contract
pkh =>
if
op_startypeminuserrorstar pkh unregistered_pkh
then
true
else
false
| _ => false
end))))))).
Definition failed_self_delegation_emptied_implicit_contract {A B : Type}
(amount : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let account := op_startypeminuserrorstar tt in
let unregistered_pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract unregistered_pkh in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
impl_contract amount)
(fun create_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract amount)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
impl_contract bootstrap amount)
(fun create_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar impl_contract
Tez.zero)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar impl_contract
(Some unregistered_pkh))
(fun self_delegation =>
op_gtgteq
(op_startypeminuserrorstar i
self_delegation)
(fun err =>
op_startypeminuserrorstar __LOC__ err
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_implicit_contract
pkh =>
if
op_startypeminuserrorstar pkh
unregistered_pkh then
true
else
false
| _ => false
end))))))))))).
Definition valid_delegate_registration_init_delegation_credit {A B : Type}
(amount : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let delegate_account := op_startypeminuserrorstar tt in
let delegate_pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract delegate_pkh in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
impl_contract amount)
(fun create_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract amount)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
impl_contract (Some delegate_pkh))
(fun self_delegation =>
op_gtgteqquestion
(op_startypeminuserrorstar i self_delegation)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar impl_contract)
(fun delegate =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ delegate
delegate_pkh)
(fun function_parameter =>
let '_ := function_parameter in
let unregistered_account :=
op_startypeminuserrorstar tt in
let unregistered_pkh :=
op_startypeminuserrorstar in
let delegator :=
Contract.implicit_contract
unregistered_pkh in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero
op_startypeminuserrorstar bootstrap
delegator Tez.one)
(fun credit_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar i
credit_contract)
(fun i =>
op_gtgteq
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegator)
(fun err =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__ err
(fun function_parameter =>
match function_parameter
with
| _ => true
| _ => false
end))
(fun function_parameter =>
let '_ :=
function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegator
(Some
(pkh
delegate_account)))
(fun delegation =>
op_gtgteqquestion
(op_startypeminuserrorstar
i delegation)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegator)
(fun
delegator_delegate
=>
op_startypeminuserrorstar
__LOC__
delegator_delegate
delegate_pkh)))))))))))))))).
Definition valid_delegate_registration_switch_delegation_credit {A B : Type}
(amount : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let delegate_account := op_startypeminuserrorstar tt in
let delegate_pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract delegate_pkh in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
impl_contract amount)
(fun create_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract amount)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
impl_contract (Some delegate_pkh))
(fun self_delegation =>
op_gtgteqquestion
(op_startypeminuserrorstar i self_delegation)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar impl_contract)
(fun delegate =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ delegate
delegate_pkh)
(fun function_parameter =>
let '_ := function_parameter in
let unregistered_account :=
op_startypeminuserrorstar tt in
let unregistered_pkh :=
op_startypeminuserrorstar in
let delegator :=
Contract.implicit_contract
unregistered_pkh in
op_gtgteqquestion
(op_startypeminuserrorstar Tez.zero
op_startypeminuserrorstar bootstrap
delegator Tez.one)
(fun credit_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar i
credit_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
bootstrap)
(fun bootstrap_manager =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegator
(Some
(pkh bootstrap_manager)))
(fun delegation =>
op_gtgteqquestion
(op_startypeminuserrorstar
i delegation)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegator)
(fun
delegator_delegate
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
delegator_delegate
(pkh
bootstrap_manager))
(fun
function_parameter
=>
let '_ :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegator
(Some
(pkh
delegate_account)))
(fun
delegation
=>
op_gtgteqquestion
(op_startypeminuserrorstar
i
delegation)
(fun i
=>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegator)
(fun
delegator_delegate
=>
op_startypeminuserrorstar
__LOC__
delegator_delegate
delegate_pkh))))))))))))))))))).
Definition valid_delegate_registration_init_delegation_credit_debit {A B : Type}
(amount : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let delegate_account := op_startypeminuserrorstar tt in
let delegate_pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract delegate_pkh in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
impl_contract amount)
(fun create_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract amount)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
impl_contract (Some delegate_pkh))
(fun self_delegation =>
op_gtgteqquestion
(op_startypeminuserrorstar i self_delegation)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar impl_contract)
(fun delegate =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
delegate_pkh delegate)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
impl_contract bootstrap amount)
(fun empty_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar i
empty_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
impl_contract Tez.zero)
(fun function_parameter =>
let '_ := function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
impl_contract)
(fun delegate =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__ delegate_pkh
delegate)
(fun function_parameter
=>
let '_ :=
function_parameter
in
let
unregistered_account :=
op_startypeminuserrorstar
tt in
let
unregistered_pkh :=
op_startypeminuserrorstar
in
let delegator :=
Contract.implicit_contract
unregistered_pkh
in
op_gtgteqquestion
(op_startypeminuserrorstar
Tez.zero
op_startypeminuserrorstar
bootstrap
delegator Tez.one)
(fun credit_contract
=>
op_gtgteqquestion
(op_startypeminuserrorstar
i
credit_contract)
(fun i =>
op_gtgteq
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegator)
(fun err =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
err
(fun
function_parameter
=>
match
function_parameter
with
| _
=>
true
| _
=>
false
end))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegator
(Some
(pkh
delegate_account)))
(fun
delegation
=>
op_gtgteqquestion
(op_startypeminuserrorstar
i
delegation)
(fun
i
=>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegator)
(fun
delegator_delegate
=>
op_startypeminuserrorstar
__LOC__
delegator_delegate
delegate_pkh))))))))))))))))))))).
Definition valid_delegate_registration_switch_delegation_credit_debit
{A B : Type} (amount : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let delegate_account := op_startypeminuserrorstar tt in
let delegate_pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract delegate_pkh in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
impl_contract amount)
(fun create_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract amount)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
impl_contract (Some delegate_pkh))
(fun self_delegation =>
op_gtgteqquestion
(op_startypeminuserrorstar i self_delegation)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar impl_contract)
(fun delegate =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
delegate_pkh delegate)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
impl_contract bootstrap amount)
(fun empty_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar i
empty_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
impl_contract Tez.zero)
(fun function_parameter =>
let '_ := function_parameter
in
let unregistered_account :=
op_startypeminuserrorstar tt
in
let unregistered_pkh :=
op_startypeminuserrorstar in
let delegator :=
Contract.implicit_contract
unregistered_pkh in
op_gtgteqquestion
(op_startypeminuserrorstar
Tez.zero
op_startypeminuserrorstar
bootstrap delegator
Tez.one)
(fun credit_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar
i credit_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
bootstrap)
(fun
bootstrap_manager
=>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegator
(Some
(pkh
bootstrap_manager)))
(fun delegation
=>
op_gtgteqquestion
(op_startypeminuserrorstar
i
delegation)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegator)
(fun
delegator_delegate
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
delegator_delegate
(pkh
bootstrap_manager))
(fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegator
(Some
(pkh
delegate_account)))
(fun
delegation
=>
op_gtgteqquestion
(op_startypeminuserrorstar
i
delegation)
(fun
i
=>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegator)
(fun
delegator_delegate
=>
op_startypeminuserrorstar
__LOC__
delegator_delegate
delegate_pkh)))))))))))))))))))))).
Definition double_registration {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let account := op_startypeminuserrorstar tt in
let pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract pkh in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
impl_contract Tez.one_mutez)
(fun create_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract Tez.one_mutez)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
impl_contract (Some pkh))
(fun self_delegation =>
op_gtgteqquestion
(op_startypeminuserrorstar i self_delegation)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar impl_contract
(Some pkh))
(fun second_registration =>
op_gtgteq
(op_startypeminuserrorstar i
second_registration)
(fun err =>
op_startypeminuserrorstar __LOC__ err
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Active_delegate
=> true
| _ => false
end)))))))))).
Definition double_registration_when_empty {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let account := op_startypeminuserrorstar tt in
let pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract pkh in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
impl_contract Tez.one_mutez)
(fun create_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract Tez.one_mutez)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
impl_contract (Some pkh))
(fun self_delegation =>
op_gtgteqquestion
(op_startypeminuserrorstar i self_delegation)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar impl_contract
bootstrap Tez.one_mutez)
(fun empty_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar i empty_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar
impl_contract Tez.zero)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
impl_contract (Some pkh))
(fun second_registration =>
op_gtgteq
(op_startypeminuserrorstar i
second_registration)
(fun err =>
op_startypeminuserrorstar
__LOC__ err
(fun function_parameter =>
match function_parameter
with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Active_delegate
=> true
| _ => false
end))))))))))))).
Definition double_registration_when_recredited {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let account := op_startypeminuserrorstar tt in
let pkh := op_startypeminuserrorstar in
let impl_contract := Contract.implicit_contract pkh in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
impl_contract Tez.one_mutez)
(fun create_contract =>
op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
impl_contract Tez.one_mutez)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
impl_contract (Some pkh))
(fun self_delegation =>
op_gtgteqquestion
(op_startypeminuserrorstar i self_delegation)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar impl_contract
bootstrap Tez.one_mutez)
(fun empty_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar i empty_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar
impl_contract Tez.zero)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
bootstrap impl_contract
Tez.one_mutez)
(fun create_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar i
create_contract)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
impl_contract
Tez.one_mutez)
(fun function_parameter =>
let '_ :=
function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
impl_contract
(Some pkh))
(fun second_registration
=>
op_gtgteq
(op_startypeminuserrorstar
i
second_registration)
(fun err =>
op_startypeminuserrorstar
__LOC__ err
(fun
function_parameter
=>
match
function_parameter
with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Active_delegate
=> true
| _ => false
end)))))))))))))))).
Definition unregistered_and_unrevealed_self_delegate_key_init_delegation
{A B : Type} (fee : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let '_ := op_startypeminuserrorstar tt in
let '_ := op_startypeminuserrorstar tt in
let contract :=
Alpha_context.Contract.implicit_contract op_startypeminuserrorstar
in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
contract (op_startypeminuserrorstar 10))
(fun op =>
op_gtgteqquestion (op_startypeminuserrorstar i op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar fee op_startypeminuserrorstar
contract (Some op_startypeminuserrorstar))
(fun op =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
contract)
(fun balance =>
if op_startypeminuserrorstar fee balance then
op_gtgteq (op_startypeminuserrorstar i op)
(fun err =>
op_startypeminuserrorstar __LOC__ err
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar
(expect_unregistered_key
op_startypeminuserrorstar) i op)
(fun i =>
op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar contract balance fee))))))).
Definition unregistered_and_revealed_self_delegate_key_init_delegation
{A B : Type} (fee : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let '_ := op_startypeminuserrorstar tt in
let '_ := op_startypeminuserrorstar tt in
let contract :=
Alpha_context.Contract.implicit_contract op_startypeminuserrorstar
in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
contract (op_startypeminuserrorstar 10))
(fun op =>
op_gtgteqquestion (op_startypeminuserrorstar i op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun op =>
op_gtgteqquestion (op_startypeminuserrorstar i op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar fee
op_startypeminuserrorstar contract
(Some op_startypeminuserrorstar))
(fun op =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar contract)
(fun balance =>
if op_startypeminuserrorstar fee balance then
op_gtgteq (op_startypeminuserrorstar i op)
(fun err =>
op_startypeminuserrorstar __LOC__ err
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end))
else
op_gtgteqquestion
(op_startypeminuserrorstar
(expect_unregistered_key
op_startypeminuserrorstar) i op)
(fun i =>
op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar contract
balance fee))))))))).
Definition registered_self_delegate_key_init_delegation
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, bootstrap_contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let bootstrap := List.hd bootstrap_contracts in
let '_ := op_startypeminuserrorstar tt in
let '_ := op_startypeminuserrorstar tt in
let contract :=
Alpha_context.Contract.implicit_contract op_startypeminuserrorstar
in
let delegate_contract :=
Alpha_context.Contract.implicit_contract op_startypeminuserrorstar
in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
contract (op_startypeminuserrorstar 10))
(fun op =>
op_gtgteqquestion (op_startypeminuserrorstar i op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
bootstrap delegate_contract (op_startypeminuserrorstar 1))
(fun op =>
op_gtgteqquestion (op_startypeminuserrorstar i op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun op =>
op_gtgteqquestion (op_startypeminuserrorstar i op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
delegate_contract
(Some op_startypeminuserrorstar))
(fun op =>
op_gtgteqquestion
(op_startypeminuserrorstar i op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar contract
(Some op_startypeminuserrorstar))
(fun op =>
op_gtgteqquestion
(op_startypeminuserrorstar i op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
contract)
(fun delegate =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__ delegate
op_startypeminuserrorstar)
(fun function_parameter
=>
let 'tt :=
function_parameter
in
return_unit)))))))))))))).
Definition tests_delegate_registration {A : Type} : list A :=
cons
(op_startypeminuserrorstar
"unregistered delegate key (origination, small fee)" % string
(* ❌ Variants not supported *)
variant (unregistered_delegate_key_init_origination Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered delegate key (origination, edge case fee)" % string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_init_origination
(op_startypeminuserrorstar 3999488)))
(cons
(op_startypeminuserrorstar
"unregistered delegate key (origination, large fee)" % string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_init_origination
(op_startypeminuserrorstar 10000000)))
(cons
(op_startypeminuserrorstar
"unregistered delegate key (init with delegation, small fee)" %
string
(* ❌ Variants not supported *)
variant (unregistered_delegate_key_init_delegation Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered delegate key (init with delegation, max fee)" %
string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_init_delegation
op_startypeminuserrorstar))
(cons
(op_startypeminuserrorstar
"unregistered delegate key (switch with delegation, small fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_switch_delegation Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered delegate key (switch with delegation, max fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_switch_delegation
op_startypeminuserrorstar))
(cons
(op_startypeminuserrorstar
"unregistered delegate key - credit/debit 1μꜩ (origination, small fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_init_origination_credit_debit
Tez.one_mutez Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered delegate key - credit/debit 1μꜩ (origination, large fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_init_origination_credit_debit
op_startypeminuserrorstar Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered delegate key - credit/debit 1μꜩ (init with delegation, small fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_init_delegation_credit_debit
Tez.one_mutez Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered delegate key - credit/debit 1μꜩ (init with delegation, large fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_init_delegation_credit_debit
Tez.one_mutez op_startypeminuserrorstar))
(cons
(op_startypeminuserrorstar
"unregistered delegate key - credit/debit 1μꜩ (switch with delegation, small fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_switch_delegation_credit_debit
Tez.one_mutez Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered delegate key - credit/debit 1μꜩ (switch with delegation, large fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_switch_delegation_credit_debit
op_startypeminuserrorstar Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered delegate key - credit 1μꜩ (origination, small fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_init_origination_credit
Tez.one_mutez Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered delegate key - credit 1μꜩ (origination, edge case fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_init_origination_credit
(op_startypeminuserrorstar 3999488)
Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered delegate key - credit 1μꜩ (origination, large fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_init_origination_credit
(op_startypeminuserrorstar 10000000)
Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered delegate key - credit 1μꜩ (init with delegation, small fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_init_delegation_credit
Tez.one_mutez Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered delegate key - credit 1μꜩ (init with delegation, large fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_init_delegation_credit
op_startypeminuserrorstar
Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered delegate key - credit 1μꜩ (switch with delegation, small fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_switch_delegation_credit
Tez.one_mutez Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered delegate key - credit 1μꜩ (switch with delegation, large fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_delegate_key_switch_delegation_credit
op_startypeminuserrorstar
Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered and unrevealed self-delegation (small fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_and_unrevealed_self_delegate_key_init_delegation
Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered and unrevealed self-delegation (large fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_and_unrevealed_self_delegate_key_init_delegation
op_startypeminuserrorstar))
(cons
(op_startypeminuserrorstar
"unregistered and revealed self-delegation (small fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_and_revealed_self_delegate_key_init_delegation
Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"unregistered and revealed self-delegation large fee)"
% string
(* ❌ Variants not supported *)
variant
(unregistered_and_revealed_self_delegate_key_init_delegation
op_startypeminuserrorstar))
(cons
(op_startypeminuserrorstar
"registered and revelead self-delegation"
% string
(* ❌ Variants not supported *)
variant
registered_self_delegate_key_init_delegation)
(cons
(op_startypeminuserrorstar
"failed self-delegation: no transaction"
% string
(* ❌ Variants not supported *)
variant
failed_self_delegation_no_transaction)
(cons
(op_startypeminuserrorstar
"failed self-delegation: credit & debit 1μꜩ"
% string
(* ❌ Variants not supported *)
variant
(failed_self_delegation_emptied_implicit_contract
Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"valid delegate registration: credit 1μꜩ, self delegation (init with delegation)"
% string
(* ❌ Variants not supported *)
variant
(valid_delegate_registration_init_delegation_credit
Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"valid delegate registration: credit 1μꜩ, self delegation (switch with delegation)"
% string
(* ❌ Variants not supported *)
variant
(valid_delegate_registration_switch_delegation_credit
Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ (init with delegation)"
% string
(* ❌ Variants not supported *)
variant
(valid_delegate_registration_init_delegation_credit_debit
Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ (switch with delegation)"
% string
(* ❌ Variants not supported *)
variant
(valid_delegate_registration_switch_delegation_credit_debit
Tez.one_mutez))
(cons
(op_startypeminuserrorstar
"double registration"
% string
(* ❌ Variants not supported *)
variant
double_registration)
(cons
(op_startypeminuserrorstar
"double registration when delegate account is emptied"
% string
(* ❌ Variants not supported *)
variant
double_registration_when_empty)
(cons
(op_startypeminuserrorstar
"double registration when delegate account is emptied and then recredited"
%
string
(* ❌ Variants not supported *)
variant
double_registration_when_recredited)
[]))))))))))))))))))))))))))))))))).
Definition tests {A : Type} : list A :=
op_at tests_bootstrap_contracts tests_delegate_registration.
src/proto_alpha/lib_protocol/test/double_baking.ml 108 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Double baking evidence operation may happen when a baker
baked two different blocks on the same level. *)
open Protocol
open Alpha_context
(****************************************************************)
(* Utility functions *)
(****************************************************************)
let get_first_different_baker baker bakers =
return
@@ List.find
(fun baker' -> Signature.Public_key_hash.( <> ) baker baker')
bakers
let get_first_different_bakers ctxt =
Context.get_bakers ctxt
>>=? fun bakers ->
let baker_1 = List.hd bakers in
get_first_different_baker baker_1 (List.tl bakers)
>>=? fun baker_2 -> return (baker_1, baker_2)
let get_first_different_endorsers ctxt =
Context.get_endorsers ctxt
>>=? fun endorsers ->
let endorser_1 = (List.hd endorsers).delegate in
let endorser_2 = (List.hd (List.tl endorsers)).delegate in
return (endorser_1, endorser_2)
(** Bake two block at the same level using the same policy (i.e. same
baker) *)
let block_fork ?policy contracts b =
let (contract_a, contract_b) =
(List.hd contracts, List.hd (List.tl contracts))
in
Op.transaction (B b) contract_a contract_b Alpha_context.Tez.one_cent
>>=? fun operation ->
Block.bake ?policy ~operation b
>>=? fun blk_a -> Block.bake ?policy b >>=? fun blk_b -> return (blk_a, blk_b)
(****************************************************************)
(* Tests *)
(****************************************************************)
(** Simple scenario where two blocks are baked by a same baker and
exposed by a double baking evidence operation *)
let valid_double_baking_evidence () =
Context.init 2
>>=? fun (b, contracts) ->
Context.get_bakers (B b)
>>=? fun bakers ->
let priority_0_baker = List.hd bakers in
block_fork ~policy:(By_priority 0) contracts b
>>=? fun (blk_a, blk_b) ->
Op.double_baking (B blk_a) blk_a.header blk_b.header
>>=? fun operation ->
Block.bake ~policy:(Excluding [priority_0_baker]) ~operation blk_a
>>=? fun blk ->
(* Check that the frozen deposit, the fees and rewards are removed *)
iter_s
(fun kind ->
let contract =
Alpha_context.Contract.implicit_contract priority_0_baker
in
Assert.balance_is ~loc:__LOC__ (B blk) contract ~kind Tez.zero)
[Deposit; Fees; Rewards]
(****************************************************************)
(* The following test scenarios are supposed to raise errors. *)
(****************************************************************)
(** Check that a double baking operation fails if it exposes the same two blocks *)
let same_blocks () =
Context.init 2
>>=? fun (b, _contracts) ->
Block.bake b
>>=? fun ba ->
Op.double_baking (B ba) ba.header ba.header
>>=? fun operation ->
Block.bake ~operation ba
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Invalid_double_baking_evidence _ ->
true
| _ ->
false)
>>=? fun () -> return_unit
(** Check that a double baking operation exposing two blocks with
different levels fails *)
let different_levels () =
Context.init 2
>>=? fun (b, contracts) ->
block_fork ~policy:(By_priority 0) contracts b
>>=? fun (blk_a, blk_b) ->
Block.bake blk_b
>>=? fun blk_b_2 ->
Op.double_baking (B blk_a) blk_a.header blk_b_2.header
>>=? fun operation ->
Block.bake ~operation blk_a
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Invalid_double_baking_evidence _ ->
true
| _ ->
false)
(** Check that a double baking operation exposing two yet to be baked
blocks fails *)
let too_early_double_baking_evidence () =
Context.init 2
>>=? fun (b, contracts) ->
block_fork ~policy:(By_priority 0) contracts b
>>=? fun (blk_a, blk_b) ->
Op.double_baking (B b) blk_a.header blk_b.header
>>=? fun operation ->
Block.bake ~operation b
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Too_early_double_baking_evidence _ ->
true
| _ ->
false)
(** Check that after [preserved_cycles + 1], it is not possible to
create a double baking operation anymore *)
let too_late_double_baking_evidence () =
Context.init 2
>>=? fun (b, contracts) ->
Context.get_constants (B b)
>>=? fun Constants.{parametric = {preserved_cycles; _}; _} ->
block_fork ~policy:(By_priority 0) contracts b
>>=? fun (blk_a, blk_b) ->
fold_left_s
(fun blk _ -> Block.bake_until_cycle_end blk)
blk_a
(1 -- (preserved_cycles + 1))
>>=? fun blk ->
Op.double_baking (B blk) blk_a.header blk_b.header
>>=? fun operation ->
Block.bake ~operation blk
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Outdated_double_baking_evidence _ ->
true
| _ ->
false)
(** Check that an invalid double baking evidence that exposes two block
baking with same level made by different bakers fails *)
let different_delegates () =
Context.init 2
>>=? fun (b, _) ->
get_first_different_bakers (B b)
>>=? fun (baker_1, baker_2) ->
Block.bake ~policy:(By_account baker_1) b
>>=? fun blk_a ->
Block.bake ~policy:(By_account baker_2) b
>>=? fun blk_b ->
Op.double_baking (B blk_a) blk_a.header blk_b.header
>>=? fun operation ->
Block.bake ~operation blk_a
>>= fun e ->
Assert.proto_error ~loc:__LOC__ e (function
| Apply.Inconsistent_double_baking_evidence _ ->
true
| _ ->
false)
let wrong_signer () =
(* Baker_2 bakes a block but baker signs it. *)
let header_custom_signer baker baker_2 b =
Block.Forge.forge_header ~policy:(By_account baker_2) b
>>=? fun header ->
Block.Forge.set_baker baker header |> Block.Forge.sign_header
in
Context.init 2
>>=? fun (b, _) ->
get_first_different_bakers (B b)
>>=? fun (baker_1, baker_2) ->
Block.bake ~policy:(By_account baker_1) b
>>=? fun blk_a ->
header_custom_signer baker_1 baker_2 b
>>=? fun header_b ->
Op.double_baking (B blk_a) blk_a.header header_b
>>=? fun operation ->
Block.bake ~operation blk_a
>>= fun e ->
Assert.proto_error ~loc:__LOC__ e (function
| Baking.Invalid_block_signature _ ->
true
| _ ->
false)
let tests =
[ Test.tztest
"valid double baking evidence"
`Quick
valid_double_baking_evidence;
(* Should fail*)
Test.tztest "same blocks" `Quick same_blocks;
Test.tztest "different levels" `Quick different_levels;
Test.tztest
"too early double baking evidence"
`Quick
too_early_double_baking_evidence;
Test.tztest
"too late double baking evidence"
`Quick
too_late_double_baking_evidence;
Test.tztest "different delegates" `Quick different_delegates;
Test.tztest "wrong delegate" `Quick wrong_signer ]
src/proto_alpha/lib_protocol/test/double_baking.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Definition get_first_different_baker {A B : Type}
(baker :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(bakers : A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
op_atat _return
(op_startypeminuserrorstar
(fun baker' => Signature.Public_key_hash.op_ltgt baker baker') bakers).
Definition get_first_different_bakers {A B : Type} (ctxt : A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* B)) :=
op_gtgteqquestion (op_startypeminuserrorstar ctxt)
(fun bakers =>
let baker_1 := List.hd bakers in
op_gtgteqquestion (get_first_different_baker baker_1 (List.tl bakers))
(fun baker_2 => _return (baker_1, baker_2))).
Definition get_first_different_endorsers {A B C : Type} (ctxt : A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (B * C)) :=
op_gtgteqquestion (op_startypeminuserrorstar ctxt)
(fun endorsers =>
let endorser_1 := delegate (List.hd endorsers) in
let endorser_2 := delegate (List.hd (List.tl endorsers)) in
_return (endorser_1, endorser_2)).
Definition block_fork {A B C D E : Type}
(policy : option A) (contracts : list B) (b : C)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (D * E)) :=
let '(contract_a, contract_b) :=
((List.hd contracts), (List.hd (List.tl contracts))) in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract_a contract_b
Alpha_context.Tez.one_cent)
(fun operation =>
op_gtgteqquestion (op_startypeminuserrorstar policy operation b)
(fun blk_a =>
op_gtgteqquestion (op_startypeminuserrorstar policy b)
(fun blk_b => _return (blk_a, blk_b)))).
Definition valid_double_baking_evidence (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun bakers =>
let priority_0_baker := List.hd bakers in
op_gtgteqquestion
(block_fork (Some op_startypeminuserrorstar) contracts b)
(fun function_parameter =>
let '(blk_a, blk_b) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(header blk_a) (header blk_b))
(fun operation =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
operation blk_a)
(fun blk =>
iter_s
(fun kind =>
let contract :=
Alpha_context.Contract.implicit_contract
priority_0_baker in
op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar contract kind Tez.zero)
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar [])))))))).
Definition same_blocks (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, _contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun ba =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar (header ba)
(header ba))
(fun operation =>
op_gtgteq (op_startypeminuserrorstar operation ba)
(fun res =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_double_baking_evidence
_ => true
| _ => false
end))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))).
Definition different_levels {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
op_gtgteqquestion
(block_fork (Some op_startypeminuserrorstar) contracts b)
(fun function_parameter =>
let '(blk_a, blk_b) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar blk_b)
(fun blk_b_2 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(header blk_a) (header blk_b_2))
(fun operation =>
op_gtgteq (op_startypeminuserrorstar operation blk_a)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_double_baking_evidence
_ => true
| _ => false
end)))))).
Definition too_early_double_baking_evidence {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
op_gtgteqquestion
(block_fork (Some op_startypeminuserrorstar) contracts b)
(fun function_parameter =>
let '(blk_a, blk_b) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar (header blk_a)
(header blk_b))
(fun operation =>
op_gtgteq (op_startypeminuserrorstar operation b)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Too_early_double_baking_evidence
_ => true
| _ => false
end))))).
Definition too_late_double_baking_evidence {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '{| parametric := {| preserved_cycles := preserved_cycles |} |} :=
function_parameter in
op_gtgteqquestion
(block_fork (Some op_startypeminuserrorstar) contracts b)
(fun function_parameter =>
let '(blk_a, blk_b) := function_parameter in
op_gtgteqquestion
(fold_left_s
(fun blk =>
fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar blk) blk_a
(op_startypeminuserrorstar 1 (op_plus preserved_cycles 1)))
(fun blk =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(header blk_a) (header blk_b))
(fun operation =>
op_gtgteq (op_startypeminuserrorstar operation blk)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Outdated_double_baking_evidence
_ => true
| _ => false
end))))))).
Definition different_delegates {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (get_first_different_bakers op_startypeminuserrorstar)
(fun function_parameter =>
let '(baker_1, baker_2) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar b)
(fun blk_a =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar b)
(fun blk_b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(header blk_a) (header blk_b))
(fun operation =>
op_gtgteq (op_startypeminuserrorstar operation blk_a)
(fun e =>
op_startypeminuserrorstar __LOC__ e
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_double_baking_evidence
_ => true
| _ => false
end))))))).
Definition wrong_signer {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
let header_custom_signer {B C D E : Type} (baker : B) (baker_2 : C) (b : D)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult E) :=
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar b)
(fun header =>
op_pipegt (op_startypeminuserrorstar baker header)
op_startypeminuserrorstar) in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (get_first_different_bakers op_startypeminuserrorstar)
(fun function_parameter =>
let '(baker_1, baker_2) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar b)
(fun blk_a =>
op_gtgteqquestion (header_custom_signer baker_1 baker_2 b)
(fun header_b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(header blk_a) header_b)
(fun operation =>
op_gtgteq (op_startypeminuserrorstar operation blk_a)
(fun e =>
op_startypeminuserrorstar __LOC__ e
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_block_signature
_ _ => true
| _ => false
end))))))).
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "valid double baking evidence" % string
(* ❌ Variants not supported *)
variant valid_double_baking_evidence)
(cons
(op_startypeminuserrorstar "same blocks" % string
(* ❌ Variants not supported *)
variant same_blocks)
(cons
(op_startypeminuserrorstar "different levels" % string
(* ❌ Variants not supported *)
variant different_levels)
(cons
(op_startypeminuserrorstar "too early double baking evidence" % string
(* ❌ Variants not supported *)
variant too_early_double_baking_evidence)
(cons
(op_startypeminuserrorstar
"too late double baking evidence" % string
(* ❌ Variants not supported *)
variant too_late_double_baking_evidence)
(cons
(op_startypeminuserrorstar "different delegates" % string
(* ❌ Variants not supported *)
variant different_delegates)
(cons
(op_startypeminuserrorstar "wrong delegate" % string
(* ❌ Variants not supported *)
variant wrong_signer) [])))))).
src/proto_alpha/lib_protocol/test/double_endorsement.ml 126 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Double endorsement evidence operation may happen when an endorser
endorsed two different blocks on the same level. *)
open Protocol
open Alpha_context
(****************************************************************)
(* Utility functions *)
(****************************************************************)
let get_first_different_baker baker bakers =
return
@@ List.find
(fun baker' -> Signature.Public_key_hash.( <> ) baker baker')
bakers
let get_first_different_bakers ctxt =
Context.get_bakers ctxt
>>=? fun bakers ->
let baker_1 = List.hd bakers in
get_first_different_baker baker_1 (List.tl bakers)
>>=? fun baker_2 -> return (baker_1, baker_2)
let get_first_different_endorsers ctxt =
Context.get_endorsers ctxt
>>=? fun endorsers ->
let endorser_1 = List.hd endorsers in
let endorser_2 = List.hd (List.tl endorsers) in
return (endorser_1, endorser_2)
let block_fork b =
get_first_different_bakers (B b)
>>=? fun (baker_1, baker_2) ->
Block.bake ~policy:(By_account baker_1) b
>>=? fun blk_a ->
Block.bake ~policy:(By_account baker_2) b
>>=? fun blk_b -> return (blk_a, blk_b)
(****************************************************************)
(* Tests *)
(****************************************************************)
(** Simple scenario where two endorsements are made from the same
delegate and exposed by a double_endorsement operation. Also verify
that punishment is operated. *)
let valid_double_endorsement_evidence () =
Context.init 2
>>=? fun (b, _) ->
block_fork b
>>=? fun (blk_a, blk_b) ->
Context.get_endorser (B blk_a)
>>=? fun (delegate, _slots) ->
Op.endorsement ~delegate (B blk_a) ()
>>=? fun endorsement_a ->
Op.endorsement ~delegate (B blk_b) ()
>>=? fun endorsement_b ->
Block.bake ~operations:[Operation.pack endorsement_a] blk_a
>>=? fun blk_a ->
(* Block.bake ~operations:[endorsement_b] blk_b >>=? fun _ -> *)
Op.double_endorsement (B blk_a) endorsement_a endorsement_b
>>=? fun operation ->
(* Bake with someone different than the bad endorser *)
Context.get_bakers (B blk_a)
>>=? fun bakers ->
get_first_different_baker delegate bakers
>>=? fun baker ->
Block.bake ~policy:(By_account baker) ~operation blk_a
>>=? fun blk ->
(* Check that the frozen deposit, the fees and rewards are removed *)
iter_s
(fun kind ->
let contract = Alpha_context.Contract.implicit_contract delegate in
Assert.balance_is ~loc:__LOC__ (B blk) contract ~kind Tez.zero)
[Deposit; Fees; Rewards]
(****************************************************************)
(* The following test scenarios are supposed to raise errors. *)
(****************************************************************)
(** Check that an invalid double endorsement operation that exposes a valid
endorsement fails. *)
let invalid_double_endorsement () =
Context.init 10
>>=? fun (b, _) ->
Block.bake b
>>=? fun b ->
Op.endorsement (B b) ()
>>=? fun endorsement ->
Block.bake ~operation:(Operation.pack endorsement) b
>>=? fun b ->
Op.double_endorsement (B b) endorsement endorsement
>>=? fun operation ->
Block.bake ~operation b
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Invalid_double_endorsement_evidence ->
true
| _ ->
false)
(** Check that a double endorsement added at the same time as a double
endorsement operation fails. *)
let too_early_double_endorsement_evidence () =
Context.init 2
>>=? fun (b, _) ->
block_fork b
>>=? fun (blk_a, blk_b) ->
Context.get_endorser (B blk_a)
>>=? fun (delegate, _slots) ->
Op.endorsement ~delegate (B blk_a) ()
>>=? fun endorsement_a ->
Op.endorsement ~delegate (B blk_b) ()
>>=? fun endorsement_b ->
Op.double_endorsement (B b) endorsement_a endorsement_b
>>=? fun operation ->
Block.bake ~operation b
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Too_early_double_endorsement_evidence _ ->
true
| _ ->
false)
(** Check that after [preserved_cycles + 1], it is not possible
to create a double_endorsement anymore. *)
let too_late_double_endorsement_evidence () =
Context.init 2
>>=? fun (b, _) ->
Context.get_constants (B b)
>>=? fun Constants.{parametric = {preserved_cycles; _}; _} ->
block_fork b
>>=? fun (blk_a, blk_b) ->
Context.get_endorser (B blk_a)
>>=? fun (delegate, _slots) ->
Op.endorsement ~delegate (B blk_a) ()
>>=? fun endorsement_a ->
Op.endorsement ~delegate (B blk_b) ()
>>=? fun endorsement_b ->
fold_left_s
(fun blk _ -> Block.bake_until_cycle_end blk)
blk_a
(1 -- (preserved_cycles + 1))
>>=? fun blk ->
Op.double_endorsement (B blk) endorsement_a endorsement_b
>>=? fun operation ->
Block.bake ~operation blk
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Outdated_double_endorsement_evidence _ ->
true
| _ ->
false)
(** Check that an invalid double endorsement evidence that expose two
endorsements made by two different endorsers fails. *)
let different_delegates () =
Context.init 2
>>=? fun (b, _) ->
Block.bake b
>>=? fun b ->
block_fork b
>>=? fun (blk_a, blk_b) ->
Context.get_endorser (B blk_a)
>>=? fun (endorser_a, _a_slots) ->
get_first_different_endorsers (B blk_b)
>>=? fun (endorser_b1c, endorser_b2c) ->
let endorser_b =
if Signature.Public_key_hash.( = ) endorser_a endorser_b1c.delegate then
endorser_b2c.delegate
else endorser_b1c.delegate
in
Op.endorsement ~delegate:endorser_a (B blk_a) ()
>>=? fun e_a ->
Op.endorsement ~delegate:endorser_b (B blk_b) ()
>>=? fun e_b ->
Block.bake ~operation:(Operation.pack e_b) blk_b
>>=? fun _ ->
Op.double_endorsement (B blk_b) e_a e_b
>>=? fun operation ->
Block.bake ~operation blk_b
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Inconsistent_double_endorsement_evidence _ ->
true
| _ ->
false)
(** Check that a double endorsement evidence that exposes a ill-formed
endorsement fails. *)
let wrong_delegate () =
Context.init ~endorsers_per_block:1 2
>>=? fun (b, contracts) ->
Error_monad.map_s (Context.Contract.manager (B b)) contracts
>>=? fun accounts ->
let pkh1 = (List.nth accounts 0).Account.pkh in
let pkh2 = (List.nth accounts 1).Account.pkh in
block_fork b
>>=? fun (blk_a, blk_b) ->
Context.get_endorser (B blk_a)
>>=? fun (endorser_a, _a_slots) ->
Op.endorsement ~delegate:endorser_a (B blk_a) ()
>>=? fun endorsement_a ->
Context.get_endorser (B blk_b)
>>=? fun (endorser_b, _b_slots) ->
let delegate =
if Signature.Public_key_hash.equal pkh1 endorser_b then pkh2 else pkh1
in
Op.endorsement ~delegate (B blk_b) ()
>>=? fun endorsement_b ->
Op.double_endorsement (B blk_b) endorsement_a endorsement_b
>>=? fun operation ->
Block.bake ~operation blk_b
>>= fun e ->
Assert.proto_error ~loc:__LOC__ e (function
| Baking.Unexpected_endorsement ->
true
| _ ->
false)
let tests =
[ Test.tztest
"valid double endorsement evidence"
`Quick
valid_double_endorsement_evidence;
Test.tztest
"invalid double endorsement evidence"
`Quick
invalid_double_endorsement;
Test.tztest
"too early double endorsement evidence"
`Quick
too_early_double_endorsement_evidence;
Test.tztest
"too late double endorsement evidence"
`Quick
too_late_double_endorsement_evidence;
Test.tztest "different delegates" `Quick different_delegates;
Test.tztest "wrong delegate" `Quick wrong_delegate ]
src/proto_alpha/lib_protocol/test/double_endorsement.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Definition get_first_different_baker {A B : Type}
(baker :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(bakers : A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
op_atat _return
(op_startypeminuserrorstar
(fun baker' => Signature.Public_key_hash.op_ltgt baker baker') bakers).
Definition get_first_different_bakers {A B : Type} (ctxt : A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* B)) :=
op_gtgteqquestion (op_startypeminuserrorstar ctxt)
(fun bakers =>
let baker_1 := List.hd bakers in
op_gtgteqquestion (get_first_different_baker baker_1 (List.tl bakers))
(fun baker_2 => _return (baker_1, baker_2))).
Definition get_first_different_endorsers {A B : Type} (ctxt : A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (B * B)) :=
op_gtgteqquestion (op_startypeminuserrorstar ctxt)
(fun endorsers =>
let endorser_1 := List.hd endorsers in
let endorser_2 := List.hd (List.tl endorsers) in
_return (endorser_1, endorser_2)).
Definition block_fork {A B C : Type} (b : A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (B * C)) :=
op_gtgteqquestion (get_first_different_bakers op_startypeminuserrorstar)
(fun function_parameter =>
let '(baker_1, baker_2) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar b)
(fun blk_a =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar b)
(fun blk_b => _return (blk_a, blk_b)))).
Definition valid_double_endorsement_evidence (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (block_fork b)
(fun function_parameter =>
let '(blk_a, blk_b) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '(delegate, _slots) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar delegate op_startypeminuserrorstar tt)
(fun endorsement_a =>
op_gtgteqquestion
(op_startypeminuserrorstar delegate
op_startypeminuserrorstar tt)
(fun endorsement_b =>
op_gtgteqquestion
(op_startypeminuserrorstar
(cons (Operation.pack endorsement_a) []) blk_a)
(fun blk_a =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
endorsement_a endorsement_b)
(fun operation =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun bakers =>
op_gtgteqquestion
(get_first_different_baker delegate bakers)
(fun baker =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar operation
blk_a)
(fun blk =>
iter_s
(fun kind =>
let contract :=
Alpha_context.Contract.implicit_contract
delegate in
op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar
contract kind Tez.zero)
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
(cons op_startypeminuserrorstar
[]))))))))))))).
Definition invalid_double_endorsement {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 10)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar tt)
(fun endorsement =>
op_gtgteqquestion
(op_startypeminuserrorstar (Operation.pack endorsement) b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
endorsement endorsement)
(fun operation =>
op_gtgteq (op_startypeminuserrorstar operation b)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_double_endorsement_evidence
=> true
| _ => false
end))))))).
Definition too_early_double_endorsement_evidence {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (block_fork b)
(fun function_parameter =>
let '(blk_a, blk_b) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '(delegate, _slots) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar delegate op_startypeminuserrorstar tt)
(fun endorsement_a =>
op_gtgteqquestion
(op_startypeminuserrorstar delegate
op_startypeminuserrorstar tt)
(fun endorsement_b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
endorsement_a endorsement_b)
(fun operation =>
op_gtgteq (op_startypeminuserrorstar operation b)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Too_early_double_endorsement_evidence
_ => true
| _ => false
end)))))))).
Definition too_late_double_endorsement_evidence {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '{| parametric := {| preserved_cycles := preserved_cycles |} |} :=
function_parameter in
op_gtgteqquestion (block_fork b)
(fun function_parameter =>
let '(blk_a, blk_b) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '(delegate, _slots) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar delegate
op_startypeminuserrorstar tt)
(fun endorsement_a =>
op_gtgteqquestion
(op_startypeminuserrorstar delegate
op_startypeminuserrorstar tt)
(fun endorsement_b =>
op_gtgteqquestion
(fold_left_s
(fun blk =>
fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar blk) blk_a
(op_startypeminuserrorstar 1
(op_plus preserved_cycles 1)))
(fun blk =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar endorsement_a
endorsement_b)
(fun operation =>
op_gtgteq
(op_startypeminuserrorstar operation blk)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Outdated_double_endorsement_evidence
_ => true
| _ => false
end)))))))))).
Definition different_delegates {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion (block_fork b)
(fun function_parameter =>
let '(blk_a, blk_b) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '(endorser_a, _a_slots) := function_parameter in
op_gtgteqquestion
(get_first_different_endorsers op_startypeminuserrorstar)
(fun function_parameter =>
let '(endorser_b1c, endorser_b2c) := function_parameter in
let endorser_b :=
if
Signature.Public_key_hash.op_eq endorser_a
(delegate endorser_b1c) then
delegate endorser_b2c
else
delegate endorser_b1c in
op_gtgteqquestion
(op_startypeminuserrorstar endorser_a
op_startypeminuserrorstar tt)
(fun e_a =>
op_gtgteqquestion
(op_startypeminuserrorstar endorser_b
op_startypeminuserrorstar tt)
(fun e_b =>
op_gtgteqquestion
(op_startypeminuserrorstar (Operation.pack e_b)
blk_b)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar e_a e_b)
(fun operation =>
op_gtgteq
(op_startypeminuserrorstar operation
blk_b)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_double_endorsement_evidence
_ => true
| _ => false
end))))))))))).
Definition wrong_delegate {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1 2)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
op_gtgteqquestion
(Error_monad.map_s (op_startypeminuserrorstar op_startypeminuserrorstar)
contracts)
(fun accounts =>
let pkh1 := Account.pkh (op_startypeminuserrorstar accounts 0) in
let pkh2 := Account.pkh (op_startypeminuserrorstar accounts 1) in
op_gtgteqquestion (block_fork b)
(fun function_parameter =>
let '(blk_a, blk_b) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '(endorser_a, _a_slots) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar endorser_a
op_startypeminuserrorstar tt)
(fun endorsement_a =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '(endorser_b, _b_slots) := function_parameter in
let delegate :=
if Signature.Public_key_hash.equal pkh1 endorser_b
then
pkh2
else
pkh1 in
op_gtgteqquestion
(op_startypeminuserrorstar delegate
op_startypeminuserrorstar tt)
(fun endorsement_b =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar endorsement_a
endorsement_b)
(fun operation =>
op_gtgteq
(op_startypeminuserrorstar operation blk_b)
(fun e =>
op_startypeminuserrorstar __LOC__ e
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_endorsement
=> true
| _ => false
end)))))))))).
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "valid double endorsement evidence" % string
(* ❌ Variants not supported *)
variant valid_double_endorsement_evidence)
(cons
(op_startypeminuserrorstar "invalid double endorsement evidence" % string
(* ❌ Variants not supported *)
variant invalid_double_endorsement)
(cons
(op_startypeminuserrorstar
"too early double endorsement evidence" % string
(* ❌ Variants not supported *)
variant too_early_double_endorsement_evidence)
(cons
(op_startypeminuserrorstar
"too late double endorsement evidence" % string
(* ❌ Variants not supported *)
variant too_late_double_endorsement_evidence)
(cons
(op_startypeminuserrorstar "different delegates" % string
(* ❌ Variants not supported *)
variant different_delegates)
(cons
(op_startypeminuserrorstar "wrong delegate" % string
(* ❌ Variants not supported *)
variant wrong_delegate) []))))).
src/proto_alpha/lib_protocol/test/endorsement.ml 302 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Endorsing a block adds an extra layer of confidence to the Tezos's
PoS algorithm. The block endorsing operation must be included in
the following block. Each endorser possess a number of slots
corresponding to their priority. After [preserved_cycles], a reward
is given to the endorser. This reward depends on the priority of
the block that contains the endorsements. *)
open Protocol
open Alpha_context
open Test_utils
open Test_tez
(****************************************************************)
(* Utility functions *)
(****************************************************************)
let get_expected_reward ctxt ~priority ~baker ~endorsing_power =
( if baker then Context.get_baking_reward ctxt ~priority ~endorsing_power
else return (Test_tez.Tez.of_int 0) )
>>=? fun baking_reward ->
Context.get_endorsing_reward ctxt ~priority ~endorsing_power
>>=? fun endorsing_reward ->
Test_tez.Tez.(endorsing_reward +? baking_reward)
>>?= fun reward -> return reward
let get_expected_deposit ctxt ~baker ~endorsing_power =
Context.get_constants ctxt
>>=? fun Constants.
{ parametric =
{endorsement_security_deposit; block_security_deposit; _};
_ } ->
let open Environment in
let open Tez in
let baking_deposit = if baker then block_security_deposit else of_int 0 in
endorsement_security_deposit *? Int64.of_int endorsing_power
>>?= fun endorsement_deposit ->
endorsement_deposit +? baking_deposit >>?= fun deposit -> return deposit
(* [baker] is true if the [pkh] has also baked the current block, in
which case correspoding deposit and reward should be ajusted *)
let assert_endorser_balance_consistency ~loc ?(priority = 0) ?(baker = false)
~endorsing_power ctxt pkh initial_balance =
let contract = Contract.implicit_contract pkh in
get_expected_reward ctxt ~priority ~baker ~endorsing_power
>>=? fun reward ->
get_expected_deposit ctxt ~baker ~endorsing_power
>>=? fun deposit ->
Assert.balance_was_debited ~loc ctxt contract initial_balance deposit
>>=? fun () ->
Context.Contract.balance ~kind:Rewards ctxt contract
>>=? fun reward_balance ->
Assert.equal_tez ~loc reward_balance reward
>>=? fun () ->
Context.Contract.balance ~kind:Deposit ctxt contract
>>=? fun deposit_balance -> Assert.equal_tez ~loc deposit_balance deposit
let delegates_with_slots endorsers =
List.map
(fun (endorser : Delegate_services.Endorsing_rights.t) ->
endorser.delegate)
endorsers
let endorsing_power endorsers =
List.fold_left
(fun sum (endorser : Delegate_services.Endorsing_rights.t) ->
sum + List.length endorser.slots)
0
endorsers
(****************************************************************)
(* Tests *)
(****************************************************************)
(** Apply a single endorsement from the slot 0 endorser *)
let simple_endorsement () =
Context.init 5
>>=? fun (b, _) ->
Context.get_endorser (B b)
>>=? fun (delegate, slots) ->
Op.endorsement ~delegate (B b) ()
>>=? fun op ->
Context.Contract.balance (B b) (Contract.implicit_contract delegate)
>>=? fun initial_balance ->
let policy = Block.Excluding [delegate] in
Block.get_next_baker ~policy b
>>=? fun (_, priority, _) ->
Block.bake ~policy ~operations:[Operation.pack op] b
>>=? fun b2 ->
assert_endorser_balance_consistency
~loc:__LOC__
(B b2)
~priority
~endorsing_power:(List.length slots)
delegate
initial_balance
(** Apply a maximum number of endorsements. An endorser can be
selected twice. *)
let max_endorsement () =
let endorsers_per_block = 16 in
Context.init ~endorsers_per_block 32
>>=? fun (b, _) ->
Context.get_endorsers (B b)
>>=? fun endorsers ->
Assert.equal_int
~loc:__LOC__
(List.length
(List.concat
(List.map
(fun {Alpha_services.Delegate.Endorsing_rights.slots; _} -> slots)
endorsers)))
endorsers_per_block
>>=? fun () ->
fold_left_s
(fun (delegates, ops, balances)
(endorser : Alpha_services.Delegate.Endorsing_rights.t) ->
let delegate = endorser.delegate in
Context.Contract.balance (B b) (Contract.implicit_contract delegate)
>>=? fun balance ->
Op.endorsement ~delegate (B b) ()
>>=? fun op ->
return
( delegate :: delegates,
Operation.pack op :: ops,
(List.length endorser.slots, balance) :: balances ))
([], [], [])
endorsers
>>=? fun (delegates, ops, previous_balances) ->
Block.bake ~policy:(Excluding delegates) ~operations:(List.rev ops) b
>>=? fun b ->
(* One account can endorse more than one time per level, we must
check that the bonds are summed up *)
iter_s
(fun (endorser_account, (endorsing_power, previous_balance)) ->
assert_endorser_balance_consistency
~loc:__LOC__
(B b)
~endorsing_power
endorser_account
previous_balance)
(List.combine delegates previous_balances)
(** Check every that endorsers' balances are consistent with different priorities *)
let consistent_priorities () =
let priorities = 0 -- 64 in
Context.init 64
>>=? fun (b, _) ->
fold_left_s
(fun (b, used_pkhes) priority ->
(* Choose an endorser that has not baked nor endorsed before *)
Context.get_endorsers (B b)
>>=? fun endorsers ->
let endorser =
List.find_opt
(fun (e : Delegate_services.Endorsing_rights.t) ->
not (Signature.Public_key_hash.Set.mem e.delegate used_pkhes))
endorsers
in
match endorser with
| None ->
return (b, used_pkhes) (* not enough fresh endorsers; we "stop" *)
| Some endorser ->
Context.Contract.balance
(B b)
(Contract.implicit_contract endorser.delegate)
>>=? fun balance ->
Op.endorsement ~delegate:endorser.delegate (B b) ()
>>=? fun operation ->
let operation = Operation.pack operation in
Block.get_next_baker ~policy:(By_priority priority) b
>>=? fun (baker, _, _) ->
let used_pkhes =
Signature.Public_key_hash.Set.add baker used_pkhes
in
let used_pkhes =
Signature.Public_key_hash.Set.add endorser.delegate used_pkhes
in
(* Bake with a specific priority *)
Block.bake ~policy:(By_priority priority) ~operation b
>>=? fun b ->
let is_baker =
Signature.Public_key_hash.(baker = endorser.delegate)
in
assert_endorser_balance_consistency
~loc:__LOC__
~priority
~baker:is_baker
(B b)
~endorsing_power:(List.length endorser.slots)
endorser.delegate
balance
>>=? fun () -> return (b, used_pkhes))
(b, Signature.Public_key_hash.Set.empty)
priorities
>>=? fun _b -> return_unit
(** Check that after [preserved_cycles] cycles the endorser gets his reward *)
let reward_retrieval () =
Context.init 5
>>=? fun (b, _) ->
Context.get_constants (B b)
>>=? fun Constants.{parametric = {preserved_cycles; _}; _} ->
Context.get_endorser (B b)
>>=? fun (endorser, slots) ->
Context.Contract.balance (B b) (Contract.implicit_contract endorser)
>>=? fun balance ->
Op.endorsement ~delegate:endorser (B b) ()
>>=? fun operation ->
let operation = Operation.pack operation in
let policy = Block.Excluding [endorser] in
Block.get_next_baker ~policy b
>>=? fun (_, priority, _) ->
Block.bake ~policy ~operation b
>>=? fun b ->
(* Bake (preserved_cycles + 1) cycles *)
fold_left_s
(fun b _ -> Block.bake_until_cycle_end ~policy:(Excluding [endorser]) b)
b
(0 -- preserved_cycles)
>>=? fun b ->
get_expected_reward
(B b)
~priority
~baker:false
~endorsing_power:(List.length slots)
>>=? fun reward ->
Assert.balance_was_credited
~loc:__LOC__
(B b)
(Contract.implicit_contract endorser)
balance
reward
(** Check that after [preserved_cycles] cycles endorsers get their
reward. Two endorsers are used and they endorse in different
cycles. *)
let reward_retrieval_two_endorsers () =
Context.init 5
>>=? fun (b, _) ->
Context.get_constants (B b)
>>=? fun Constants.
{ parametric =
{ preserved_cycles;
endorsement_reward;
endorsement_security_deposit;
_ };
_ } ->
Context.get_endorsers (B b)
>>=? fun endorsers ->
let endorser1 = List.hd endorsers in
let endorser2 = List.hd (List.tl endorsers) in
Context.Contract.balance
(B b)
(Contract.implicit_contract endorser1.delegate)
>>=? fun balance1 ->
Context.Contract.balance
(B b)
(Contract.implicit_contract endorser2.delegate)
>>=? fun balance2 ->
Lwt.return
Tez.(
endorsement_security_deposit
*? Int64.of_int (List.length endorser1.slots))
>>=? fun security_deposit1 ->
(* endorser1 endorses the genesis block in cycle 0 *)
Op.endorsement ~delegate:endorser1.delegate (B b) ()
>>=? fun operation1 ->
let policy = Block.Excluding [endorser1.delegate; endorser2.delegate] in
Block.get_next_baker ~policy b
>>=? fun (_, priority, _) ->
Tez.(endorsement_reward /? Int64.(succ (of_int priority)))
>>?= fun reward_per_slot ->
Lwt.return
Tez.(reward_per_slot *? Int64.of_int (List.length endorser1.slots))
>>=? fun reward1 ->
(* bake next block, include endorsement of endorser1 *)
Block.bake ~policy ~operation:(Operation.pack operation1) b
>>=? fun b ->
Assert.balance_was_debited
~loc:__LOC__
(B b)
(Contract.implicit_contract endorser1.delegate)
balance1
security_deposit1
>>=? fun () ->
Assert.balance_is
~loc:__LOC__
(B b)
(Contract.implicit_contract endorser2.delegate)
balance2
>>=? fun () ->
(* complete cycle 0 *)
Block.bake_until_cycle_end ~policy b
>>=? fun b ->
Assert.balance_was_debited
~loc:__LOC__
(B b)
(Contract.implicit_contract endorser1.delegate)
balance1
security_deposit1
>>=? fun () ->
Assert.balance_is
~loc:__LOC__
(B b)
(Contract.implicit_contract endorser2.delegate)
balance2
>>=? fun () ->
(* get the slots of endorser2 for the current block *)
Context.get_endorsers (B b)
>>=? fun endorsers ->
let same_endorser2 endorser =
Signature.Public_key_hash.(
endorser.Delegate_services.Endorsing_rights.delegate = endorser2.delegate)
in
let endorser2 = List.find same_endorser2 endorsers in
(* No exception raised: in sandboxed mode endorsers do not change between blocks *)
Lwt.return
Tez.(
endorsement_security_deposit
*? Int64.of_int (List.length endorser2.slots))
>>=? fun security_deposit2 ->
(* endorser2 endorses the last block in cycle 0 *)
Op.endorsement ~delegate:endorser2.delegate (B b) ()
>>=? fun operation2 ->
(* bake first block in cycle 1, include endorsement of endorser2 *)
Block.bake ~policy ~operation:(Operation.pack operation2) b
>>=? fun b ->
let priority = b.header.protocol_data.contents.priority in
Tez.(endorsement_reward /? Int64.(succ (of_int priority)))
>>?= fun reward_per_slot ->
Lwt.return
Tez.(reward_per_slot *? Int64.of_int (List.length endorser2.slots))
>>=? fun reward2 ->
Assert.balance_was_debited
~loc:__LOC__
(B b)
(Contract.implicit_contract endorser1.delegate)
balance1
security_deposit1
>>=? fun () ->
Assert.balance_was_debited
~loc:__LOC__
(B b)
(Contract.implicit_contract endorser2.delegate)
balance2
security_deposit2
>>=? fun () ->
(* bake [preserved_cycles] cycles *)
fold_left_s
(fun b _ ->
Assert.balance_was_debited
~loc:__LOC__
(B b)
(Contract.implicit_contract endorser1.delegate)
balance1
security_deposit1
>>=? fun () ->
Assert.balance_was_debited
~loc:__LOC__
(B b)
(Contract.implicit_contract endorser2.delegate)
balance2
security_deposit2
>>=? fun () -> Block.bake_until_cycle_end ~policy b)
b
(1 -- preserved_cycles)
>>=? fun b ->
Assert.balance_was_credited
~loc:__LOC__
(B b)
(Contract.implicit_contract endorser1.delegate)
balance1
reward1
>>=? fun () ->
Assert.balance_was_debited
~loc:__LOC__
(B b)
(Contract.implicit_contract endorser2.delegate)
balance2
security_deposit2
>>=? fun () ->
(* bake cycle [preserved_cycle + 1] *)
Block.bake_until_cycle_end ~policy b
>>=? fun b ->
Assert.balance_was_credited
~loc:__LOC__
(B b)
(Contract.implicit_contract endorser1.delegate)
balance1
reward1
>>=? fun () ->
Assert.balance_was_credited
~loc:__LOC__
(B b)
(Contract.implicit_contract endorser2.delegate)
balance2
reward2
(****************************************************************)
(* The following test scenarios are supposed to raise errors. *)
(****************************************************************)
(** Wrong endorsement predecessor : apply an endorsement with an
incorrect block predecessor *)
let wrong_endorsement_predecessor () =
Context.init 5
>>=? fun (b, _) ->
Context.get_endorser (B b)
>>=? fun (genesis_endorser, _slots) ->
Block.bake b
>>=? fun b' ->
Op.endorsement ~delegate:genesis_endorser ~signing_context:(B b) (B b') ()
>>=? fun operation ->
let operation = Operation.pack operation in
Block.bake ~operation b'
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Wrong_endorsement_predecessor _ ->
true
| _ ->
false)
(** Invalid_endorsement_level : apply an endorsement with an incorrect
level (i.e. the predecessor level) *)
let invalid_endorsement_level () =
Context.init 5
>>=? fun (b, _) ->
Context.get_level (B b)
>>=? fun genesis_level ->
Block.bake b
>>=? fun b ->
Op.endorsement ~level:genesis_level (B b) ()
>>=? fun operation ->
let operation = Operation.pack operation in
Block.bake ~operation b
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Invalid_endorsement_level ->
true
| _ ->
false)
(** Duplicate endorsement : apply an endorsement that has already been done *)
let duplicate_endorsement () =
Context.init 5
>>=? fun (b, _) ->
Incremental.begin_construction b
>>=? fun inc ->
Op.endorsement (B b) ()
>>=? fun operation ->
let operation = Operation.pack operation in
Incremental.add_operation inc operation
>>=? fun inc ->
Op.endorsement (B b) ()
>>=? fun operation ->
let operation = Operation.pack operation in
Incremental.add_operation inc operation
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Apply.Duplicate_endorsement _ ->
true
| _ ->
false)
(** Apply a single endorsement from the slot 0 endorser *)
let not_enough_for_deposit () =
Context.init 5 ~endorsers_per_block:1
>>=? fun (b_init, contracts) ->
Error_monad.map_s
(fun c ->
Context.Contract.manager (B b_init) c >>=? fun m -> return (m, c))
contracts
>>=? fun managers ->
Block.bake b_init
>>=? fun b ->
(* retrieve the level 2's endorser *)
Context.get_endorser (B b)
>>=? fun (endorser, _slots) ->
let (_, contract_other_than_endorser) =
List.find
(fun (c, _) ->
not (Signature.Public_key_hash.equal c.Account.pkh endorser))
managers
in
let (_, contract_of_endorser) =
List.find
(fun (c, _) -> Signature.Public_key_hash.equal c.Account.pkh endorser)
managers
in
Context.Contract.balance (B b) (Contract.implicit_contract endorser)
>>=? fun initial_balance ->
(* Empty the future endorser account *)
Op.transaction
(B b_init)
contract_of_endorser
contract_other_than_endorser
initial_balance
>>=? fun op_trans ->
Block.bake ~operation:op_trans b_init
>>=? fun b ->
(* Endorse with a zero balance *)
Op.endorsement ~delegate:endorser (B b) ()
>>=? fun op_endo ->
Block.bake
~policy:(Excluding [endorser])
~operation:(Operation.pack op_endo)
b
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Delegate_storage.Balance_too_low_for_deposit _ ->
true
| _ ->
false)
(* check that a block with not enough endorsement cannot be baked *)
let endorsement_threshold () =
let initial_endorsers = 28 in
let num_accounts = 100 in
Context.init ~initial_endorsers num_accounts
>>=? fun (b, _) ->
Context.get_endorsers (B b)
>>=? fun endorsers ->
let num_endorsers = List.length endorsers in
(* we try to bake with more and more endorsers, but at each
iteration with a timestamp smaller than required *)
iter_s
(fun i ->
(* the priority is chosen rather arbitrarily *)
let priority = num_endorsers - i in
let crt_endorsers = List.take_n i endorsers in
let endorsing_power = endorsing_power crt_endorsers in
let delegates = delegates_with_slots crt_endorsers in
map_s (fun x -> Op.endorsement ~delegate:x (B b) ()) delegates
>>=? fun ops ->
Context.get_minimal_valid_time (B b) ~priority ~endorsing_power
>>=? fun timestamp ->
(* decrease the timestamp by one second *)
let seconds =
Int64.(sub (of_string (Timestamp.to_seconds_string timestamp)) 1L)
in
match Timestamp.of_seconds (Int64.to_string seconds) with
| None ->
failwith "timestamp to/from string manipulation failed"
| Some timestamp ->
Block.bake
~timestamp
~policy:(By_priority priority)
~operations:(List.map Operation.pack ops)
b
>>= fun b2 ->
Assert.proto_error ~loc:__LOC__ b2 (function
| Baking.Timestamp_too_early _
| Apply.Not_enough_endorsements_for_priority _ ->
true
| _ ->
false))
(0 -- (num_endorsers - 1))
>>=? fun () ->
(* we bake with all endorsers endorsing, at the right time *)
let priority = 0 in
let endorsing_power = endorsing_power endorsers in
let delegates = delegates_with_slots endorsers in
map_s (fun delegate -> Op.endorsement ~delegate (B b) ()) delegates
>>=? fun ops ->
Context.get_minimal_valid_time (B b) ~priority ~endorsing_power
>>=? fun timestamp ->
Block.bake
~policy:(By_priority priority)
~timestamp
~operations:(List.map Operation.pack ops)
b
>>= fun _ -> return_unit
let test_fitness_gap () =
let num_accounts = 5 in
Context.init num_accounts
>>=? fun (b, _) ->
( match Fitness_repr.to_int64 b.header.shell.fitness with
| Ok fitness ->
return (Int64.to_int fitness)
| Error _ ->
assert false )
>>=? fun fitness ->
Context.get_endorser (B b)
>>=? fun (delegate, _slots) ->
Op.endorsement ~delegate (B b) ()
>>=? fun op ->
(* bake at priority 0 succeed thanks to enough endorsements *)
Block.bake ~policy:(By_priority 0) ~operations:[Operation.pack op] b
>>=? fun b ->
( match Fitness_repr.to_int64 b.header.shell.fitness with
| Ok new_fitness ->
return (Int64.to_int new_fitness - fitness)
| Error _ ->
assert false )
>>=? fun res ->
(* in Emmy+, the fitness increases by 1, so the difference between
the fitness at level 1 and at level 0 is 1, independently if the
number fo endorements (here 1) *)
Assert.equal_int ~loc:__LOC__ res 1 >>=? fun () -> return_unit
let tests =
[ Test.tztest "Simple endorsement" `Quick simple_endorsement;
Test.tztest "Maximum endorsement" `Quick max_endorsement;
Test.tztest "Consistent priorities" `Quick consistent_priorities;
Test.tztest "Reward retrieval" `Quick reward_retrieval;
Test.tztest
"Reward retrieval two endorsers"
`Quick
reward_retrieval_two_endorsers;
Test.tztest "Endorsement threshold" `Quick endorsement_threshold;
Test.tztest "Fitness gap" `Quick test_fitness_gap;
(* Fail scenarios *)
Test.tztest
"Wrong endorsement predecessor"
`Quick
wrong_endorsement_predecessor;
Test.tztest "Invalid endorsement level" `Quick invalid_endorsement_level;
Test.tztest "Duplicate endorsement" `Quick duplicate_endorsement;
Test.tztest "Not enough for deposit" `Quick not_enough_for_deposit ]
src/proto_alpha/lib_protocol/test/endorsement.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Definition get_expected_reward {A B C D : Type}
(ctxt : A) (priority : B) (baker : bool) (endorsing_power : C)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult D) :=
op_gtgteqquestion
(if baker then
op_startypeminuserrorstar ctxt priority endorsing_power
else
_return (op_startypeminuserrorstar 0))
(fun baking_reward =>
op_gtgteqquestion
(op_startypeminuserrorstar ctxt priority endorsing_power)
(fun endorsing_reward =>
op_startypeminuserrorstar op_startypeminuserrorstar
(fun reward => _return reward))).
Definition get_expected_deposit {A B : Type}
(ctxt : A) (baker : bool) (endorsing_power : Z)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
op_gtgteqquestion (op_startypeminuserrorstar ctxt)
(fun function_parameter =>
let '{|
parametric := {|
block_security_deposit := block_security_deposit;
endorsement_security_deposit := endorsement_security_deposit
|}
|} := function_parameter in
let baking_deposit :=
if baker then
block_security_deposit
else
op_startypeminuserrorstar 0 in
op_startypeminuserrorstar
(op_starquestion endorsement_security_deposit
(Int64.of_int endorsing_power))
(fun endorsement_deposit =>
op_startypeminuserrorstar
(op_plusquestion endorsement_deposit baking_deposit)
(fun deposit => _return deposit))).
Definition assert_endorser_balance_consistency {A B C D : Type}
(loc : A) (op_staroptstar : option Z)
: (option bool) ->
Z ->
B ->
Tezos_raw_protocol_alpha__Alpha_context.public_key_hash ->
C ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
D) :=
let priority :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 0
end in
fun op_staroptstar =>
let baker :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun endorsing_power =>
fun ctxt =>
fun pkh =>
fun initial_balance =>
let contract := Contract.implicit_contract pkh in
op_gtgteqquestion
(get_expected_reward ctxt priority baker endorsing_power)
(fun reward =>
op_gtgteqquestion
(get_expected_deposit ctxt baker endorsing_power)
(fun deposit =>
op_gtgteqquestion
(op_startypeminuserrorstar loc ctxt contract
initial_balance deposit)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
ctxt contract)
(fun reward_balance =>
op_gtgteqquestion
(op_startypeminuserrorstar loc reward_balance
reward)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar ctxt contract)
(fun deposit_balance =>
op_startypeminuserrorstar loc
deposit_balance deposit)))))).
Definition delegates_with_slots
(endorsers :
list Tezos_protocol_alpha.Protocol.Delegate_services.Endorsing_rights.t)
: list
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t :=
List.map (fun endorser => delegate endorser) endorsers.
Definition endorsing_power
(endorsers :
list Tezos_protocol_alpha.Protocol.Delegate_services.Endorsing_rights.t)
: Z :=
List.fold_left
(fun sum => fun endorser => op_plus sum (List.length (slots endorser))) 0
endorsers.
Definition simple_endorsement {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 5)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '(delegate, slots) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar delegate op_startypeminuserrorstar tt)
(fun op =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(Contract.implicit_contract delegate))
(fun initial_balance =>
let policy := op_startypeminuserrorstar in
op_gtgteqquestion (op_startypeminuserrorstar policy b)
(fun function_parameter =>
let '(_, priority, _) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar policy
(cons (Operation.pack op) []) b)
(fun b2 =>
assert_endorser_balance_consistency __LOC__
(Some priority) None (List.length slots)
op_startypeminuserrorstar delegate initial_balance)))))).
Definition max_endorsement (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
let endorsers_per_block := 16 in
op_gtgteqquestion (op_startypeminuserrorstar endorsers_per_block 32)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun endorsers =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
(List.length
(List.concat
(List.map
(fun function_parameter =>
let '{|
Alpha_services.Delegate.Endorsing_rights.slots := slots
|} := function_parameter in
slots) endorsers))) endorsers_per_block)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(fold_left_s
(fun function_parameter =>
let '(delegates, ops, balances) := function_parameter in
fun endorser =>
let delegate := delegate endorser in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(Contract.implicit_contract delegate))
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar delegate
op_startypeminuserrorstar tt)
(fun op =>
_return
((cons delegate delegates),
(cons (Operation.pack op) ops),
(cons
((List.length (slots endorser)), balance)
balances))))) ([], [], []) endorsers)
(fun function_parameter =>
let '(delegates, ops, previous_balances) := function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(List.rev ops) b)
(fun b =>
iter_s
(fun function_parameter =>
let
'(endorser_account,
(endorsing_power, previous_balance)) :=
function_parameter in
assert_endorser_balance_consistency __LOC__ None None
endorsing_power op_startypeminuserrorstar
endorser_account previous_balance)
(List.combine delegates previous_balances)))))).
Definition consistent_priorities (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
let priorities := op_startypeminuserrorstar 0 64 in
op_gtgteqquestion (op_startypeminuserrorstar 64)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion
(fold_left_s
(fun function_parameter =>
let '(b, used_pkhes) := function_parameter in
fun priority =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun endorsers =>
let endorser :=
List.find_opt
(fun e =>
not
(Signature.Public_key_hash.Set.mem (delegate e)
used_pkhes)) endorsers in
match endorser with
| None => _return (b, used_pkhes)
| Some endorser =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(Contract.implicit_contract (delegate endorser)))
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar (delegate endorser)
op_startypeminuserrorstar tt)
(fun operation =>
let operation := Operation.pack operation in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar b)
(fun function_parameter =>
let '(baker, _, _) := function_parameter in
let used_pkhes :=
Signature.Public_key_hash.Set.add baker
used_pkhes in
let used_pkhes :=
Signature.Public_key_hash.Set.add
(delegate endorser) used_pkhes in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar operation b)
(fun b =>
let is_baker :=
op_eq baker (delegate endorser) in
op_gtgteqquestion
(assert_endorser_balance_consistency
__LOC__ (Some priority) (Some is_baker)
(List.length (slots endorser))
op_startypeminuserrorstar
(delegate endorser) balance)
(fun function_parameter =>
let 'tt := function_parameter in
_return (b, used_pkhes))))))
end)) (b, Signature.Public_key_hash.Set.empty) priorities)
(fun _b => return_unit)).
Definition reward_retrieval {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 5)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '{| parametric := {| preserved_cycles := preserved_cycles |} |} :=
function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '(endorser, slots) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(Contract.implicit_contract endorser))
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar endorser
op_startypeminuserrorstar tt)
(fun operation =>
let operation := Operation.pack operation in
let policy := op_startypeminuserrorstar in
op_gtgteqquestion (op_startypeminuserrorstar policy b)
(fun function_parameter =>
let '(_, priority, _) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar policy operation b)
(fun b =>
op_gtgteqquestion
(fold_left_s
(fun b =>
fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
op_startypeminuserrorstar b) b
(op_startypeminuserrorstar 0 preserved_cycles))
(fun b =>
op_gtgteqquestion
(get_expected_reward
op_startypeminuserrorstar priority false
(List.length slots))
(fun reward =>
op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar
(Contract.implicit_contract endorser)
balance reward))))))))).
Definition reward_retrieval_two_endorsers {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 5)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '{|
parametric := {|
preserved_cycles := preserved_cycles;
endorsement_security_deposit :=
endorsement_security_deposit;
endorsement_reward := endorsement_reward
|}
|} := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun endorsers =>
let endorser1 := List.hd endorsers in
let endorser2 := List.hd (List.tl endorsers) in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(Contract.implicit_contract (delegate endorser1)))
(fun balance1 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(Contract.implicit_contract (delegate endorser2)))
(fun balance2 =>
op_gtgteqquestion
(Lwt._return
(op_starquestion endorsement_security_deposit
(Int64.of_int (List.length (slots endorser1)))))
(fun security_deposit1 =>
op_gtgteqquestion
(op_startypeminuserrorstar (delegate endorser1)
op_startypeminuserrorstar tt)
(fun operation1 =>
let policy := op_startypeminuserrorstar in
op_gtgteqquestion
(op_startypeminuserrorstar policy b)
(fun function_parameter =>
let '(_, priority, _) := function_parameter in
op_startypeminuserrorstar
(op_divquestion endorsement_reward
(succ (of_int priority)))
(fun reward_per_slot =>
op_gtgteqquestion
(Lwt._return
(op_starquestion reward_per_slot
(Int64.of_int
(List.length (slots endorser1)))))
(fun reward1 =>
op_gtgteqquestion
(op_startypeminuserrorstar policy
(Operation.pack operation1) b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
(Contract.implicit_contract
(delegate endorser1))
balance1 security_deposit1)
(fun function_parameter =>
let 'tt := function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
(Contract.implicit_contract
(delegate endorser2))
balance2)
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
policy b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
(Contract.implicit_contract
(delegate
endorser1))
balance1
security_deposit1)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
(Contract.implicit_contract
(delegate
endorser2))
balance2)
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
endorsers
=>
let
same_endorser2
(endorser
:
Tezos_protocol_alpha.Protocol.Delegate_services.Endorsing_rights.t)
: bool :=
op_eq
(Delegate_services.Endorsing_rights.delegate
endorser)
(delegate
endorser2)
in
let
endorser2 :=
op_startypeminuserrorstar
same_endorser2
endorsers
in
op_gtgteqquestion
(Lwt._return
(op_starquestion
endorsement_security_deposit
(Int64.of_int
(List.length
(slots
endorser2)))))
(fun
security_deposit2
=>
op_gtgteqquestion
(op_startypeminuserrorstar
(delegate
endorser2)
op_startypeminuserrorstar
tt)
(fun
operation2
=>
op_gtgteqquestion
(op_startypeminuserrorstar
policy
(Operation.pack
operation2)
b)
(fun
b
=>
let
priority :=
priority
op_startypeminuserrorstar
in
op_startypeminuserrorstar
(op_divquestion
endorsement_reward
(succ
(of_int
priority)))
(fun
reward_per_slot
=>
op_gtgteqquestion
(Lwt._return
(op_starquestion
reward_per_slot
(Int64.of_int
(List.length
(slots
endorser2)))))
(fun
reward2
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
(Contract.implicit_contract
(delegate
endorser1))
balance1
security_deposit1)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
(Contract.implicit_contract
(delegate
endorser2))
balance2
security_deposit2)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(fold_left_s
(fun
b
=>
fun
function_parameter
=>
let
'_ :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
(Contract.implicit_contract
(delegate
endorser1))
balance1
security_deposit1)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
(Contract.implicit_contract
(delegate
endorser2))
balance2
security_deposit2)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
policy
b)))
b
(op_startypeminuserrorstar
1
preserved_cycles))
(fun
b
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
(Contract.implicit_contract
(delegate
endorser1))
balance1
reward1)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
(Contract.implicit_contract
(delegate
endorser2))
balance2
security_deposit2)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
policy
b)
(fun
b
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
(Contract.implicit_contract
(delegate
endorser1))
balance1
reward1)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_startypeminuserrorstar
__LOC__
op_startypeminuserrorstar
(Contract.implicit_contract
(delegate
endorser2))
balance2
reward2))))))))))))))))))))))))))))).
Definition wrong_endorsement_predecessor {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 5)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '(genesis_endorser, _slots) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b' =>
op_gtgteqquestion
(op_startypeminuserrorstar genesis_endorser
op_startypeminuserrorstar op_startypeminuserrorstar tt)
(fun operation =>
let operation := Operation.pack operation in
op_gtgteq (op_startypeminuserrorstar operation b')
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Wrong_endorsement_predecessor
_ _ => true
| _ => false
end)))))).
Definition invalid_endorsement_level {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 5)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun genesis_level =>
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar genesis_level
op_startypeminuserrorstar tt)
(fun operation =>
let operation := Operation.pack operation in
op_gtgteq (op_startypeminuserrorstar operation b)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_endorsement_level
=> true
| _ => false
end)))))).
Definition duplicate_endorsement {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 5)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun inc =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar tt)
(fun operation =>
let operation := Operation.pack operation in
op_gtgteqquestion (op_startypeminuserrorstar inc operation)
(fun inc =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar tt)
(fun operation =>
let operation := Operation.pack operation in
op_gtgteq (op_startypeminuserrorstar inc operation)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_endorsement
_ => true
| _ => false
end))))))).
Definition not_enough_for_deposit {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 5 1)
(fun function_parameter =>
let '(b_init, contracts) := function_parameter in
op_gtgteqquestion
(Error_monad.map_s
(fun c =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar c)
(fun m => _return (m, c))) contracts)
(fun managers =>
op_gtgteqquestion (op_startypeminuserrorstar b_init)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '(endorser, _slots) := function_parameter in
let '(_, contract_other_than_endorser) :=
op_startypeminuserrorstar
(fun function_parameter =>
let '(c, _) := function_parameter in
not
(Signature.Public_key_hash.equal (Account.pkh c)
endorser)) managers in
let '(_, contract_of_endorser) :=
op_startypeminuserrorstar
(fun function_parameter =>
let '(c, _) := function_parameter in
Signature.Public_key_hash.equal (Account.pkh c) endorser)
managers in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(Contract.implicit_contract endorser))
(fun initial_balance =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
contract_of_endorser contract_other_than_endorser
initial_balance)
(fun op_trans =>
op_gtgteqquestion
(op_startypeminuserrorstar op_trans b_init)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar endorser
op_startypeminuserrorstar tt)
(fun op_endo =>
op_gtgteq
(op_startypeminuserrorstar
op_startypeminuserrorstar
(Operation.pack op_endo) b)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low_for_deposit
_ => true
| _ => false
end)))))))))).
Definition endorsement_threshold (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
let initial_endorsers := 28 in
let num_accounts := 100 in
op_gtgteqquestion (op_startypeminuserrorstar initial_endorsers num_accounts)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun endorsers =>
let num_endorsers := List.length endorsers in
op_gtgteqquestion
(iter_s
(fun i =>
let priority := op_minus num_endorsers i in
let crt_endorsers := op_startypeminuserrorstar i endorsers in
let endorsing_power := endorsing_power crt_endorsers in
let delegates := delegates_with_slots crt_endorsers in
op_gtgteqquestion
(map_s
(fun x =>
op_startypeminuserrorstar x op_startypeminuserrorstar tt)
delegates)
(fun ops =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
priority endorsing_power)
(fun timestamp =>
let seconds :=
sub
(of_string (Timestamp.to_seconds_string timestamp))
(* ❌ Constant of type int64 is converted to int *)
1 in
match Timestamp.of_seconds (Int64.to_string seconds)
with
| None =>
failwith
"timestamp to/from string manipulation failed" %
string
| Some timestamp =>
op_gtgteq
(op_startypeminuserrorstar timestamp
op_startypeminuserrorstar
(List.map Operation.pack ops) b)
(fun b2 =>
op_startypeminuserrorstar __LOC__ b2
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Timestamp_too_early
_ _ |
Tezos_protocol_environment_alpha__Environment.Error_monad.Not_enough_endorsements_for_priority
_ => true
| _ => false
end))
end)))
(op_startypeminuserrorstar 0 (op_minus num_endorsers 1)))
(fun function_parameter =>
let 'tt := function_parameter in
let priority := 0 in
let endorsing_power := endorsing_power endorsers in
let delegates := delegates_with_slots endorsers in
op_gtgteqquestion
(map_s
(fun delegate =>
op_startypeminuserrorstar delegate op_startypeminuserrorstar
tt) delegates)
(fun ops =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
priority endorsing_power)
(fun timestamp =>
op_gtgteq
(op_startypeminuserrorstar op_startypeminuserrorstar
timestamp (List.map Operation.pack ops) b)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)))))).
Definition test_fitness_gap (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
let num_accounts := 5 in
op_gtgteqquestion (op_startypeminuserrorstar num_accounts)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion
match Fitness_repr.to_int64 (fitness (shell (header b))) with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok fitness =>
_return (Int64.to_int fitness)
| Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end
(fun fitness =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '(delegate, _slots) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar delegate op_startypeminuserrorstar tt)
(fun op =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(cons (Operation.pack op) []) b)
(fun b =>
op_gtgteqquestion
match Fitness_repr.to_int64 (fitness (shell (header b)))
with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
new_fitness =>
_return (op_minus (Int64.to_int new_fitness) fitness)
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ =>
(* ❌ Assert instruction is not handled. *)
assert false
end
(fun res =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ res 1)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))))).
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "Simple endorsement" % string
(* ❌ Variants not supported *)
variant simple_endorsement)
(cons
(op_startypeminuserrorstar "Maximum endorsement" % string
(* ❌ Variants not supported *)
variant max_endorsement)
(cons
(op_startypeminuserrorstar "Consistent priorities" % string
(* ❌ Variants not supported *)
variant consistent_priorities)
(cons
(op_startypeminuserrorstar "Reward retrieval" % string
(* ❌ Variants not supported *)
variant reward_retrieval)
(cons
(op_startypeminuserrorstar "Reward retrieval two endorsers" % string
(* ❌ Variants not supported *)
variant reward_retrieval_two_endorsers)
(cons
(op_startypeminuserrorstar "Endorsement threshold" % string
(* ❌ Variants not supported *)
variant endorsement_threshold)
(cons
(op_startypeminuserrorstar "Fitness gap" % string
(* ❌ Variants not supported *)
variant test_fitness_gap)
(cons
(op_startypeminuserrorstar
"Wrong endorsement predecessor" % string
(* ❌ Variants not supported *)
variant wrong_endorsement_predecessor)
(cons
(op_startypeminuserrorstar
"Invalid endorsement level" % string
(* ❌ Variants not supported *)
variant invalid_endorsement_level)
(cons
(op_startypeminuserrorstar
"Duplicate endorsement" % string
(* ❌ Variants not supported *)
variant duplicate_endorsement)
(cons
(op_startypeminuserrorstar
"Not enough for deposit" % string
(* ❌ Variants not supported *)
variant not_enough_for_deposit) [])))))))))).
src/proto_alpha/lib_protocol/test/helpers/account.ml 26 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
type t = {
pkh : Signature.Public_key_hash.t;
pk : Signature.Public_key.t;
sk : Signature.Secret_key.t;
}
type account = t
let known_accounts = Signature.Public_key_hash.Table.create 17
let new_account ?seed () =
let seed = Option.map ~f:Bigstring.of_bytes seed in
let (pkh, pk, sk) = Signature.generate_key ?seed () in
let account = {pkh; pk; sk} in
Signature.Public_key_hash.Table.add known_accounts pkh account ;
account
let add_account ({pkh; _} as account) =
Signature.Public_key_hash.Table.add known_accounts pkh account
let activator_account = new_account ()
let find pkh =
try return (Signature.Public_key_hash.Table.find known_accounts pkh)
with Not_found ->
failwith "Missing account: %a" Signature.Public_key_hash.pp pkh
let find_alternate pkh =
let exception Found of t in
try
Signature.Public_key_hash.Table.iter
(fun pkh' account ->
if not (Signature.Public_key_hash.equal pkh pkh') then
raise (Found account))
known_accounts ;
raise Not_found
with Found account -> account
let dummy_account = new_account ()
let generate_accounts ?(initial_balances = []) n : (t * Tez_repr.t) list =
Signature.Public_key_hash.Table.clear known_accounts ;
let default_amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in
let amount i =
match List.nth_opt initial_balances i with
| None ->
default_amount
| Some a ->
Tez_repr.of_mutez_exn a
in
List.map
(fun i ->
let (pkh, pk, sk) = Signature.generate_key () in
let account = {pkh; pk; sk} in
Signature.Public_key_hash.Table.add known_accounts pkh account ;
(account, amount i))
(0 -- (n - 1))
let commitment_secret =
Blinded_public_key_hash.activation_code_of_hex
"aaaaaaaaaaaaaaaaaaaabbbbbbbbbbbbbbbbbbbb"
let new_commitment ?seed () =
let seed = Option.map ~f:Bigstring.of_bytes seed in
let (pkh, pk, sk) = Signature.generate_key ?seed ~algo:Ed25519 () in
let unactivated_account = {pkh; pk; sk} in
let open Commitment_repr in
let pkh = match pkh with Ed25519 pkh -> pkh | _ -> assert false in
let bpkh = Blinded_public_key_hash.of_ed25519_pkh commitment_secret pkh in
(Lwt.return @@ Environment.wrap_error @@ Tez_repr.(one *? 4_000L))
>>=? fun amount ->
return @@ (unactivated_account, {blinded_public_key_hash = bpkh; amount})
src/proto_alpha/lib_protocol/test/helpers/account.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Record t := {
pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t;
pk : Tezos_base__TzPervasives.Signature.Public_key.t;
sk : Tezos_base__TzPervasives.Signature.Secret_key.t }.
Definition account := t.
Definition known_accounts
: Tezos_base__TzPervasives.Signature.Public_key_hash.Table.t t :=
Signature.Public_key_hash.Table.create 17.
Definition new_account
(seed : option Stdlib.Bytes.t) (function_parameter : unit) : t :=
let 'tt := function_parameter in
let seed := Option.map Bigstring.of_bytes seed in
let '(pkh, pk, sk) := Signature.generate_key None seed tt in
let account := {| pkh := pkh; pk := pk; sk := sk |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Signature.Public_key_hash.Table.add known_accounts pkh account in
account.
Definition add_account (function_parameter : t) : unit :=
let '{| pkh := pkh |} as account := function_parameter in
Signature.Public_key_hash.Table.add known_accounts pkh account.
Definition activator_account : t := new_account None tt.
Definition find
(pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.Table.key)
: Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
(* ❌ Try-with are not handled *)
try (_return (Signature.Public_key_hash.Table.find known_accounts pkh)).
Definition find_alternate
(pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t) : t :=
(* ❌ Let of exception is not handled *)
let_exception.
Definition dummy_account : t := new_account None tt.
Definition generate_accounts (op_staroptstar : option (list int64))
: Z -> list (t * Tezos_protocol_alpha.Protocol.Tez_repr.t) :=
let initial_balances :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun n =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Signature.Public_key_hash.Table.clear known_accounts in
let default_amount :=
Tez_repr.of_mutez_exn
(* ❌ Constant of type int64 is converted to int *)
4000000000000 in
let amount (i : Z) : Tezos_protocol_alpha.Protocol.Tez_repr.t :=
match List.nth_opt initial_balances i with
| None => default_amount
| Some a => Tez_repr.of_mutez_exn a
end in
List.map
(fun i =>
let '(pkh, pk, sk) := Signature.generate_key None None tt in
let account := {| pkh := pkh; pk := pk; sk := sk |} in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Signature.Public_key_hash.Table.add known_accounts pkh account
in
(account, (amount i))) (op_minusminus 0 (Z.sub n 1)).
Definition commitment_secret
: Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code :=
Blinded_public_key_hash.activation_code_of_hex
"aaaaaaaaaaaaaaaaaaaabbbbbbbbbbbbbbbbbbbb" % string.
Definition new_commitment
(seed : option Stdlib.Bytes.t) (function_parameter : unit)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(t * Tezos_protocol_alpha.Protocol.Commitment_repr.t)) :=
let 'tt := function_parameter in
let seed := Option.map Bigstring.of_bytes seed in
let '(pkh, pk, sk) :=
Signature.generate_key (Some Tezos_base__TzPervasives.Signature.Ed25519)
seed tt in
let unactivated_account := {| pkh := pkh; pk := pk; sk := sk |} in
let pkh :=
match pkh with
| Tezos_base__TzPervasives.Signature.Ed25519 pkh => pkh
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
let bpkh := Blinded_public_key_hash.of_ed25519_pkh commitment_secret pkh in
op_gtgteqquestion
(apply Lwt._return
(apply Environment.wrap_error
(op_starquestion one
(* ❌ Constant of type int64 is converted to int *)
4000)))
(fun amount =>
apply _return
(unactivated_account,
{| blinded_public_key_hash := bpkh; amount := amount |})).
src/proto_alpha/lib_protocol/test/helpers/assert.ml 41 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
let error ~loc v f =
match v with
| Error err when List.exists f err ->
return_unit
| Ok _ ->
failwith "Unexpected successful result (%s)" loc
| Error err ->
failwith "@[Unexpected error (%s): %a@]" loc pp_print_error err
let proto_error ~loc v f =
error ~loc v (function
| Environment.Ecoproto_error err ->
f err
| _ ->
false)
let equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b =
if not (cmp a b) then
failwith "@[@[[%s]@] - @[%s : %a is not equal to %a@]@]" loc msg pp a pp b
else return_unit
let not_equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b =
if cmp a b then
failwith "@[@[[%s]@] - @[%s : %a is equal to %a@]@]" loc msg pp a pp b
else return_unit
(* tez *)
let equal_tez ~loc (a : Alpha_context.Tez.t) (b : Alpha_context.Tez.t) =
let open Alpha_context in
equal ~loc Tez.( = ) "Tez aren't equal" Tez.pp a b
let not_equal_tez ~loc (a : Alpha_context.Tez.t) (b : Alpha_context.Tez.t) =
let open Alpha_context in
not_equal ~loc Tez.( = ) "Tez are equal" Tez.pp a b
(* int *)
let equal_int ~loc (a : int) (b : int) =
equal ~loc ( = ) "Integers aren't equal" Format.pp_print_int a b
let not_equal_int ~loc (a : int) (b : int) =
not_equal ~loc ( = ) "Integers are equal" Format.pp_print_int a b
(* bool *)
let equal_bool ~loc (a : bool) (b : bool) =
equal ~loc ( = ) "Booleans aren't equal" Format.pp_print_bool a b
let not_equal_bool ~loc (a : bool) (b : bool) =
not_equal ~loc ( = ) "Booleans are equal" Format.pp_print_bool a b
(* pkh *)
let equal_pkh ~loc (a : Signature.Public_key_hash.t)
(b : Signature.Public_key_hash.t) =
let module PKH = Signature.Public_key_hash in
equal ~loc PKH.equal "Public key hashes aren't equal" PKH.pp a b
let not_equal_pkh ~loc (a : Signature.Public_key_hash.t)
(b : Signature.Public_key_hash.t) =
let module PKH = Signature.Public_key_hash in
not_equal ~loc PKH.equal "Public key hashes are equal" PKH.pp a b
open Context
(* Some asserts for account operations *)
(** [balance_is b c amount] checks that the current balance of contract [c] is
[amount].
Default balance type is [Main], pass [~kind] with [Deposit], [Fees] or
[Rewards] for the others. *)
let balance_is ~loc b contract ?(kind = Contract.Main) expected =
Contract.balance b contract ~kind
>>=? fun balance -> equal_tez ~loc balance expected
(** [balance_was_operated ~operand b c old_balance amount] checks that the
current balance of contract [c] is [operand old_balance amount] and
returns the current balance.
Default balance type is [Main], pass [~kind] with [Deposit], [Fees] or
[Rewards] for the others. *)
let balance_was_operated ~operand ~loc b contract ?(kind = Contract.Main)
old_balance amount =
operand old_balance amount |> Environment.wrap_error |> Lwt.return
>>=? fun expected -> balance_is ~loc b contract ~kind expected
let balance_was_credited =
balance_was_operated ~operand:Alpha_context.Tez.( +? )
let balance_was_debited =
balance_was_operated ~operand:Alpha_context.Tez.( -? )
(* debug *)
let print_balances ctxt id =
Contract.balance ~kind:Main ctxt id
>>=? fun main ->
Contract.balance ~kind:Deposit ctxt id
>>=? fun deposit ->
Contract.balance ~kind:Fees ctxt id
>>=? fun fees ->
Contract.balance ~kind:Rewards ctxt id
>>|? fun rewards ->
Format.printf
"\nMain: %s\nDeposit: %s\nFees: %s\nRewards: %s\n"
(Alpha_context.Tez.to_string main)
(Alpha_context.Tez.to_string deposit)
(Alpha_context.Tez.to_string fees)
(Alpha_context.Tez.to_string rewards)
src/proto_alpha/lib_protocol/test/helpers/assert.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Definition error {A : Type}
(loc : string) (v : sum A Tezos_base__TzPervasives.trace)
(f : Tezos_base__TzPervasives.error -> bool)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
match v with
| Stdlib.Error err => return_unit
| Stdlib.Ok _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Unexpected successful result (" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal ")" % char
CamlinternalFormatBasics.End_of_format)))
"Unexpected successful result (%s)" % string) loc
| Stdlib.Error err =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String_literal "Unexpected error (" % string
(CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal "): " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format))))))
"@[Unexpected error (%s): %a@]" % string) loc pp_print_error err
end.
Definition proto_error {A : Type}
(loc : string) (v : sum A Tezos_base__TzPervasives.trace)
(f : Tezos_protocol_alpha.Protocol.Environment.Error_monad.error -> bool)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
error loc v
(fun function_parameter =>
match function_parameter with
| Tezos_base__TzPervasives.Error_monad.Ecoproto_error err => f err
| _ => false
end).
Definition equal {a : Type}
(loc : string) (cmp : a -> a -> bool) (msg : string)
(pp : Stdlib.Format.formatter -> a -> unit) (a : a) (b : a)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if negb (cmp a b) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "]" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.String_literal " - " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" : " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is not equal to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))))
"@[@[[%s]@] - @[%s : %a is not equal to %a@]@]" % string) loc msg pp a
pp b
else
return_unit.
Definition not_equal {a : Type}
(loc : string) (cmp : a -> a -> bool) (msg : string)
(pp : Stdlib.Format.formatter -> a -> unit) (a : a) (b : a)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
if cmp a b then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.Char_literal "[" % char
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "]" % char
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.String_literal " - " % string
(CamlinternalFormatBasics.Formatting_gen
(CamlinternalFormatBasics.Open_box
(CamlinternalFormatBasics.Format
CamlinternalFormatBasics.End_of_format "" % string))
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
" : " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" is equal to " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
(CamlinternalFormatBasics.Formatting_lit
CamlinternalFormatBasics.Close_box
CamlinternalFormatBasics.End_of_format)))))))))))))))
"@[@[[%s]@] - @[%s : %a is equal to %a@]@]" % string) loc msg pp a pp b
else
return_unit.
Definition equal_tez
(loc : string) (a : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(b : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
equal loc Tez.op_eq "Tez aren't equal" % string Tez.pp a b.
Definition not_equal_tez
(loc : string) (a : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
(b : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
not_equal loc Tez.op_eq "Tez are equal" % string Tez.pp a b.
Definition equal_int (loc : string) (a : Z) (b : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
equal loc equiv_decb "Integers aren't equal" % string Format.pp_print_int a b.
Definition not_equal_int (loc : string) (a : Z) (b : Z)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
not_equal loc equiv_decb "Integers are equal" % string Format.pp_print_int a b.
Definition equal_bool (loc : string) (a : bool) (b : bool)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
equal loc equiv_decb "Booleans aren't equal" % string Format.pp_print_bool a b.
Definition not_equal_bool (loc : string) (a : bool) (b : bool)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
not_equal loc equiv_decb "Booleans are equal" % string Format.pp_print_bool a
b.
Definition equal_pkh
(loc : string) (a : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(b : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let PKH := Signature.Public_key_hash in
equal loc PKH.equal "Public key hashes aren't equal" % string PKH.pp a b.
Definition not_equal_pkh
(loc : string) (a : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(b : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let PKH := Signature.Public_key_hash in
not_equal loc PKH.equal "Public key hashes are equal" % string PKH.pp a b.
Import Context.
Definition balance_is
(loc : string) (b : Tezos_alpha_test_helpers__Context.t)
(contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
(op_staroptstar :
option Tezos_alpha_test_helpers.Context.Contract.balance_kind)
: Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let kind :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Tezos_alpha_test_helpers.Context.Contract.Main
end in
fun expected =>
op_gtgteqquestion (Contract.balance (Some kind) b contract)
(fun balance => equal_tez loc balance expected).
Definition balance_was_operated {A B : Type}
(operand :
A ->
B ->
Tezos_protocol_alpha.Protocol.Environment.Error_monad.tzresult
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) (loc : string)
(b : Tezos_alpha_test_helpers__Context.t)
(contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
(op_staroptstar :
option Tezos_alpha_test_helpers.Context.Contract.balance_kind)
: A -> B -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let kind :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Tezos_alpha_test_helpers.Context.Contract.Main
end in
fun old_balance =>
fun amount =>
op_gtgteqquestion
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply (operand old_balance amount)
Environment.wrap_error) Lwt._return)
(fun expected => balance_is loc b contract (Some kind) expected).
Definition balance_was_credited
: string ->
Tezos_alpha_test_helpers__Context.t ->
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
(option Tezos_alpha_test_helpers.Context.Contract.balance_kind) ->
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
balance_was_operated Alpha_context.Tez.op_plusquestion.
Definition balance_was_debited
: string ->
Tezos_alpha_test_helpers__Context.t ->
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
(option Tezos_alpha_test_helpers.Context.Contract.balance_kind) ->
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
balance_was_operated Alpha_context.Tez.op_minusquestion.
Definition print_balances
(ctxt : Tezos_alpha_test_helpers__Context.t)
(id : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
op_gtgteqquestion
(Contract.balance (Some Tezos_alpha_test_helpers.Context.Contract.Main) ctxt
id)
(fun main =>
op_gtgteqquestion
(Contract.balance
(Some Tezos_alpha_test_helpers.Context.Contract.Deposit) ctxt id)
(fun deposit =>
op_gtgteqquestion
(Contract.balance
(Some Tezos_alpha_test_helpers.Context.Contract.Fees) ctxt id)
(fun fees =>
op_gtgtpipequestion
(Contract.balance
(Some Tezos_alpha_test_helpers.Context.Contract.Rewards) ctxt
id)
(fun rewards =>
Format.printf
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"
Main: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"
Deposit: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"
Fees: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.String_literal
"
Rewards: " % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal
"010" % char
CamlinternalFormatBasics.End_of_format)))))))))
"
Main: %s
Deposit: %s
Fees: %s
Rewards: %s
" % string)
(Alpha_context.Tez.to_string main)
(Alpha_context.Tez.to_string deposit)
(Alpha_context.Tez.to_string fees)
(Alpha_context.Tez.to_string rewards))))).
src/proto_alpha/lib_protocol/test/helpers/block.ml 49 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
module Proto_Nonce = Nonce (* Renamed otherwise is masked by Alpha_context *)
open Alpha_context
(* This type collects a block and the context that results from its application *)
type t = {
hash : Block_hash.t;
header : Block_header.t;
operations : Operation.packed list;
context : Tezos_protocol_environment.Context.t;
}
type block = t
let rpc_context block =
{
Environment.Updater.block_hash = block.hash;
block_header = block.header.shell;
context = block.context;
}
let rpc_ctxt =
new Environment.proto_rpc_context_of_directory rpc_context rpc_services
(******** Policies ***********)
(* Policies are functions that take a block and return a tuple
[(account, level, timestamp)] for the [forge_header] function. *)
(* This type is used only to provide a simpler interface to the exterior. *)
type baker_policy =
| By_priority of int
| By_account of public_key_hash
| Excluding of public_key_hash list
let get_next_baker_by_priority priority block =
Alpha_services.Delegate.Baking_rights.get
rpc_ctxt
~all:true
~max_priority:(priority + 1)
block
>>=? fun bakers ->
let {Alpha_services.Delegate.Baking_rights.delegate = pkh; timestamp; _} =
List.find
(fun {Alpha_services.Delegate.Baking_rights.priority = p; _} ->
p = priority)
bakers
in
return (pkh, priority, Option.unopt_exn (Failure "") timestamp)
let get_next_baker_by_account pkh block =
Alpha_services.Delegate.Baking_rights.get
rpc_ctxt
~delegates:[pkh]
~max_priority:256
block
>>=? fun bakers ->
let { Alpha_services.Delegate.Baking_rights.delegate = pkh;
timestamp;
priority;
_ } =
List.hd bakers
in
return (pkh, priority, Option.unopt_exn (Failure "") timestamp)
let get_next_baker_excluding excludes block =
Alpha_services.Delegate.Baking_rights.get rpc_ctxt ~max_priority:256 block
>>=? fun bakers ->
let { Alpha_services.Delegate.Baking_rights.delegate = pkh;
timestamp;
priority;
_ } =
List.find
(fun {Alpha_services.Delegate.Baking_rights.delegate; _} ->
not (List.mem delegate excludes))
bakers
in
return (pkh, priority, Option.unopt_exn (Failure "") timestamp)
let dispatch_policy = function
| By_priority p ->
get_next_baker_by_priority p
| By_account a ->
get_next_baker_by_account a
| Excluding al ->
get_next_baker_excluding al
let get_next_baker ?(policy = By_priority 0) = dispatch_policy policy
let get_endorsing_power b =
fold_left_s
(fun acc (op : Operation.packed) ->
let (Operation_data data) = op.protocol_data in
match data.contents with
| Single (Endorsement _) ->
Alpha_services.Delegate.Endorsing_power.get
rpc_ctxt
b
op
Chain_id.zero
>>=? fun endorsement_power -> return (acc + endorsement_power)
| _ ->
return acc)
0
b.operations
module Forge = struct
type header = {
baker : public_key_hash;
(* the signer of the block *)
shell : Block_header.shell_header;
contents : Block_header.contents;
}
let default_proof_of_work_nonce =
MBytes.create Constants.proof_of_work_nonce_size
let make_contents ?(proof_of_work_nonce = default_proof_of_work_nonce)
~priority ~seed_nonce_hash () =
Block_header.{priority; proof_of_work_nonce; seed_nonce_hash}
let make_shell ~level ~predecessor ~timestamp ~fitness ~operations_hash =
Tezos_base.Block_header.
{
level;
predecessor;
timestamp;
fitness;
operations_hash;
(* We don't care of the following values, only the shell validates them. *)
proto_level = 0;
validation_passes = 0;
context = Context_hash.zero;
}
let set_seed_nonce_hash seed_nonce_hash {baker; shell; contents} =
{baker; shell; contents = {contents with seed_nonce_hash}}
let set_baker baker header = {header with baker}
let sign_header {baker; shell; contents} =
Account.find baker
>>=? fun delegate ->
let unsigned_bytes =
Data_encoding.Binary.to_bytes_exn
Block_header.unsigned_encoding
(shell, contents)
in
let signature =
Signature.sign
~watermark:Signature.(Block_header Chain_id.zero)
delegate.sk
unsigned_bytes
in
Block_header.{shell; protocol_data = {contents; signature}} |> return
let forge_header ?(policy = By_priority 0) ?timestamp ?(operations = []) pred
=
dispatch_policy policy pred
>>=? fun (pkh, priority, _timestamp) ->
Alpha_services.Delegate.Minimal_valid_time.get rpc_ctxt pred priority 0
>>=? fun expected_timestamp ->
let timestamp = Option.unopt ~default:expected_timestamp timestamp in
let level = Int32.succ pred.header.shell.level in
( match Fitness_repr.to_int64 pred.header.shell.fitness with
| Ok old_fitness ->
return
(Fitness_repr.from_int64 (Int64.add (Int64.of_int 1) old_fitness))
| Error _ ->
assert false )
>>=? fun fitness ->
Alpha_services.Helpers.current_level ~offset:1l rpc_ctxt pred
>>|? (function
| {expected_commitment = true; _} ->
Some (fst (Proto_Nonce.generate ()))
| {expected_commitment = false; _} ->
None)
>>=? fun seed_nonce_hash ->
let hashes = List.map Operation.hash_packed operations in
let operations_hash =
Operation_list_list_hash.compute [Operation_list_hash.compute hashes]
in
let shell =
make_shell
~level
~predecessor:pred.hash
~timestamp
~fitness
~operations_hash
in
let contents = make_contents ~priority ~seed_nonce_hash () in
return {baker = pkh; shell; contents}
(* compatibility only, needed by incremental *)
let contents ?(proof_of_work_nonce = default_proof_of_work_nonce)
?(priority = 0) ?seed_nonce_hash () =
{Block_header.priority; proof_of_work_nonce; seed_nonce_hash}
end
(********* Genesis creation *************)
(* Hard-coded context key *)
let protocol_param_key = ["protocol_parameters"]
let check_constants_consistency constants =
let open Constants_repr in
let {blocks_per_cycle; blocks_per_commitment; blocks_per_roll_snapshot; _} =
constants
in
Error_monad.unless (blocks_per_commitment <= blocks_per_cycle) (fun () ->
failwith
"Inconsistent constants : blocks per commitment must be less than \
blocks per cycle")
>>=? fun () ->
Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot) (fun () ->
failwith
"Inconsistent constants : blocks per cycle must be superior than \
blocks per roll snapshot")
>>=? return
let initial_context ?(with_commitments = false) constants header
initial_accounts =
let open Tezos_protocol_alpha_parameters in
let bootstrap_accounts =
List.map
(fun (Account.{pk; pkh; _}, amount) ->
Default_parameters.make_bootstrap_account (pkh, pk, amount))
initial_accounts
in
let parameters =
Default_parameters.parameters_of_constants
~bootstrap_accounts
~with_commitments
constants
in
let json = Default_parameters.json_of_parameters parameters in
let proto_params =
Data_encoding.Binary.to_bytes_exn Data_encoding.json json
in
Tezos_protocol_environment.Context.(
let empty = Memory_context.empty in
set empty ["version"] (MBytes.of_string "genesis")
>>= fun ctxt -> set ctxt protocol_param_key proto_params)
>>= fun ctxt ->
Main.init ctxt header >|= Environment.wrap_error
>>=? fun {context; _} -> return context
let genesis_with_parameters parameters =
let hash =
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
in
let shell =
Forge.make_shell
~level:0l
~predecessor:hash
~timestamp:Time.Protocol.epoch
~fitness:(Fitness_repr.from_int64 0L)
~operations_hash:Operation_list_list_hash.zero
in
let contents = Forge.make_contents ~priority:0 ~seed_nonce_hash:None () in
let open Tezos_protocol_alpha_parameters in
let json = Default_parameters.json_of_parameters parameters in
let proto_params =
Data_encoding.Binary.to_bytes_exn Data_encoding.json json
in
Tezos_protocol_environment.Context.(
let empty = Memory_context.empty in
set empty ["version"] (MBytes.of_string "genesis")
>>= fun ctxt -> set ctxt protocol_param_key proto_params)
>>= fun ctxt ->
Main.init ctxt shell >|= Environment.wrap_error
>>=? fun {context; _} ->
let block =
{
hash;
header = {shell; protocol_data = {contents; signature = Signature.zero}};
operations = [];
context;
}
in
return block
(* if no parameter file is passed we check in the current directory
where the test is run *)
let genesis ?with_commitments ?endorsers_per_block ?initial_endorsers
?min_proposal_quorum (initial_accounts : (Account.t * Tez_repr.t) list) =
if initial_accounts = [] then
Pervasives.failwith "Must have one account with a roll to bake" ;
let open Tezos_protocol_alpha_parameters in
let constants = Default_parameters.constants_test in
let endorsers_per_block =
Option.unopt ~default:constants.endorsers_per_block endorsers_per_block
in
let initial_endorsers =
Option.unopt ~default:constants.initial_endorsers initial_endorsers
in
let min_proposal_quorum =
Option.unopt ~default:constants.min_proposal_quorum min_proposal_quorum
in
let constants =
{
constants with
endorsers_per_block;
initial_endorsers;
min_proposal_quorum;
}
in
(* Check there is at least one roll *)
( try
let open Test_utils in
fold_left_s
(fun acc (_, amount) ->
Environment.wrap_error @@ Tez_repr.( +? ) acc amount
>>?= fun acc ->
if acc >= constants.tokens_per_roll then raise Exit else return acc)
Tez_repr.zero
initial_accounts
>>=? fun _ ->
failwith "Insufficient tokens in initial accounts to create one roll"
with Exit -> return_unit )
>>=? fun () ->
check_constants_consistency constants
>>=? fun () ->
let hash =
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
in
let shell =
Forge.make_shell
~level:0l
~predecessor:hash
~timestamp:Time.Protocol.epoch
~fitness:(Fitness_repr.from_int64 0L)
~operations_hash:Operation_list_list_hash.zero
in
let contents = Forge.make_contents ~priority:0 ~seed_nonce_hash:None () in
initial_context ?with_commitments constants shell initial_accounts
>>=? fun context ->
let block =
{
hash;
header = {shell; protocol_data = {contents; signature = Signature.zero}};
operations = [];
context;
}
in
return block
(********* Baking *************)
let apply header ?(operations = []) pred =
(let open Environment.Error_monad in
Main.begin_application
~chain_id:Chain_id.zero
~predecessor_context:pred.context
~predecessor_fitness:pred.header.shell.fitness
~predecessor_timestamp:pred.header.shell.timestamp
header
>>=? fun vstate ->
fold_left_s
(fun vstate op ->
apply_operation vstate op >>=? fun (state, _result) -> return state)
vstate
operations
>>=? fun vstate ->
Main.finalize_block vstate
>>=? fun (validation, _result) -> return validation.context)
>|= Environment.wrap_error
>>|? fun context ->
let hash = Block_header.hash header in
{hash; header; operations; context}
let bake ?policy ?timestamp ?operation ?operations pred =
let operations =
match (operation, operations) with
| (Some op, Some ops) ->
Some (op :: ops)
| (Some op, None) ->
Some [op]
| (None, Some ops) ->
Some ops
| (None, None) ->
None
in
Forge.forge_header ?timestamp ?policy ?operations pred
>>=? fun header ->
Forge.sign_header header >>=? fun header -> apply header ?operations pred
(********** Cycles ****************)
(* This function is duplicated from Context to avoid a cyclic dependency *)
let get_constants b = Alpha_services.Constants.all rpc_ctxt b
let bake_n ?policy n b =
Error_monad.fold_left_s (fun b _ -> bake ?policy b) b (1 -- n)
let bake_until_cycle_end ?policy b =
get_constants b
>>=? fun Constants.{parametric = {blocks_per_cycle; _}; _} ->
let current_level = b.header.shell.level in
let current_level = Int32.rem current_level blocks_per_cycle in
let delta = Int32.sub blocks_per_cycle current_level in
bake_n ?policy (Int32.to_int delta) b
let bake_until_n_cycle_end ?policy n b =
Error_monad.fold_left_s (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n)
let bake_until_cycle ?policy cycle (b : t) =
get_constants b
>>=? fun Constants.{parametric = {blocks_per_cycle; _}; _} ->
let rec loop (b : t) =
let current_cycle =
let current_level = b.header.shell.level in
let current_cycle = Int32.div current_level blocks_per_cycle in
current_cycle
in
if Int32.equal (Cycle.to_int32 cycle) current_cycle then return b
else bake_until_cycle_end ?policy b >>=? fun b -> loop b
in
loop b
src/proto_alpha/lib_protocol/test/helpers/block.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
(* ❌ This kind of module is not handled. *)
unhandled_module
Import Alpha_context.
Record t := {
hash : Tezos_base__TzPervasives.Block_hash.t;
header : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t;
operations : list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed;
context : Tezos_protocol_environment.Context.t }.
Definition block := t.
Definition rpc_context (block : t)
: Tezos_protocol_alpha.Protocol.Environment.Updater.rpc_context :=
{| Environment.Updater.block_hash := hash block;
Environment.Updater.block_header := shell (header block);
Environment.Updater.context := context block |}.
Definition rpc_ctxt
: Tezos_protocol_alpha.Protocol.Environment.proto_rpc_context_of_directory t :=
(* ❌ Creation of new objects is not handled *)
new rpc_context rpc_services.
Inductive baker_policy : Type :=
| By_priority : Z -> baker_policy
| By_account : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash ->
baker_policy
| Excluding : (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
-> baker_policy.
Definition get_next_baker_by_priority (priority : Z) (block : t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
op_gtgteqquestion
(Alpha_services.Delegate.Baking_rights.get rpc_ctxt None None None
(Some true) (Some (Z.add priority 1)) block)
(fun bakers =>
let '{|
Alpha_services.Delegate.Baking_rights.delegate := pkh;
Alpha_services.Delegate.Baking_rights.timestamp := timestamp
|} :=
List.find
(fun function_parameter =>
let '{| Alpha_services.Delegate.Baking_rights.priority := p |} :=
function_parameter in
equiv_decb p priority) bakers in
_return
(pkh, priority, (Option.unopt_exn (OCaml.Failure "" % string) timestamp))).
Definition get_next_baker_by_account
(pkh : Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash)
(block : t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
op_gtgteqquestion
(Alpha_services.Delegate.Baking_rights.get rpc_ctxt None None
(Some (cons pkh [])) None (Some 256) block)
(fun bakers =>
let '{|
Alpha_services.Delegate.Baking_rights.delegate := pkh;
Alpha_services.Delegate.Baking_rights.priority := priority;
Alpha_services.Delegate.Baking_rights.timestamp := timestamp
|} := List.hd bakers in
_return
(pkh, priority, (Option.unopt_exn (OCaml.Failure "" % string) timestamp))).
Definition get_next_baker_excluding
(excludes :
list
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(block : t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
op_gtgteqquestion
(Alpha_services.Delegate.Baking_rights.get rpc_ctxt None None None None
(Some 256) block)
(fun bakers =>
let '{|
Alpha_services.Delegate.Baking_rights.delegate := pkh;
Alpha_services.Delegate.Baking_rights.priority := priority;
Alpha_services.Delegate.Baking_rights.timestamp := timestamp
|} :=
List.find
(fun function_parameter =>
let '{|
Alpha_services.Delegate.Baking_rights.delegate := delegate |} :=
function_parameter in
negb (List.mem delegate excludes)) bakers in
_return
(pkh, priority, (Option.unopt_exn (OCaml.Failure "" % string) timestamp))).
Definition dispatch_policy (function_parameter : baker_policy)
: t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
match function_parameter with
| By_priority p => get_next_baker_by_priority p
| By_account a => get_next_baker_by_account a
| Excluding al => get_next_baker_excluding al
end.
Definition get_next_baker (op_staroptstar : option baker_policy)
: t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
let policy :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => By_priority 0
end in
dispatch_policy policy.
Definition get_endorsing_power (b : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Z) :=
fold_left_s
(fun acc =>
fun op =>
let 'Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data data :=
protocol_data op in
match contents data with
|
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Endorsement _) =>
op_gtgteqquestion
(Alpha_services.Delegate.Endorsing_power.get rpc_ctxt b op
Chain_id.zero)
(fun endorsement_power => _return (Z.add acc endorsement_power))
| _ => _return acc
end) 0 (operations b).
Module Forge.
Record header := {
baker : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash;
shell :
Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.shell_header;
contents : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.contents
}.
Definition default_proof_of_work_nonce : Tezos_base__TzPervasives.MBytes.t :=
MBytes.create Constants.proof_of_work_nonce_size.
Definition make_contents
(op_staroptstar : option Tezos_base__TzPervasives.MBytes.t)
: Z ->
(option Tezos_raw_protocol_alpha.Nonce_hash.t) ->
unit ->
Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.contents :=
let proof_of_work_nonce :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_proof_of_work_nonce
end in
fun priority =>
fun seed_nonce_hash =>
fun function_parameter =>
let 'tt := function_parameter in
{| priority := priority; seed_nonce_hash := seed_nonce_hash;
proof_of_work_nonce := proof_of_work_nonce |}.
Definition make_shell
(level : Stdlib.Int32.t) (predecessor : Tezos_crypto.Block_hash.t)
(timestamp : Tezos_base.Time.Protocol.t) (fitness : Tezos_base.Fitness.t)
(operations_hash : Tezos_crypto.Operation_list_list_hash.t)
: Tezos_base.Block_header.shell_header :=
{| level := level; proto_level := 0; predecessor := predecessor;
timestamp := timestamp; validation_passes := 0;
operations_hash := operations_hash; fitness := fitness;
context := Context_hash.zero |}.
Definition set_seed_nonce_hash
(seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
(function_parameter : header) : header :=
let '{| baker := baker; shell := shell; contents := contents |} :=
function_parameter in
{| baker := baker; shell := shell;
contents :=
(* ❌ Record substitution not handled *)
record_substitution |}.
Definition set_baker
(baker : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
(header : header) : header :=
(* ❌ Record substitution not handled *)
record_substitution.
Definition sign_header (function_parameter : header)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t) :=
let '{| baker := baker; shell := shell; contents := contents |} :=
function_parameter in
op_gtgteqquestion (Account.find baker)
(fun delegate =>
let unsigned_bytes :=
Data_encoding.Binary.to_bytes_exn Block_header.unsigned_encoding
(shell, contents) in
let signature :=
Signature.sign
(Some
(Tezos_base__TzPervasives.Signature.Block_header Chain_id.zero))
(sk delegate) unsigned_bytes in
OCaml.Stdlib.reverse_apply
{| shell := shell;
protocol_data := {| contents := contents; signature := signature |}
|} _return).
Definition forge_header (op_staroptstar : option baker_policy)
: (option Tezos_protocol_environment_alpha__Environment.Time.t) ->
(option (list Tezos_raw_protocol_alpha__Alpha_context.packed_operation))
-> t -> Lwt.t (Tezos_base__TzPervasives.tzresult header) :=
let policy :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => By_priority 0
end in
fun timestamp =>
fun op_staroptstar =>
let operations :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun pred =>
op_gtgteqquestion (dispatch_policy policy pred)
(fun function_parameter =>
let '(pkh, priority, _timestamp) := function_parameter in
op_gtgteqquestion
(Alpha_services.Delegate.Minimal_valid_time.get rpc_ctxt pred
priority 0)
(fun expected_timestamp =>
let timestamp := Option.unopt expected_timestamp timestamp in
let level := Int32.succ (level (shell (header pred))) in
op_gtgteqquestion
match Fitness_repr.to_int64 (fitness (shell (header pred)))
with
| Stdlib.Ok old_fitness =>
_return
(Fitness_repr.from_int64
(Int64.add (Int64.of_int 1) old_fitness))
| Stdlib.Error _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end
(fun fitness =>
op_gtgteqquestion
(op_gtgtpipequestion
(Alpha_services.Helpers.current_level rpc_ctxt
(Some
(* ❌ Constant of type int32 is converted to int *)
1) pred)
(fun function_parameter =>
match function_parameter with
| {| expected_commitment := true |} =>
Some (fst (Proto_Nonce.generate tt))
| {| expected_commitment := false |} => None
end))
(fun seed_nonce_hash =>
let hashes :=
List.map Operation.hash_packed operations in
let operations_hash :=
Operation_list_list_hash.compute
(cons (Operation_list_hash.compute hashes) []) in
let shell :=
make_shell level (hash pred) timestamp fitness
operations_hash in
let contents :=
make_contents None priority seed_nonce_hash tt in
_return
{| baker := pkh; shell := shell;
contents := contents |})))).
Definition contents
(op_staroptstar : option Tezos_base__TzPervasives.MBytes.t)
: (option Z) ->
(option Tezos_raw_protocol_alpha.Nonce_hash.t) ->
unit ->
Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.contents :=
let proof_of_work_nonce :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_proof_of_work_nonce
end in
fun op_staroptstar =>
let priority :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 0
end in
fun seed_nonce_hash =>
fun function_parameter =>
let 'tt := function_parameter in
{| Block_header.priority := priority;
Block_header.seed_nonce_hash := seed_nonce_hash;
Block_header.proof_of_work_nonce := proof_of_work_nonce |}.
End Forge.
Definition protocol_param_key : list string :=
cons "protocol_parameters" % string [].
Definition check_constants_consistency
(constants : Tezos_protocol_alpha.Protocol.Constants_repr.parametric)
: Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
let '{|
blocks_per_cycle := blocks_per_cycle;
blocks_per_commitment := blocks_per_commitment;
blocks_per_roll_snapshot := blocks_per_roll_snapshot
|} := constants in
op_gtgteqquestion
(Error_monad.unless (OCaml.Stdlib.le blocks_per_commitment blocks_per_cycle)
(fun function_parameter =>
let 'tt := function_parameter in
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Inconsistent constants : blocks per commitment must be less than blocks per cycle"
% string CamlinternalFormatBasics.End_of_format)
"Inconsistent constants : blocks per commitment must be less than blocks per cycle"
% string)))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(Error_monad.unless
(OCaml.Stdlib.ge blocks_per_cycle blocks_per_roll_snapshot)
(fun function_parameter =>
let 'tt := function_parameter in
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Inconsistent constants : blocks per cycle must be superior than blocks per roll snapshot"
% string CamlinternalFormatBasics.End_of_format)
"Inconsistent constants : blocks per cycle must be superior than blocks per roll snapshot"
% string))) _return).
Definition initial_context (op_staroptstar : option bool)
: Tezos_protocol_alpha.Protocol.Constants_repr.parametric ->
Tezos_protocol_environment_alpha__Environment.Block_header.shell_header ->
(list
(Tezos_alpha_test_helpers.Account.t *
Tezos_protocol_alpha.Protocol.Tez_repr.t)) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_environment_alpha__Environment.Context.t) :=
let with_commitments :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun constants =>
fun header =>
fun initial_accounts =>
let bootstrap_accounts :=
List.map
(fun function_parameter =>
let '({| pkh := pkh; pk := pk |}, amount) := function_parameter in
Default_parameters.make_bootstrap_account (pkh, pk, amount))
initial_accounts in
let parameters :=
Default_parameters.parameters_of_constants (Some bootstrap_accounts)
None (Some with_commitments) constants in
let json := Default_parameters.json_of_parameters parameters in
let proto_params :=
Data_encoding.Binary.to_bytes_exn Data_encoding.json json in
op_gtgteq
(let empty := Memory_context.empty in
op_gtgteq
(set empty (cons "version" % string [])
(MBytes.of_string "genesis" % string))
(fun ctxt => set ctxt protocol_param_key proto_params))
(fun ctxt =>
op_gtgteqquestion
(op_gtpipeeq (Main.init ctxt header) Environment.wrap_error)
(fun function_parameter =>
let '{| context := context |} := function_parameter in
_return context)).
Definition genesis_with_parameters
(parameters : Tezos_protocol_alpha.Protocol.Parameters_repr.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
let hash :=
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" % string in
let shell :=
Forge.make_shell
(* ❌ Constant of type int32 is converted to int *)
0 hash Time.Protocol.epoch
(Fitness_repr.from_int64
(* ❌ Constant of type int64 is converted to int *)
0) Operation_list_list_hash.zero in
let contents := Forge.make_contents None 0 None tt in
let json := Default_parameters.json_of_parameters parameters in
let proto_params := Data_encoding.Binary.to_bytes_exn Data_encoding.json json
in
op_gtgteq
(let empty := Memory_context.empty in
op_gtgteq
(set empty (cons "version" % string [])
(MBytes.of_string "genesis" % string))
(fun ctxt => set ctxt protocol_param_key proto_params))
(fun ctxt =>
op_gtgteqquestion
(op_gtpipeeq (Main.init ctxt shell) Environment.wrap_error)
(fun function_parameter =>
let '{| context := context |} := function_parameter in
let block :=
{| hash := hash;
header :=
{| shell := shell;
protocol_data :=
{| contents := contents; signature := Signature.zero |} |};
operations := []; context := context |} in
_return block)).
Definition genesis
(with_commitments : option bool) (endorsers_per_block : option Z)
(initial_endorsers : option Z) (min_proposal_quorum : option int32)
(initial_accounts :
list
(Tezos_alpha_test_helpers.Account.t *
Tezos_protocol_alpha.Protocol.Tez_repr.t))
: Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if equiv_decb initial_accounts [] then
Pervasives.failwith "Must have one account with a roll to bake" % string
else
tt in
let constants := Default_parameters.constants_test in
let endorsers_per_block :=
Option.unopt (endorsers_per_block constants) endorsers_per_block in
let initial_endorsers :=
Option.unopt (initial_endorsers constants) initial_endorsers in
let min_proposal_quorum :=
Option.unopt (min_proposal_quorum constants) min_proposal_quorum in
let constants :=
(* ❌ Record substitution not handled *)
record_substitution in
op_gtgteqquestion
(* ❌ Try-with are not handled *)
(try
(op_gtgteqquestion
(fold_left_s
(fun acc =>
fun function_parameter =>
let '(_, amount) := function_parameter in
op_gtgtquestioneq
(apply Environment.wrap_error
(Tez_repr.op_plusquestion acc amount))
(fun acc =>
if OCaml.Stdlib.ge acc (tokens_per_roll constants) then
Stdlib.raise Exit
else
_return acc)) Tez_repr.zero initial_accounts)
(fun function_parameter =>
let '_ := function_parameter in
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Insufficient tokens in initial accounts to create one roll" %
string CamlinternalFormatBasics.End_of_format)
"Insufficient tokens in initial accounts to create one roll" %
string))))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (check_constants_consistency constants)
(fun function_parameter =>
let 'tt := function_parameter in
let hash :=
Block_hash.of_b58check_exn
"BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" % string in
let shell :=
Forge.make_shell
(* ❌ Constant of type int32 is converted to int *)
0 hash Time.Protocol.epoch
(Fitness_repr.from_int64
(* ❌ Constant of type int64 is converted to int *)
0) Operation_list_list_hash.zero in
let contents := Forge.make_contents None 0 None tt in
op_gtgteqquestion
(initial_context with_commitments constants shell initial_accounts)
(fun context =>
let block :=
{| hash := hash;
header :=
{| shell := shell;
protocol_data :=
{| contents := contents; signature := Signature.zero |}
|}; operations := []; context := context |} in
_return block))).
Definition apply
(header : Tezos_protocol_alpha.Protocol.Main.block_header)
(op_staroptstar :
option (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed))
: t -> Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
let operations :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun pred =>
op_gtgtpipequestion
(op_gtpipeeq
(op_gtgteqquestion
(Main.begin_application Chain_id.zero (context pred)
(timestamp (shell (header pred))) (fitness (shell (header pred)))
header)
(fun vstate =>
op_gtgteqquestion
(fold_left_s
(fun vstate =>
fun op =>
op_gtgteqquestion (apply_operation vstate op)
(fun function_parameter =>
let '(state, _result) := function_parameter in
_return state)) vstate operations)
(fun vstate =>
op_gtgteqquestion (Main.finalize_block vstate)
(fun function_parameter =>
let '(validation, _result) := function_parameter in
_return (context validation))))) Environment.wrap_error)
(fun context =>
let hash := Block_header.hash header in
{| hash := hash; header := header; operations := operations;
context := context |}).
Definition bake
(policy : option baker_policy)
(timestamp : option Tezos_protocol_environment_alpha__Environment.Time.t)
(operation :
option Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
(operations :
option (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed))
(pred : t) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
let operations :=
match (operation, operations) with
| (Some op, Some ops) => Some (cons op ops)
| (Some op, None) => Some (cons op [])
| (None, Some ops) => Some ops
| (None, None) => None
end in
op_gtgteqquestion (Forge.forge_header policy timestamp operations pred)
(fun header =>
op_gtgteqquestion (Forge.sign_header header)
(fun header => apply header operations pred)).
Definition get_constants (b : t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Constants.t) :=
Alpha_services.Constants.all rpc_ctxt b.
Definition bake_n (policy : option baker_policy) (n : Z) (b : t)
: Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult t) :=
Error_monad.fold_left_s
(fun b =>
fun function_parameter =>
let '_ := function_parameter in
bake policy None None None b) b (op_minusminus 1 n).
Definition bake_until_cycle_end (policy : option baker_policy) (b : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
op_gtgteqquestion (get_constants b)
(fun function_parameter =>
let '{| parametric := {| blocks_per_cycle := blocks_per_cycle |} |} :=
function_parameter in
let current_level := level (shell (header b)) in
let current_level := Int32.rem current_level blocks_per_cycle in
let delta := Int32.sub blocks_per_cycle current_level in
bake_n policy (Int32.to_int delta) b).
Definition bake_until_n_cycle_end (policy : option baker_policy) (n : Z) (b : t)
: Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult t) :=
Error_monad.fold_left_s
(fun b =>
fun function_parameter =>
let '_ := function_parameter in
bake_until_cycle_end policy b) b (op_minusminus 1 n).
Definition bake_until_cycle
(policy : option baker_policy)
(cycle : Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.cycle) (b : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
op_gtgteqquestion (get_constants b)
(fun function_parameter =>
let '{| parametric := {| blocks_per_cycle := blocks_per_cycle |} |} :=
function_parameter in
let fix loop (b : t) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
let current_cycle :=
let current_level := level (shell (header b)) in
let current_cycle := Int32.div current_level blocks_per_cycle in
current_cycle in
if Int32.equal (Cycle.to_int32 cycle) current_cycle then
_return b
else
op_gtgteqquestion (bake_until_cycle_end policy b) (fun b => loop b) in
loop b).
src/proto_alpha/lib_protocol/test/helpers/context.ml 81 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
type t = B of Block.t | I of Incremental.t
let branch = function B b -> b.hash | I i -> (Incremental.predecessor i).hash
let level = function B b -> b.header.shell.level | I i -> Incremental.level i
let get_level ctxt =
level ctxt |> Raw_level.of_int32 |> Environment.wrap_error |> Lwt.return
let rpc_ctxt =
object
method call_proto_service0
: 'm 'q 'i 'o.
( ([< RPC_service.meth] as 'm),
Environment.RPC_context.t,
Environment.RPC_context.t,
'q,
'i,
'o )
RPC_service.t -> t -> 'q -> 'i -> 'o tzresult Lwt.t =
fun s pr q i ->
match pr with
| B b ->
Block.rpc_ctxt#call_proto_service0 s b q i
| I b ->
Incremental.rpc_ctxt#call_proto_service0 s b q i
method call_proto_service1
: 'm 'a 'q 'i 'o.
( ([< RPC_service.meth] as 'm),
Environment.RPC_context.t,
Environment.RPC_context.t * 'a,
'q,
'i,
'o )
RPC_service.t -> t -> 'a -> 'q -> 'i -> 'o tzresult Lwt.t =
fun s pr a q i ->
match pr with
| B bl ->
Block.rpc_ctxt#call_proto_service1 s bl a q i
| I bl ->
Incremental.rpc_ctxt#call_proto_service1 s bl a q i
method call_proto_service2
: 'm 'a 'b 'q 'i 'o.
( ([< RPC_service.meth] as 'm),
Environment.RPC_context.t,
(Environment.RPC_context.t * 'a) * 'b,
'q,
'i,
'o )
RPC_service.t -> t -> 'a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t =
fun s pr a b q i ->
match pr with
| B bl ->
Block.rpc_ctxt#call_proto_service2 s bl a b q i
| I bl ->
Incremental.rpc_ctxt#call_proto_service2 s bl a b q i
method call_proto_service3
: 'm 'a 'b 'c 'q 'i 'o.
( ([< RPC_service.meth] as 'm),
Environment.RPC_context.t,
((Environment.RPC_context.t * 'a) * 'b) * 'c,
'q,
'i,
'o )
RPC_service.t -> t -> 'a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t
=
fun s pr a b c q i ->
match pr with
| B bl ->
Block.rpc_ctxt#call_proto_service3 s bl a b c q i
| I bl ->
Incremental.rpc_ctxt#call_proto_service3 s bl a b c q i
end
let get_endorsers ctxt =
Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt
let get_endorser ctxt =
Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt
>>=? fun endorsers ->
let endorser = List.hd endorsers in
return (endorser.delegate, endorser.slots)
let get_bakers ctxt =
Alpha_services.Delegate.Baking_rights.get ~max_priority:256 rpc_ctxt ctxt
>>=? fun bakers ->
return
(List.map
(fun p -> p.Alpha_services.Delegate.Baking_rights.delegate)
bakers)
let get_seed_nonce_hash ctxt =
let header =
match ctxt with B {header; _} -> header | I i -> Incremental.header i
in
match header.protocol_data.contents.seed_nonce_hash with
| None ->
failwith "No committed nonce"
| Some hash ->
return hash
let get_seed ctxt = Alpha_services.Seed.get rpc_ctxt ctxt
let get_constants ctxt = Alpha_services.Constants.all rpc_ctxt ctxt
let get_minimal_valid_time ctxt ~priority ~endorsing_power =
Alpha_services.Delegate.Minimal_valid_time.get
rpc_ctxt
ctxt
priority
endorsing_power
let get_baking_reward ctxt ~priority ~endorsing_power =
get_constants ctxt
>>=? fun Constants.{parametric = {block_reward; endorsers_per_block; _}; _} ->
let prio_factor_denominator = Int64.(succ (of_int priority)) in
let endo_factor_numerator =
Int64.of_int (8 + (2 * endorsing_power / endorsers_per_block))
in
let endo_factor_denominator = 10L in
Lwt.return
Test_tez.Tez.(
block_reward *? endo_factor_numerator
>>? fun val1 ->
val1 /? endo_factor_denominator
>>? fun val2 -> val2 /? prio_factor_denominator)
let get_endorsing_reward ctxt ~priority ~endorsing_power =
get_constants ctxt
>>=? fun Constants.{parametric = {endorsement_reward; _}; _} ->
let open Test_utils in
Test_tez.Tez.(
(endorsement_reward /? Int64.(succ (of_int priority)))
>>?= fun reward_per_slot ->
reward_per_slot *? Int64.of_int endorsing_power
>>?= fun reward -> return reward)
(* Voting *)
module Vote = struct
let get_ballots ctxt = Alpha_services.Voting.ballots rpc_ctxt ctxt
let get_ballot_list ctxt = Alpha_services.Voting.ballot_list rpc_ctxt ctxt
let get_voting_period ctxt =
Alpha_services.Helpers.current_level rpc_ctxt ~offset:1l ctxt
>>=? fun l -> return l.voting_period
let get_voting_period_position ctxt =
Alpha_services.Helpers.current_level rpc_ctxt ~offset:1l ctxt
>>=? fun l -> return l.voting_period_position
let get_current_period_kind ctxt =
Alpha_services.Voting.current_period_kind rpc_ctxt ctxt
let get_current_quorum ctxt =
Alpha_services.Voting.current_quorum rpc_ctxt ctxt
let get_listings ctxt = Alpha_services.Voting.listings rpc_ctxt ctxt
let get_proposals ctxt = Alpha_services.Voting.proposals rpc_ctxt ctxt
let get_current_proposal ctxt =
Alpha_services.Voting.current_proposal rpc_ctxt ctxt
let get_protocol (b : Block.t) =
Tezos_protocol_environment.Context.get b.context ["protocol"]
>>= function
| None ->
assert false
| Some p ->
Lwt.return (Protocol_hash.of_bytes_exn p)
let get_participation_ema (b : Block.t) =
Environment.Context.get b.context ["votes"; "participation_ema"]
>>= function
| None -> assert false | Some bytes -> return (MBytes.get_int32 bytes 0)
let set_participation_ema (b : Block.t) ema =
let bytes = Bytes.make 4 '\000' in
MBytes.set_int32 bytes 0 ema ;
Environment.Context.set b.context ["votes"; "participation_ema"] bytes
>>= fun context -> Lwt.return {b with context}
end
module Contract = struct
let pp = Alpha_context.Contract.pp
let pkh c =
Alpha_context.Contract.is_implicit c
|> function
| Some p -> return p | None -> failwith "pkh: only for implicit contracts"
type balance_kind = Main | Deposit | Fees | Rewards
let balance ?(kind = Main) ctxt contract =
match kind with
| Main ->
Alpha_services.Contract.balance rpc_ctxt ctxt contract
| _ -> (
match Alpha_context.Contract.is_implicit contract with
| None ->
invalid_arg
"get_balance: no frozen accounts for an originated contract."
| Some pkh ->
Alpha_services.Delegate.frozen_balance_by_cycle rpc_ctxt ctxt pkh
>>=? fun map ->
Lwt.return
@@ Cycle.Map.fold
(fun _cycle {Delegate.deposit; fees; rewards} acc ->
acc
>>? fun acc ->
match kind with
| Deposit ->
Test_tez.Tez.(acc +? deposit)
| Fees ->
Test_tez.Tez.(acc +? fees)
| Rewards ->
Test_tez.Tez.(acc +? rewards)
| _ ->
assert false)
map
(Ok Tez.zero) )
let counter ctxt contract =
match Contract.is_implicit contract with
| None ->
invalid_arg "Helpers.Context.counter"
| Some mgr ->
Alpha_services.Contract.counter rpc_ctxt ctxt mgr
let manager _ contract =
match Contract.is_implicit contract with
| None ->
invalid_arg "Helpers.Context.manager"
| Some pkh ->
Account.find pkh
let is_manager_key_revealed ctxt contract =
match Contract.is_implicit contract with
| None ->
invalid_arg "Helpers.Context.is_manager_key_revealed"
| Some mgr ->
Alpha_services.Contract.manager_key rpc_ctxt ctxt mgr
>>=? fun res -> return (res <> None)
let delegate ctxt contract =
Alpha_services.Contract.delegate rpc_ctxt ctxt contract
let delegate_opt ctxt contract =
Alpha_services.Contract.delegate_opt rpc_ctxt ctxt contract
end
module Delegate = struct
type info = Delegate_services.info = {
balance : Tez.t;
frozen_balance : Tez.t;
frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t;
staking_balance : Tez.t;
delegated_contracts : Contract_repr.t list;
delegated_balance : Tez.t;
deactivated : bool;
grace_period : Cycle.t;
}
let info ctxt pkh = Alpha_services.Delegate.info rpc_ctxt ctxt pkh
end
let init ?endorsers_per_block ?with_commitments ?(initial_balances = [])
?initial_endorsers ?min_proposal_quorum n =
let accounts = Account.generate_accounts ~initial_balances n in
let contracts =
List.map
(fun (a, _) -> Alpha_context.Contract.implicit_contract Account.(a.pkh))
accounts
in
Block.genesis
?endorsers_per_block
?with_commitments
?initial_endorsers
?min_proposal_quorum
accounts
>>=? fun blk -> return (blk, contracts)
src/proto_alpha/lib_protocol/test/helpers/context.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Inductive t : Type :=
| B : Tezos_alpha_test_helpers.Block.t -> t
| I : Tezos_alpha_test_helpers.Incremental.t -> t.
Definition branch (function_parameter : t)
: Tezos_base__TzPervasives.Block_hash.t :=
match function_parameter with
| B b => hash b
| I i => hash (Incremental.predecessor i)
end.
Definition level (function_parameter : t)
: Tezos_protocol_environment_alpha__Environment.Int32.t :=
match function_parameter with
| B b => level (shell (header b))
| I i => Incremental.level i
end.
Definition get_level (ctxt : t)
: Lwt.t
(Tezos_base__TzPervasives.Error_monad.tzresult
Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.raw_level) :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply (level ctxt) Raw_level.of_int32)
Environment.wrap_error) Lwt._return.
Definition rpc_ctxt {D F H J a b c i o q : Type}
: ((((Tezos_base__TzPervasives.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
t -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o)) *
(D * q * i * o)) *
((((Tezos_base__TzPervasives.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
t -> a -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o)) *
(F * a * q * i * o)) *
((((Tezos_base__TzPervasives.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
o) ->
t -> a -> b -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o)) *
(H * a * b * q * i * o)) *
((((Tezos_base__TzPervasives.RPC_service.t variant
Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
(((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
c) q i o) ->
t ->
a -> b -> c -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o))
* (J * a * b * c * q * i * o)) * nil)))) :=
(* ❌ Creation of objects is not handled *)
object.
Definition get_endorsers (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(list
Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Endorsing_rights.t)) :=
Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt None None None ctxt.
Definition get_endorser (ctxt : t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* (list Z))) :=
op_gtgteqquestion
(Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt None None None ctxt)
(fun endorsers =>
let endorser := List.hd endorsers in
_return ((delegate endorser), (slots endorser))).
Definition get_bakers (ctxt : t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(list
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
op_gtgteqquestion
(Alpha_services.Delegate.Baking_rights.get rpc_ctxt None None None None
(Some 256) ctxt)
(fun bakers =>
_return
(List.map (fun p => Alpha_services.Delegate.Baking_rights.delegate p)
bakers)).
Definition get_seed_nonce_hash (ctxt : t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_raw_protocol_alpha.Nonce_hash.t) :=
let header :=
match ctxt with
| B {| header := header |} => header
| I i => Incremental.header i
end in
match seed_nonce_hash (contents (protocol_data header)) with
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal "No committed nonce" % string
CamlinternalFormatBasics.End_of_format) "No committed nonce" % string)
| Some hash => _return hash
end.
Definition get_seed (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Seed.seed) :=
Alpha_services.Seed.get rpc_ctxt ctxt.
Definition get_constants (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Constants.t) :=
Alpha_services.Constants.all rpc_ctxt ctxt.
Definition get_minimal_valid_time
(ctxt : t) (priority : Z) (endorsing_power : Z)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_environment_alpha__Environment.Time.t) :=
Alpha_services.Delegate.Minimal_valid_time.get rpc_ctxt ctxt priority
endorsing_power.
Definition get_baking_reward (ctxt : t) (priority : Z) (endorsing_power : Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_alpha_test_helpers.Test_tez.Tez.tez) :=
op_gtgteqquestion (get_constants ctxt)
(fun function_parameter =>
let '{|
parametric := {|
endorsers_per_block := endorsers_per_block;
block_reward := block_reward
|}
|} := function_parameter in
let prio_factor_denominator := succ (of_int priority) in
let endo_factor_numerator :=
Int64.of_int
(Z.add 8 (Z.div (Z.mul 2 endorsing_power) endorsers_per_block)) in
let endo_factor_denominator :=
(* ❌ Constant of type int64 is converted to int *)
10 in
Lwt._return
(op_gtgtquestion (op_starquestion block_reward endo_factor_numerator)
(fun val1 =>
op_gtgtquestion (op_divquestion val1 endo_factor_denominator)
(fun val2 => op_divquestion val2 prio_factor_denominator)))).
Definition get_endorsing_reward (ctxt : t) (priority : Z) (endorsing_power : Z)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_alpha_test_helpers.Test_tez.Tez.tez) :=
op_gtgteqquestion (get_constants ctxt)
(fun function_parameter =>
let '{| parametric := {| endorsement_reward := endorsement_reward |} |} :=
function_parameter in
op_gtgtquestioneq
(op_divquestion endorsement_reward (succ (of_int priority)))
(fun reward_per_slot =>
op_gtgtquestioneq
(op_starquestion reward_per_slot (Int64.of_int endorsing_power))
(fun reward => _return reward))).
Module Vote.
Definition get_ballots (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Vote.ballots) :=
Alpha_services.Voting.ballots rpc_ctxt ctxt.
Definition get_ballot_list (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(list
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot))) :=
Alpha_services.Voting.ballot_list rpc_ctxt ctxt.
Definition get_voting_period (ctxt : t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_raw_protocol_alpha__Alpha_context.Voting_period.t) :=
op_gtgteqquestion
(Alpha_services.Helpers.current_level rpc_ctxt
(Some
(* ❌ Constant of type int32 is converted to int *)
1) ctxt) (fun l => _return (voting_period l)).
Definition get_voting_period_position (ctxt : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult int32) :=
op_gtgteqquestion
(Alpha_services.Helpers.current_level rpc_ctxt
(Some
(* ❌ Constant of type int32 is converted to int *)
1) ctxt) (fun l => _return (voting_period_position l)).
Definition get_current_period_kind (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind) :=
Alpha_services.Voting.current_period_kind rpc_ctxt ctxt.
Definition get_current_quorum (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_environment_alpha__Environment.Int32.t) :=
Alpha_services.Voting.current_quorum rpc_ctxt ctxt.
Definition get_listings (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(list
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* int32))) := Alpha_services.Voting.listings rpc_ctxt ctxt.
Definition get_proposals (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t
Tezos_protocol_environment_alpha__Environment.Int32.t)) :=
Alpha_services.Voting.proposals rpc_ctxt ctxt.
Definition get_current_proposal (ctxt : t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(option
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))) :=
Alpha_services.Voting.current_proposal rpc_ctxt ctxt.
Definition get_protocol (b : Tezos_alpha_test_helpers.Block.t)
: Lwt.t Tezos_base__TzPervasives.Protocol_hash.t :=
op_gtgteq
(Tezos_protocol_environment.Context.get (context b)
(cons "protocol" % string []))
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some p => Lwt._return (Protocol_hash.of_bytes_exn p)
end).
Definition get_participation_ema (b : Tezos_alpha_test_helpers.Block.t)
: Lwt.t (Tezos_base__TzPervasives.tzresult int32) :=
op_gtgteq
(Environment.Context.get (context b)
(cons "votes" % string (cons "participation_ema" % string [])))
(fun function_parameter =>
match function_parameter with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some bytes => _return (MBytes.get_int32 string 0)
end).
Definition set_participation_ema
(b : Tezos_alpha_test_helpers.Block.t) (ema : int32)
: Lwt.t Tezos_alpha_test_helpers.Block.t :=
let bytes := Stdlib.Bytes.make 4 "000" % char in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := MBytes.set_int32 string 0 ema in
op_gtgteq
(Environment.Context.set (context b)
(cons "votes" % string (cons "participation_ema" % string [])) string)
(fun context =>
Lwt._return
(* ❌ Record substitution not handled *)
record_substitution).
End Vote.
Module Contract.
Definition pp
: Tezos_protocol_environment_alpha__Environment.Format.formatter ->
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t -> unit :=
Alpha_context.Contract.pp.
Definition pkh
(c : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_raw_protocol_alpha__Alpha_context.public_key_hash) :=
OCaml.Stdlib.reverse_apply (Alpha_context.Contract.is_implicit c)
(fun function_parameter =>
match function_parameter with
| Some p => _return p
| None =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"pkh: only for implicit contracts" % string
CamlinternalFormatBasics.End_of_format)
"pkh: only for implicit contracts" % string)
end).
Inductive balance_kind : Type :=
| Main : balance_kind
| Deposit : balance_kind
| Fees : balance_kind
| Rewards : balance_kind.
Definition balance (op_staroptstar : option balance_kind)
: t ->
Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
let kind :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Main
end in
fun ctxt =>
fun contract =>
match kind with
| Main => Alpha_services.Contract.balance rpc_ctxt ctxt contract
| _ =>
match Alpha_context.Contract.is_implicit contract with
| None =>
OCaml.Stdlib.invalid_arg
"get_balance: no frozen accounts for an originated contract." %
string
| Some pkh =>
op_gtgteqquestion
(Alpha_services.Delegate.frozen_balance_by_cycle rpc_ctxt ctxt pkh)
(fun map =>
apply Lwt._return
(Cycle.Map.fold
(fun _cycle =>
fun function_parameter =>
let '{|
Delegate.deposit := deposit;
Delegate.fees := fees;
Delegate.rewards := rewards
|} := function_parameter in
fun acc =>
op_gtgtquestion acc
(fun acc =>
match kind with
| Deposit => op_plusquestion acc deposit
| Fees => op_plusquestion acc fees
| Rewards => op_plusquestion acc rewards
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end)) map (Stdlib.Ok Tez.zero)))
end
end.
Definition counter
(ctxt : t)
(contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.counter) :=
match Contract.is_implicit contract with
| None => OCaml.Stdlib.invalid_arg "Helpers.Context.counter" % string
| Some mgr => Alpha_services.Contract.counter rpc_ctxt ctxt mgr
end.
Definition manager {A : Type} (function_parameter : A)
: Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract ->
Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_alpha_test_helpers.Account.t) :=
let '_ := function_parameter in
fun contract =>
match Contract.is_implicit contract with
| None => OCaml.Stdlib.invalid_arg "Helpers.Context.manager" % string
| Some pkh => Account.find pkh
end.
Definition is_manager_key_revealed
(ctxt : t)
(contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
: Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
match Contract.is_implicit contract with
| None =>
OCaml.Stdlib.invalid_arg
"Helpers.Context.is_manager_key_revealed" % string
| Some mgr =>
op_gtgteqquestion (Alpha_services.Contract.manager_key rpc_ctxt ctxt mgr)
(fun res => _return (nequiv_decb res None))
end.
Definition delegate
(ctxt : t) (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) :=
Alpha_services.Contract.delegate rpc_ctxt ctxt contract.
Definition delegate_opt
(ctxt : t) (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)) :=
Alpha_services.Contract.delegate_opt rpc_ctxt ctxt contract.
End Contract.
Module Delegate.
Record info := {
balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
frozen_balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
frozen_balance_by_cycle :
Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.Map.t
Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.frozen_balance;
staking_balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
delegated_contracts : list Tezos_protocol_alpha.Protocol.Contract_repr.t;
delegated_balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
deactivated : bool;
grace_period : Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.t }.
Definition info
(ctxt : t)
(pkh :
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.info) :=
Alpha_services.Delegate.info rpc_ctxt ctxt pkh.
End Delegate.
Definition init
(endorsers_per_block : option Z) (with_commitments : option bool)
(op_staroptstar : option (list int64))
: (option Z) ->
(option int32) ->
Z ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_alpha_test_helpers.Block.block *
(list
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract))) :=
let initial_balances :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => []
end in
fun initial_endorsers =>
fun min_proposal_quorum =>
fun n =>
let accounts := Account.generate_accounts (Some initial_balances) n in
let contracts :=
List.map
(fun function_parameter =>
let '(a, _) := function_parameter in
Alpha_context.Contract.implicit_contract (pkh a)) accounts in
op_gtgteqquestion
(Block.genesis with_commitments endorsers_per_block initial_endorsers
min_proposal_quorum accounts) (fun blk => _return (blk, contracts)).
src/proto_alpha/lib_protocol/test/helpers/incremental.ml 15 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
type t = {
predecessor : Block.t;
state : validation_state;
rev_operations : Operation.packed list;
rev_tickets : operation_receipt list;
header : Block_header.t;
delegate : Account.t;
}
type incremental = t
let predecessor {predecessor; _} = predecessor
let header {header; _} = header
let rev_tickets {rev_tickets; _} = rev_tickets
let level st = st.header.shell.level
let rpc_context st =
let result = Alpha_context.finalize st.state.ctxt in
{
Environment.Updater.block_hash = Block_hash.zero;
block_header = {st.header.shell with fitness = result.fitness};
context = result.context;
}
let rpc_ctxt =
new Environment.proto_rpc_context_of_directory rpc_context rpc_services
let begin_construction ?(priority = 0) ?timestamp ?seed_nonce_hash
?(policy = Block.By_priority priority) (predecessor : Block.t) =
Block.get_next_baker ~policy predecessor
>>=? fun (delegate, priority, _timestamp) ->
Alpha_services.Delegate.Minimal_valid_time.get
Block.rpc_ctxt
predecessor
priority
0
>>=? fun real_timestamp ->
Account.find delegate
>>=? fun delegate ->
let timestamp = Option.unopt ~default:real_timestamp timestamp in
let contents = Block.Forge.contents ~priority ?seed_nonce_hash () in
let protocol_data = {Block_header.contents; signature = Signature.zero} in
let header =
{
Block_header.shell =
{
predecessor = predecessor.hash;
proto_level = predecessor.header.shell.proto_level;
validation_passes = predecessor.header.shell.validation_passes;
fitness = predecessor.header.shell.fitness;
timestamp;
level = predecessor.header.shell.level;
context = Context_hash.zero;
operations_hash = Operation_list_list_hash.zero;
};
protocol_data = {contents; signature = Signature.zero};
}
in
begin_construction
~chain_id:Chain_id.zero
~predecessor_context:predecessor.context
~predecessor_timestamp:predecessor.header.shell.timestamp
~predecessor_fitness:predecessor.header.shell.fitness
~predecessor_level:predecessor.header.shell.level
~predecessor:predecessor.hash
~timestamp
~protocol_data
()
>>= fun state ->
Lwt.return (Environment.wrap_error state)
>>=? fun state ->
return
{
predecessor;
state;
rev_operations = [];
rev_tickets = [];
header;
delegate;
}
let detect_script_failure :
type kind. kind Apply_results.operation_metadata -> _ =
let rec detect_script_failure :
type kind. kind Apply_results.contents_result_list -> _ =
let open Apply_results in
let detect_script_failure_single (type kind)
(Manager_operation_result
{operation_result; internal_operation_results; _} :
kind Kind.manager Apply_results.contents_result) =
let detect_script_failure (type kind)
(result : kind manager_operation_result) =
match result with
| Applied _ ->
Ok ()
| Skipped _ ->
assert false
| Backtracked (_, None) ->
(* there must be another error for this to happen *)
Ok ()
| Backtracked (_, Some errs) ->
Environment.wrap_error (Error errs)
| Failed (_, errs) ->
Environment.wrap_error (Error errs)
in
List.fold_left
(fun acc (Internal_operation_result (_, r)) ->
acc >>? fun () -> detect_script_failure r)
(detect_script_failure operation_result)
internal_operation_results
in
function
| Single_result (Manager_operation_result _ as res) ->
detect_script_failure_single res
| Single_result _ ->
Ok ()
| Cons_result (res, rest) ->
detect_script_failure_single res
>>? fun () -> detect_script_failure rest
in
fun {contents} -> detect_script_failure contents
let add_operation ?expect_failure st op =
let open Apply_results in
apply_operation st.state op
>>= fun x ->
Lwt.return (Environment.wrap_error x)
>>=? function
| (state, (Operation_metadata result as metadata)) ->
Lwt.return @@ detect_script_failure result
>>= fun result ->
( match expect_failure with
| None ->
Lwt.return result
| Some f -> (
match result with
| Ok _ ->
failwith "Error expected while adding operation"
| Error e ->
f e ) )
>>=? fun () ->
return
{
st with
state;
rev_operations = op :: st.rev_operations;
rev_tickets = metadata :: st.rev_tickets;
}
| (state, (No_operation_metadata as metadata)) ->
return
{
st with
state;
rev_operations = op :: st.rev_operations;
rev_tickets = metadata :: st.rev_tickets;
}
let finalize_block st =
finalize_block st.state
>>= fun x ->
Lwt.return (Environment.wrap_error x)
>>=? fun (result, _) ->
let operations = List.rev st.rev_operations in
let operations_hash =
Operation_list_list_hash.compute
[Operation_list_hash.compute (List.map Operation.hash_packed operations)]
in
let header =
{
st.header with
shell =
{
st.header.shell with
level = Int32.succ st.header.shell.level;
operations_hash;
fitness = result.fitness;
};
}
in
let hash = Block_header.hash header in
return {Block.hash; header; operations; context = result.context}
src/proto_alpha/lib_protocol/test/helpers/incremental.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Record t := {
predecessor : Tezos_alpha_test_helpers.Block.t;
state : Tezos_protocol_alpha.Protocol.validation_state;
rev_operations :
list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed;
rev_tickets : list Tezos_protocol_alpha.Protocol.operation_receipt;
header : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t;
delegate : Tezos_alpha_test_helpers.Account.t }.
Definition incremental := t.
Definition predecessor (function_parameter : t)
: Tezos_alpha_test_helpers.Block.t :=
let '{| predecessor := predecessor |} := function_parameter in
predecessor.
Definition header (function_parameter : t)
: Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t :=
let '{| header := header |} := function_parameter in
header.
Definition rev_tickets (function_parameter : t)
: list Tezos_protocol_alpha.Protocol.operation_receipt :=
let '{| rev_tickets := rev_tickets |} := function_parameter in
rev_tickets.
Definition level (st : t)
: Tezos_protocol_environment_alpha__Environment.Int32.t :=
level (shell (header st)).
Definition rpc_context (st : t)
: Tezos_protocol_alpha.Protocol.Environment.Updater.rpc_context :=
let result := Alpha_context.finalize None (ctxt (state st)) in
{| Environment.Updater.block_hash := Block_hash.zero;
Environment.Updater.block_header :=
(* ❌ Record substitution not handled *)
record_substitution; Environment.Updater.context := context result |}.
Definition rpc_ctxt
: Tezos_protocol_alpha.Protocol.Environment.proto_rpc_context_of_directory t :=
(* ❌ Creation of new objects is not handled *)
new rpc_context rpc_services.
Definition begin_construction (op_staroptstar : option Z)
: (option Tezos_protocol_environment_alpha__Environment.Time.t) ->
(option Tezos_protocol_alpha.Protocol.Nonce_hash.t) ->
(option Tezos_alpha_test_helpers.Block.baker_policy) ->
Tezos_alpha_test_helpers.Block.t ->
Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
let priority :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => 0
end in
fun timestamp =>
fun seed_nonce_hash =>
fun op_staroptstar =>
let policy :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Tezos_alpha_test_helpers.Block.By_priority priority
end in
fun predecessor =>
op_gtgteqquestion (Block.get_next_baker (Some policy) predecessor)
(fun function_parameter =>
let '(delegate, priority, _timestamp) := function_parameter in
op_gtgteqquestion
(Alpha_services.Delegate.Minimal_valid_time.get Block.rpc_ctxt
predecessor priority 0)
(fun real_timestamp =>
op_gtgteqquestion (Account.find delegate)
(fun delegate =>
let timestamp := Option.unopt real_timestamp timestamp in
let contents :=
Block.Forge.contents None (Some priority)
seed_nonce_hash tt in
let protocol_data :=
{| Block_header.contents := contents;
Block_header.signature := Signature.zero |} in
let header :=
{|
Block_header.shell :=
{| level := level (shell (header predecessor));
proto_level :=
proto_level (shell (header predecessor));
predecessor := hash predecessor;
timestamp := timestamp;
validation_passes :=
validation_passes (shell (header predecessor));
operations_hash := Operation_list_list_hash.zero;
fitness := fitness (shell (header predecessor));
context := Context_hash.zero |};
Block_header.protocol_data :=
{| contents := contents; signature := Signature.zero
|} |} in
op_gtgteq
(begin_construction Chain_id.zero (context predecessor)
(timestamp (shell (header predecessor)))
(level (shell (header predecessor)))
(fitness (shell (header predecessor)))
(hash predecessor) timestamp (Some protocol_data) tt)
(fun state =>
op_gtgteqquestion
(Lwt._return (Environment.wrap_error state))
(fun state =>
_return
{| predecessor := predecessor; state := state;
rev_operations := []; rev_tickets := [];
header := header; delegate := delegate |}))))).
Definition detect_script_failure {kind : Type}
: (Tezos_protocol_alpha.Protocol.Apply_results.operation_metadata kind) ->
Tezos_base__TzPervasives.tzresult unit :=
let detect_script_failure :=
let detect_script_failure_single {B : Type}
(function_parameter :
Tezos_protocol_alpha.Protocol.Apply_results.contents_result
(Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager B))
: Tezos_base__TzPervasives.tzresult unit :=
let
'Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result {|
operation_result := operation_result;
internal_operation_results := internal_operation_results
|} := function_parameter in
let detect_script_failure {C : Type}
(result :
Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result C)
: sum unit Tezos_base__TzPervasives.Error_monad.trace :=
match result with
| Tezos_protocol_alpha.Protocol.Apply_results.Applied _ => Stdlib.Ok tt
| Tezos_protocol_alpha.Protocol.Apply_results.Skipped _ =>
(* ❌ Assert instruction is not handled. *)
assert false
| Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ None =>
Stdlib.Ok tt
| Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ (Some errs)
=> Environment.wrap_error (Stdlib.Error errs)
| Tezos_protocol_alpha.Protocol.Apply_results.Failed _ errs =>
Environment.wrap_error (Stdlib.Error errs)
end in
List.fold_left
(fun acc =>
fun function_parameter =>
let
'Tezos_protocol_alpha.Protocol.Apply_results.Internal_operation_result
_ r := function_parameter in
op_gtgtquestion acc
(fun function_parameter =>
let 'tt := function_parameter in
detect_script_failure r))
(detect_script_failure operation_result) internal_operation_results in
fun function_parameter =>
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Apply_results.Single_result
((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
_) as res) => detect_script_failure_single res
| Tezos_protocol_alpha.Protocol.Apply_results.Single_result _ =>
Stdlib.Ok tt
| Tezos_protocol_alpha.Protocol.Apply_results.Cons_result res rest =>
op_gtgtquestion (detect_script_failure_single res)
(fun function_parameter =>
let 'tt := function_parameter in
detect_script_failure rest)
end in
fun function_parameter =>
let '{| contents := contents |} := function_parameter in
detect_script_failure contents.
Definition add_operation
(expect_failure :
option
(Tezos_base__TzPervasives.trace ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit))) (st : t)
(op : Tezos_protocol_alpha.Protocol.operation)
: Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
op_gtgteq (apply_operation (state st) op)
(fun x =>
op_gtgteqquestion (Lwt._return (Environment.wrap_error x))
(fun function_parameter =>
match function_parameter with
|
(state,
(Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata
result) as metadata) =>
op_gtgteq (apply Lwt._return (detect_script_failure result))
(fun result =>
op_gtgteqquestion
match expect_failure with
| None => Lwt._return result
| Some f =>
match result with
| Stdlib.Ok _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Error expected while adding operation" % string
CamlinternalFormatBasics.End_of_format)
"Error expected while adding operation" % string)
| Stdlib.Error e => f e
end
end
(fun function_parameter =>
let 'tt := function_parameter in
_return
(* ❌ Record substitution not handled *)
record_substitution))
|
(state,
Tezos_protocol_alpha.Protocol.Apply_results.No_operation_metadata
as metadata) =>
_return
(* ❌ Record substitution not handled *)
record_substitution
end)).
Definition finalize_block (st : t)
: Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_alpha_test_helpers.Block.t) :=
op_gtgteq (finalize_block (state st))
(fun x =>
op_gtgteqquestion (Lwt._return (Environment.wrap_error x))
(fun function_parameter =>
let '(result, _) := function_parameter in
let operations := List.rev (rev_operations st) in
let operations_hash :=
Operation_list_list_hash.compute
(cons
(Operation_list_hash.compute
(List.map Operation.hash_packed operations)) []) in
let header :=
(* ❌ Record substitution not handled *)
record_substitution in
let hash := Block_header.hash header in
_return
{| Block.hash := hash; Block.header := header;
Block.operations := operations; Block.context := context result |})).
src/proto_alpha/lib_protocol/test/helpers/nonce.ml 9 errors
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2018. *)
(* Dynamic Ledger Solutions, Inc.< contact@tezos.com > *)
(* *)
(* All rights reserved.No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Protocol
module Table = Hashtbl.Make (struct
type t = Nonce_hash.t
let hash h = Int32.to_int (MBytes.get_int32 (Nonce_hash.to_bytes h) 0)
let equal = Nonce_hash.equal
end)
let known_nonces = Table.create 17
let generate () =
match
Alpha_context.Nonce.of_bytes
@@ Rand.generate Alpha_context.Constants.nonce_length
with
| Ok nonce ->
let hash = Alpha_context.Nonce.hash nonce in
Table.add known_nonces hash nonce ;
(hash, nonce)
| Error _ ->
assert false
let forget_all () = Table.clear known_nonces
let get hash = Table.find known_nonces hash
src/proto_alpha/lib_protocol/test/helpers/nonce.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
(* ❌ Applications of functors are not handled. *)
functor_application
Definition known_nonces
: Table.t Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
Table.create 17.
Definition generate (function_parameter : unit)
: Tezos_raw_protocol_alpha.Nonce_hash.t *
Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
let 'tt := function_parameter in
match
apply Alpha_context.Nonce.of_bytes
(Rand.generate Alpha_context.Constants.nonce_length) with
| Stdlib.Ok nonce =>
let hash := Alpha_context.Nonce.hash nonce in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := Table.add known_nonces hash nonce in
(hash, nonce)
| Stdlib.Error _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end.
Definition forget_all (function_parameter : unit) : unit :=
let 'tt := function_parameter in
Table.clear known_nonces.
Definition get (hash : Table.key)
: Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
Table.find known_nonces hash.
src/proto_alpha/lib_protocol/test/helpers/op.ml 91 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
let sign ?(watermark = Signature.Generic_operation) sk ctxt contents =
let branch = Context.branch ctxt in
let unsigned =
Data_encoding.Binary.to_bytes_exn
Operation.unsigned_encoding
({branch}, Contents_list contents)
in
let signature = Some (Signature.sign ~watermark sk unsigned) in
({shell = {branch}; protocol_data = {contents; signature}} : _ Operation.t)
let endorsement ?delegate ?level ctxt ?(signing_context = ctxt) () =
( match delegate with
| None ->
Context.get_endorser ctxt >>=? fun (delegate, _slots) -> return delegate
| Some delegate ->
return delegate )
>>=? fun delegate_pkh ->
Account.find delegate_pkh
>>=? fun delegate ->
( match level with
| None ->
Context.get_level ctxt
| Some level ->
return level )
>>=? fun level ->
let op = Single (Endorsement {level}) in
return
(sign
~watermark:Signature.(Endorsement Chain_id.zero)
delegate.sk
signing_context
op)
let sign ?watermark sk ctxt (Contents_list contents) =
Operation.pack (sign ?watermark sk ctxt contents)
let combine_operations ?public_key ?counter ~source ctxt
(packed_operations : packed_operation list) =
assert (List.length packed_operations > 0) ;
(* Hypothesis : each operation must have the same branch (is this really true?) *)
let {Tezos_base.Operation.branch} = (List.hd packed_operations).shell in
assert (
List.for_all
(fun {shell = {Tezos_base.Operation.branch = b; _}; _} ->
Block_hash.(branch = b))
packed_operations ) ;
(* TODO? : check signatures consistency *)
let unpacked_operations =
List.map
(function
| {Alpha_context.protocol_data = Operation_data {contents; _}; _} -> (
match Contents_list contents with
| Contents_list (Single o) ->
Contents o
| Contents_list
(Cons (Manager_operation {operation = Reveal _; _}, Single o)) ->
Contents o
| _ ->
(* TODO : decent error *) assert false ))
packed_operations
in
( match counter with
| Some counter ->
return counter
| None ->
Context.Contract.counter ctxt source )
>>=? fun counter ->
(* We increment the counter *)
let counter = Z.succ counter in
Context.Contract.manager ctxt source
>>=? fun account ->
let public_key = Option.unopt ~default:account.pk public_key in
Context.Contract.is_manager_key_revealed ctxt source
>>=? (function
| false ->
let reveal_op =
Manager_operation
{
source = Signature.Public_key.hash public_key;
fee = Tez.zero;
counter;
operation = Reveal public_key;
gas_limit = Z.of_int 10000;
storage_limit = Z.zero;
}
in
return (Some (Contents reveal_op), Z.succ counter)
| true ->
return (None, counter))
>>=? fun (manager_op, counter) ->
(* Update counters and transform into a contents_list *)
let operations =
List.fold_left
(fun (counter, acc) -> function Contents (Manager_operation m) ->
( Z.succ counter,
Contents (Manager_operation {m with counter}) :: acc ) | x ->
(counter, x :: acc))
(counter, match manager_op with None -> [] | Some op -> [op])
unpacked_operations
|> snd |> List.rev
in
let operations = Operation.of_list operations in
return @@ sign account.sk ctxt operations
let manager_operation ?counter ?(fee = Tez.zero) ?gas_limit ?storage_limit
?public_key ~source ctxt operation =
( match counter with
| Some counter ->
return counter
| None ->
Context.Contract.counter ctxt source )
>>=? fun counter ->
Context.get_constants ctxt
>>=? fun c ->
let gas_limit =
Option.unopt
~default:c.parametric.hard_storage_limit_per_operation
gas_limit
in
let storage_limit =
Option.unopt
~default:c.parametric.hard_storage_limit_per_operation
storage_limit
in
Context.Contract.manager ctxt source
>>=? fun account ->
let public_key = Option.unopt ~default:account.pk public_key in
let counter = Z.succ counter in
Context.Contract.is_manager_key_revealed ctxt source
>>=? function
| true ->
let op =
Manager_operation
{
source = Signature.Public_key.hash public_key;
fee;
counter;
operation;
gas_limit;
storage_limit;
}
in
return (Contents_list (Single op))
| false ->
let op_reveal =
Manager_operation
{
source = Signature.Public_key.hash public_key;
fee = Tez.zero;
counter;
operation = Reveal public_key;
gas_limit = Z.of_int 10000;
storage_limit = Z.zero;
}
in
let op =
Manager_operation
{
source = Signature.Public_key.hash public_key;
fee;
counter = Z.succ counter;
operation;
gas_limit;
storage_limit;
}
in
return (Contents_list (Cons (op_reveal, Single op)))
let revelation ctxt public_key =
let pkh = Signature.Public_key.hash public_key in
let source = Contract.implicit_contract pkh in
Context.Contract.counter ctxt source
>>=? fun counter ->
Context.Contract.manager ctxt source
>>=? fun account ->
let counter = Z.succ counter in
let sop =
Contents_list
(Single
(Manager_operation
{
source = Signature.Public_key.hash public_key;
fee = Tez.zero;
counter;
operation = Reveal public_key;
gas_limit = Z.of_int 10000;
storage_limit = Z.zero;
}))
in
return @@ sign account.sk ctxt sop
let originated_contract op =
let nonce = Contract.initial_origination_nonce (Operation.hash_packed op) in
Contract.originated_contract nonce
exception Impossible
let origination ?counter ?delegate ~script ?(preorigination = None) ?public_key
?credit ?fee ?gas_limit ?storage_limit ctxt source =
Context.Contract.manager ctxt source
>>=? fun account ->
let default_credit = Tez.of_mutez @@ Int64.of_int 1000001 in
let default_credit = Option.unopt_exn Impossible default_credit in
let credit = Option.unopt ~default:default_credit credit in
let operation = Origination {delegate; script; credit; preorigination} in
manager_operation
?counter
?public_key
?fee
?gas_limit
?storage_limit
~source
ctxt
operation
>>=? fun sop ->
let op = sign account.sk ctxt sop in
return (op, originated_contract op)
let miss_signed_endorsement ?level ctxt =
( match level with
| None ->
Context.get_level ctxt
| Some level ->
return level )
>>=? fun level ->
Context.get_endorser ctxt
>>=? fun (real_delegate_pkh, _slots) ->
let delegate = Account.find_alternate real_delegate_pkh in
endorsement ~delegate:delegate.pkh ~level ctxt ()
let transaction ?fee ?gas_limit ?storage_limit
?(parameters = Script.unit_parameter) ?(entrypoint = "default") ctxt
(src : Contract.t) (dst : Contract.t) (amount : Tez.t) =
let top = Transaction {amount; parameters; destination = dst; entrypoint} in
manager_operation ?fee ?gas_limit ?storage_limit ~source:src ctxt top
>>=? fun sop ->
Context.Contract.manager ctxt src
>>=? fun account -> return @@ sign account.sk ctxt sop
let delegation ?fee ctxt source dst =
let top = Delegation dst in
manager_operation ?fee ~source ctxt top
>>=? fun sop ->
Context.Contract.manager ctxt source
>>=? fun account -> return @@ sign account.sk ctxt sop
let activation ctxt (pkh : Signature.Public_key_hash.t) activation_code =
( match pkh with
| Ed25519 edpkh ->
return edpkh
| _ ->
failwith
"Wrong public key hash : %a - Commitments must be activated with an \
Ed25519 encrypted public key hash"
Signature.Public_key_hash.pp
pkh )
>>=? fun id ->
let contents = Single (Activate_account {id; activation_code}) in
let branch = Context.branch ctxt in
return
{
shell = {branch};
protocol_data = Operation_data {contents; signature = None};
}
let double_endorsement ctxt op1 op2 =
let contents = Single (Double_endorsement_evidence {op1; op2}) in
let branch = Context.branch ctxt in
return
{
shell = {branch};
protocol_data = Operation_data {contents; signature = None};
}
let double_baking ctxt bh1 bh2 =
let contents = Single (Double_baking_evidence {bh1; bh2}) in
let branch = Context.branch ctxt in
return
{
shell = {branch};
protocol_data = Operation_data {contents; signature = None};
}
let seed_nonce_revelation ctxt level nonce =
return
{
shell = {branch = Context.branch ctxt};
protocol_data =
Operation_data
{
contents = Single (Seed_nonce_revelation {level; nonce});
signature = None;
};
}
let proposals ctxt (pkh : Contract.t) proposals =
Context.Contract.pkh pkh
>>=? fun source ->
Context.Vote.get_voting_period ctxt
>>=? fun period ->
let op = Proposals {source; period; proposals} in
Account.find source
>>=? fun account -> return (sign account.sk ctxt (Contents_list (Single op)))
let ballot ctxt (pkh : Contract.t) proposal ballot =
Context.Contract.pkh pkh
>>=? fun source ->
Context.Vote.get_voting_period ctxt
>>=? fun period ->
let op = Ballot {source; period; proposal; ballot} in
Account.find source
>>=? fun account -> return (sign account.sk ctxt (Contents_list (Single op)))
let dummy_script =
let open Micheline in
Script.
{
code =
lazy_expr
(strip_locations
(Seq
( 0,
[ Prim (0, K_parameter, [Prim (0, T_unit, [], [])], []);
Prim (0, K_storage, [Prim (0, T_unit, [], [])], []);
Prim
( 0,
K_code,
[ Seq
( 0,
[ Prim (0, I_CDR, [], []);
Prim
( 0,
I_NIL,
[Prim (0, T_operation, [], [])],
[] );
Prim (0, I_PAIR, [], []) ] ) ],
[] ) ] )));
storage = lazy_expr (strip_locations (Prim (0, D_Unit, [], [])));
}
let dummy_script_cost = Test_tez.Tez.of_mutez_exn 38_000L
src/proto_alpha/lib_protocol/test/helpers/op.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Definition sign {A : Type}
(op_staroptstar : option Tezos_base__TzPervasives.Signature.watermark)
: Tezos_base__TzPervasives.Signature.Secret_key.t ->
Tezos_alpha_test_helpers.Context.t ->
(Tezos_protocol_alpha.Protocol.Alpha_context.contents_list A) ->
Tezos_protocol_alpha.Protocol.Alpha_context.Operation.t A :=
let watermark :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Tezos_base__TzPervasives.Signature.Generic_operation
end in
fun sk =>
fun ctxt =>
fun contents =>
let branch := Context.branch ctxt in
let unsigned :=
Data_encoding.Binary.to_bytes_exn Operation.unsigned_encoding
({| branch := branch |},
(Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
contents)) in
let signature := Some (Signature.sign (Some watermark) sk unsigned) in
{| shell := {| branch := branch |};
protocol_data := {| contents := contents; signature := signature |} |}.
Definition endorsement
(delegate : option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
(level : option Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
(ctxt : Tezos_alpha_test_helpers.Context.t)
(op_staroptstar : option Tezos_alpha_test_helpers.Context.t)
: unit ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_protocol_alpha.Protocol.Alpha_context.Operation.t
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)) :=
let signing_context :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => ctxt
end in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
match delegate with
| None =>
op_gtgteqquestion (Context.get_endorser ctxt)
(fun function_parameter =>
let '(delegate, _slots) := function_parameter in
_return delegate)
| Some delegate => _return delegate
end
(fun delegate_pkh =>
op_gtgteqquestion (Account.find delegate_pkh)
(fun delegate =>
op_gtgteqquestion
match level with
| None => Context.get_level ctxt
| Some level => _return level
end
(fun level =>
let op :=
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Endorsement
{| level := level |}) in
_return
(sign
(Some
(Tezos_base__TzPervasives.Signature.Endorsement
Chain_id.zero)) (sk delegate) signing_context op)))).
Definition sign
(watermark : option Tezos_base__TzPervasives.Signature.watermark)
(sk : Tezos_base__TzPervasives.Signature.Secret_key.t)
(ctxt : Tezos_alpha_test_helpers.Context.t)
(function_parameter :
Tezos_protocol_alpha.Protocol.Alpha_context.packed_contents_list)
: Tezos_raw_protocol_alpha__Alpha_context.packed_operation :=
let 'Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list contents :=
function_parameter in
Operation.pack (sign watermark sk ctxt contents).
Definition combine_operations
(public_key : option Tezos_base__TzPervasives.Signature.Public_key.t)
(counter : option Tezos_protocol_alpha.Protocol.Environment.Z.t)
(source : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
(ctxt : Tezos_alpha_test_helpers.Context.t)
(packed_operations :
list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert (OCaml.Stdlib.gt (List.length packed_operations) 0) in
let '{| Tezos_base.Operation.branch := branch |} :=
shell (List.hd packed_operations) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ Assert instruction is not handled. *)
assert
(List.for_all
(fun function_parameter =>
let '{| shell := {| Tezos_base.Operation.branch := b |} |} :=
function_parameter in
op_eq branch b) packed_operations) in
let unpacked_operations :=
List.map
(fun function_parameter =>
let '{|
Alpha_context.protocol_data :=
Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data {|
contents := contents |}
|} := function_parameter in
match Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list contents
with
|
Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
(Tezos_protocol_alpha.Protocol.Alpha_context.Single o) =>
Tezos_protocol_alpha.Protocol.Alpha_context.Contents o
|
Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
(Tezos_protocol_alpha.Protocol.Alpha_context.Cons
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation {|
operation := Tezos_protocol_alpha.Protocol.Alpha_context.Reveal _
|}) (Tezos_protocol_alpha.Protocol.Alpha_context.Single o)) =>
Tezos_protocol_alpha.Protocol.Alpha_context.Contents o
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end) packed_operations in
op_gtgteqquestion
match counter with
| Some counter => _return counter
| None => Context.Contract.counter ctxt source
end
(fun counter =>
let counter := Z.succ counter in
op_gtgteqquestion (Context.Contract.manager ctxt source)
(fun account =>
let public_key := Option.unopt (pk account) public_key in
op_gtgteqquestion
(op_gtgteqquestion
(Context.Contract.is_manager_key_revealed ctxt source)
(fun function_parameter =>
match function_parameter with
| false =>
let reveal_op :=
Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
{| source := Signature.Public_key.hash public_key;
fee := Tez.zero; counter := counter;
operation :=
Tezos_protocol_alpha.Protocol.Alpha_context.Reveal
public_key; gas_limit := Z.of_int 10000;
storage_limit := Z.zero |} in
_return
((Some
(Tezos_protocol_alpha.Protocol.Alpha_context.Contents
reveal_op)), (Z.succ counter))
| true => _return (None, counter)
end))
(fun function_parameter =>
let '(manager_op, counter) := function_parameter in
let operations :=
OCaml.Stdlib.reverse_apply
(OCaml.Stdlib.reverse_apply
(List.fold_left
(fun function_parameter =>
let '(counter, acc) := function_parameter in
fun function_parameter =>
match function_parameter with
|
Tezos_protocol_alpha.Protocol.Alpha_context.Contents
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
m) =>
((Z.succ counter),
(cons
(Tezos_protocol_alpha.Protocol.Alpha_context.Contents
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
(* ❌ Record substitution not handled *)
record_substitution)) acc))
| x => (counter, (cons x acc))
end)
(counter,
match manager_op with
| None => []
| Some op => cons op []
end) unpacked_operations) snd) List.rev in
let operations := Operation.of_list operations in
apply _return (sign None (sk account) ctxt operations)))).
Definition manager_operation {A : Type}
(counter : option Tezos_protocol_alpha.Protocol.Environment.Z.t)
(op_staroptstar : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
: (option Tezos_protocol_environment_alpha__Environment.Z.t) ->
(option Tezos_protocol_environment_alpha__Environment.Z.t) ->
(option Tezos_base__TzPervasives.Signature.Public_key.t) ->
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
Tezos_alpha_test_helpers.Context.t ->
(Tezos_protocol_alpha.Protocol.Alpha_context.manager_operation A) ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_alpha.Protocol.Alpha_context.packed_contents_list) :=
let fee :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Tez.zero
end in
fun gas_limit =>
fun storage_limit =>
fun public_key =>
fun source =>
fun ctxt =>
fun operation =>
op_gtgteqquestion
match counter with
| Some counter => _return counter
| None => Context.Contract.counter ctxt source
end
(fun counter =>
op_gtgteqquestion (Context.get_constants ctxt)
(fun c =>
let gas_limit :=
Option.unopt
(hard_storage_limit_per_operation (parametric c))
gas_limit in
let storage_limit :=
Option.unopt
(hard_storage_limit_per_operation (parametric c))
storage_limit in
op_gtgteqquestion (Context.Contract.manager ctxt source)
(fun account =>
let public_key := Option.unopt (pk account) public_key
in
let counter := Z.succ counter in
op_gtgteqquestion
(Context.Contract.is_manager_key_revealed ctxt
source)
(fun function_parameter =>
match function_parameter with
| true =>
let op :=
Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
{|
source :=
Signature.Public_key.hash public_key;
fee := fee; counter := counter;
operation := operation;
gas_limit := gas_limit;
storage_limit := storage_limit |} in
_return
(Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
(Tezos_protocol_alpha.Protocol.Alpha_context.Single
op))
| false =>
let op_reveal :=
Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
{|
source :=
Signature.Public_key.hash public_key;
fee := Tez.zero; counter := counter;
operation :=
Tezos_protocol_alpha.Protocol.Alpha_context.Reveal
public_key;
gas_limit := Z.of_int 10000;
storage_limit := Z.zero |} in
let op :=
Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
{|
source :=
Signature.Public_key.hash public_key;
fee := fee; counter := Z.succ counter;
operation := operation;
gas_limit := gas_limit;
storage_limit := storage_limit |} in
_return
(Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
(Tezos_protocol_alpha.Protocol.Alpha_context.Cons
op_reveal
(Tezos_protocol_alpha.Protocol.Alpha_context.Single
op)))
end)))).
Definition revelation
(ctxt : Tezos_alpha_test_helpers.Context.t)
(public_key : Tezos_base__TzPervasives.Signature.Public_key.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
let pkh := Signature.Public_key.hash public_key in
let source := Contract.implicit_contract pkh in
op_gtgteqquestion (Context.Contract.counter ctxt source)
(fun counter =>
op_gtgteqquestion (Context.Contract.manager ctxt source)
(fun account =>
let counter := Z.succ counter in
let sop :=
Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
(Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
{| source := Signature.Public_key.hash public_key;
fee := Tez.zero; counter := counter;
operation :=
Tezos_protocol_alpha.Protocol.Alpha_context.Reveal
public_key; gas_limit := Z.of_int 10000;
storage_limit := Z.zero |})) in
apply _return (sign None (sk account) ctxt sop))).
Definition originated_contract
(op : Tezos_raw_protocol_alpha__Alpha_context.packed_operation)
: Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract :=
let nonce := Contract.initial_origination_nonce (Operation.hash_packed op) in
Contract.originated_contract nonce.
(* ❌ The definition of exceptions is not handled. *)
exception
Definition origination
(counter : option Tezos_protocol_alpha.Protocol.Environment.Z.t)
(delegate :
option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
(script : Tezos_protocol_alpha.Protocol.Alpha_context.Script.t)
(op_staroptstar :
option (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))
: (option Tezos_base__TzPervasives.Signature.Public_key.t) ->
(option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
(option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
(option Tezos_protocol_environment_alpha__Environment.Z.t) ->
(option Tezos_protocol_environment_alpha__Environment.Z.t) ->
Tezos_alpha_test_helpers.Context.t ->
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_raw_protocol_alpha__Alpha_context.packed_operation *
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)) :=
let preorigination :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => None
end in
fun public_key =>
fun credit =>
fun fee =>
fun gas_limit =>
fun storage_limit =>
fun ctxt =>
fun source =>
op_gtgteqquestion (Context.Contract.manager ctxt source)
(fun account =>
let default_credit :=
apply Tez.of_mutez (Int64.of_int 1000001) in
let default_credit :=
Option.unopt_exn Impossible default_credit in
let credit := Option.unopt default_credit credit in
let operation :=
Tezos_protocol_alpha.Protocol.Alpha_context.Origination
{| delegate := delegate; script := script;
credit := credit; preorigination := preorigination |}
in
op_gtgteqquestion
(manager_operation counter fee gas_limit storage_limit
public_key source ctxt operation)
(fun sop =>
let op := sign None (sk account) ctxt sop in
_return (op, (originated_contract op)))).
Definition miss_signed_endorsement
(level : option Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
(ctxt : Tezos_alpha_test_helpers.Context.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
(Tezos_protocol_alpha.Protocol.Alpha_context.Operation.t
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)) :=
op_gtgteqquestion
match level with
| None => Context.get_level ctxt
| Some level => _return level
end
(fun level =>
op_gtgteqquestion (Context.get_endorser ctxt)
(fun function_parameter =>
let '(real_delegate_pkh, _slots) := function_parameter in
let delegate := Account.find_alternate real_delegate_pkh in
endorsement (Some (pkh delegate)) (Some level) ctxt None tt)).
Definition transaction
(fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
(gas_limit : option Tezos_protocol_environment_alpha__Environment.Z.t)
(storage_limit : option Tezos_protocol_environment_alpha__Environment.Z.t)
(op_staroptstar :
option Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr)
: (option string) ->
Tezos_alpha_test_helpers.Context.t ->
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
let parameters :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Script.unit_parameter
end in
fun op_staroptstar =>
let entrypoint :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "default" % string
end in
fun ctxt =>
fun src =>
fun dst =>
fun amount =>
let top :=
Tezos_protocol_alpha.Protocol.Alpha_context.Transaction
{| amount := amount; parameters := parameters;
entrypoint := entrypoint; destination := dst |} in
op_gtgteqquestion
(manager_operation None fee gas_limit storage_limit None src ctxt
top)
(fun sop =>
op_gtgteqquestion (Context.Contract.manager ctxt src)
(fun account =>
apply _return (sign None (sk account) ctxt sop))).
Definition delegation
(fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
(ctxt : Tezos_alpha_test_helpers.Context.t)
(source : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
(dst :
option
Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
let top := Tezos_protocol_alpha.Protocol.Alpha_context.Delegation dst in
op_gtgteqquestion (manager_operation None fee None None None source ctxt top)
(fun sop =>
op_gtgteqquestion (Context.Contract.manager ctxt source)
(fun account => apply _return (sign None (sk account) ctxt sop))).
Definition activation
(ctxt : Tezos_alpha_test_helpers.Context.t)
(pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
(activation_code :
Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) :=
op_gtgteqquestion
match pkh with
| Tezos_crypto__Signature.Ed25519 edpkh => _return edpkh
| _ =>
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Wrong public key hash : " % string
(CamlinternalFormatBasics.Alpha
(CamlinternalFormatBasics.String_literal
" - Commitments must be activated with an Ed25519 encrypted public key hash"
% string CamlinternalFormatBasics.End_of_format)))
"Wrong public key hash : %a - Commitments must be activated with an Ed25519 encrypted public key hash"
% string) Signature.Public_key_hash.pp pkh
end
(fun id =>
let contents :=
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Activate_account
{| id := id; activation_code := activation_code |}) in
let branch := Context.branch ctxt in
_return
{| shell := {| branch := branch |};
protocol_data :=
Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data
{| contents := contents; signature := None |} |}).
Definition double_endorsement
(ctxt : Tezos_alpha_test_helpers.Context.t)
(op1 :
Tezos_protocol_alpha.Protocol.Alpha_context.operation
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)
(op2 :
Tezos_protocol_alpha.Protocol.Alpha_context.operation
Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) :=
let contents :=
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Double_endorsement_evidence
{| op1 := op1; op2 := op2 |}) in
let branch := Context.branch ctxt in
_return
{| shell := {| branch := branch |};
protocol_data :=
Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data
{| contents := contents; signature := None |} |}.
Definition double_baking
(ctxt : Tezos_alpha_test_helpers.Context.t)
(bh1 : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t)
(bh2 : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) :=
let contents :=
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Double_baking_evidence
{| bh1 := bh1; bh2 := bh2 |}) in
let branch := Context.branch ctxt in
_return
{| shell := {| branch := branch |};
protocol_data :=
Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data
{| contents := contents; signature := None |} |}.
Definition seed_nonce_revelation
(ctxt : Tezos_alpha_test_helpers.Context.t)
(level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
(nonce : Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) :=
_return
{| shell := {| branch := Context.branch ctxt |};
protocol_data :=
Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data
{|
contents :=
Tezos_protocol_alpha.Protocol.Alpha_context.Single
(Tezos_protocol_alpha.Protocol.Alpha_context.Seed_nonce_revelation
{| level := level; nonce := nonce |}); signature := None |} |}.
Definition proposals
(ctxt : Tezos_alpha_test_helpers.Context.t)
(pkh : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
(proposals :
list
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
op_gtgteqquestion (Context.Contract.pkh pkh)
(fun source =>
op_gtgteqquestion (Context.Vote.get_voting_period ctxt)
(fun period =>
let op :=
Tezos_protocol_alpha.Protocol.Alpha_context.Proposals
{| source := source; period := period; proposals := proposals |}
in
op_gtgteqquestion (Account.find source)
(fun account =>
_return
(sign None (sk account) ctxt
(Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
(Tezos_protocol_alpha.Protocol.Alpha_context.Single op)))))).
Definition ballot
(ctxt : Tezos_alpha_test_helpers.Context.t)
(pkh : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
(proposal :
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(ballot : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballot)
: Lwt.t
(Tezos_base__TzPervasives.tzresult
Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
op_gtgteqquestion (Context.Contract.pkh pkh)
(fun source =>
op_gtgteqquestion (Context.Vote.get_voting_period ctxt)
(fun period =>
let op :=
Tezos_protocol_alpha.Protocol.Alpha_context.Ballot
{| source := source; period := period; proposal := proposal;
ballot := ballot |} in
op_gtgteqquestion (Account.find source)
(fun account =>
_return
(sign None (sk account) ctxt
(Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
(Tezos_protocol_alpha.Protocol.Alpha_context.Single op)))))).
Definition dummy_script
: Tezos_protocol_alpha.Protocol.Alpha_context.Script.t :=
{|
code :=
lazy_expr
(strip_locations
(Tezos_micheline.Micheline.Seq 0
(cons
(Tezos_micheline.Micheline.Prim 0
Tezos_protocol_alpha.Protocol.Alpha_context.Script.K_parameter
(cons
(Tezos_micheline.Micheline.Prim 0
Tezos_protocol_alpha.Protocol.Alpha_context.Script.T_unit []
[]) []) [])
(cons
(Tezos_micheline.Micheline.Prim 0
Tezos_protocol_alpha.Protocol.Alpha_context.Script.K_storage
(cons
(Tezos_micheline.Micheline.Prim 0
Tezos_protocol_alpha.Protocol.Alpha_context.Script.T_unit
[] []) []) [])
(cons
(Tezos_micheline.Micheline.Prim 0
Tezos_protocol_alpha.Protocol.Alpha_context.Script.K_code
(cons
(Tezos_micheline.Micheline.Seq 0
(cons
(Tezos_micheline.Micheline.Prim 0
Tezos_protocol_alpha.Protocol.Alpha_context.Script.I_CDR
[] [])
(cons
(Tezos_micheline.Micheline.Prim 0
Tezos_protocol_alpha.Protocol.Alpha_context.Script.I_NIL
(cons
(Tezos_micheline.Micheline.Prim 0
Tezos_protocol_alpha.Protocol.Alpha_context.Script.T_operation
[] []) []) [])
(cons
(Tezos_micheline.Micheline.Prim 0
Tezos_protocol_alpha.Protocol.Alpha_context.Script.I_PAIR
[] []) [])))) []) []) [])))));
storage :=
lazy_expr
(strip_locations
(Tezos_micheline.Micheline.Prim 0
Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Unit [] [])) |}.
Definition dummy_script_cost
: Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
Test_tez.Tez.of_mutez_exn
(* ❌ Constant of type int64 is converted to int *)
38000.
src/proto_alpha/lib_protocol/test/helpers/test_tez.ml 12 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Environment
(* This module is mostly to wrap the errors from the protocol *)
module Tez = struct
include Tez
let ( +? ) t1 t2 = t1 +? t2 |> wrap_error
let ( -? ) t1 t2 = t1 -? t2 |> wrap_error
let ( *? ) t1 t2 = t1 *? t2 |> wrap_error
let ( /? ) t1 t2 = t1 /? t2 |> wrap_error
let ( + ) t1 t2 =
match t1 +? t2 with
| Ok r ->
r
| Error _ ->
Pervasives.failwith "adding tez"
let of_int x =
match Tez.of_mutez (Int64.mul (Int64.of_int x) 1_000_000L) with
| None ->
invalid_arg "tez_of_int"
| Some x ->
x
let of_mutez_exn x =
match Tez.of_mutez x with
| None ->
invalid_arg "tez_of_mutez"
| Some x ->
x
let max_tez =
match Tez.of_mutez Int64.max_int with None -> assert false | Some p -> p
end
src/proto_alpha/lib_protocol/test/helpers/test_tez.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Import Environment.
Module Tez.
(* ❌ Structure item `include` not handled. *)
include
Definition op_plusquestion (t1 : tez) (t2 : tez)
: Tezos_base__TzPervasives.Error_monad.tzresult tez :=
OCaml.Stdlib.reverse_apply (op_plusquestion t1 t2) wrap_error.
Definition op_minusquestion (t1 : tez) (t2 : tez)
: Tezos_base__TzPervasives.Error_monad.tzresult tez :=
OCaml.Stdlib.reverse_apply (op_minusquestion t1 t2) wrap_error.
Definition op_starquestion (t1 : tez) (t2 : int64)
: Tezos_base__TzPervasives.Error_monad.tzresult tez :=
OCaml.Stdlib.reverse_apply (op_starquestion t1 t2) wrap_error.
Definition op_divquestion (t1 : tez) (t2 : int64)
: Tezos_base__TzPervasives.Error_monad.tzresult tez :=
OCaml.Stdlib.reverse_apply (op_divquestion t1 t2) wrap_error.
Definition op_plus (t1 : tez) (t2 : tez) : tez :=
match op_plusquestion t1 t2 with
| Stdlib.Ok r => r
| Stdlib.Error _ => Pervasives.failwith "adding tez" % string
end.
Definition of_int (x : Z)
: Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
match
Tez.of_mutez
(Int64.mul (Int64.of_int x)
(* ❌ Constant of type int64 is converted to int *)
1000000) with
| None => OCaml.Stdlib.invalid_arg "tez_of_int" % string
| Some x => x
end.
Definition of_mutez_exn (x : int64)
: Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
match Tez.of_mutez x with
| None => OCaml.Stdlib.invalid_arg "tez_of_mutez" % string
| Some x => x
end.
Definition max_tez : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
match Tez.of_mutez Int64.max_int with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some p => p
end.
End Tez.
src/proto_alpha/lib_protocol/test/helpers/test_utils.ml 1 error
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* This file should not depend on any other file from tests. *)
let ( >>?= ) x y = match x with Ok a -> y a | Error b -> fail @@ List.hd b
(** Like List.find but returns the index of the found element *)
let findi p =
let rec aux p i = function
| [] ->
raise Not_found
| x :: l ->
if p x then (x, i) else aux p (i + 1) l
in
aux p 0
exception Pair_of_list
let pair_of_list = function [a; b] -> (a, b) | _ -> raise Pair_of_list
src/proto_alpha/lib_protocol/test/helpers/test_utils.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition op_gtgtquestioneq {A B : Type}
(x : sum A (list Tezos_base__TzPervasives.error))
(y : A -> Lwt.t (Tezos_base__TzPervasives.tzresult B))
: Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
match x with
| Stdlib.Ok a => y a
| Stdlib.Error b => apply fail (List.hd b)
end.
Definition findi {A : Type} (p : A -> bool) : (list A) -> A * Z :=
let fix aux {B : Type} (p : B -> bool) (i : Z) (function_parameter : list B)
: B * Z :=
match function_parameter with
| [] => Stdlib.raise OCaml.Not_found
| cons x l =>
if p x then
(x, i)
else
aux p (Z.add i 1) l
end in
aux p 0.
(* ❌ The definition of exceptions is not handled. *)
exception
Definition pair_of_list {A : Type} (function_parameter : list A) : A * A :=
match function_parameter with
| cons a (cons b []) => (a, b)
| _ => Stdlib.raise Pair_of_list
end.
src/proto_alpha/lib_protocol/test/main.ml 16 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let () =
Alcotest.run
"protocol_alpha"
[ ("transfer", Transfer.tests);
("origination", Origination.tests);
("activation", Activation.tests);
("endorsement", Endorsement.tests);
("double endorsement", Double_endorsement.tests);
("double baking", Double_baking.tests);
("seed", Seed.tests);
("baking", Baking.tests);
("delegation", Delegation.tests);
("rolls", Rolls.tests);
("combined", Combined_operations.tests);
("qty", Qty.tests);
("voting", Voting.tests) ]
src/proto_alpha/lib_protocol/test/main.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations.
src/proto_alpha/lib_protocol/test/origination.ml 118 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Test_utils
open Test_tez
let ten_tez = Tez.of_int 10
(** [register_origination fee credit spendable delegatable] takes four
optional parameter: fee for the fee need to be paid if set to
create an originated contract; credit is the amount of tez that
send to this originated contract; spendable default is set to true
meaning that this contract is spendable; delegatable default is
set to true meaning that this contract is able to delegate. *)
let register_origination ?(fee = Tez.zero) ?(credit = Tez.zero) () =
Context.init 1
>>=? fun (b, contracts) ->
let source = List.hd contracts in
Context.Contract.balance (B b) source
>>=? fun source_balance ->
Op.origination (B b) source ~fee ~credit ~script:Op.dummy_script
>>=? fun (operation, originated) ->
Block.bake ~operation b
>>=? fun b ->
(* fee + credit + block security deposit were debited from source *)
Context.get_constants (B b)
>>=? fun { parametric =
{origination_size; cost_per_byte; block_security_deposit; _};
_ } ->
Tez.(cost_per_byte *? Int64.of_int origination_size)
>>?= fun origination_burn ->
Lwt.return
( Tez.( +? ) credit block_security_deposit
>>? Tez.( +? ) fee
>>? Tez.( +? ) origination_burn
>>? Tez.( +? ) Op.dummy_script_cost )
>>=? fun total_fee ->
Assert.balance_was_debited ~loc:__LOC__ (B b) source source_balance total_fee
>>=? fun () ->
(* originated contract has been credited *)
Assert.balance_was_credited ~loc:__LOC__ (B b) originated Tez.zero credit
>>=? fun () ->
(* TODO spendable or not and delegatable or not if relevant for some
test. Not the case at the moment, cf. uses of
register_origination *)
return (b, source, originated)
(* [test_origination_balances fee credit spendable delegatable]
takes four optional parameter: fee is the fee that pay if require to create
an originated contract; credit is the amount of tez that will send to this
contract; delegatable default is set to true meaning that this contract is
able to delegate.
This function will create a contract, get the balance of this contract, call
the origination operation to create a new originated contract from this
contract with all the possible fees; and check the balance before/after
originated operation valid.
- the source contract has payed all the fees
- the originated has been credited correctly *)
let test_origination_balances ~loc:_ ?(fee = Tez.zero) ?(credit = Tez.zero) ()
=
Context.init 1
>>=? fun (b, contracts) ->
let contract = List.hd contracts in
Context.Contract.balance (B b) contract
>>=? fun balance ->
Op.origination (B b) contract ~fee ~credit ~script:Op.dummy_script
>>=? fun (operation, new_contract) ->
(* The possible fees are: a given credit, an origination burn fee
(constants_repr.default.origination_burn = 257 mtez),
a fee that is paid when creating an originate contract.
We also take into account a block security deposit. Note that it
is not related to origination but to the baking done in the
tests.*)
Context.get_constants (B b)
>>=? fun { parametric =
{origination_size; cost_per_byte; block_security_deposit; _};
_ } ->
Tez.(cost_per_byte *? Int64.of_int origination_size)
>>?= fun origination_burn ->
Lwt.return
( Tez.( +? ) credit block_security_deposit
>>? Tez.( +? ) fee
>>? Tez.( +? ) origination_burn
>>? Tez.( +? ) Op.dummy_script_cost )
>>=? fun total_fee ->
Block.bake ~operation b
>>=? fun b ->
(* check that after the block has been baked the source contract
was debited all the fees *)
Assert.balance_was_debited ~loc:__LOC__ (B b) contract balance total_fee
>>=? fun _ ->
(* check the balance of the originate contract is equal to credit *)
Assert.balance_is ~loc:__LOC__ (B b) new_contract credit
(******************************************************)
(** Tests *)
(******************************************************)
(** compute half of the balance and divided it by nth times *)
let two_nth_of_balance incr contract nth =
Context.Contract.balance (I incr) contract
>>=? fun balance ->
Tez.( /? ) balance nth
>>?= fun res -> Tez.( *? ) res 2L >>?= fun balance -> return balance
(*******************)
(** Basic test *)
(*******************)
let balances_simple () = test_origination_balances ~loc:__LOC__ ()
let balances_credit () =
test_origination_balances ~loc:__LOC__ ~credit:ten_tez ()
let balances_credit_fee () =
test_origination_balances ~loc:__LOC__ ~credit:(Tez.of_int 2) ~fee:ten_tez ()
let balances_undelegatable () = test_origination_balances ~loc:__LOC__ ()
(*******************)
(** ask source contract to pay a fee when originating a contract *)
(*******************)
let pay_fee () =
register_origination ~credit:(Tez.of_int 2) ~fee:ten_tez ()
>>=? fun (_b, _contract, _new_contract) -> return_unit
(******************************************************)
(** Errors *)
(******************************************************)
(*******************)
(** create an originate contract where the contract
does not have enough tez to pay for the fee *)
(*******************)
let not_tez_in_contract_to_pay_fee () =
Context.init 2
>>=? fun (b, contracts) ->
let contract_1 = List.nth contracts 0 in
let contract_2 = List.nth contracts 1 in
Incremental.begin_construction b
>>=? fun inc ->
(* transfer everything but one tez from 1 to 2 and check balance of 1 *)
Context.Contract.balance (I inc) contract_1
>>=? fun balance ->
Lwt.return @@ Tez.( -? ) balance Tez.one
>>=? fun amount ->
Op.transaction (I inc) contract_1 contract_2 amount
>>=? fun operation ->
Incremental.add_operation inc operation
>>=? fun inc ->
Assert.balance_was_debited ~loc:__LOC__ (I inc) contract_1 balance amount
>>=? fun _ ->
(* use this source contract to create an originate contract where it requires
to pay a fee and add an amount of credit into this new contract *)
Op.origination
(I inc)
~fee:ten_tez
~credit:Tez.one
contract_1
~script:Op.dummy_script
>>=? fun (op, _) ->
Incremental.add_operation inc op
>>= fun inc ->
Assert.proto_error ~loc:__LOC__ inc (function
| Contract_storage.Balance_too_low _ ->
true
| _ ->
false)
(***************************************************)
(* set the endorser of the block as manager/delegate of the originated
account *)
(***************************************************)
let register_contract_get_endorser () =
Context.init 1
>>=? fun (b, contracts) ->
let contract = List.hd contracts in
Incremental.begin_construction b
>>=? fun inc ->
Context.get_endorser (I inc)
>>=? fun (account_endorser, _slots) ->
return (inc, contract, account_endorser)
(*******************)
(** create multiple originated contracts and
ask contract to pay the fee *)
(*******************)
let n_originations n ?credit ?fee () =
fold_left_s
(fun new_contracts _ ->
register_origination ?fee ?credit ()
>>=? fun (_b, _source, new_contract) ->
let contracts = new_contract :: new_contracts in
return contracts)
[]
(1 -- n)
let multiple_originations () =
n_originations 100 ~credit:(Tez.of_int 2) ~fee:ten_tez ()
>>=? fun contracts ->
Assert.equal_int ~loc:__LOC__ (List.length contracts) 100
(*******************)
(** cannot originate two contracts with the same context's counter *)
(*******************)
let counter () =
Context.init 1
>>=? fun (b, contracts) ->
let contract = List.hd contracts in
Incremental.begin_construction b
>>=? fun inc ->
Op.origination (I inc) ~credit:Tez.one contract ~script:Op.dummy_script
>>=? fun (op1, _) ->
Op.origination (I inc) ~credit:Tez.one contract ~script:Op.dummy_script
>>=? fun (op2, _) ->
Incremental.add_operation inc op1
>>=? fun inc ->
Incremental.add_operation inc op2
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Contract_storage.Counter_in_the_past _ ->
true
| _ ->
false)
(******************************************************)
let tests =
[ Test.tztest "balances_simple" `Quick balances_simple;
Test.tztest "balances_credit" `Quick balances_credit;
Test.tztest "balances_credit_fee" `Quick balances_credit_fee;
Test.tztest "balances_undelegatable" `Quick balances_undelegatable;
Test.tztest "pay_fee" `Quick pay_fee;
Test.tztest
"not enough tez in contract to pay fee"
`Quick
not_tez_in_contract_to_pay_fee;
Test.tztest "multiple originations" `Quick multiple_originations;
Test.tztest "counter" `Quick counter ]
src/proto_alpha/lib_protocol/test/origination.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Definition ten_tez {A : Type} : A := op_startypeminuserrorstar 10.
Definition register_origination {A B C : Type} (op_staroptstar : option A)
: (option B) ->
unit ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
let fee :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => op_startypeminuserrorstar
end in
fun op_staroptstar =>
let credit :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => op_startypeminuserrorstar
end in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let source := List.hd contracts in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar source)
(fun source_balance =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar source fee
credit op_startypeminuserrorstar)
(fun function_parameter =>
let '(operation, originated) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar operation b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar op_startypeminuserrorstar
(fun origination_burn =>
op_gtgteqquestion
(Lwt._return
(op_gtgtquestion
(op_gtgtquestion
(op_gtgtquestion
(op_startypeminuserrorstar credit
op_startypeminuserrorstar)
(op_startypeminuserrorstar fee))
(op_startypeminuserrorstar
origination_burn))
(op_startypeminuserrorstar
op_startypeminuserrorstar)))
(fun total_fee =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar source
source_balance total_fee)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar originated
op_startypeminuserrorstar credit)
(fun function_parameter =>
let 'tt := function_parameter in
_return (b, source, originated)))))))))).
Definition test_origination_balances {A B C D : Type} (function_parameter : A)
: (option B) ->
(option C) ->
unit ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult D) :=
let '_ := function_parameter in
fun op_staroptstar =>
let fee :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => op_startypeminuserrorstar
end in
fun op_staroptstar =>
let credit :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => op_startypeminuserrorstar
end in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let contract := List.hd contracts in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract)
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract
fee credit op_startypeminuserrorstar)
(fun function_parameter =>
let '(operation, new_contract) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar op_startypeminuserrorstar
(fun origination_burn =>
op_gtgteqquestion
(Lwt._return
(op_gtgtquestion
(op_gtgtquestion
(op_gtgtquestion
(op_startypeminuserrorstar credit
op_startypeminuserrorstar)
(op_startypeminuserrorstar fee))
(op_startypeminuserrorstar origination_burn))
(op_startypeminuserrorstar
op_startypeminuserrorstar)))
(fun total_fee =>
op_gtgteqquestion
(op_startypeminuserrorstar operation b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar contract
balance total_fee)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar new_contract
credit)))))))).
Definition two_nth_of_balance {A B C D : Type}
(incr : A) (contract : B) (nth : C)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult D) :=
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract)
(fun balance =>
op_startypeminuserrorstar (op_startypeminuserrorstar balance nth)
(fun res =>
op_startypeminuserrorstar
(op_startypeminuserrorstar res
(* ❌ Constant of type int64 is converted to int *)
2) (fun balance => _return balance))).
Definition balances_simple {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
test_origination_balances __LOC__ None None tt.
Definition balances_credit {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
test_origination_balances __LOC__ None (Some ten_tez) tt.
Definition balances_credit_fee {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
test_origination_balances __LOC__ (Some ten_tez)
(Some (op_startypeminuserrorstar 2)) tt.
Definition balances_undelegatable {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
test_origination_balances __LOC__ None None tt.
Definition pay_fee (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion
(register_origination (Some ten_tez) (Some (op_startypeminuserrorstar 2)) tt)
(fun function_parameter =>
let '(_b, _contract, _new_contract) := function_parameter in
return_unit).
Definition not_tez_in_contract_to_pay_fee {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let contract_1 := op_startypeminuserrorstar contracts 0 in
let contract_2 := op_startypeminuserrorstar contracts 1 in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun inc =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract_1)
(fun balance =>
op_gtgteqquestion
(op_atat Lwt._return
(op_startypeminuserrorstar balance op_startypeminuserrorstar))
(fun amount =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
contract_1 contract_2 amount)
(fun operation =>
op_gtgteqquestion
(op_startypeminuserrorstar inc operation)
(fun inc =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar contract_1 balance
amount)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar ten_tez
op_startypeminuserrorstar contract_1
op_startypeminuserrorstar)
(fun function_parameter =>
let '(op, _) := function_parameter in
op_gtgteq (op_startypeminuserrorstar inc op)
(fun inc =>
op_startypeminuserrorstar __LOC__ inc
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _ => true
| _ => false
end)))))))))).
Definition register_contract_get_endorser {A B C : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(A * B * C)) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let contract := List.hd contracts in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun inc =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '(account_endorser, _slots) := function_parameter in
_return (inc, contract, account_endorser)))).
Definition n_originations {A B C D : Type}
(n : A) (credit : option B) (fee : option C) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (list D)) :=
let 'tt := function_parameter in
fold_left_s
(fun new_contracts =>
fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion (register_origination fee credit tt)
(fun function_parameter =>
let '(_b, _source, new_contract) := function_parameter in
let contracts := cons new_contract new_contracts in
_return contracts)) [] (op_startypeminuserrorstar 1 n).
Definition multiple_originations {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion
(n_originations 100 (Some (op_startypeminuserrorstar 2)) (Some ten_tez) tt)
(fun contracts =>
op_startypeminuserrorstar __LOC__ (List.length contracts) 100).
Definition counter {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let contract := List.hd contracts in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun inc =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar contract op_startypeminuserrorstar)
(fun function_parameter =>
let '(op1, _) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
op_startypeminuserrorstar contract op_startypeminuserrorstar)
(fun function_parameter =>
let '(op2, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar inc op1)
(fun inc =>
op_gtgteq (op_startypeminuserrorstar inc op2)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Counter_in_the_past
_ _ _ => true
| _ => false
end))))))).
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "balances_simple" % string
(* ❌ Variants not supported *)
variant balances_simple)
(cons
(op_startypeminuserrorstar "balances_credit" % string
(* ❌ Variants not supported *)
variant balances_credit)
(cons
(op_startypeminuserrorstar "balances_credit_fee" % string
(* ❌ Variants not supported *)
variant balances_credit_fee)
(cons
(op_startypeminuserrorstar "balances_undelegatable" % string
(* ❌ Variants not supported *)
variant balances_undelegatable)
(cons
(op_startypeminuserrorstar "pay_fee" % string
(* ❌ Variants not supported *)
variant pay_fee)
(cons
(op_startypeminuserrorstar
"not enough tez in contract to pay fee" % string
(* ❌ Variants not supported *)
variant not_tez_in_contract_to_pay_fee)
(cons
(op_startypeminuserrorstar "multiple originations" % string
(* ❌ Variants not supported *)
variant multiple_originations)
(cons
(op_startypeminuserrorstar "counter" % string
(* ❌ Variants not supported *)
variant counter) []))))))).
src/proto_alpha/lib_protocol/test/qty.ml 14 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
let known_ok_tez_literals =
[ (0L, "0");
(10L, "0.00001");
(100L, "0.0001");
(1_000L, "0.001");
(10_000L, "0.01");
(100_000L, "0.1");
(1_000_000L, "1");
(10_000_000L, "10");
(100_000_000L, "100");
(1_000_000_000L, "1000");
(10_000_000_000L, "10000");
(100_000_000_000L, "100000");
(1_000_000_000_000L, "1000000");
(1_000_000_000_001L, "1000000.000001");
(1_000_000_000_010L, "1000000.00001");
(1_000_000_000_100L, "1000000.0001");
(1_000_000_001_000L, "1000000.001");
(1_000_000_010_000L, "1000000.01");
(1_000_000_100_000L, "1000000.1");
(123_123_123_123_123_123L, "123123123123.123123");
(999_999_999_999_999_999L, "999999999999.999999") ]
let known_bad_tez_literals =
[ "10000.";
"100,.";
"100,";
"1,0000";
"0.0000,1";
"0.00,1";
"0,1";
"HAHA";
"0.000,000,1";
"0.0000000";
"9,999,999,999,999.999,999" ]
let fail expected given msg =
Format.kasprintf
Pervasives.failwith
"@[%s@ expected: %s@ got: %s@]"
msg
expected
given
let fail_msg fmt = Format.kasprintf (fail "" "") fmt
let default_printer _ = ""
let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
if not (eq x y) then fail (prn x) (prn y) msg
let is_none ?(msg = "") x = if x <> None then fail "None" "Some _" msg
let is_some ?(msg = "") x = if x = None then fail "Some _" "None" msg
let test_known_tez_literals () =
List.iter
(fun (v, s) ->
let vv = Tez_repr.of_mutez v in
let vs = Tez_repr.of_string s in
let vs' =
Tez_repr.of_string (String.concat "" (String.split_on_char ',' s))
in
let vv =
match vv with
| None ->
fail_msg "could not unopt %Ld" v
| Some vv ->
vv
in
let vs =
match vs with None -> fail_msg "could not unopt %s" s | Some vs -> vs
in
let vs' =
match vs' with
| None ->
fail_msg "could not unopt %s" s
| Some vs' ->
vs'
in
equal ~prn:Tez_repr.to_string vv vs ;
equal ~prn:Tez_repr.to_string vv vs' ;
equal ~prn:(fun s -> s) (Tez_repr.to_string vv) s)
known_ok_tez_literals ;
List.iter
(fun s ->
let vs = Tez_repr.of_string s in
is_none ~msg:("Unexpected successful parsing of " ^ s) vs)
known_bad_tez_literals ;
return_unit
let test_random_tez_literals () =
for _ = 0 to 100_000 do
let v = Random.int64 12L in
let vv = Tez_repr.of_mutez v in
let vv =
match vv with None -> fail_msg "could not unopt %Ld" v | Some vv -> vv
in
let s = Tez_repr.to_string vv in
let vs = Tez_repr.of_string s in
let s' = String.concat "" (String.split_on_char ',' s) in
let vs' = Tez_repr.of_string s' in
is_some ~msg:("Could not parse " ^ s ^ " back") vs ;
is_some ~msg:("Could not parse " ^ s ^ " back") vs' ;
( match vs with
| None ->
assert false
| Some vs ->
let rev = Tez_repr.to_int64 vs in
equal ~prn:Int64.to_string ~msg:(Tez_repr.to_string vv) v rev ) ;
match vs' with
| None ->
assert false
| Some vs' ->
let rev = Tez_repr.to_int64 vs' in
equal ~prn:Int64.to_string ~msg:(Tez_repr.to_string vv) v rev
done ;
return_unit
let tests =
[ ("tez-literals", fun _ -> test_known_tez_literals ());
("rnd-tez-literals", fun _ -> test_random_tez_literals ()) ]
let wrap (n, f) =
Alcotest_lwt.test_case n `Quick (fun _ () ->
f ()
>>= function
| Ok () ->
Lwt.return_unit
| Error error ->
Format.kasprintf Pervasives.failwith "%a" pp_print_error error)
let tests = List.map wrap tests
src/proto_alpha/lib_protocol/test/qty.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Definition known_ok_tez_literals : list (int64 * string) :=
cons
((* ❌ Constant of type int64 is converted to int *)
0, "0" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
10, "0.00001" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
100, "0.0001" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
1000, "0.001" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
10000, "0.01" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
100000, "0.1" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
1000000, "1" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
10000000, "10" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
100000000, "100" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
1000000000, "1000" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
10000000000, "10000" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
100000000000, "100000" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
1000000000000, "1000000" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
1000000000001, "1000000.000001" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
1000000000010, "1000000.00001" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
1000000000100, "1000000.0001" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
1000000001000, "1000000.001" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
1000000010000, "1000000.01" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
1000000100000, "1000000.1" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
123123123123123123,
"123123123123.123123" % string)
(cons
((* ❌ Constant of type int64 is converted to int *)
999999999999999999,
"999999999999.999999" % string) [])))))))))))))))))))).
Definition known_bad_tez_literals : list string :=
cons "10000." % string
(cons "100,." % string
(cons "100," % string
(cons "1,0000" % string
(cons "0.0000,1" % string
(cons "0.00,1" % string
(cons "0,1" % string
(cons "HAHA" % string
(cons "0.000,000,1" % string
(cons "0.0000000" % string
(cons "9,999,999,999,999.999,999" % string [])))))))))).
Definition fail {A : Type} (expected : string) (given : string) (msg : string)
: A :=
Format.kasprintf Pervasives.failwith
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_gen
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Open_box
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format
"" % string))
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_lit
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Break
"@ " % string 1 0)
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"expected: " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_lit
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Break
"@ " % string 1 0)
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"got: " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_lit
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Close_box
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))))))))
"@[%s@ expected: %s@ got: %s@]" % string) msg expected given.
Definition fail_msg {A B : Type}
(fmt :
Tezos_protocol_environment_alpha__Environment.Pervasives.format4 A
Tezos_protocol_environment_alpha__Environment.Format.formatter unit B)
: A := Format.kasprintf (fail "" % string "" % string) fmt.
Definition default_printer {A : Type} (function_parameter : A) : string :=
let '_ := function_parameter in
"" % string.
Definition equal {A : Type} (op_staroptstar : option (A -> A -> bool))
: (option (A -> string)) -> (option string) -> A -> A -> unit :=
let eq :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => op_startypeminuserrorstar
end in
fun op_staroptstar =>
let prn :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => default_printer
end in
fun op_staroptstar =>
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
fun y =>
if not (eq x y) then
fail (prn x) (prn y) msg
else
tt.
Definition is_none {A : Type} (op_staroptstar : option string) : A -> unit :=
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
if op_startypeminuserrorstar x None then
fail "None" % string "Some _" % string msg
else
tt.
Definition is_some {A : Type} (op_staroptstar : option string) : A -> unit :=
let msg :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => "" % string
end in
fun x =>
if op_startypeminuserrorstar x None then
fail "Some _" % string "None" % string msg
else
tt.
Definition test_known_tez_literals (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun function_parameter =>
let '(v, s) := function_parameter in
let vv := Tez_repr.of_mutez v in
let vs := Tez_repr.of_string s in
let vs' :=
Tez_repr.of_string
(String.concat "" % string (String.split_on_char "," % char s)) in
let vv :=
match vv with
| None =>
fail_msg
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"could not unopt " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int64
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format))
"could not unopt %Ld" % string) v
| Some vv => vv
end in
let vs :=
match vs with
| None =>
fail_msg
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"could not unopt " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format))
"could not unopt %s" % string) s
| Some vs => vs
end in
let vs' :=
match vs' with
| None =>
fail_msg
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"could not unopt " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format))
"could not unopt %s" % string) s
| Some vs' => vs'
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := equal None (Some Tez_repr.to_string) None vv vs in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := equal None (Some Tez_repr.to_string) None vv vs' in
equal None (Some (fun s => s)) None (Tez_repr.to_string vv) s)
known_ok_tez_literals in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
List.iter
(fun s =>
let vs := Tez_repr.of_string s in
is_none (Some (op_caret "Unexpected successful parsing of " % string s))
vs) known_bad_tez_literals in
return_unit.
Definition test_random_tez_literals (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
(* ❌ For loops not handled. *)
for in
return_unit.
Definition tests {A : Type}
: list
(string *
(A ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
unit))) :=
cons
("tez-literals" % string,
(fun function_parameter =>
let '_ := function_parameter in
test_known_tez_literals tt))
(cons
("rnd-tez-literals" % string,
(fun function_parameter =>
let '_ := function_parameter in
test_random_tez_literals tt)) []).
Definition wrap {A B C : Type}
(function_parameter :
A *
(unit ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Pervasives.result unit
B))) : C :=
let '(n, f) := function_parameter in
op_startypeminuserrorstar n
(* ❌ Variants not supported *)
variant
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (f tt)
(fun function_parameter =>
match function_parameter with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok tt =>
Lwt.return_unit
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
error =>
Format.kasprintf Pervasives.failwith
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Alpha
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
"%a" % string) op_startypeminuserrorstar error
end)).
Definition tests {A : Type} : list A := List.map wrap tests.
src/proto_alpha/lib_protocol/test/rolls.ml 257 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Test_tez
open Test_utils
let account_pair = function [a1; a2] -> (a1, a2) | _ -> assert false
let wrap e = Lwt.return (Environment.wrap_error e)
let traverse_rolls ctxt head =
let rec loop acc roll =
Storage.Roll.Successor.get_option ctxt roll
>>= wrap
>>=? function
| None -> return (List.rev acc) | Some next -> loop (next :: acc) next
in
loop [head] head
let get_rolls ctxt delegate =
Storage.Roll.Delegate_roll_list.get_option ctxt delegate
>>= wrap
>>=? function
| None -> return_nil | Some head_roll -> traverse_rolls ctxt head_roll
let check_rolls b (account : Account.t) =
Context.get_constants (B b)
>>=? fun constants ->
Context.Delegate.info (B b) account.pkh
>>=? fun {staking_balance; _} ->
let token_per_roll = constants.parametric.tokens_per_roll in
let expected_rolls =
Int64.div (Tez.to_mutez staking_balance) (Tez.to_mutez token_per_roll)
in
Raw_context.prepare
b.context
~level:b.header.shell.level
~predecessor_timestamp:b.header.shell.timestamp
~timestamp:b.header.shell.timestamp
~fitness:b.header.shell.fitness
>>= wrap
>>=? fun ctxt ->
get_rolls ctxt account.pkh
>>=? fun rolls ->
Assert.equal_int
~loc:__LOC__
(List.length rolls)
(Int64.to_int expected_rolls)
let check_no_rolls (b : Block.t) (account : Account.t) =
Raw_context.prepare
b.context
~level:b.header.shell.level
~predecessor_timestamp:b.header.shell.timestamp
~timestamp:b.header.shell.timestamp
~fitness:b.header.shell.fitness
>>= wrap
>>=? fun ctxt ->
get_rolls ctxt account.pkh
>>=? fun rolls -> Assert.equal_int ~loc:__LOC__ (List.length rolls) 0
let simple_staking_rights () =
Context.init 2
>>=? fun (b, accounts) ->
let (a1, _a2) = account_pair accounts in
Context.Contract.balance (B b) a1
>>=? fun balance ->
Context.Contract.manager (B b) a1
>>=? fun m1 ->
Context.Delegate.info (B b) m1.pkh
>>=? fun info ->
Assert.equal_tez ~loc:__LOC__ balance info.staking_balance
>>=? fun () -> check_rolls b m1
let simple_staking_rights_after_baking () =
Context.init 2
>>=? fun (b, accounts) ->
let (a1, a2) = account_pair accounts in
Context.Contract.balance (B b) a1
>>=? fun balance ->
Context.Contract.manager (B b) a1
>>=? fun m1 ->
Context.Contract.manager (B b) a2
>>=? fun m2 ->
Block.bake_n ~policy:(By_account m2.pkh) 5 b
>>=? fun b ->
Context.Delegate.info (B b) m1.pkh
>>=? fun info ->
Assert.equal_tez ~loc:__LOC__ balance info.staking_balance
>>=? fun () -> check_rolls b m1 >>=? fun () -> check_rolls b m2
let frozen_deposit (info : Context.Delegate.info) =
Cycle.Map.fold
(fun _ {Delegate.deposit; _} acc -> Test_tez.Tez.(deposit + acc))
info.frozen_balance_by_cycle
Tez.zero
let check_activate_staking_balance ~loc ~deactivated b (a, (m : Account.t)) =
Context.Delegate.info (B b) m.pkh
>>=? fun info ->
Assert.equal_bool ~loc info.deactivated deactivated
>>=? fun () ->
Context.Contract.balance (B b) a
>>=? fun balance ->
let deposit = frozen_deposit info in
Assert.equal_tez ~loc Test_tez.Tez.(balance + deposit) info.staking_balance
let run_until_deactivation () =
Context.init 2
>>=? fun (b, accounts) ->
let (a1, a2) = account_pair accounts in
Context.Contract.balance (B b) a1
>>=? fun balance_start ->
Context.Contract.manager (B b) a1
>>=? fun m1 ->
Context.Contract.manager (B b) a2
>>=? fun m2 ->
check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b (a1, m1)
>>=? fun () ->
Context.Delegate.info (B b) m1.pkh
>>=? fun info ->
Block.bake_until_cycle ~policy:(By_account m2.pkh) info.grace_period b
>>=? fun b ->
check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b (a1, m1)
>>=? fun () ->
Block.bake_until_cycle_end ~policy:(By_account m2.pkh) b
>>=? fun b ->
check_activate_staking_balance ~loc:__LOC__ ~deactivated:true b (a1, m1)
>>=? fun () -> return (b, ((a1, m1), balance_start), (a2, m2))
let deactivation_then_bake () =
run_until_deactivation ()
>>=? fun ( b,
( ((_deactivated_contract, deactivated_account) as deactivated),
_start_balance ),
(_a2, _m2) ) ->
Block.bake ~policy:(By_account deactivated_account.pkh) b
>>=? fun b ->
check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated
>>=? fun () -> check_rolls b deactivated_account
let deactivation_then_self_delegation () =
run_until_deactivation ()
>>=? fun ( b,
( ((deactivated_contract, deactivated_account) as deactivated),
start_balance ),
(_a2, m2) ) ->
Op.delegation (B b) deactivated_contract (Some deactivated_account.pkh)
>>=? fun self_delegation ->
Block.bake ~policy:(By_account m2.pkh) b ~operation:self_delegation
>>=? fun b ->
check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated
>>=? fun () ->
Context.Contract.balance (B b) deactivated_contract
>>=? fun balance ->
Assert.equal_tez ~loc:__LOC__ start_balance balance
>>=? fun () -> check_rolls b deactivated_account
let deactivation_then_empty_then_self_delegation () =
run_until_deactivation ()
>>=? fun ( b,
( ((deactivated_contract, deactivated_account) as deactivated),
_start_balance ),
(_a2, m2) ) ->
(* empty the contract *)
Context.Contract.balance (B b) deactivated_contract
>>=? fun balance ->
let sink_account = Account.new_account () in
let sink_contract = Contract.implicit_contract sink_account.pkh in
Context.get_constants (B b)
>>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
Tez.(cost_per_byte *? Int64.of_int origination_size)
>>?= fun origination_burn ->
let amount =
match Tez.(balance -? origination_burn) with
| Ok r ->
r
| Error _ ->
assert false
in
Op.transaction (B b) deactivated_contract sink_contract amount
>>=? fun empty_contract ->
Block.bake ~policy:(By_account m2.pkh) ~operation:empty_contract b
>>=? fun b ->
(* self delegation *)
Op.delegation (B b) deactivated_contract (Some deactivated_account.pkh)
>>=? fun self_delegation ->
Block.bake ~policy:(By_account m2.pkh) ~operation:self_delegation b
>>=? fun b ->
check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated
>>=? fun () ->
Context.Contract.balance (B b) deactivated_contract
>>=? fun balance ->
Assert.equal_tez ~loc:__LOC__ Tez.zero balance
>>=? fun () -> check_rolls b deactivated_account
let deactivation_then_empty_then_self_delegation_then_recredit () =
run_until_deactivation ()
>>=? fun ( b,
( ((deactivated_contract, deactivated_account) as deactivated),
balance ),
(_a2, m2) ) ->
(* empty the contract *)
let sink_account = Account.new_account () in
let sink_contract = Contract.implicit_contract sink_account.pkh in
Context.get_constants (B b)
>>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
Tez.(cost_per_byte *? Int64.of_int origination_size)
>>?= fun origination_burn ->
let amount =
match Tez.(balance -? origination_burn) with
| Ok r ->
r
| Error _ ->
assert false
in
Op.transaction (B b) deactivated_contract sink_contract amount
>>=? fun empty_contract ->
Block.bake ~policy:(By_account m2.pkh) ~operation:empty_contract b
>>=? fun b ->
(* self delegation *)
Op.delegation (B b) deactivated_contract (Some deactivated_account.pkh)
>>=? fun self_delegation ->
Block.bake ~policy:(By_account m2.pkh) ~operation:self_delegation b
>>=? fun b ->
(* recredit *)
Op.transaction (B b) sink_contract deactivated_contract amount
>>=? fun recredit_contract ->
Block.bake ~policy:(By_account m2.pkh) ~operation:recredit_contract b
>>=? fun b ->
check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated
>>=? fun () ->
Context.Contract.balance (B b) deactivated_contract
>>=? fun balance ->
Assert.equal_tez ~loc:__LOC__ amount balance
>>=? fun () -> check_rolls b deactivated_account
let delegation () =
Context.init 2
>>=? fun (b, accounts) ->
let (a1, a2) = account_pair accounts in
let m3 = Account.new_account () in
Account.add_account m3 ;
Context.Contract.manager (B b) a1
>>=? fun m1 ->
Context.Contract.manager (B b) a2
>>=? fun m2 ->
let a3 = Contract.implicit_contract m3.pkh in
Context.Contract.delegate_opt (B b) a1
>>=? fun delegate ->
( match delegate with
| None ->
assert false
| Some pkh ->
assert (Signature.Public_key_hash.equal pkh m1.pkh) ) ;
Op.transaction (B b) a1 a3 Tez.fifty_cents
>>=? fun transact ->
Block.bake ~policy:(By_account m2.pkh) b ~operation:transact
>>=? fun b ->
Context.Contract.delegate_opt (B b) a3
>>=? fun delegate ->
(match delegate with None -> () | Some _ -> assert false) ;
check_no_rolls b m3
>>=? fun () ->
Op.delegation (B b) a3 (Some m3.pkh)
>>=? fun delegation ->
Block.bake ~policy:(By_account m2.pkh) b ~operation:delegation
>>=? fun b ->
Context.Contract.delegate_opt (B b) a3
>>=? fun delegate ->
( match delegate with
| None ->
assert false
| Some pkh ->
assert (Signature.Public_key_hash.equal pkh m3.pkh) ) ;
check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b (a3, m3)
>>=? fun () -> check_rolls b m3 >>=? fun () -> check_rolls b m1
let tests =
[ Test.tztest "simple staking rights" `Quick simple_staking_rights;
Test.tztest
"simple staking rights after baking"
`Quick
simple_staking_rights_after_baking;
Test.tztest "deactivation then bake" `Quick deactivation_then_bake;
Test.tztest
"deactivation then self delegation"
`Quick
deactivation_then_self_delegation;
Test.tztest
"deactivation then empty then self delegation"
`Quick
deactivation_then_empty_then_self_delegation;
Test.tztest
"deactivation then empty then self delegation then recredit"
`Quick
deactivation_then_empty_then_self_delegation_then_recredit;
Test.tztest "delegation" `Quick delegation ]
src/proto_alpha/lib_protocol/test/rolls.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Definition account_pair {A : Type} (function_parameter : list A) : A * A :=
match function_parameter with
| cons a1 (cons a2 []) => (a1, a2)
| _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end.
Definition wrap {A : Type}
(e : Tezos_protocol_alpha.Protocol.Environment.Error_monad.tzresult A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_base__TzPervasives.Error_monad.tzresult A) :=
Lwt._return (Environment.wrap_error e).
Definition traverse_rolls
(ctxt : Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.context)
(head : Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)) :=
let fix loop
(acc : list Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)
(roll : Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)) :=
op_gtgteqquestion op_startypeminuserrorstar
(fun function_parameter =>
match function_parameter with
| None => _return (List.rev acc)
| Some next => loop (cons next acc) next
end) in
loop (cons head []) head.
Definition get_rolls
(ctxt : Tezos_protocol_alpha.Protocol.Storage.Roll.Delegate_roll_list.context)
(delegate : Tezos_protocol_alpha.Protocol.Storage.Roll.Delegate_roll_list.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(list Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)) :=
op_gtgteqquestion op_startypeminuserrorstar
(fun function_parameter =>
match function_parameter with
| None => return_nil
| Some head_roll => traverse_rolls ctxt head_roll
end).
Definition check_rolls {A B : Type} (b : A) (function_parameter : B)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let '_ := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun constants =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(pkh op_startypeminuserrorstar))
(fun function_parameter =>
let '_ := function_parameter in
let token_per_roll := tokens_per_roll (parametric constants) in
let expected_rolls :=
Int64.div (Tez.to_mutez op_startypeminuserrorstar)
(Tez.to_mutez token_per_roll) in
op_gtgteqquestion op_startypeminuserrorstar
(fun ctxt =>
op_gtgteqquestion (get_rolls ctxt (pkh op_startypeminuserrorstar))
(fun rolls =>
op_startypeminuserrorstar __LOC__ (List.length rolls)
(Int64.to_int expected_rolls))))).
Definition check_no_rolls {A B : Type} (function_parameter : A)
: B ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion op_startypeminuserrorstar
(fun ctxt =>
op_gtgteqquestion (get_rolls ctxt (pkh op_startypeminuserrorstar))
(fun rolls => op_startypeminuserrorstar __LOC__ (List.length rolls) 0)).
Definition simple_staking_rights (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, accounts) := function_parameter in
let '(a1, _a2) := account_pair accounts in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar a1)
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar a1)
(fun m1 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar (pkh m1))
(fun info =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ balance
(staking_balance info))
(fun function_parameter =>
let 'tt := function_parameter in
check_rolls b m1))))).
Definition simple_staking_rights_after_baking (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, accounts) := function_parameter in
let '(a1, a2) := account_pair accounts in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar a1)
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar a1)
(fun m1 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar a2)
(fun m2 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar 5 b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(pkh m1))
(fun info =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ balance
(staking_balance info))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (check_rolls b m1)
(fun function_parameter =>
let 'tt := function_parameter in
check_rolls b m2)))))))).
Definition frozen_deposit {A : Type} (function_parameter : A)
: Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
let '_ := function_parameter in
Cycle.Map.fold
(fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '{| Delegate.deposit := deposit |} := function_parameter in
fun acc => op_startypeminuserrorstar)
(frozen_balance_by_cycle op_startypeminuserrorstar) Tez.zero.
Definition check_activate_staking_balance {A B : Type}
(loc : string) (deactivated : bool) (b : A)
(function_parameter :
Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract * B)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(pkh op_startypeminuserrorstar))
(fun info =>
op_gtgteqquestion
(op_startypeminuserrorstar loc (deactivated info) deactivated)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar a)
(fun balance =>
let deposit := frozen_deposit info in
op_startypeminuserrorstar loc op_startypeminuserrorstar
(staking_balance info)))).
Definition run_until_deactivation {A B C D : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(A *
((Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract * B) * C)
* (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract * D))) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, accounts) := function_parameter in
let '(a1, a2) := account_pair accounts in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar a1)
(fun balance_start =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar a1)
(fun m1 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar a2)
(fun m2 =>
op_gtgteqquestion
(check_activate_staking_balance __LOC__ false b (a1, m1))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(pkh m1))
(fun info =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(grace_period info) b)
(fun b =>
op_gtgteqquestion
(check_activate_staking_balance __LOC__ false b
(a1, m1))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion
(check_activate_staking_balance __LOC__
true b (a1, m1))
(fun function_parameter =>
let 'tt := function_parameter in
_return
(b, ((a1, m1), balance_start),
(a2, m2)))))))))))).
Definition deactivation_then_bake (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (run_until_deactivation tt)
(fun function_parameter =>
let
'(b,
((_deactivated_contract, deactivated_account) as deactivated,
_start_balance), (_a2, _m2)) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion
(check_activate_staking_balance __LOC__ false b deactivated)
(fun function_parameter =>
let 'tt := function_parameter in
check_rolls b deactivated_account))).
Definition deactivation_then_self_delegation (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (run_until_deactivation tt)
(fun function_parameter =>
let
'(b,
((deactivated_contract, deactivated_account) as deactivated,
start_balance), (_a2, m2)) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
deactivated_contract (Some (pkh deactivated_account)))
(fun self_delegation =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar b
self_delegation)
(fun b =>
op_gtgteqquestion
(check_activate_staking_balance __LOC__ false b deactivated)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
deactivated_contract)
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ start_balance balance)
(fun function_parameter =>
let 'tt := function_parameter in
check_rolls b deactivated_account)))))).
Definition deactivation_then_empty_then_self_delegation {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (run_until_deactivation tt)
(fun function_parameter =>
let
'(b,
((deactivated_contract, deactivated_account) as deactivated,
_start_balance), (_a2, m2)) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
deactivated_contract)
(fun balance =>
let sink_account := op_startypeminuserrorstar tt in
let sink_contract := Contract.implicit_contract (pkh sink_account) in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_starquestion op_startypeminuserrorstar
(Int64.of_int op_startypeminuserrorstar))
(fun origination_burn =>
let amount :=
match op_minusquestion balance origination_burn with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
r => r
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
deactivated_contract sink_contract amount)
(fun empty_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
empty_contract b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
deactivated_contract
(Some (pkh deactivated_account)))
(fun self_delegation =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar self_delegation b)
(fun b =>
op_gtgteqquestion
(check_activate_staking_balance __LOC__
false b deactivated)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
deactivated_contract)
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
Tez.zero balance)
(fun function_parameter =>
let 'tt := function_parameter in
check_rolls b deactivated_account))))))))))).
Definition deactivation_then_empty_then_self_delegation_then_recredit {A : Type}
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (run_until_deactivation tt)
(fun function_parameter =>
let
'(b,
((deactivated_contract, deactivated_account) as deactivated, balance),
(_a2, m2)) := function_parameter in
let sink_account := op_startypeminuserrorstar tt in
let sink_contract := Contract.implicit_contract (pkh sink_account) in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_starquestion op_startypeminuserrorstar
(Int64.of_int op_startypeminuserrorstar))
(fun origination_burn =>
let amount :=
match op_minusquestion balance origination_burn with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok r
=> r
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
deactivated_contract sink_contract amount)
(fun empty_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
empty_contract b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
deactivated_contract (Some (pkh deactivated_account)))
(fun self_delegation =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
self_delegation b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar sink_contract
deactivated_contract amount)
(fun recredit_contract =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
recredit_contract b)
(fun b =>
op_gtgteqquestion
(check_activate_staking_balance __LOC__
false b deactivated)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
deactivated_contract)
(fun balance =>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__ amount balance)
(fun function_parameter =>
let 'tt := function_parameter
in
check_rolls b
deactivated_account)))))))))))).
Definition delegation (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, accounts) := function_parameter in
let '(a1, a2) := account_pair accounts in
let m3 := op_startypeminuserrorstar tt in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar m3 in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar a1)
(fun m1 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar a2)
(fun m2 =>
let a3 := Contract.implicit_contract (pkh m3) in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar a1)
(fun delegate =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match delegate with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some pkh =>
(* ❌ Assert instruction is not handled. *)
assert (Signature.Public_key_hash.equal pkh (pkh m1))
end in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar a1 a3
Tez.fifty_cents)
(fun transact =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar b
transact)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
a3)
(fun delegate =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match delegate with
| None => tt
| Some _ =>
(* ❌ Assert instruction is not handled. *)
assert false
end in
op_gtgteqquestion (check_no_rolls b m3)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar a3
(Some (pkh m3)))
(fun delegation =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar b delegation)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar a3)
(fun delegate =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
match delegate with
| None =>
(* ❌ Assert instruction is not handled. *)
assert false
| Some pkh =>
(* ❌ Assert instruction is not handled. *)
assert
(Signature.Public_key_hash.equal
pkh (pkh m3))
end in
op_gtgteqquestion
(check_activate_staking_balance
__LOC__ false b (a3, m3))
(fun function_parameter =>
let 'tt := function_parameter
in
op_gtgteqquestion
(check_rolls b m3)
(fun function_parameter =>
let 'tt :=
function_parameter in
check_rolls b m1))))))))))))).
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "simple staking rights" % string
(* ❌ Variants not supported *)
variant simple_staking_rights)
(cons
(op_startypeminuserrorstar "simple staking rights after baking" % string
(* ❌ Variants not supported *)
variant simple_staking_rights_after_baking)
(cons
(op_startypeminuserrorstar "deactivation then bake" % string
(* ❌ Variants not supported *)
variant deactivation_then_bake)
(cons
(op_startypeminuserrorstar
"deactivation then self delegation" % string
(* ❌ Variants not supported *)
variant deactivation_then_self_delegation)
(cons
(op_startypeminuserrorstar
"deactivation then empty then self delegation" % string
(* ❌ Variants not supported *)
variant deactivation_then_empty_then_self_delegation)
(cons
(op_startypeminuserrorstar
"deactivation then empty then self delegation then recredit" %
string
(* ❌ Variants not supported *)
variant
deactivation_then_empty_then_self_delegation_then_recredit)
(cons
(op_startypeminuserrorstar "delegation" % string
(* ❌ Variants not supported *)
variant delegation) [])))))).
src/proto_alpha/lib_protocol/test/seed.ml 27 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(** Tests about
- seed_nonce_hash included in some blocks
- revelation operation of seed_nonce that should correspond to each
seed_nonce_hash
*)
open Protocol
open Test_tez
(** Tests that baking [blocks_per_commitment] blocks without a
[seed_nonce_hash] commitment fails with [Invalid_commitment] *)
let no_commitment () =
Context.init 5
>>=? fun (b, _) ->
Context.get_constants (B b)
>>=? fun {parametric = {blocks_per_commitment; _}; _} ->
let blocks_per_commitment = Int32.to_int blocks_per_commitment in
(* Bake normally until before the commitment *)
Block.bake_n (blocks_per_commitment - 2) b
>>=? fun b ->
(* Forge a block with empty commitment and apply it *)
Block.Forge.forge_header b
>>=? fun header ->
Block.Forge.set_seed_nonce_hash None header
|> Block.Forge.sign_header
>>=? fun header ->
Block.apply header b
>>= fun e ->
Assert.proto_error ~loc:__LOC__ e (function
| Apply.Invalid_commitment _ ->
true
| _ ->
false)
let baking_reward ctxt (b : Block.t) =
let priority = b.header.protocol_data.contents.priority in
Block.get_endorsing_power b
>>=? fun endorsing_power ->
Context.get_baking_reward ctxt ~priority ~endorsing_power
(** Choose a baker, denote it by id. In the first cycle, make id bake only once.
Test that:
- after id bakes with a commitment the bond is frozen and the reward allocated
- when id reveals the nonce too early, there's an error
- when id reveals at the right time but the wrong value, there's an error
- when another baker reveals correctly, it receives the tip
- revealing twice produces an error
- after [preserved cycles] a committer that correctly revealed
receives back the bond and the reward
*)
let revelation_early_wrong_right_twice () =
let open Assert in
Context.init 5
>>=? fun (b, _) ->
Context.get_constants (B b)
>>=? fun csts ->
let bond = csts.parametric.block_security_deposit in
let tip = csts.parametric.seed_nonce_revelation_tip in
let blocks_per_commitment =
Int32.to_int csts.parametric.blocks_per_commitment
in
let preserved_cycles = csts.parametric.preserved_cycles in
(* get the pkh of a baker *)
Block.get_next_baker b
>>=? fun (pkh, _, _) ->
let id = Alpha_context.Contract.implicit_contract pkh in
let policy = Block.Excluding [pkh] in
(* bake until commitment, excluding id *)
Block.bake_n ~policy (blocks_per_commitment - 2) b
>>=? fun b ->
Context.Contract.balance ~kind:Main (B b) id
>>=? fun bal_main ->
Context.Contract.balance ~kind:Deposit (B b) id
>>=? fun bal_deposit ->
Context.Contract.balance ~kind:Rewards (B b) id
>>=? fun bal_rewards ->
(* the baker [id] will include a seed_nonce commitment *)
Block.bake ~policy:(Block.By_account pkh) b
>>=? fun b ->
Context.get_level (B b)
>>=? fun level_commitment ->
Context.get_seed_nonce_hash (B b)
>>=? fun committed_hash ->
baking_reward (B b) b
>>=? fun reward ->
(* test that the bond was frozen and the reward allocated *)
balance_was_debited ~loc:__LOC__ (B b) id bal_main bond
>>=? fun () ->
balance_was_credited ~loc:__LOC__ (B b) id ~kind:Deposit bal_deposit bond
>>=? fun () ->
balance_was_credited ~loc:__LOC__ (B b) id ~kind:Rewards bal_rewards reward
>>=? fun () ->
(* test that revealing too early produces an error *)
Op.seed_nonce_revelation (B b) level_commitment (Nonce.get committed_hash)
>>=? fun operation ->
Block.bake ~policy ~operation b
>>= fun e ->
let expected = function
| Nonce_storage.Too_early_revelation ->
true
| _ ->
false
in
Assert.proto_error ~loc:__LOC__ e expected
>>=? fun () ->
(* finish the cycle excluding the committing baker, id *)
Block.bake_until_cycle_end ~policy b
>>=? fun b ->
(* test that revealing at the right time but the wrong value produces an error *)
let (wrong_hash, _) = Nonce.generate () in
Op.seed_nonce_revelation (B b) level_commitment (Nonce.get wrong_hash)
>>=? fun operation ->
Block.bake ~operation b
>>= fun e ->
Assert.proto_error ~loc:__LOC__ e (function
| Nonce_storage.Unexpected_nonce ->
true
| _ ->
false)
>>=? fun () ->
(* reveals correctly *)
Op.seed_nonce_revelation (B b) level_commitment (Nonce.get committed_hash)
>>=? fun operation ->
Block.get_next_baker ~policy b
>>=? fun (baker_pkh, _, _) ->
let baker = Alpha_context.Contract.implicit_contract baker_pkh in
Context.Contract.balance ~kind:Main (B b) baker
>>=? fun baker_bal_main ->
Context.Contract.balance ~kind:Deposit (B b) baker
>>=? fun baker_bal_deposit ->
Context.Contract.balance ~kind:Rewards (B b) baker
>>=? fun baker_bal_rewards ->
(* bake the operation in a block *)
Block.bake ~policy ~operation b
>>=? fun b ->
baking_reward (B b) b
>>=? fun baker_reward ->
(* test that the baker gets the tip reward *)
balance_was_debited ~loc:__LOC__ (B b) baker ~kind:Main baker_bal_main bond
>>=? fun () ->
balance_was_credited
~loc:__LOC__
(B b)
baker
~kind:Deposit
baker_bal_deposit
bond
>>=? fun () ->
Lwt.return @@ Tez.( +? ) baker_reward tip
>>=? fun expected_rewards ->
balance_was_credited
~loc:__LOC__
(B b)
baker
~kind:Rewards
baker_bal_rewards
expected_rewards
>>=? fun () ->
(* test that revealing twice produces an error *)
Op.seed_nonce_revelation (B b) level_commitment (Nonce.get wrong_hash)
>>=? fun operation ->
Block.bake ~operation ~policy b
>>= fun e ->
Assert.proto_error ~loc:__LOC__ e (function
| Nonce_storage.Previously_revealed_nonce ->
true
| _ ->
false)
>>=? fun () ->
(* bake [preserved_cycles] cycles excluding [id] *)
Error_monad.fold_left_s
(fun b _ -> Block.bake_until_cycle_end ~policy b)
b
(1 -- preserved_cycles)
>>=? fun b ->
(* test that [id] receives back the bond and the reward *)
(* note that in order to have that new_bal = bal_main + reward,
id can only bake once; this is why we exclude id from all other bake ops. *)
balance_was_credited ~loc:__LOC__ (B b) id ~kind:Main bal_main reward
>>=? fun () ->
balance_is ~loc:__LOC__ (B b) id ~kind:Deposit Tez.zero
>>=? fun () -> balance_is ~loc:__LOC__ (B b) id ~kind:Rewards Tez.zero
(** Tests that:
- a committer at cycle 0, which doesn't reveal at cycle 1,
at the end of the cycle 1 looses the bond and the reward
- revealing too late produces an error
*)
let revelation_missing_and_late () =
let open Context in
let open Assert in
Context.init 5
>>=? fun (b, _) ->
get_constants (B b)
>>=? fun csts ->
baking_reward (B b) b
>>=? fun reward ->
let blocks_per_commitment =
Int32.to_int csts.parametric.blocks_per_commitment
in
(* bake until commitment *)
Block.bake_n (blocks_per_commitment - 2) b
>>=? fun b ->
(* the next baker [id] will include a seed_nonce commitment *)
Block.get_next_baker b
>>=? fun (pkh, _, _) ->
let id = Alpha_context.Contract.implicit_contract pkh in
Block.bake b
>>=? fun b ->
Context.get_level (B b)
>>=? fun level_commitment ->
Context.get_seed_nonce_hash (B b)
>>=? fun committed_hash ->
Context.Contract.balance ~kind:Main (B b) id
>>=? fun bal_main ->
Context.Contract.balance ~kind:Deposit (B b) id
>>=? fun bal_deposit ->
Context.Contract.balance ~kind:Rewards (B b) id
>>=? fun bal_rewards ->
(* finish cycle 0 excluding the committing baker [id] *)
let policy = Block.Excluding [pkh] in
Block.bake_until_cycle_end ~policy b
>>=? fun b ->
(* finish cycle 1 excluding the committing baker [id] *)
Block.bake_until_cycle_end ~policy b
>>=? fun b ->
(* test that baker [id], which didn't reveal at cycle 1 like it was supposed to,
at the end of the cycle 1 looses the reward but not the bond *)
balance_is ~loc:__LOC__ (B b) id ~kind:Main bal_main
>>=? fun () ->
balance_is ~loc:__LOC__ (B b) id ~kind:Deposit bal_deposit
>>=? fun () ->
balance_was_debited ~loc:__LOC__ (B b) id ~kind:Rewards bal_rewards reward
>>=? fun () ->
(* test that revealing too late (after cycle 1) produces an error *)
Op.seed_nonce_revelation (B b) level_commitment (Nonce.get committed_hash)
>>=? fun operation ->
Block.bake ~operation b
>>= fun e ->
Assert.proto_error ~loc:__LOC__ e (function
| Nonce_storage.Too_late_revelation ->
true
| _ ->
false)
let tests =
[ Test.tztest "no commitment" `Quick no_commitment;
Test.tztest
"revelation_early_wrong_right_twice"
`Quick
revelation_early_wrong_right_twice;
Test.tztest
"revelation_missing_and_late"
`Quick
revelation_missing_and_late ]
src/proto_alpha/lib_protocol/test/seed.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Definition no_commitment {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 5)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
let blocks_per_commitment := Int32.to_int op_startypeminuserrorstar in
op_gtgteqquestion
(op_startypeminuserrorstar (op_minus blocks_per_commitment 2) b)
(fun b =>
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun header =>
op_gtgteqquestion
(op_pipegt (op_startypeminuserrorstar None header)
op_startypeminuserrorstar)
(fun header =>
op_gtgteq (op_startypeminuserrorstar header b)
(fun e =>
op_startypeminuserrorstar __LOC__ e
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_commitment
_ => true
| _ => false
end))))))).
Definition baking_reward {A B C : Type} (ctxt : A) (function_parameter : B)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
let '_ := function_parameter in
let priority :=
priority (contents (protocol_data (header op_startypeminuserrorstar))) in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun endorsing_power =>
op_startypeminuserrorstar ctxt priority endorsing_power).
Definition revelation_early_wrong_right_twice {A : Type}
(function_parameter : unit) : A :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
Definition revelation_missing_and_late {A : Type} (function_parameter : unit)
: A :=
let 'tt := function_parameter in
op_startypeminuserrorstar.
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "no commitment" % string
(* ❌ Variants not supported *)
variant no_commitment)
(cons
(op_startypeminuserrorstar "revelation_early_wrong_right_twice" % string
(* ❌ Variants not supported *)
variant revelation_early_wrong_right_twice)
(cons
(op_startypeminuserrorstar "revelation_missing_and_late" % string
(* ❌ Variants not supported *)
variant revelation_missing_and_late) [])).
src/proto_alpha/lib_protocol/test/test.ml 7 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
(* Wraps an alcotest so that it prints correcly errors from the Error_monad. *)
let tztest name speed f =
Alcotest_lwt.test_case name speed (fun _sw () ->
f ()
>>= function
| Ok () ->
Lwt.return_unit
| Error err ->
Tezos_stdlib_unix.Internal_event_unix.close ()
>>= fun () ->
Format.printf "@.%a@." pp_print_error err ;
Lwt.fail Alcotest.Test_error)
src/proto_alpha/lib_protocol/test/test.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition tztest {A B C D : Type}
(name : A) (speed : B)
(f :
unit ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Pervasives.result unit C))
: D :=
op_startypeminuserrorstar name speed
(fun _sw =>
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (f tt)
(fun function_parameter =>
match function_parameter with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok tt =>
Lwt.return_unit
| Tezos_protocol_environment_alpha__Environment.Pervasives.Error err
=>
op_gtgteq (Tezos_stdlib_unix.Internal_event_unix.close tt)
(fun function_parameter =>
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
op_startypeminuserrorstar "@.%a@." % string
op_startypeminuserrorstar err in
op_startypeminuserrorstar op_startypeminuserrorstar)
end)).
src/proto_alpha/lib_protocol/test/transfer.ml 309 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Test_utils
open Test_tez
(*********************************************************************)
(* Utility functions *)
(*********************************************************************)
(**
[transfer_and_check_balances b fee src dst amount]
this function takes a block, an optional parameter fee if fee does not
given it will be set to zero tez, a source contract, a destination contract
and the amount that one wants to transfer.
1- Transfer the amount of tez (w/wo fee) from a source contract to a
destination contract.
2- Check the equivalent of the balance of the source/destination
contract before and after transfer is valided.
This function returns a pair:
- A block that added a valid operation
- a valid operation
*)
let transfer_and_check_balances ?(with_burn = false) ~loc b ?(fee = Tez.zero)
?expect_failure src dst amount =
Tez.( +? ) fee amount
>>?= fun amount_fee ->
Context.Contract.balance (I b) src
>>=? fun bal_src ->
Context.Contract.balance (I b) dst
>>=? fun bal_dst ->
Op.transaction (I b) ~fee src dst amount
>>=? fun op ->
Incremental.add_operation ?expect_failure b op
>>=? fun b ->
Context.get_constants (I b)
>>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
Tez.(cost_per_byte *? Int64.of_int origination_size)
>>?= fun origination_burn ->
let amount_fee_maybe_burn =
if with_burn then
match Tez.(amount_fee +? origination_burn) with
| Ok r ->
r
| Error _ ->
assert false
else amount_fee
in
Assert.balance_was_debited ~loc (I b) src bal_src amount_fee_maybe_burn
>>=? fun () ->
Assert.balance_was_credited ~loc (I b) dst bal_dst amount
>>=? fun () -> return (b, op)
(**
[transfer_to_itself_and_check_balances b fee contract amount]
this function takes a block, an optional parameter fee,
a contract that is a source and a destination contract,
and an amount of tez that one wants to transfer.
1- Transfer the amount of tez (w/wo transfer fee) from/to a contract itself.
2- Check the equivalent of the balance of the contract before
and after transfer.
This function returns a pair:
- a block that added the valid transaction
- an valid transaction
*)
let transfer_to_itself_and_check_balances ~loc b ?(fee = Tez.zero) contract
amount =
Context.Contract.balance (I b) contract
>>=? fun bal ->
Op.transaction (I b) ~fee contract contract amount
>>=? fun op ->
Incremental.add_operation b op
>>=? fun b ->
Assert.balance_was_debited ~loc (I b) contract bal fee
>>=? fun () -> return (b, op)
(**
[n_transactions n b fee source dest amount]
this function takes a number of "n" that one wish to transfer,
a block, an optional parameter fee, a source contract,
a destination contract and an amount one wants to transfer.
This function will do a transaction from a source contract to
a destination contract with the amount "n" times.
*)
let n_transactions n b ?fee source dest amount =
fold_left_s
(fun b _ ->
transfer_and_check_balances ~loc:__LOC__ b ?fee source dest amount
>>=? fun (b, _) -> return b)
b
(1 -- n)
let ten_tez = Tez.of_int 10
(*********************************************************************)
(* Tests *)
(*********************************************************************)
let register_two_contracts () =
Context.init 2
>>=? fun (b, contracts) ->
let contract_1 = List.nth contracts 0 in
let contract_2 = List.nth contracts 1 in
return (b, contract_1, contract_2)
(** compute half of the balance and divided by nth
times *)
let two_nth_of_balance incr contract nth =
Context.Contract.balance (I incr) contract
>>=? fun balance ->
Tez.( /? ) balance nth
>>?= fun res -> Tez.( *? ) res 2L >>?= fun balance -> return balance
(********************)
(** Single transfer *)
(********************)
let single_transfer ?fee ?expect_failure amount =
register_two_contracts ()
>>=? fun (b, contract_1, contract_2) ->
Incremental.begin_construction b
>>=? fun b ->
transfer_and_check_balances
~loc:__LOC__
?fee
?expect_failure
b
contract_1
contract_2
amount
>>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit
(** single transfer without fee *)
let block_with_a_single_transfer () = single_transfer Tez.one
(** single transfer with fee *)
let block_with_a_single_transfer_with_fee () =
single_transfer ~fee:Tez.one Tez.one
(** single transfer without fee *)
let transfer_zero_tez () =
single_transfer
~expect_failure:(function
| Environment.Ecoproto_error (Contract_storage.Empty_transaction _) :: _
->
return_unit
| _ ->
failwith "Empty transaction should fail")
Tez.zero
(********************)
(** Transfer zero tez from an implicit contract *)
(********************)
let transfer_zero_implicit () =
Context.init 1
>>=? fun (b, contracts) ->
let dest = List.nth contracts 0 in
let account = Account.new_account () in
Incremental.begin_construction b
>>=? fun i ->
let src = Contract.implicit_contract account.Account.pkh in
Op.transaction (I i) src dest Tez.zero
>>=? fun op ->
Incremental.add_operation i op
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Contract_storage.Empty_implicit_contract _ ->
true
| _ ->
false)
(********************)
(** Transfer to originted contract *)
(********************)
let transfer_to_originate_with_fee () =
Context.init 1
>>=? fun (b, contracts) ->
let contract = List.nth contracts 0 in
Incremental.begin_construction b
>>=? fun b ->
two_nth_of_balance b contract 10L
>>=? fun fee ->
(* originated contract, paying a fee to originated this contract *)
Op.origination (I b) ~fee:ten_tez contract ~script:Op.dummy_script
>>=? fun (operation, new_contract) ->
Incremental.add_operation b operation
>>=? fun b ->
two_nth_of_balance b contract 3L
>>=? fun amount ->
transfer_and_check_balances ~loc:__LOC__ b ~fee contract new_contract amount
>>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit
(********************)
(** Transfer from balance *)
(********************)
let transfer_amount_of_contract_balance () =
register_two_contracts ()
>>=? fun (b, contract_1, contract_2) ->
Context.Contract.pkh contract_1
>>=? fun pkh1 ->
(* given that contract_1 no longer has a sufficient balance to bake,
make sure it cannot be chosen as baker *)
Incremental.begin_construction b ~policy:(Block.Excluding [pkh1])
>>=? fun b ->
(* get the balance of the source contract *)
Context.Contract.balance (I b) contract_1
>>=? fun balance ->
(* transfer all the tez inside contract 1 *)
transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 balance
>>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit
(********************)
(** Transfer to itself *)
(********************)
let transfers_to_self () =
Context.init 1
>>=? fun (b, contracts) ->
let contract = List.nth contracts 0 in
Incremental.begin_construction b
>>=? fun b ->
two_nth_of_balance b contract 3L
>>=? fun amount ->
transfer_to_itself_and_check_balances ~loc:__LOC__ b contract amount
>>=? fun (b, _) ->
two_nth_of_balance b contract 5L
>>=? fun fee ->
transfer_to_itself_and_check_balances ~loc:__LOC__ b ~fee contract ten_tez
>>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit
(********************)
(** Forgot to add the valid transaction into the block *)
(********************)
let missing_transaction () =
register_two_contracts ()
>>=? fun (b, contract_1, contract_2) ->
(* given that contract_1 no longer has a sufficient balance to bake,
make sure it cannot be chosen as baker *)
Context.Contract.pkh contract_1
>>=? fun pkh1 ->
Incremental.begin_construction b ~policy:(Block.Excluding [pkh1])
>>=? fun b ->
two_nth_of_balance b contract_1 6L
>>=? fun amount ->
(* do the transfer 3 times from source contract to destination contract *)
n_transactions 3 b contract_1 contract_2 amount
>>=? fun b ->
(* do the fourth transfer from source contract to destination contract *)
Op.transaction (I b) contract_1 contract_2 amount
>>=? fun _ -> Incremental.finalize_block b >>=? fun _ -> return_unit
(********************)
(** These following tests are for different kind of contracts:
- implicit to implicit
- implicit to originated
- originated to implicit
- originted to originted *)
(********************)
(** Implicit to Implicit *)
let transfer_from_implicit_to_implicit_contract () =
Context.init 1
>>=? fun (b, contracts) ->
let bootstrap_contract = List.nth contracts 0 in
let account_a = Account.new_account () in
let account_b = Account.new_account () in
Incremental.begin_construction b
>>=? fun b ->
let src = Contract.implicit_contract account_a.Account.pkh in
two_nth_of_balance b bootstrap_contract 3L
>>=? fun amount1 ->
two_nth_of_balance b bootstrap_contract 10L
>>=? fun fee1 ->
transfer_and_check_balances
~with_burn:true
~loc:__LOC__
~fee:fee1
b
bootstrap_contract
src
amount1
>>=? fun (b, _) ->
(* create an implicit contract as a destination contract *)
let dest = Contract.implicit_contract account_b.pkh in
two_nth_of_balance b bootstrap_contract 4L
>>=? fun amount2 ->
two_nth_of_balance b bootstrap_contract 10L
>>=? fun fee2 ->
(* transfer from implicit contract to another implicit contract *)
transfer_and_check_balances
~with_burn:true
~loc:__LOC__
~fee:fee2
b
src
dest
amount2
>>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit
(** Implicit to originated *)
let transfer_from_implicit_to_originated_contract () =
Context.init 1
>>=? fun (b, contracts) ->
let bootstrap_contract = List.nth contracts 0 in
let contract = List.nth contracts 0 in
let account = Account.new_account () in
let src = Contract.implicit_contract account.Account.pkh in
Incremental.begin_construction b
>>=? fun b ->
two_nth_of_balance b bootstrap_contract 3L
>>=? fun amount1 ->
(* transfer the money to implicit contract *)
transfer_and_check_balances
~with_burn:true
~loc:__LOC__
b
bootstrap_contract
src
amount1
>>=? fun (b, _) ->
(* originated contract *)
Op.origination (I b) contract ~script:Op.dummy_script
>>=? fun (operation, new_contract) ->
Incremental.add_operation b operation
>>=? fun b ->
two_nth_of_balance b bootstrap_contract 4L
>>=? fun amount2 ->
(* transfer from implicit contract to originated contract *)
transfer_and_check_balances ~loc:__LOC__ b src new_contract amount2
>>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit
(********************)
(** Slow tests case *)
(********************)
let multiple_transfer n ?fee amount =
register_two_contracts ()
>>=? fun (b, contract_1, contract_2) ->
Incremental.begin_construction b
>>=? fun b ->
n_transactions n b ?fee contract_1 contract_2 amount
>>=? fun b -> Incremental.finalize_block b >>=? fun _ -> return_unit
(** 1- Create a block with two contracts;
2- Apply 100 transfers. *)
let block_with_multiple_transfers () = multiple_transfer 99 (Tez.of_int 1000)
(** 1- Create a block with two contracts;
2- Apply 100 transfers with 10tz fee. *)
let block_with_multiple_transfers_pay_fee () =
multiple_transfer 10 ~fee:ten_tez (Tez.of_int 1000)
(* TODO : increase the number of operations and add a `Slow tag to it in `tests` *)
(** 1- Create a block with 8 contracts;
2- Apply multiple transfers without fees;
3- Apply multiple transfers with fees. *)
let block_with_multiple_transfers_with_without_fee () =
Context.init 8
>>=? fun (b, contracts) ->
let contracts = Array.of_list contracts in
Incremental.begin_construction b
>>=? fun b ->
let hundred = Tez.of_int 100 in
let ten = Tez.of_int 10 in
let twenty = Tez.of_int 20 in
n_transactions 10 b contracts.(0) contracts.(1) Tez.one
>>=? fun b ->
n_transactions 30 b contracts.(1) contracts.(2) hundred
>>=? fun b ->
n_transactions 30 b contracts.(1) contracts.(3) hundred
>>=? fun b ->
n_transactions 30 b contracts.(4) contracts.(3) hundred
>>=? fun b ->
n_transactions 20 b contracts.(0) contracts.(1) hundred
>>=? fun b ->
n_transactions 10 b contracts.(1) contracts.(3) hundred
>>=? fun b ->
n_transactions 10 b contracts.(1) contracts.(3) hundred
>>=? fun b ->
n_transactions 20 ~fee:ten b contracts.(3) contracts.(4) ten
>>=? fun b ->
n_transactions 10 ~fee:twenty b contracts.(4) contracts.(5) ten
>>=? fun b ->
n_transactions 70 ~fee:twenty b contracts.(6) contracts.(0) twenty
>>=? fun b ->
n_transactions 550 ~fee:twenty b contracts.(6) contracts.(4) twenty
>>=? fun b ->
n_transactions 50 ~fee:ten b contracts.(7) contracts.(5) twenty
>>=? fun b ->
n_transactions 30 ~fee:ten b contracts.(0) contracts.(7) hundred
>>=? fun b ->
n_transactions 20 ~fee:ten b contracts.(1) contracts.(0) twenty
>>=? fun b -> Incremental.finalize_block b >>=? fun _ -> return_unit
(********************)
(** Build a chain that has 10 blocks. *)
(********************)
let build_a_chain () =
register_two_contracts ()
>>=? fun (b, contract_1, contract_2) ->
let ten = Tez.of_int 10 in
fold_left_s
(fun b _ ->
Incremental.begin_construction b
>>=? fun b ->
transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 ten
>>=? fun (b, _) -> Incremental.finalize_block b)
b
(1 -- 10)
>>=? fun _ -> return_unit
(*********************************************************************)
(* Expected error test cases *)
(*********************************************************************)
(********************)
(** transfer zero tez is forbidden in implicit contract *)
(********************)
let empty_implicit () =
Context.init 1
>>=? fun (b, contracts) ->
let dest = List.nth contracts 0 in
let account = Account.new_account () in
Incremental.begin_construction b
>>=? fun incr ->
let src = Contract.implicit_contract account.Account.pkh in
two_nth_of_balance incr dest 3L
>>=? fun amount ->
(* transfer zero tez from an implicit contract *)
Op.transaction (I incr) src dest amount
>>=? fun op ->
Incremental.add_operation incr op
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Contract_storage.Empty_implicit_contract _ ->
true
| _ ->
false)
(********************)
(** Balance is too low to transfer *)
(********************)
let balance_too_low fee () =
register_two_contracts ()
>>=? fun (b, contract_1, contract_2) ->
Incremental.begin_construction b
>>=? fun i ->
Context.Contract.balance (I i) contract_1
>>=? fun balance1 ->
Context.Contract.balance (I i) contract_2
>>=? fun balance2 ->
(* transfer the amount of tez that is bigger than the balance in the source contract *)
Op.transaction ~fee (I i) contract_1 contract_2 Tez.max_tez
>>=? fun op ->
let expect_failure = function
| Environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ ->
return_unit
| _ ->
failwith "balance too low should fail"
in
(* the fee is higher than the balance then raise an error "Balance_too_low" *)
if fee > balance1 then
Incremental.add_operation ~expect_failure i op >>= fun _res -> return_unit
(* the fee is smaller than the balance, then the transfer is accepted
but it is not processed, and fees are taken *)
else
Incremental.add_operation ~expect_failure i op
>>=? fun i ->
(* contract_1 loses the fees *)
Assert.balance_was_debited ~loc:__LOC__ (I i) contract_1 balance1 fee
>>=? fun () ->
(* contract_2 is not credited *)
Assert.balance_was_credited ~loc:__LOC__ (I i) contract_2 balance2 Tez.zero
(** 1- Create a block, and three contracts;
2- Add a transfer that at the end the balance of a contract is
zero into this block;
3- Add another transfer that send tez from a zero balance contract;
4- Catch the expected error: Balance_too_low. *)
let balance_too_low_two_transfers fee () =
Context.init 3
>>=? fun (b, contracts) ->
let contract_1 = List.nth contracts 0 in
let contract_2 = List.nth contracts 1 in
let contract_3 = List.nth contracts 2 in
Incremental.begin_construction b
>>=? fun i ->
Context.Contract.balance (I i) contract_1
>>=? fun balance ->
Tez.( /? ) balance 3L
>>?= fun res ->
Tez.( *? ) res 2L
>>?= fun two_third_of_balance ->
transfer_and_check_balances
~loc:__LOC__
i
contract_1
contract_2
two_third_of_balance
>>=? fun (i, _) ->
Context.Contract.balance (I i) contract_1
>>=? fun balance1 ->
Context.Contract.balance (I i) contract_3
>>=? fun balance3 ->
Op.transaction ~fee (I i) contract_1 contract_3 two_third_of_balance
>>=? fun operation ->
let expect_failure = function
| Environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ ->
return_unit
| _ ->
failwith "balance too low should fail"
in
Incremental.add_operation ~expect_failure i operation
>>=? fun i ->
(* contract_1 loses the fees *)
Assert.balance_was_debited ~loc:__LOC__ (I i) contract_1 balance1 fee
>>=? fun () ->
(* contract_3 is not credited *)
Assert.balance_was_credited ~loc:__LOC__ (I i) contract_3 balance3 Tez.zero
(********************)
(** The counter is already used for the previous operation *)
(********************)
let invalid_counter () =
register_two_contracts ()
>>=? fun (b, contract_1, contract_2) ->
Incremental.begin_construction b
>>=? fun b ->
Op.transaction (I b) contract_1 contract_2 Tez.one
>>=? fun op1 ->
Op.transaction (I b) contract_1 contract_2 Tez.one
>>=? fun op2 ->
Incremental.add_operation b op1
>>=? fun b ->
Incremental.add_operation b op2
>>= fun b ->
Assert.proto_error ~loc:__LOC__ b (function
| Contract_storage.Counter_in_the_past _ ->
true
| _ ->
false)
(* same as before but different way to perform this error *)
let add_the_same_operation_twice () =
register_two_contracts ()
>>=? fun (b, contract_1, contract_2) ->
Incremental.begin_construction b
>>=? fun b ->
transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 ten_tez
>>=? fun (b, op_transfer) ->
Op.transaction (I b) contract_1 contract_2 ten_tez
>>=? fun _ ->
Incremental.add_operation b op_transfer
>>= fun b ->
Assert.proto_error ~loc:__LOC__ b (function
| Contract_storage.Counter_in_the_past _ ->
true
| _ ->
false)
(********************)
(** check ownership *)
(********************)
let ownership_sender () =
register_two_contracts ()
>>=? fun (b, contract_1, contract_2) ->
Incremental.begin_construction b
>>=? fun b ->
(* get the manager of the contract_1 as a sender *)
Context.Contract.manager (I b) contract_1
>>=? fun manager ->
(* create an implicit_contract *)
let imcontract_1 = Alpha_context.Contract.implicit_contract manager.pkh in
transfer_and_check_balances ~loc:__LOC__ b imcontract_1 contract_2 Tez.one
>>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit
(*********************************************************************)
(** Random transfer *)
(** Return a pair of minimum and maximum random number *)
let random_range (min, max) =
let interv = max - min + 1 in
let init =
Random.self_init () ;
Random.int interv + min
in
init
(** Return a random contract *)
let random_contract contract_array =
let i = Random.int (Array.length contract_array) in
contract_array.(i)
(** Transfer by randomly choose amount 10 contracts, and randomly
choose the amount in the source contract *)
let random_transfer () =
Context.init 10
>>=? fun (b, contracts) ->
let contracts = Array.of_list contracts in
let source = random_contract contracts in
let dest = random_contract contracts in
Context.Contract.pkh source
>>=? fun source_pkh ->
(* given that source may not have a sufficient balance for the transfer + to bake,
make sure it cannot be chosen as baker *)
Incremental.begin_construction b ~policy:(Block.Excluding [source_pkh])
>>=? fun b ->
Context.Contract.balance (I b) source
>>=? fun amount ->
( if source = dest then
transfer_to_itself_and_check_balances ~loc:__LOC__ b source amount
else transfer_and_check_balances ~loc:__LOC__ b source dest amount )
>>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit
(** Transfer random transactions *)
let random_multi_transactions () =
let n = random_range (1, 100) in
multiple_transfer n (Tez.of_int 100)
(*********************************************************************)
let tests =
[ (* single transfer *)
Test.tztest "single transfer" `Quick block_with_a_single_transfer;
Test.tztest
"single transfer with fee"
`Quick
block_with_a_single_transfer_with_fee;
(* transfer zero tez *)
Test.tztest "single transfer zero tez" `Quick transfer_zero_tez;
Test.tztest
"transfer zero tez from implicit contract"
`Quick
transfer_zero_implicit;
(* transfer to originated contract *)
Test.tztest
"transfer to originated contract paying transaction fee"
`Quick
transfer_to_originate_with_fee;
(* transfer by the balance of contract *)
Test.tztest
"transfer the amount from source contract balance"
`Quick
transfer_amount_of_contract_balance;
(* transfer to itself *)
Test.tztest "transfers to itself" `Quick transfers_to_self;
(* missing operation *)
Test.tztest "missing transaction" `Quick missing_transaction;
(* transfer from/to implicit/originted contracts*)
Test.tztest
"transfer from an implicit to implicit contract "
`Quick
transfer_from_implicit_to_implicit_contract;
Test.tztest
"transfer from an implicit to an originated contract"
`Quick
transfer_from_implicit_to_originated_contract;
(* Slow tests *)
Test.tztest
"block with multiple transfers"
`Slow
block_with_multiple_transfers;
(* TODO increase the number of transaction times *)
Test.tztest
"block with multiple transfer paying fee"
`Slow
block_with_multiple_transfers_pay_fee;
Test.tztest
"block with multiple transfer without paying fee"
`Slow
block_with_multiple_transfers_with_without_fee;
(* build the chain *)
Test.tztest "build a chain" `Quick build_a_chain;
(* Erroneous *)
Test.tztest "empty implicit" `Quick empty_implicit;
Test.tztest
"balance too low - transfer zero"
`Quick
(balance_too_low Tez.zero);
Test.tztest "balance too low" `Quick (balance_too_low Tez.one);
Test.tztest
"balance too low (max fee)"
`Quick
(balance_too_low Tez.max_tez);
Test.tztest
"balance too low with two transfers - transfer zero"
`Quick
(balance_too_low_two_transfers Tez.zero);
Test.tztest
"balance too low with two transfers"
`Quick
(balance_too_low_two_transfers Tez.one);
Test.tztest "invalid_counter" `Quick invalid_counter;
Test.tztest
"add the same operation twice"
`Quick
add_the_same_operation_twice;
Test.tztest "ownership sender" `Quick ownership_sender;
(* Random tests *)
Test.tztest "random transfer" `Quick random_transfer;
Test.tztest "random multi transfer" `Quick random_multi_transactions ]
src/proto_alpha/lib_protocol/test/transfer.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Alpha_context.
Definition transfer_and_check_balances {A B C D E F : Type}
(op_staroptstar : option bool)
: A ->
B ->
(option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
(option C) ->
D -> E -> Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez -> F :=
let with_burn :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => false
end in
fun loc =>
fun b =>
fun op_staroptstar =>
let fee :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Tez.zero
end in
fun expect_failure =>
fun src =>
fun dst =>
fun amount =>
op_startypeminuserrorstar (Tez.op_plusquestion fee amount)
(fun amount_fee =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar src)
(fun bal_src =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
dst)
(fun bal_dst =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar fee src dst amount)
(fun op =>
op_gtgteqquestion
(op_startypeminuserrorstar expect_failure b op)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_startypeminuserrorstar
(op_starquestion
op_startypeminuserrorstar
(Int64.of_int
op_startypeminuserrorstar))
(fun origination_burn =>
let amount_fee_maybe_burn :=
if with_burn then
match
op_plusquestion amount_fee
origination_burn with
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
r => r
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_ =>
(* ❌ Assert instruction is not handled. *)
assert false
end
else
amount_fee in
op_gtgteqquestion
(op_startypeminuserrorstar loc
op_startypeminuserrorstar src
bal_src amount_fee_maybe_burn)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar loc
op_startypeminuserrorstar
dst bal_dst amount)
(fun function_parameter =>
let 'tt :=
function_parameter in
_return (b, op)))))))))).
Definition transfer_to_itself_and_check_balances {A B C D E F : Type}
(loc : A) (b : B)
(op_staroptstar : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
: C ->
D ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(E * F)) :=
let fee :=
match op_staroptstar with
| Some op_starsthstar => op_starsthstar
| None => Tez.zero
end in
fun contract =>
fun amount =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract)
(fun bal =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar fee contract
contract amount)
(fun op =>
op_gtgteqquestion (op_startypeminuserrorstar b op)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar loc op_startypeminuserrorstar
contract bal fee)
(fun function_parameter =>
let 'tt := function_parameter in
_return (b, op))))).
Definition n_transactions {A B C D : Type}
(n : A) (b : B)
(fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
(source : C) (dest : D)
(amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
fold_left_s
(fun b =>
fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(transfer_and_check_balances None __LOC__ b fee None source dest
amount)
(fun function_parameter =>
let '(b, _) := function_parameter in
_return b)) b (op_startypeminuserrorstar 1 n).
Definition ten_tez {A : Type} : A := op_startypeminuserrorstar 10.
Definition register_two_contracts {A B C : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(A * B * C)) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 2)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let contract_1 := op_startypeminuserrorstar contracts 0 in
let contract_2 := op_startypeminuserrorstar contracts 1 in
_return (b, contract_1, contract_2)).
Definition two_nth_of_balance {A B C : Type}
(incr : A) (contract : B) (nth : int64)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract)
(fun balance =>
op_startypeminuserrorstar (Tez.op_divquestion balance nth)
(fun res =>
op_startypeminuserrorstar
(Tez.op_starquestion res
(* ❌ Constant of type int64 is converted to int *)
2) (fun balance => _return balance))).
Definition single_transfer {A : Type}
(fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
(expect_failure : option A)
(amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
op_gtgteqquestion (register_two_contracts tt)
(fun function_parameter =>
let '(b, contract_1, contract_2) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion
(transfer_and_check_balances None __LOC__ b fee expect_failure
contract_1 contract_2 amount)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)))).
Definition block_with_a_single_transfer (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
single_transfer None None Tez.one.
Definition block_with_a_single_transfer_with_fee (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
single_transfer (Some Tez.one) None Tez.one.
Definition transfer_zero_tez (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
single_transfer None
(Some
(fun function_parameter =>
match function_parameter with
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_transaction
_)) _ => return_unit
| _ => failwith "Empty transaction should fail" % string
end)) Tez.zero.
Definition transfer_zero_implicit {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let dest := op_startypeminuserrorstar contracts 0 in
let account := op_startypeminuserrorstar tt in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
let src := Contract.implicit_contract (Account.pkh account) in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar src dest
Tez.zero)
(fun op =>
op_gtgteq (op_startypeminuserrorstar i op)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_implicit_contract
_ => true
| _ => false
end))))).
Definition transfer_to_originate_with_fee (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let contract := op_startypeminuserrorstar contracts 0 in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion
(two_nth_of_balance b contract
(* ❌ Constant of type int64 is converted to int *)
10)
(fun fee =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar ten_tez
contract op_startypeminuserrorstar)
(fun function_parameter =>
let '(operation, new_contract) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b operation)
(fun b =>
op_gtgteqquestion
(two_nth_of_balance b contract
(* ❌ Constant of type int64 is converted to int *)
3)
(fun amount =>
op_gtgteqquestion
(transfer_and_check_balances None __LOC__ b
(Some fee) None contract new_contract amount)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)))))))).
Definition transfer_amount_of_contract_balance (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (register_two_contracts tt)
(fun function_parameter =>
let '(b, contract_1, contract_2) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar contract_1)
(fun pkh1 =>
op_gtgteqquestion
(op_startypeminuserrorstar b op_startypeminuserrorstar)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract_1)
(fun balance =>
op_gtgteqquestion
(transfer_and_check_balances None __LOC__ b None None
contract_1 contract_2 balance)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)))))).
Definition transfers_to_self (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let contract := op_startypeminuserrorstar contracts 0 in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion
(two_nth_of_balance b contract
(* ❌ Constant of type int64 is converted to int *)
3)
(fun amount =>
op_gtgteqquestion
(transfer_to_itself_and_check_balances __LOC__ b None contract
amount)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion
(two_nth_of_balance b contract
(* ❌ Constant of type int64 is converted to int *)
5)
(fun fee =>
op_gtgteqquestion
(transfer_to_itself_and_check_balances __LOC__ b
(Some fee) contract ten_tez)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun function_parameter =>
let '_ := function_parameter in
return_unit))))))).
Definition missing_transaction (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (register_two_contracts tt)
(fun function_parameter =>
let '(b, contract_1, contract_2) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar contract_1)
(fun pkh1 =>
op_gtgteqquestion
(op_startypeminuserrorstar b op_startypeminuserrorstar)
(fun b =>
op_gtgteqquestion
(two_nth_of_balance b contract_1
(* ❌ Constant of type int64 is converted to int *)
6)
(fun amount =>
op_gtgteqquestion
(n_transactions 3 b None contract_1 contract_2 amount)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
contract_1 contract_2 amount)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun function_parameter =>
let '_ := function_parameter in
return_unit))))))).
Definition transfer_from_implicit_to_implicit_contract
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let bootstrap_contract := op_startypeminuserrorstar contracts 0 in
let account_a := op_startypeminuserrorstar tt in
let account_b := op_startypeminuserrorstar tt in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
let src := Contract.implicit_contract (Account.pkh account_a) in
op_gtgteqquestion
(two_nth_of_balance b bootstrap_contract
(* ❌ Constant of type int64 is converted to int *)
3)
(fun amount1 =>
op_gtgteqquestion
(two_nth_of_balance b bootstrap_contract
(* ❌ Constant of type int64 is converted to int *)
10)
(fun fee1 =>
op_gtgteqquestion
(transfer_and_check_balances (Some true) __LOC__ b
(Some fee1) None bootstrap_contract src amount1)
(fun function_parameter =>
let '(b, _) := function_parameter in
let dest := Contract.implicit_contract (pkh account_b) in
op_gtgteqquestion
(two_nth_of_balance b bootstrap_contract
(* ❌ Constant of type int64 is converted to int *)
4)
(fun amount2 =>
op_gtgteqquestion
(two_nth_of_balance b bootstrap_contract
(* ❌ Constant of type int64 is converted to int *)
10)
(fun fee2 =>
op_gtgteqquestion
(transfer_and_check_balances (Some true) __LOC__
b (Some fee2) None src dest amount2)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar b)
(fun function_parameter =>
let '_ := function_parameter in
return_unit))))))))).
Definition transfer_from_implicit_to_originated_contract
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let bootstrap_contract := op_startypeminuserrorstar contracts 0 in
let contract := op_startypeminuserrorstar contracts 0 in
let account := op_startypeminuserrorstar tt in
let src := Contract.implicit_contract (Account.pkh account) in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion
(two_nth_of_balance b bootstrap_contract
(* ❌ Constant of type int64 is converted to int *)
3)
(fun amount1 =>
op_gtgteqquestion
(transfer_and_check_balances (Some true) __LOC__ b None None
bootstrap_contract src amount1)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
contract op_startypeminuserrorstar)
(fun function_parameter =>
let '(operation, new_contract) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b operation)
(fun b =>
op_gtgteqquestion
(two_nth_of_balance b bootstrap_contract
(* ❌ Constant of type int64 is converted to int *)
4)
(fun amount2 =>
op_gtgteqquestion
(transfer_and_check_balances None __LOC__ b None
None src new_contract amount2)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar b)
(fun function_parameter =>
let '_ := function_parameter in
return_unit))))))))).
Definition multiple_transfer {A : Type}
(n : A) (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
(amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
op_gtgteqquestion (register_two_contracts tt)
(fun function_parameter =>
let '(b, contract_1, contract_2) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion
(n_transactions n b fee contract_1 contract_2 amount)
(fun b =>
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)))).
Definition block_with_multiple_transfers (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
multiple_transfer 99 None (op_startypeminuserrorstar 1000).
Definition block_with_multiple_transfers_pay_fee (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
multiple_transfer 10 (Some ten_tez) (op_startypeminuserrorstar 1000).
Definition block_with_multiple_transfers_with_without_fee
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 8)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let contracts := op_startypeminuserrorstar contracts in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
let hundred := op_startypeminuserrorstar 100 in
let ten := op_startypeminuserrorstar 10 in
let twenty := op_startypeminuserrorstar 20 in
op_gtgteqquestion
(n_transactions 10 b None (op_startypeminuserrorstar contracts 0)
(op_startypeminuserrorstar contracts 1) Tez.one)
(fun b =>
op_gtgteqquestion
(n_transactions 30 b None
(op_startypeminuserrorstar contracts 1)
(op_startypeminuserrorstar contracts 2) hundred)
(fun b =>
op_gtgteqquestion
(n_transactions 30 b None
(op_startypeminuserrorstar contracts 1)
(op_startypeminuserrorstar contracts 3) hundred)
(fun b =>
op_gtgteqquestion
(n_transactions 30 b None
(op_startypeminuserrorstar contracts 4)
(op_startypeminuserrorstar contracts 3) hundred)
(fun b =>
op_gtgteqquestion
(n_transactions 20 b None
(op_startypeminuserrorstar contracts 0)
(op_startypeminuserrorstar contracts 1) hundred)
(fun b =>
op_gtgteqquestion
(n_transactions 10 b None
(op_startypeminuserrorstar contracts 1)
(op_startypeminuserrorstar contracts 3)
hundred)
(fun b =>
op_gtgteqquestion
(n_transactions 10 b None
(op_startypeminuserrorstar contracts 1)
(op_startypeminuserrorstar contracts 3)
hundred)
(fun b =>
op_gtgteqquestion
(n_transactions 20 b (Some ten)
(op_startypeminuserrorstar contracts 3)
(op_startypeminuserrorstar contracts 4)
ten)
(fun b =>
op_gtgteqquestion
(n_transactions 10 b (Some twenty)
(op_startypeminuserrorstar
contracts 4)
(op_startypeminuserrorstar
contracts 5) ten)
(fun b =>
op_gtgteqquestion
(n_transactions 70 b
(Some twenty)
(op_startypeminuserrorstar
contracts 6)
(op_startypeminuserrorstar
contracts 0) twenty)
(fun b =>
op_gtgteqquestion
(n_transactions 550 b
(Some twenty)
(op_startypeminuserrorstar
contracts 6)
(op_startypeminuserrorstar
contracts 4) twenty)
(fun b =>
op_gtgteqquestion
(n_transactions 50 b
(Some ten)
(op_startypeminuserrorstar
contracts 7)
(op_startypeminuserrorstar
contracts 5) twenty)
(fun b =>
op_gtgteqquestion
(n_transactions 30 b
(Some ten)
(op_startypeminuserrorstar
contracts 0)
(op_startypeminuserrorstar
contracts 7)
hundred)
(fun b =>
op_gtgteqquestion
(n_transactions
20 b
(Some ten)
(op_startypeminuserrorstar
contracts 1)
(op_startypeminuserrorstar
contracts 0)
twenty)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
b)
(fun
function_parameter
=>
let '_ :=
function_parameter
in
return_unit))))))))))))))))).
Definition build_a_chain (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (register_two_contracts tt)
(fun function_parameter =>
let '(b, contract_1, contract_2) := function_parameter in
let ten := op_startypeminuserrorstar 10 in
op_gtgteqquestion
(fold_left_s
(fun b =>
fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion
(transfer_and_check_balances None __LOC__ b None None
contract_1 contract_2 ten)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_startypeminuserrorstar b))) b
(op_startypeminuserrorstar 1 10))
(fun function_parameter =>
let '_ := function_parameter in
return_unit)).
Definition empty_implicit {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let dest := op_startypeminuserrorstar contracts 0 in
let account := op_startypeminuserrorstar tt in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun incr =>
let src := Contract.implicit_contract (Account.pkh account) in
op_gtgteqquestion
(two_nth_of_balance incr dest
(* ❌ Constant of type int64 is converted to int *)
3)
(fun amount =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar src dest
amount)
(fun op =>
op_gtgteq (op_startypeminuserrorstar incr op)
(fun res =>
op_startypeminuserrorstar __LOC__ res
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_implicit_contract
_ => true
| _ => false
end)))))).
Definition balance_too_low {A : Type} (fee : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (register_two_contracts tt)
(fun function_parameter =>
let '(b, contract_1, contract_2) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract_1)
(fun balance1 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract_2)
(fun balance2 =>
op_gtgteqquestion
(op_startypeminuserrorstar fee op_startypeminuserrorstar
contract_1 contract_2 op_startypeminuserrorstar)
(fun op =>
let expect_failure
(function_parameter :
list Tezos_base__TzPervasives.Error_monad.error)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
unit) :=
match function_parameter with
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _)) _ => return_unit
| _ => failwith "balance too low should fail" % string
end in
if op_startypeminuserrorstar fee balance1 then
op_gtgteq
(op_startypeminuserrorstar expect_failure i op)
(fun _res => return_unit)
else
op_gtgteqquestion
(op_startypeminuserrorstar expect_failure i op)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar contract_1 balance1
fee)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar contract_2 balance2
Tez.zero))))))).
Definition balance_too_low_two_transfers {A B : Type}
(fee : A) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 3)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let contract_1 := op_startypeminuserrorstar contracts 0 in
let contract_2 := op_startypeminuserrorstar contracts 1 in
let contract_3 := op_startypeminuserrorstar contracts 2 in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract_1)
(fun balance =>
op_startypeminuserrorstar
(Tez.op_divquestion balance
(* ❌ Constant of type int64 is converted to int *)
3)
(fun res =>
op_startypeminuserrorstar
(Tez.op_starquestion res
(* ❌ Constant of type int64 is converted to int *)
2)
(fun two_third_of_balance =>
op_gtgteqquestion
(transfer_and_check_balances None __LOC__ i None None
contract_1 contract_2 two_third_of_balance)
(fun function_parameter =>
let '(i, _) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
contract_1)
(fun balance1 =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar contract_3)
(fun balance3 =>
op_gtgteqquestion
(op_startypeminuserrorstar fee
op_startypeminuserrorstar contract_1
contract_3 two_third_of_balance)
(fun operation =>
let expect_failure
(function_parameter :
list
Tezos_base__TzPervasives.Error_monad.error)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
unit) :=
match function_parameter with
|
cons
(Tezos_base__TzPervasives.Error_monad.Ecoproto_error
(Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
_ _ _)) _ => return_unit
| _ =>
failwith
"balance too low should fail" %
string
end in
op_gtgteqquestion
(op_startypeminuserrorstar
expect_failure i operation)
(fun i =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar
contract_1 balance1 fee)
(fun function_parameter =>
let 'tt := function_parameter in
op_startypeminuserrorstar __LOC__
op_startypeminuserrorstar
contract_3 balance3 Tez.zero))))))))))).
Definition invalid_counter {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (register_two_contracts tt)
(fun function_parameter =>
let '(b, contract_1, contract_2) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract_1
contract_2 Tez.one)
(fun op1 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract_1
contract_2 Tez.one)
(fun op2 =>
op_gtgteqquestion (op_startypeminuserrorstar b op1)
(fun b =>
op_gtgteq (op_startypeminuserrorstar b op2)
(fun b =>
op_startypeminuserrorstar __LOC__ b
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Counter_in_the_past
_ _ _ => true
| _ => false
end))))))).
Definition add_the_same_operation_twice {A : Type} (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
op_gtgteqquestion (register_two_contracts tt)
(fun function_parameter =>
let '(b, contract_1, contract_2) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion
(transfer_and_check_balances None __LOC__ b None None contract_1
contract_2 ten_tez)
(fun function_parameter =>
let '(b, op_transfer) := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract_1
contract_2 ten_tez)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteq (op_startypeminuserrorstar b op_transfer)
(fun b =>
op_startypeminuserrorstar __LOC__ b
(fun function_parameter =>
match function_parameter with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Counter_in_the_past
_ _ _ => true
| _ => false
end)))))).
Definition ownership_sender (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (register_two_contracts tt)
(fun function_parameter =>
let '(b, contract_1, contract_2) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar contract_1)
(fun manager =>
let imcontract_1 :=
Alpha_context.Contract.implicit_contract (pkh manager) in
op_gtgteqquestion
(transfer_and_check_balances None __LOC__ b None None
imcontract_1 contract_2 Tez.one)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun function_parameter =>
let '_ := function_parameter in
return_unit))))).
Definition random_range (function_parameter : Z * Z) : Z :=
let '(min, max) := function_parameter in
let interv := op_plus (op_minus max min) 1 in
let init :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := op_startypeminuserrorstar tt in
op_plus (op_startypeminuserrorstar interv) min in
init.
Definition random_contract {A B : Type} (contract_array : A) : B :=
let i := op_startypeminuserrorstar (op_startypeminuserrorstar contract_array)
in
op_startypeminuserrorstar contract_array i.
Definition random_transfer (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 10)
(fun function_parameter =>
let '(b, contracts) := function_parameter in
let contracts := op_startypeminuserrorstar contracts in
let source := random_contract contracts in
let dest := random_contract contracts in
op_gtgteqquestion (op_startypeminuserrorstar source)
(fun source_pkh =>
op_gtgteqquestion
(op_startypeminuserrorstar b op_startypeminuserrorstar)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar source)
(fun amount =>
op_gtgteqquestion
(if op_startypeminuserrorstar source dest then
transfer_to_itself_and_check_balances __LOC__ b None
source amount
else
transfer_and_check_balances None __LOC__ b None None
source dest amount)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun function_parameter =>
let '_ := function_parameter in
return_unit)))))).
Definition random_multi_transactions (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
let n := random_range (1, 100) in
multiple_transfer n None (op_startypeminuserrorstar 100).
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "single transfer" % string
(* ❌ Variants not supported *)
variant block_with_a_single_transfer)
(cons
(op_startypeminuserrorstar "single transfer with fee" % string
(* ❌ Variants not supported *)
variant block_with_a_single_transfer_with_fee)
(cons
(op_startypeminuserrorstar "single transfer zero tez" % string
(* ❌ Variants not supported *)
variant transfer_zero_tez)
(cons
(op_startypeminuserrorstar
"transfer zero tez from implicit contract" % string
(* ❌ Variants not supported *)
variant transfer_zero_implicit)
(cons
(op_startypeminuserrorstar
"transfer to originated contract paying transaction fee" % string
(* ❌ Variants not supported *)
variant transfer_to_originate_with_fee)
(cons
(op_startypeminuserrorstar
"transfer the amount from source contract balance" % string
(* ❌ Variants not supported *)
variant transfer_amount_of_contract_balance)
(cons
(op_startypeminuserrorstar "transfers to itself" % string
(* ❌ Variants not supported *)
variant transfers_to_self)
(cons
(op_startypeminuserrorstar "missing transaction" % string
(* ❌ Variants not supported *)
variant missing_transaction)
(cons
(op_startypeminuserrorstar
"transfer from an implicit to implicit contract " % string
(* ❌ Variants not supported *)
variant transfer_from_implicit_to_implicit_contract)
(cons
(op_startypeminuserrorstar
"transfer from an implicit to an originated contract" %
string
(* ❌ Variants not supported *)
variant transfer_from_implicit_to_originated_contract)
(cons
(op_startypeminuserrorstar
"block with multiple transfers" % string
(* ❌ Variants not supported *)
variant block_with_multiple_transfers)
(cons
(op_startypeminuserrorstar
"block with multiple transfer paying fee" % string
(* ❌ Variants not supported *)
variant block_with_multiple_transfers_pay_fee)
(cons
(op_startypeminuserrorstar
"block with multiple transfer without paying fee"
% string
(* ❌ Variants not supported *)
variant
block_with_multiple_transfers_with_without_fee)
(cons
(op_startypeminuserrorstar
"build a chain" % string
(* ❌ Variants not supported *)
variant build_a_chain)
(cons
(op_startypeminuserrorstar
"empty implicit" % string
(* ❌ Variants not supported *)
variant empty_implicit)
(cons
(op_startypeminuserrorstar
"balance too low - transfer zero" % string
(* ❌ Variants not supported *)
variant (balance_too_low Tez.zero))
(cons
(op_startypeminuserrorstar
"balance too low" % string
(* ❌ Variants not supported *)
variant (balance_too_low Tez.one))
(cons
(op_startypeminuserrorstar
"balance too low (max fee)" % string
(* ❌ Variants not supported *)
variant
(balance_too_low
op_startypeminuserrorstar))
(cons
(op_startypeminuserrorstar
"balance too low with two transfers - transfer zero"
% string
(* ❌ Variants not supported *)
variant
(balance_too_low_two_transfers
Tez.zero))
(cons
(op_startypeminuserrorstar
"balance too low with two transfers"
% string
(* ❌ Variants not supported *)
variant
(balance_too_low_two_transfers
Tez.one))
(cons
(op_startypeminuserrorstar
"invalid_counter" % string
(* ❌ Variants not supported *)
variant invalid_counter)
(cons
(op_startypeminuserrorstar
"add the same operation twice" %
string
(* ❌ Variants not supported *)
variant
add_the_same_operation_twice)
(cons
(op_startypeminuserrorstar
"ownership sender" % string
(* ❌ Variants not supported *)
variant ownership_sender)
(cons
(op_startypeminuserrorstar
"random transfer" % string
(* ❌ Variants not supported *)
variant random_transfer)
(cons
(op_startypeminuserrorstar
"random multi transfer" %
string
(* ❌ Variants not supported *)
variant
random_multi_transactions)
[])))))))))))))))))))))))).
src/proto_alpha/lib_protocol/test/voting.ml 562 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Test_utils
(* missing stuff in Alpha_context.Vote *)
let ballots_zero = Alpha_context.Vote.{yay = 0l; nay = 0l; pass = 0l}
let ballots_equal b1 b2 =
Alpha_context.Vote.(b1.yay = b2.yay && b1.nay = b2.nay && b1.pass = b2.pass)
let ballots_pp ppf v =
Alpha_context.Vote.(
Format.fprintf
ppf
"{ yay = %ld ; nay = %ld ; pass = %ld"
v.yay
v.nay
v.pass)
(* constants and ratios used in voting:
percent_mul denotes the percent multiplier
initial_participation is 7000 that is, 7/10 * percent_mul
the participation EMA ratio pr_ema_weight / den = 7 / 10
the participation ratio pr_num / den = 2 / 10
note: we use the same denominator for both participation EMA and participation rate.
supermajority rate is s_num / s_den = 8 / 10 *)
let percent_mul = 100_00
let initial_participation_num = 7
let initial_participation = initial_participation_num * percent_mul / 10
let pr_ema_weight = 8
let den = 10
let pr_num = den - pr_ema_weight
let s_num = 8
let s_den = 10
let qr_min_num = 2
let qr_max_num = 7
let expected_qr_num =
Float.(
of_int qr_min_num
+. of_int initial_participation_num
*. (of_int qr_max_num -. of_int qr_min_num)
/. of_int den)
(* Protocol_hash.zero is "PrihK96nBAFSxVL1GLJTVhu9YnzkMFiBeuJRPA8NwuZVZCE1L6i" *)
let protos =
Array.map
(fun s -> Protocol_hash.of_b58check_exn s)
[| "ProtoALphaALphaALphaALphaALphaALphaALpha61322gcLUGH";
"ProtoALphaALphaALphaALphaALphaALphaALphabc2a7ebx6WB";
"ProtoALphaALphaALphaALphaALphaALphaALpha84efbeiF6cm";
"ProtoALphaALphaALphaALphaALphaALphaALpha91249Z65tWS";
"ProtoALphaALphaALphaALphaALphaALphaALpha537f5h25LnN";
"ProtoALphaALphaALphaALphaALphaALphaALpha5c8fefgDYkr";
"ProtoALphaALphaALphaALphaALphaALphaALpha3f31feSSarC";
"ProtoALphaALphaALphaALphaALphaALphaALphabe31ahnkxSC";
"ProtoALphaALphaALphaALphaALphaALphaALphabab3bgRb7zQ";
"ProtoALphaALphaALphaALphaALphaALphaALphaf8d39cctbpk";
"ProtoALphaALphaALphaALphaALphaALphaALpha3b981byuYxD";
"ProtoALphaALphaALphaALphaALphaALphaALphaa116bccYowi";
"ProtoALphaALphaALphaALphaALphaALphaALphacce68eHqboj";
"ProtoALphaALphaALphaALphaALphaALphaALpha225c7YrWwR7";
"ProtoALphaALphaALphaALphaALphaALphaALpha58743cJL6FG";
"ProtoALphaALphaALphaALphaALphaALphaALphac91bcdvmJFR";
"ProtoALphaALphaALphaALphaALphaALphaALpha1faaadhV7oW";
"ProtoALphaALphaALphaALphaALphaALphaALpha98232gD94QJ";
"ProtoALphaALphaALphaALphaALphaALphaALpha9d1d8cijvAh";
"ProtoALphaALphaALphaALphaALphaALphaALphaeec52dKF6Gx";
"ProtoALphaALphaALphaALphaALphaALphaALpha841f2cQqajX" |]
(** helper functions *)
let mk_contracts_from_pkh pkh_list =
List.map Alpha_context.Contract.implicit_contract pkh_list
(* get the list of delegates and the list of their rolls from listings *)
let get_delegates_and_rolls_from_listings b =
Context.Vote.get_listings (B b)
>>=? fun l -> return (mk_contracts_from_pkh (List.map fst l), List.map snd l)
(* compute the rolls of each delegate *)
let get_rolls b delegates loc =
Context.Vote.get_listings (B b)
>>=? fun l ->
map_s
(fun delegate ->
Context.Contract.pkh delegate
>>=? fun pkh ->
match List.find_opt (fun (del, _) -> del = pkh) l with
| None ->
failwith "%s - Missing delegate" loc
| Some (_, rolls) ->
return rolls)
delegates
let test_successful_vote num_delegates () =
let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
Context.init ~min_proposal_quorum num_delegates
>>=? fun (b, _) ->
Context.get_constants (B b)
>>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
(* no ballots in proposal period *)
Context.Vote.get_ballots (B b)
>>=? fun v ->
Assert.equal
~loc:__LOC__
ballots_equal
"Unexpected ballots"
ballots_pp
v
ballots_zero
>>=? fun () ->
(* no ballots in proposal period *)
Context.Vote.get_ballot_list (B b)
>>=? (function
| [] ->
return_unit
| _ ->
failwith "%s - Unexpected ballot list" __LOC__)
>>=? fun () ->
(* period 0 *)
Context.Vote.get_voting_period (B b)
>>=? fun v ->
let open Alpha_context in
Assert.equal
~loc:__LOC__
Voting_period.equal
"Unexpected period"
Voting_period.pp
v
Voting_period.(root)
>>=? fun () ->
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Proposal ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
(* participation EMA starts at initial_participation *)
Context.Vote.get_participation_ema b
>>=? fun v ->
Assert.equal_int ~loc:__LOC__ initial_participation (Int32.to_int v)
>>=? fun () ->
(* listings must be populated in proposal period *)
Context.Vote.get_listings (B b)
>>=? (function
| [] ->
failwith "%s - Unexpected empty listings" __LOC__
| _ ->
return_unit)
>>=? fun () ->
(* beginning of proposal, denoted by _p1;
take a snapshot of the active delegates and their rolls from listings *)
get_delegates_and_rolls_from_listings b
>>=? fun (delegates_p1, rolls_p1) ->
(* no proposals at the beginning of proposal period *)
Context.Vote.get_proposals (B b)
>>=? fun ps ->
( if Environment.Protocol_hash.Map.is_empty ps then return_unit
else failwith "%s - Unexpected proposals" __LOC__ )
>>=? fun () ->
(* no current proposal during proposal period *)
Context.Vote.get_current_proposal (B b)
>>=? (function
| None ->
return_unit
| Some _ ->
failwith "%s - Unexpected proposal" __LOC__)
>>=? fun () ->
let del1 = List.nth delegates_p1 0 in
let del2 = List.nth delegates_p1 1 in
let props =
List.map (fun i -> protos.(i)) (2 -- Constants.max_proposals_per_delegate)
in
Op.proposals (B b) del1 (Protocol_hash.zero :: props)
>>=? fun ops1 ->
Op.proposals (B b) del2 [Protocol_hash.zero]
>>=? fun ops2 ->
Block.bake ~operations:[ops1; ops2] b
>>=? fun b ->
(* proposals are now populated *)
Context.Vote.get_proposals (B b)
>>=? fun ps ->
(* correctly count the double proposal for zero *)
(let weight = Int32.add (List.nth rolls_p1 0) (List.nth rolls_p1 1) in
match Environment.Protocol_hash.(Map.find_opt zero ps) with
| Some v ->
if v = weight then return_unit
else failwith "%s - Wrong count %ld is not %ld" __LOC__ v weight
| None ->
failwith "%s - Missing proposal" __LOC__)
>>=? fun () ->
(* proposing more than maximum_proposals fails *)
Op.proposals (B b) del1 (Protocol_hash.zero :: props)
>>=? fun ops ->
Block.bake ~operations:[ops] b
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Amendment.Too_many_proposals ->
true
| _ ->
false)
>>=? fun () ->
(* proposing less than one proposal fails *)
Op.proposals (B b) del1 []
>>=? fun ops ->
Block.bake ~operations:[ops] b
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Amendment.Empty_proposal ->
true
| _ ->
false)
>>=? fun () ->
(* skip to testing_vote period
-1 because we already baked one block with the proposal *)
Block.bake_n (Int32.to_int blocks_per_voting_period - 2) b
>>=? fun b ->
(* we moved to a testing_vote period with one proposal *)
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Testing_vote ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
(* period 1 *)
Context.Vote.get_voting_period (B b)
>>=? fun v ->
let open Alpha_context in
Assert.equal
~loc:__LOC__
Voting_period.equal
"Unexpected period"
Voting_period.pp
v
Voting_period.(succ root)
>>=? fun () ->
(* listings must be populated in testing_vote period *)
Context.Vote.get_listings (B b)
>>=? (function
| [] ->
failwith "%s - Unexpected empty listings" __LOC__
| _ ->
return_unit)
>>=? fun () ->
(* beginning of testing_vote period, denoted by _p2;
take a snapshot of the active delegates and their rolls from listings *)
get_delegates_and_rolls_from_listings b
>>=? fun (delegates_p2, rolls_p2) ->
(* no proposals during testing_vote period *)
Context.Vote.get_proposals (B b)
>>=? fun ps ->
( if Environment.Protocol_hash.Map.is_empty ps then return_unit
else failwith "%s - Unexpected proposals" __LOC__ )
>>=? fun () ->
(* current proposal must be set during testing_vote period *)
Context.Vote.get_current_proposal (B b)
>>=? (function
| Some v ->
if Protocol_hash.(equal zero v) then return_unit
else failwith "%s - Wrong proposal" __LOC__
| None ->
failwith "%s - Missing proposal" __LOC__)
>>=? fun () ->
(* unanimous vote: all delegates --active when p2 started-- vote *)
map_s
(fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay)
delegates_p2
>>=? fun operations ->
Block.bake ~operations b
>>=? fun b ->
Op.ballot (B b) del1 Protocol_hash.zero Vote.Nay
>>=? fun op ->
Block.bake ~operations:[op] b
>>= fun res ->
Assert.proto_error ~loc:__LOC__ res (function
| Amendment.Unauthorized_ballot ->
true
| _ ->
false)
>>=? fun () ->
fold_left_s (fun v acc -> return Int32.(add v acc)) 0l rolls_p2
>>=? fun rolls_sum ->
(* # of Yays in ballots matches rolls of the delegate *)
Context.Vote.get_ballots (B b)
>>=? fun v ->
Assert.equal
~loc:__LOC__
ballots_equal
"Unexpected ballots"
ballots_pp
v
Vote.{yay = rolls_sum; nay = 0l; pass = 0l}
>>=? fun () ->
(* One Yay ballot per delegate *)
Context.Vote.get_ballot_list (B b)
>>=? (function
| [] ->
failwith "%s - Unexpected empty ballot list" __LOC__
| l ->
iter_s
(fun delegate ->
Context.Contract.pkh delegate
>>=? fun pkh ->
match List.find_opt (fun (del, _) -> del = pkh) l with
| None ->
failwith "%s - Missing delegate" __LOC__
| Some (_, Vote.Yay) ->
return_unit
| Some _ ->
failwith "%s - Wrong ballot" __LOC__)
delegates_p2)
>>=? fun () ->
(* skip to testing period
-1 because we already baked one block with the ballot *)
Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
>>=? fun b ->
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Testing ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
(* period 2 *)
Context.Vote.get_voting_period (B b)
>>=? fun v ->
let open Alpha_context in
Assert.equal
~loc:__LOC__
Voting_period.equal
"Unexpected period"
Voting_period.pp
v
Voting_period.(succ (succ root))
>>=? fun () ->
(* no ballots in testing period *)
Context.Vote.get_ballots (B b)
>>=? fun v ->
Assert.equal
~loc:__LOC__
ballots_equal
"Unexpected ballots"
ballots_pp
v
ballots_zero
>>=? fun () ->
(* listings must be empty in testing period *)
Context.Vote.get_listings (B b)
>>=? (function
| [] -> return_unit | _ -> failwith "%s - Unexpected listings" __LOC__)
>>=? fun () ->
(* skip to promotion_vote period *)
Block.bake_n (Int32.to_int blocks_per_voting_period) b
>>=? fun b ->
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Promotion_vote ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
(* period 3 *)
Context.Vote.get_voting_period (B b)
>>=? fun v ->
let open Alpha_context in
Assert.equal
~loc:__LOC__
Voting_period.equal
"Unexpected period"
Voting_period.pp
v
Voting_period.(succ (succ (succ root)))
>>=? fun () ->
(* listings must be populated in promotion_vote period *)
Context.Vote.get_listings (B b)
>>=? (function
| [] ->
failwith "%s - Unexpected empty listings" __LOC__
| _ ->
return_unit)
>>=? fun () ->
(* beginning of promotion_vote period, denoted by _p4;
take a snapshot of the active delegates and their rolls from listings *)
get_delegates_and_rolls_from_listings b
>>=? fun (delegates_p4, rolls_p4) ->
(* no proposals during promotion_vote period *)
Context.Vote.get_proposals (B b)
>>=? fun ps ->
( if Environment.Protocol_hash.Map.is_empty ps then return_unit
else failwith "%s - Unexpected proposals" __LOC__ )
>>=? fun () ->
(* current proposal must be set during promotion_vote period *)
Context.Vote.get_current_proposal (B b)
>>=? (function
| Some v ->
if Protocol_hash.(equal zero v) then return_unit
else failwith "%s - Wrong proposal" __LOC__
| None ->
failwith "%s - Missing proposal" __LOC__)
>>=? fun () ->
(* unanimous vote: all delegates --active when p4 started-- vote *)
map_s
(fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay)
delegates_p4
>>=? fun operations ->
Block.bake ~operations b
>>=? fun b ->
fold_left_s (fun v acc -> return Int32.(add v acc)) 0l rolls_p4
>>=? fun rolls_sum ->
(* # of Yays in ballots matches rolls of the delegate *)
Context.Vote.get_ballots (B b)
>>=? fun v ->
Assert.equal
~loc:__LOC__
ballots_equal
"Unexpected ballots"
ballots_pp
v
Vote.{yay = rolls_sum; nay = 0l; pass = 0l}
>>=? fun () ->
(* One Yay ballot per delegate *)
Context.Vote.get_ballot_list (B b)
>>=? (function
| [] ->
failwith "%s - Unexpected empty ballot list" __LOC__
| l ->
iter_s
(fun delegate ->
Context.Contract.pkh delegate
>>=? fun pkh ->
match List.find_opt (fun (del, _) -> del = pkh) l with
| None ->
failwith "%s - Missing delegate" __LOC__
| Some (_, Vote.Yay) ->
return_unit
| Some _ ->
failwith "%s - Wrong ballot" __LOC__)
delegates_p4)
>>=? fun () ->
(* skip to end of promotion_vote period and activation*)
Block.bake_n Int32.(to_int blocks_per_voting_period - 1) b
>>=? fun b ->
(* zero is the new protocol (before the vote this value is unset) *)
Context.Vote.get_protocol b
>>= fun p ->
Assert.equal
~loc:__LOC__
Protocol_hash.equal
"Unexpected proposal"
Protocol_hash.pp
p
Protocol_hash.zero
>>=? fun () -> return_unit
(* given a list of active delegates,
return the first k active delegates with which one can have quorum, that is:
their roll sum divided by the total roll sum is bigger than pr_ema_weight/den *)
let get_smallest_prefix_voters_for_quorum active_delegates active_rolls =
fold_left_s (fun v acc -> return Int32.(add v acc)) 0l active_rolls
>>=? fun active_rolls_sum ->
let rec loop delegates rolls sum selected =
match (delegates, rolls) with
| ([], []) ->
selected
| (del :: delegates, del_rolls :: rolls) ->
if
den * sum
< Float.to_int (expected_qr_num *. Int32.to_float active_rolls_sum)
then
loop delegates rolls (sum + Int32.to_int del_rolls) (del :: selected)
else selected
| (_, _) ->
[]
in
return (loop active_delegates active_rolls 0 [])
let get_expected_participation_ema rolls voter_rolls old_participation_ema =
(* formula to compute the updated participation_ema *)
let get_updated_participation_ema old_participation_ema participation =
( (pr_ema_weight * Int32.to_int old_participation_ema)
+ (pr_num * participation) )
/ den
in
fold_left_s (fun v acc -> return Int32.(add v acc)) 0l rolls
>>=? fun rolls_sum ->
fold_left_s (fun v acc -> return Int32.(add v acc)) 0l voter_rolls
>>=? fun voter_rolls_sum ->
let participation =
Int32.to_int voter_rolls_sum * percent_mul / Int32.to_int rolls_sum
in
return (get_updated_participation_ema old_participation_ema participation)
(* if not enough quorum -- get_updated_participation_ema < pr_ema_weight/den -- in testing vote,
go back to proposal period *)
let test_not_enough_quorum_in_testing_vote num_delegates () =
let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
Context.init ~min_proposal_quorum num_delegates
>>=? fun (b, delegates) ->
Context.get_constants (B b)
>>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
(* proposal period *)
let open Alpha_context in
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Proposal ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
let proposer = List.nth delegates 0 in
Op.proposals (B b) proposer [Protocol_hash.zero]
>>=? fun ops ->
Block.bake ~operations:[ops] b
>>=? fun b ->
(* skip to vote_testing period
-1 because we already baked one block with the proposal *)
Block.bake_n (Int32.to_int blocks_per_voting_period - 2) b
>>=? fun b ->
(* we moved to a testing_vote period with one proposal *)
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Testing_vote ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
Context.Vote.get_participation_ema b
>>=? fun initial_participation_ema ->
(* beginning of testing_vote period, denoted by _p2;
take a snapshot of the active delegates and their rolls from listings *)
get_delegates_and_rolls_from_listings b
>>=? fun (delegates_p2, rolls_p2) ->
get_smallest_prefix_voters_for_quorum delegates_p2 rolls_p2
>>=? fun voters ->
(* take the first two voters out so there cannot be quorum *)
let voters_without_quorum = List.tl voters in
get_rolls b voters_without_quorum __LOC__
>>=? fun voters_rolls_in_testing_vote ->
(* all voters_without_quorum vote, for yays;
no nays, so supermajority is satisfied *)
map_s
(fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay)
voters_without_quorum
>>=? fun operations ->
Block.bake ~operations b
>>=? fun b ->
(* skip to testing period *)
Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
>>=? fun b ->
(* we move back to the proposal period because not enough quorum *)
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Proposal ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
(* check participation_ema update *)
get_expected_participation_ema
rolls_p2
voters_rolls_in_testing_vote
initial_participation_ema
>>=? fun expected_participation_ema ->
Context.Vote.get_participation_ema b
>>=? fun new_participation_ema ->
(* assert the formula to calculate participation_ema is correct *)
Assert.equal_int
~loc:__LOC__
expected_participation_ema
(Int32.to_int new_participation_ema)
>>=? fun () -> return_unit
(* if not enough quorum -- get_updated_participation_ema < pr_ema_weight/den -- in promotion vote,
go back to proposal period *)
let test_not_enough_quorum_in_promotion_vote num_delegates () =
let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
Context.init ~min_proposal_quorum num_delegates
>>=? fun (b, delegates) ->
Context.get_constants (B b)
>>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Proposal ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
let proposer = List.nth delegates 0 in
Op.proposals (B b) proposer [Protocol_hash.zero]
>>=? fun ops ->
Block.bake ~operations:[ops] b
>>=? fun b ->
(* skip to vote_testing period
-1 because we already baked one block with the proposal *)
Block.bake_n (Int32.to_int blocks_per_voting_period - 2) b
>>=? fun b ->
(* we moved to a testing_vote period with one proposal *)
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Testing_vote ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
(* beginning of testing_vote period, denoted by _p2;
take a snapshot of the active delegates and their rolls from listings *)
get_delegates_and_rolls_from_listings b
>>=? fun (delegates_p2, rolls_p2) ->
get_smallest_prefix_voters_for_quorum delegates_p2 rolls_p2
>>=? fun voters ->
let open Alpha_context in
(* all voters vote, for yays;
no nays, so supermajority is satisfied *)
map_s (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters
>>=? fun operations ->
Block.bake ~operations b
>>=? fun b ->
(* skip to testing period *)
Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
>>=? fun b ->
(* we move to testing because we have supermajority and enough quorum *)
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Testing ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
(* skip to promotion_vote period *)
Block.bake_n (Int32.to_int blocks_per_voting_period) b
>>=? fun b ->
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Promotion_vote ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
Context.Vote.get_participation_ema b
>>=? fun initial_participation_ema ->
(* beginning of promotion period, denoted by _p4;
take a snapshot of the active delegates and their rolls from listings *)
get_delegates_and_rolls_from_listings b
>>=? fun (delegates_p4, rolls_p4) ->
get_smallest_prefix_voters_for_quorum delegates_p4 rolls_p4
>>=? fun voters ->
(* take the first voter out so there cannot be quorum *)
let voters_without_quorum = List.tl voters in
get_rolls b voters_without_quorum __LOC__
>>=? fun voter_rolls ->
(* all voters_without_quorum vote, for yays;
no nays, so supermajority is satisfied *)
map_s
(fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay)
voters_without_quorum
>>=? fun operations ->
Block.bake ~operations b
>>=? fun b ->
(* skip to end of promotion_vote period *)
Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
>>=? fun b ->
get_expected_participation_ema rolls_p4 voter_rolls initial_participation_ema
>>=? fun expected_participation_ema ->
Context.Vote.get_participation_ema b
>>=? fun new_participation_ema ->
(* assert the formula to calculate participation_ema is correct *)
Assert.equal_int
~loc:__LOC__
expected_participation_ema
(Int32.to_int new_participation_ema)
>>=? fun () ->
(* we move back to the proposal period because not enough quorum *)
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Proposal ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () -> return_unit
let test_multiple_identical_proposals_count_as_one () =
Context.init 1
>>=? fun (b, delegates) ->
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Proposal ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
let proposer = List.hd delegates in
Op.proposals (B b) proposer [Protocol_hash.zero; Protocol_hash.zero]
>>=? fun ops ->
Block.bake ~operations:[ops] b
>>=? fun b ->
(* compute the weight of proposals *)
Context.Vote.get_proposals (B b)
>>=? fun ps ->
(* compute the rolls of proposer *)
Context.Contract.pkh proposer
>>=? fun pkh ->
Context.Vote.get_listings (B b)
>>=? fun l ->
( match List.find_opt (fun (del, _) -> del = pkh) l with
| None ->
failwith "%s - Missing delegate" __LOC__
| Some (_, proposer_rolls) ->
return proposer_rolls )
>>=? fun proposer_rolls ->
(* correctly count the double proposal for zero as one proposal *)
let expected_weight_proposer = proposer_rolls in
match Environment.Protocol_hash.(Map.find_opt zero ps) with
| Some v ->
if v = expected_weight_proposer then return_unit
else
failwith
"%s - Wrong count %ld is not %ld; identical proposals count as one"
__LOC__
v
expected_weight_proposer
| None ->
failwith "%s - Missing proposal" __LOC__
(* assumes the initial balance of allocated by Context.init is at
least 4 time the value of the tokens_per_roll constant *)
let test_supermajority_in_proposal there_is_a_winner () =
let min_proposal_quorum = 0l in
Context.init ~min_proposal_quorum ~initial_balances:[1L; 1L; 1L] 10
>>=? fun (b, delegates) ->
Context.get_constants (B b)
>>=? fun { parametric =
{blocks_per_cycle; blocks_per_voting_period; tokens_per_roll; _};
_ } ->
let del1 = List.nth delegates 0 in
let del2 = List.nth delegates 1 in
let del3 = List.nth delegates 2 in
map_s (fun del -> Context.Contract.pkh del) [del1; del2; del3]
>>=? fun pkhs ->
let policy = Block.Excluding pkhs in
Op.transaction (B b) (List.nth delegates 3) del1 tokens_per_roll
>>=? fun op1 ->
Op.transaction (B b) (List.nth delegates 4) del2 tokens_per_roll
>>=? fun op2 ->
( if there_is_a_winner then Test_tez.Tez.( *? ) tokens_per_roll 3L
else Test_tez.Tez.( *? ) tokens_per_roll 2L )
>>?= fun bal3 ->
Op.transaction (B b) (List.nth delegates 5) del3 bal3
>>=? fun op3 ->
Block.bake ~policy ~operations:[op1; op2; op3] b
>>=? fun b ->
(* we let one voting period pass; we make sure that:
- the three selected delegates remain active by re-registering as delegates
- their number of rolls do not change *)
fold_left_s
(fun b _ ->
Error_monad.map_s
(fun del ->
Context.Contract.pkh del
>>=? fun pkh -> Op.delegation (B b) del (Some pkh))
delegates
>>=? fun ops ->
Block.bake ~policy ~operations:ops b
>>=? fun b -> Block.bake_until_cycle_end ~policy b)
b
(1 -- Int32.to_int (Int32.div blocks_per_voting_period blocks_per_cycle))
>>=? fun b ->
(* make the proposals *)
Op.proposals (B b) del1 [protos.(0)]
>>=? fun ops1 ->
Op.proposals (B b) del2 [protos.(0)]
>>=? fun ops2 ->
Op.proposals (B b) del3 [protos.(1)]
>>=? fun ops3 ->
Block.bake ~policy ~operations:[ops1; ops2; ops3] b
>>=? fun b ->
Block.bake_n ~policy (Int32.to_int blocks_per_voting_period - 1) b
>>=? fun b ->
(* we remain in the proposal period when there is no winner,
otherwise we move to the testing vote period *)
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Testing_vote ->
if there_is_a_winner then return_unit
else
failwith
"%s - Expected period kind Proposal, obtained Testing_vote"
__LOC__
| Proposal ->
if not there_is_a_winner then return_unit
else
failwith
"%s - Expected period kind Testing_vote, obtained Proposal"
__LOC__
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () -> return_unit
let test_quorum_in_proposal has_quorum () =
let total_tokens = 32_000_000_000_000L in
let half_tokens = Int64.div total_tokens 2L in
Context.init ~initial_balances:[1L; half_tokens; half_tokens] 3
>>=? fun (b, delegates) ->
Context.get_constants (B b)
>>=? fun { parametric =
{ blocks_per_cycle;
blocks_per_voting_period;
min_proposal_quorum;
_ };
_ } ->
let del1 = List.nth delegates 0 in
let del2 = List.nth delegates 1 in
map_s (fun del -> Context.Contract.pkh del) [del1; del2]
>>=? fun pkhs ->
let policy = Block.Excluding pkhs in
let quorum =
if has_quorum then Int64.of_int32 min_proposal_quorum
else Int64.(sub (of_int32 min_proposal_quorum) 10L)
in
let bal =
Int64.(div (mul total_tokens quorum) 100_00L) |> Test_tez.Tez.of_mutez_exn
in
Op.transaction (B b) del2 del1 bal
>>=? fun op2 ->
Block.bake ~policy ~operations:[op2] b
>>=? fun b ->
(* we let one voting period pass; we make sure that:
- the two selected delegates remain active by re-registering as delegates
- their number of rolls do not change *)
fold_left_s
(fun b _ ->
Error_monad.map_s
(fun del ->
Context.Contract.pkh del
>>=? fun pkh -> Op.delegation (B b) del (Some pkh))
[del1; del2]
>>=? fun ops ->
Block.bake ~policy ~operations:ops b
>>=? fun b -> Block.bake_until_cycle_end ~policy b)
b
(1 -- Int32.to_int (Int32.div blocks_per_voting_period blocks_per_cycle))
>>=? fun b ->
(* make the proposal *)
Op.proposals (B b) del1 [protos.(0)]
>>=? fun ops ->
Block.bake ~policy ~operations:[ops] b
>>=? fun b ->
Block.bake_n ~policy (Int32.to_int blocks_per_voting_period - 1) b
>>=? fun b ->
(* we remain in the proposal period when there is no quorum,
otherwise we move to the testing vote period *)
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Testing_vote ->
if has_quorum then return_unit
else
failwith
"%s - Expected period kind Proposal, obtained Testing_vote"
__LOC__
| Proposal ->
if not has_quorum then return_unit
else
failwith
"%s - Expected period kind Testing_vote, obtained Proposal"
__LOC__
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () -> return_unit
let test_supermajority_in_testing_vote supermajority () =
let min_proposal_quorum = Int32.(of_int @@ (100_00 / 100)) in
Context.init ~min_proposal_quorum 100
>>=? fun (b, delegates) ->
Context.get_constants (B b)
>>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
let del1 = List.nth delegates 0 in
let proposal = protos.(0) in
Op.proposals (B b) del1 [proposal]
>>=? fun ops1 ->
Block.bake ~operations:[ops1] b
>>=? fun b ->
Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
>>=? fun b ->
(* move to testing_vote *)
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Testing_vote ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
(* assert our proposal won *)
Context.Vote.get_current_proposal (B b)
>>=? (function
| Some v ->
if Protocol_hash.(equal proposal v) then return_unit
else failwith "%s - Wrong proposal" __LOC__
| None ->
failwith "%s - Missing proposal" __LOC__)
>>=? fun () ->
(* beginning of testing_vote period, denoted by _p2;
take a snapshot of the active delegates and their rolls from listings *)
get_delegates_and_rolls_from_listings b
>>=? fun (delegates_p2, _olls_p2) ->
(* supermajority means [num_yays / (num_yays + num_nays) >= s_num / s_den],
which is equivalent with [num_yays >= num_nays * s_num / (s_den - s_num)] *)
let num_delegates = List.length delegates_p2 in
let num_nays = num_delegates / 5 in
(* any smaller number will do as well *)
let num_yays = num_nays * s_num / (s_den - s_num) in
(* majority/minority vote depending on the [supermajority] parameter *)
let num_yays = if supermajority then num_yays else num_yays - 1 in
let open Alpha_context in
let (nays_delegates, rest) = List.split_n num_nays delegates_p2 in
let (yays_delegates, _) = List.split_n num_yays rest in
map_s (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates
>>=? fun operations_yays ->
map_s (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates
>>=? fun operations_nays ->
let operations = operations_yays @ operations_nays in
Block.bake ~operations b
>>=? fun b ->
Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
>>=? fun b ->
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Testing ->
if supermajority then return_unit
else
failwith
"%s - Expected period kind Proposal, obtained Testing"
__LOC__
| Proposal ->
if not supermajority then return_unit
else
failwith
"%s - Expected period kind Testing_vote, obtained Proposal"
__LOC__
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () -> return_unit
(* test also how the selection scales: all delegates propose max proposals *)
let test_no_winning_proposal num_delegates () =
let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
Context.init ~min_proposal_quorum num_delegates
>>=? fun (b, _) ->
Context.get_constants (B b)
>>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
(* beginning of proposal, denoted by _p1;
take a snapshot of the active delegates and their rolls from listings *)
get_delegates_and_rolls_from_listings b
>>=? fun (delegates_p1, _rolls_p1) ->
let open Alpha_context in
let props =
List.map (fun i -> protos.(i)) (1 -- Constants.max_proposals_per_delegate)
in
(* all delegates active in p1 propose the same proposals *)
map_s (fun del -> Op.proposals (B b) del props) delegates_p1
>>=? fun ops_list ->
Block.bake ~operations:ops_list b
>>=? fun b ->
(* skip to testing_vote period
-1 because we already baked one block with the proposal *)
Block.bake_n (Int32.to_int blocks_per_voting_period - 2) b
>>=? fun b ->
(* we stay in the same proposal period because no winning proposal *)
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Proposal ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () -> return_unit
(** Test that for the vote to pass with maximum possible participation_ema
(100%), it is sufficient for the vote quorum to be equal or greater than
the maximum quorum cap. *)
let test_quorum_capped_maximum num_delegates () =
let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
Context.init ~min_proposal_quorum num_delegates
>>=? fun (b, delegates) ->
(* set the participation EMA to 100% *)
Context.Vote.set_participation_ema b 100_00l
>>= fun b ->
Context.get_constants (B b)
>>=? fun {parametric = {blocks_per_voting_period; quorum_max; _}; _} ->
(* proposal period *)
let open Alpha_context in
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Proposal ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
(* propose a new protocol *)
let protocol = Protocol_hash.zero in
let proposer = List.nth delegates 0 in
Op.proposals (B b) proposer [protocol]
>>=? fun ops ->
Block.bake ~operations:[ops] b
>>=? fun b ->
(* skip to vote_testing period
-1 because we already baked one block with the proposal *)
Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
>>=? fun b ->
(* we moved to a testing_vote period with one proposal *)
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Testing_vote ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
(* take percentage of the delegates equal or greater than quorum_max *)
let minimum_to_pass =
Float.of_int (List.length delegates)
*. Int32.(to_float quorum_max)
/. 100_00.
|> Float.ceil |> Float.to_int
in
let voters = List.take_n minimum_to_pass delegates in
(* all voters vote for yays; no nays, so supermajority is satisfied *)
map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters
>>=? fun operations ->
Block.bake ~operations b
>>=? fun b ->
(* skip to next period *)
Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
>>=? fun b ->
(* expect to move to testing because we have supermajority and enough quorum *)
Context.Vote.get_current_period_kind (B b)
>>=? function
| Testing ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__
(** Test that for the vote to pass with minimum possible participation_ema
(0%), it is sufficient for the vote quorum to be equal or greater than
the minimum quorum cap. *)
let test_quorum_capped_minimum num_delegates () =
let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
Context.init ~min_proposal_quorum num_delegates
>>=? fun (b, delegates) ->
(* set the participation EMA to 0% *)
Context.Vote.set_participation_ema b 0l
>>= fun b ->
Context.get_constants (B b)
>>=? fun {parametric = {blocks_per_voting_period; quorum_min; _}; _} ->
(* proposal period *)
let open Alpha_context in
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Proposal ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
(* propose a new protocol *)
let protocol = Protocol_hash.zero in
let proposer = List.nth delegates 0 in
Op.proposals (B b) proposer [protocol]
>>=? fun ops ->
Block.bake ~operations:[ops] b
>>=? fun b ->
(* skip to vote_testing period
-1 because we already baked one block with the proposal *)
Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
>>=? fun b ->
(* we moved to a testing_vote period with one proposal *)
Context.Vote.get_current_period_kind (B b)
>>=? (function
| Testing_vote ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__)
>>=? fun () ->
(* take percentage of the delegates equal or greater than quorum_min *)
let minimum_to_pass =
Float.of_int (List.length delegates)
*. Int32.(to_float quorum_min)
/. 100_00.
|> Float.ceil |> Float.to_int
in
let voters = List.take_n minimum_to_pass delegates in
(* all voters vote for yays; no nays, so supermajority is satisfied *)
map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters
>>=? fun operations ->
Block.bake ~operations b
>>=? fun b ->
(* skip to next period *)
Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
>>=? fun b ->
(* expect to move to testing because we have supermajority and enough quorum *)
Context.Vote.get_current_period_kind (B b)
>>=? function
| Testing ->
return_unit
| _ ->
failwith "%s - Unexpected period kind" __LOC__
let tests =
[ Test.tztest "voting successful_vote" `Quick (test_successful_vote 137);
Test.tztest
"voting testing vote, not enough quorum"
`Quick
(test_not_enough_quorum_in_testing_vote 245);
Test.tztest
"voting promotion vote, not enough quorum"
`Quick
(test_not_enough_quorum_in_promotion_vote 432);
Test.tztest
"voting counting double proposal"
`Quick
test_multiple_identical_proposals_count_as_one;
Test.tztest
"voting proposal, with supermajority"
`Quick
(test_supermajority_in_proposal true);
Test.tztest
"voting proposal, without supermajority"
`Quick
(test_supermajority_in_proposal false);
Test.tztest
"voting proposal, with quorum"
`Quick
(test_quorum_in_proposal true);
Test.tztest
"voting proposal, without quorum"
`Quick
(test_quorum_in_proposal false);
Test.tztest
"voting testing vote, with supermajority"
`Quick
(test_supermajority_in_testing_vote true);
Test.tztest
"voting testing vote, without supermajority"
`Quick
(test_supermajority_in_testing_vote false);
Test.tztest
"voting proposal, no winning proposal"
`Quick
(test_no_winning_proposal 400);
Test.tztest
"voting quorum, quorum capped maximum"
`Quick
(test_quorum_capped_maximum 400);
Test.tztest
"voting quorum, quorum capped minimum"
`Quick
(test_quorum_capped_minimum 401) ]
src/proto_alpha/lib_protocol/test/voting.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Definition ballots_zero
: Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots :=
{|
yay :=
(* ❌ Constant of type int32 is converted to int *)
0;
nay :=
(* ❌ Constant of type int32 is converted to int *)
0;
pass :=
(* ❌ Constant of type int32 is converted to int *)
0 |}.
Definition ballots_equal
(b1 : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots)
(b2 : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots) : bool :=
op_andand (op_startypeminuserrorstar (yay b1) (yay b2))
(op_andand (op_startypeminuserrorstar (nay b1) (nay b2))
(op_startypeminuserrorstar (pass b1) (pass b2))).
Definition ballots_pp
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
(v : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots) : unit :=
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
"{ yay = " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
" ; nay = " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
" ; pass = " % string
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format))))))
"{ yay = %ld ; nay = %ld ; pass = %ld" % string) (yay v) (nay v) (pass v).
Definition percent_mul : Z := 10000.
Definition initial_participation_num : Z := 7.
Definition initial_participation : Z :=
op_div (op_star initial_participation_num percent_mul) 10.
Definition pr_ema_weight : Z := 8.
Definition den : Z := 10.
Definition pr_num : Z := op_minus den pr_ema_weight.
Definition s_num : Z := 8.
Definition s_den : Z := 10.
Definition qr_min_num : Z := 2.
Definition qr_max_num : Z := 7.
Definition expected_qr_num {A : Type} : A := op_startypeminuserrorstar.
Definition protos {A : Type} : A :=
op_startypeminuserrorstar
(fun s =>
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.of_b58check_exn)
s)
(* ❌ Arrays not handled. *)
[
"ProtoALphaALphaALphaALphaALphaALphaALpha61322gcLUGH" % string;
"ProtoALphaALphaALphaALphaALphaALphaALphabc2a7ebx6WB" % string;
"ProtoALphaALphaALphaALphaALphaALphaALpha84efbeiF6cm" % string;
"ProtoALphaALphaALphaALphaALphaALphaALpha91249Z65tWS" % string;
"ProtoALphaALphaALphaALphaALphaALphaALpha537f5h25LnN" % string;
"ProtoALphaALphaALphaALphaALphaALphaALpha5c8fefgDYkr" % string;
"ProtoALphaALphaALphaALphaALphaALphaALpha3f31feSSarC" % string;
"ProtoALphaALphaALphaALphaALphaALphaALphabe31ahnkxSC" % string;
"ProtoALphaALphaALphaALphaALphaALphaALphabab3bgRb7zQ" % string;
"ProtoALphaALphaALphaALphaALphaALphaALphaf8d39cctbpk" % string;
"ProtoALphaALphaALphaALphaALphaALphaALpha3b981byuYxD" % string;
"ProtoALphaALphaALphaALphaALphaALphaALphaa116bccYowi" % string;
"ProtoALphaALphaALphaALphaALphaALphaALphacce68eHqboj" % string;
"ProtoALphaALphaALphaALphaALphaALphaALpha225c7YrWwR7" % string;
"ProtoALphaALphaALphaALphaALphaALphaALpha58743cJL6FG" % string;
"ProtoALphaALphaALphaALphaALphaALphaALphac91bcdvmJFR" % string;
"ProtoALphaALphaALphaALphaALphaALphaALpha1faaadhV7oW" % string;
"ProtoALphaALphaALphaALphaALphaALphaALpha98232gD94QJ" % string;
"ProtoALphaALphaALphaALphaALphaALphaALpha9d1d8cijvAh" % string;
"ProtoALphaALphaALphaALphaALphaALphaALphaeec52dKF6Gx" % string;
"ProtoALphaALphaALphaALphaALphaALphaALpha841f2cQqajX" % string
].
Definition mk_contracts_from_pkh
(pkh_list : list Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
: list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract :=
List.map Alpha_context.Contract.implicit_contract pkh_list.
Definition get_delegates_and_rolls_from_listings {A B : Type} (b : A)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
((list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract) *
(list B))) :=
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun l =>
_return ((mk_contracts_from_pkh (List.map fst l)), (List.map snd l))).
Definition get_rolls {A B C D : Type} (b : A) (delegates : list B) (loc : C)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (list D)) :=
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun l =>
map_s
(fun delegate =>
op_gtgteqquestion (op_startypeminuserrorstar delegate)
(fun pkh =>
match
List.find_opt
(fun function_parameter =>
let '(del, _) := function_parameter in
op_startypeminuserrorstar del pkh) l with
| None => failwith "%s - Missing delegate" % string loc
| Some (_, rolls) => _return rolls
end)) delegates).
Definition test_successful_vote (num_delegates : Z) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
let min_proposal_quorum := op_atat of_int (op_div 10000 num_delegates) in
op_gtgteqquestion
(op_startypeminuserrorstar min_proposal_quorum num_delegates)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun v =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__ ballots_equal
"Unexpected ballots" % string ballots_pp v ballots_zero)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| [] => return_unit
| _ =>
failwith "%s - Unexpected ballot list" % string
__LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun v =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
Voting_period.equal "Unexpected period" % string
Voting_period.pp v root)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ => return_unit
| _ =>
failwith
"%s - Unexpected period kind" % string
__LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar b)
(fun v =>
op_gtgteqquestion
(op_startypeminuserrorstar __LOC__
initial_participation (Int32.to_int v))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| [] =>
failwith
"%s - Unexpected empty listings"
% string __LOC__
| _ => return_unit
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(get_delegates_and_rolls_from_listings
b)
(fun function_parameter =>
let
'(delegates_p1, rolls_p1) :=
function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun ps =>
op_gtgteqquestion
(if
Environment.Protocol_hash.Map.is_empty
ps then
return_unit
else
failwith
"%s - Unexpected proposals"
% string __LOC__)
(fun function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
| None =>
return_unit
| Some _ =>
failwith
"%s - Unexpected proposal"
% string
__LOC__
end))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
let del1 :=
op_startypeminuserrorstar
delegates_p1 0
in
let del2 :=
op_startypeminuserrorstar
delegates_p1 1
in
let props :=
List.map
(fun i =>
op_startypeminuserrorstar
protos i)
(op_startypeminuserrorstar
2
Constants.max_proposals_per_delegate)
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
del1
(cons
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
props))
(fun ops1 =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
del2
(cons
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
[]))
(fun ops2 =>
op_gtgteqquestion
(op_startypeminuserrorstar
(cons
ops1
(cons
ops2
[]))
b)
(fun b
=>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
ps
=>
op_gtgteqquestion
(let
weight :=
Int32.add
(op_startypeminuserrorstar
rolls_p1
0)
(op_startypeminuserrorstar
rolls_p1
1)
in
match
Map.find_opt
zero
ps
with
|
Some
v
=>
if
op_startypeminuserrorstar
v
weight
then
return_unit
else
failwith
"%s - Wrong count %ld is not %ld"
%
string
__LOC__
v
weight
|
None
=>
failwith
"%s - Missing proposal"
%
string
__LOC__
end)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
del1
(cons
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
props))
(fun
ops
=>
op_gtgteq
(op_startypeminuserrorstar
(cons
ops
[])
b)
(fun
res
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
res
(fun
function_parameter
=>
match
function_parameter
with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Too_many_proposals
=>
true
|
_
=>
false
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
del1
[])
(fun
ops
=>
op_gtgteq
(op_startypeminuserrorstar
(cons
ops
[])
b)
(fun
res
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
res
(fun
function_parameter
=>
match
function_parameter
with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_proposal
=>
true
|
_
=>
false
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus
(Int32.to_int
op_startypeminuserrorstar)
2)
b)
(fun
b
=>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
|
_
=>
return_unit
|
_
=>
failwith
"%s - Unexpected period kind"
%
string
__LOC__
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
v
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
Voting_period.equal
"Unexpected period"
%
string
Voting_period.pp
v
(succ
root))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
|
[]
=>
failwith
"%s - Unexpected empty listings"
%
string
__LOC__
|
_
=>
return_unit
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(get_delegates_and_rolls_from_listings
b)
(fun
function_parameter
=>
let
'(delegates_p2,
rolls_p2) :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
ps
=>
op_gtgteqquestion
(if
Environment.Protocol_hash.Map.is_empty
ps
then
return_unit
else
failwith
"%s - Unexpected proposals"
%
string
__LOC__)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
|
Some
v
=>
if
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
v
then
return_unit
else
failwith
"%s - Wrong proposal"
%
string
__LOC__
|
None
=>
failwith
"%s - Missing proposal"
%
string
__LOC__
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(map_s
(fun
del
=>
op_startypeminuserrorstar
op_startypeminuserrorstar
del
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
delegates_p2)
(fun
operations
=>
op_gtgteqquestion
(op_startypeminuserrorstar
operations
b)
(fun
b
=>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar
del1
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Nay)
(fun
op
=>
op_gtgteq
(op_startypeminuserrorstar
(cons
op
[])
b)
(fun
res
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
res
(fun
function_parameter
=>
match
function_parameter
with
|
Tezos_protocol_environment_alpha__Environment.Error_monad.Unauthorized_ballot
=>
true
|
_
=>
false
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(fold_left_s
(fun
v
=>
fun
acc
=>
_return
(add
v
acc))
(* ❌ Constant of type int32 is converted to int *)
0
rolls_p2)
(fun
rolls_sum
=>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
v
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
ballots_equal
"Unexpected ballots"
%
string
ballots_pp
v
{|
yay :=
rolls_sum;
nay :=
(* ❌ Constant of type int32 is converted to int *)
0;
pass :=
(* ❌ Constant of type int32 is converted to int *)
0
|})
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
|
[]
=>
failwith
"%s - Unexpected empty ballot list"
%
string
__LOC__
|
l
=>
iter_s
(fun
delegate
=>
op_gtgteqquestion
(op_startypeminuserrorstar
delegate)
(fun
pkh
=>
match
List.find_opt
(fun
function_parameter
=>
let
'(del,
_) :=
function_parameter
in
op_startypeminuserrorstar
del
pkh)
l
with
|
None
=>
failwith
"%s - Missing delegate"
%
string
__LOC__
|
Some
(_,
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
=>
return_unit
|
Some
_
=>
failwith
"%s - Wrong ballot"
%
string
__LOC__
end))
delegates_p2
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus
(Int32.to_int
op_startypeminuserrorstar)
1)
b)
(fun
b
=>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
|
_
=>
return_unit
|
_
=>
failwith
"%s - Unexpected period kind"
%
string
__LOC__
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
v
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
Voting_period.equal
"Unexpected period"
%
string
Voting_period.pp
v
(succ
(succ
root)))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
v
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
ballots_equal
"Unexpected ballots"
%
string
ballots_pp
v
ballots_zero)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
|
[]
=>
return_unit
|
_
=>
failwith
"%s - Unexpected listings"
%
string
__LOC__
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
(Int32.to_int
op_startypeminuserrorstar)
b)
(fun
b
=>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
|
_
=>
return_unit
|
_
=>
failwith
"%s - Unexpected period kind"
%
string
__LOC__
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
v
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
Voting_period.equal
"Unexpected period"
%
string
Voting_period.pp
v
(succ
(succ
(succ
root))))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
|
[]
=>
failwith
"%s - Unexpected empty listings"
%
string
__LOC__
|
_
=>
return_unit
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(get_delegates_and_rolls_from_listings
b)
(fun
function_parameter
=>
let
'(delegates_p4,
rolls_p4) :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
ps
=>
op_gtgteqquestion
(if
Environment.Protocol_hash.Map.is_empty
ps
then
return_unit
else
failwith
"%s - Unexpected proposals"
%
string
__LOC__)
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
|
Some
v
=>
if
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
v
then
return_unit
else
failwith
"%s - Wrong proposal"
%
string
__LOC__
|
None
=>
failwith
"%s - Missing proposal"
%
string
__LOC__
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(map_s
(fun
del
=>
op_startypeminuserrorstar
op_startypeminuserrorstar
del
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
delegates_p4)
(fun
operations
=>
op_gtgteqquestion
(op_startypeminuserrorstar
operations
b)
(fun
b
=>
op_gtgteqquestion
(fold_left_s
(fun
v
=>
fun
acc
=>
_return
(add
v
acc))
(* ❌ Constant of type int32 is converted to int *)
0
rolls_p4)
(fun
rolls_sum
=>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
v
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
ballots_equal
"Unexpected ballots"
%
string
ballots_pp
v
{|
yay :=
rolls_sum;
nay :=
(* ❌ Constant of type int32 is converted to int *)
0;
pass :=
(* ❌ Constant of type int32 is converted to int *)
0
|})
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
|
[]
=>
failwith
"%s - Unexpected empty ballot list"
%
string
__LOC__
|
l
=>
iter_s
(fun
delegate
=>
op_gtgteqquestion
(op_startypeminuserrorstar
delegate)
(fun
pkh
=>
match
List.find_opt
(fun
function_parameter
=>
let
'(del,
_) :=
function_parameter
in
op_startypeminuserrorstar
del
pkh)
l
with
|
None
=>
failwith
"%s - Missing delegate"
%
string
__LOC__
|
Some
(_,
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
=>
return_unit
|
Some
_
=>
failwith
"%s - Wrong ballot"
%
string
__LOC__
end))
delegates_p4
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus
(to_int
op_startypeminuserrorstar)
1)
b)
(fun
b
=>
op_gtgteq
(op_startypeminuserrorstar
b)
(fun
p
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
"Unexpected proposal"
%
string
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.pp)
p
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
return_unit))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))).
Definition get_smallest_prefix_voters_for_quorum {A : Type}
(active_delegates : list A) (active_rolls : list int32)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (list A)) :=
op_gtgteqquestion
(fold_left_s (fun v => fun acc => _return (add v acc))
(* ❌ Constant of type int32 is converted to int *)
0 active_rolls)
(fun active_rolls_sum =>
let fix loop {B : Type}
(delegates : list B) (rolls : list int32) (sum : Z) (selected : list B)
: list B :=
match (delegates, rolls) with
| ([], []) => selected
| (cons del delegates, cons del_rolls rolls) =>
if
op_startypeminuserrorstar (op_star den sum)
(op_startypeminuserrorstar
(op_startypeminuserrorstar expected_qr_num
(Int32.to_float active_rolls_sum))) then
loop delegates rolls (op_plus sum (Int32.to_int del_rolls))
(cons del selected)
else
selected
| (_, _) => []
end in
_return (loop active_delegates active_rolls 0 [])).
Definition get_expected_participation_ema
(rolls : list int32) (voter_rolls : list int32)
(old_participation_ema : int32)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
let get_updated_participation_ema
(old_participation_ema : int32) (participation : Z) : Z :=
op_div
(op_plus (op_star pr_ema_weight (Int32.to_int old_participation_ema))
(op_star pr_num participation)) den in
op_gtgteqquestion
(fold_left_s (fun v => fun acc => _return (add v acc))
(* ❌ Constant of type int32 is converted to int *)
0 rolls)
(fun rolls_sum =>
op_gtgteqquestion
(fold_left_s (fun v => fun acc => _return (add v acc))
(* ❌ Constant of type int32 is converted to int *)
0 voter_rolls)
(fun voter_rolls_sum =>
let participation :=
op_div (op_star (Int32.to_int voter_rolls_sum) percent_mul)
(Int32.to_int rolls_sum) in
_return
(get_updated_participation_ema old_participation_ema participation))).
Definition test_not_enough_quorum_in_testing_vote
(num_delegates : Z) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
let min_proposal_quorum := op_atat of_int (op_div 10000 num_delegates) in
op_gtgteqquestion
(op_startypeminuserrorstar min_proposal_quorum num_delegates)
(fun function_parameter =>
let '(b, delegates) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ => return_unit
| _ => failwith "%s - Unexpected period kind" % string __LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
let proposer := op_startypeminuserrorstar delegates 0 in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar proposer
(cons
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
[]))
(fun ops =>
op_gtgteqquestion (op_startypeminuserrorstar (cons ops []) b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus (Int32.to_int op_startypeminuserrorstar) 2)
b)
(fun b =>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ => return_unit
| _ =>
failwith
"%s - Unexpected period kind" % string
__LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar b)
(fun initial_participation_ema =>
op_gtgteqquestion
(get_delegates_and_rolls_from_listings b)
(fun function_parameter =>
let '(delegates_p2, rolls_p2) :=
function_parameter in
op_gtgteqquestion
(get_smallest_prefix_voters_for_quorum
delegates_p2 rolls_p2)
(fun voters =>
let voters_without_quorum :=
List.tl voters in
op_gtgteqquestion
(get_rolls b voters_without_quorum
__LOC__)
(fun voters_rolls_in_testing_vote =>
op_gtgteqquestion
(map_s
(fun del =>
op_startypeminuserrorstar
op_startypeminuserrorstar
del
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
voters_without_quorum)
(fun operations =>
op_gtgteqquestion
(op_startypeminuserrorstar
operations b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus
(Int32.to_int
op_startypeminuserrorstar)
1) b)
(fun b =>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
| _ =>
return_unit
| _ =>
failwith
"%s - Unexpected period kind"
% string
__LOC__
end))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteqquestion
(get_expected_participation_ema
rolls_p2
voters_rolls_in_testing_vote
initial_participation_ema)
(fun
expected_participation_ema
=>
op_gtgteqquestion
(op_startypeminuserrorstar
b)
(fun
new_participation_ema
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
expected_participation_ema
(Int32.to_int
new_participation_ema))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
return_unit)))))))))))))))))).
Definition test_not_enough_quorum_in_promotion_vote
(num_delegates : Z) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
let min_proposal_quorum := op_atat of_int (op_div 10000 num_delegates) in
op_gtgteqquestion
(op_startypeminuserrorstar min_proposal_quorum num_delegates)
(fun function_parameter =>
let '(b, delegates) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ => return_unit
| _ => failwith "%s - Unexpected period kind" % string __LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
let proposer := op_startypeminuserrorstar delegates 0 in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar proposer
(cons
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
[]))
(fun ops =>
op_gtgteqquestion (op_startypeminuserrorstar (cons ops []) b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus (Int32.to_int op_startypeminuserrorstar) 2)
b)
(fun b =>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ => return_unit
| _ =>
failwith
"%s - Unexpected period kind" % string
__LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(get_delegates_and_rolls_from_listings b)
(fun function_parameter =>
let '(delegates_p2, rolls_p2) :=
function_parameter in
op_gtgteqquestion
(get_smallest_prefix_voters_for_quorum
delegates_p2 rolls_p2)
(fun voters =>
op_gtgteqquestion
(map_s
(fun del =>
op_startypeminuserrorstar
op_startypeminuserrorstar del
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
voters)
(fun operations =>
op_gtgteqquestion
(op_startypeminuserrorstar
operations b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus
(Int32.to_int
op_startypeminuserrorstar)
1) b)
(fun b =>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter
with
| _ => return_unit
| _ =>
failwith
"%s - Unexpected period kind"
% string __LOC__
end))
(fun function_parameter =>
let 'tt :=
function_parameter in
op_gtgteqquestion
(op_startypeminuserrorstar
(Int32.to_int
op_startypeminuserrorstar)
b)
(fun b =>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
| _ =>
return_unit
| _ =>
failwith
"%s - Unexpected period kind"
% string
__LOC__
end))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
op_gtgteqquestion
(op_startypeminuserrorstar
b)
(fun
initial_participation_ema
=>
op_gtgteqquestion
(get_delegates_and_rolls_from_listings
b)
(fun
function_parameter
=>
let
'(delegates_p4,
rolls_p4) :=
function_parameter
in
op_gtgteqquestion
(get_smallest_prefix_voters_for_quorum
delegates_p4
rolls_p4)
(fun
voters
=>
let
voters_without_quorum :=
List.tl
voters
in
op_gtgteqquestion
(get_rolls
b
voters_without_quorum
__LOC__)
(fun
voter_rolls
=>
op_gtgteqquestion
(map_s
(fun
del
=>
op_startypeminuserrorstar
op_startypeminuserrorstar
del
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
voters_without_quorum)
(fun
operations
=>
op_gtgteqquestion
(op_startypeminuserrorstar
operations
b)
(fun
b
=>
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus
(Int32.to_int
op_startypeminuserrorstar)
1)
b)
(fun
b
=>
op_gtgteqquestion
(get_expected_participation_ema
rolls_p4
voter_rolls
initial_participation_ema)
(fun
expected_participation_ema
=>
op_gtgteqquestion
(op_startypeminuserrorstar
b)
(fun
new_participation_ema
=>
op_gtgteqquestion
(op_startypeminuserrorstar
__LOC__
expected_participation_ema
(Int32.to_int
new_participation_ema))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
|
_
=>
return_unit
|
_
=>
failwith
"%s - Unexpected period kind"
%
string
__LOC__
end))
(fun
function_parameter
=>
let
'tt :=
function_parameter
in
return_unit)))))))))))))))))))))))))).
Definition test_multiple_identical_proposals_count_as_one
(function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar 1)
(fun function_parameter =>
let '(b, delegates) := function_parameter in
op_gtgteqquestion
(op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ => return_unit
| _ => failwith "%s - Unexpected period kind" % string __LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
let proposer := List.hd delegates in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar proposer
(cons
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
(cons
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
[])))
(fun ops =>
op_gtgteqquestion (op_startypeminuserrorstar (cons ops []) b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun ps =>
op_gtgteqquestion (op_startypeminuserrorstar proposer)
(fun pkh =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun l =>
op_gtgteqquestion
match
List.find_opt
(fun function_parameter =>
let '(del, _) := function_parameter in
op_startypeminuserrorstar del pkh) l with
| None =>
failwith "%s - Missing delegate" % string
__LOC__
| Some (_, proposer_rolls) =>
_return proposer_rolls
end
(fun proposer_rolls =>
let expected_weight_proposer := proposer_rolls
in
match Map.find_opt zero ps with
| Some v =>
if
op_startypeminuserrorstar v
expected_weight_proposer then
return_unit
else
failwith
"%s - Wrong count %ld is not %ld; identical proposals count as one"
% string __LOC__ v
expected_weight_proposer
| None =>
failwith "%s - Missing proposal" % string
__LOC__
end)))))))).
Definition test_supermajority_in_proposal {A : Type}
(there_is_a_winner : bool) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
let 'tt := function_parameter in
let min_proposal_quorum :=
(* ❌ Constant of type int32 is converted to int *)
0 in
op_gtgteqquestion
(op_startypeminuserrorstar min_proposal_quorum
(cons
(* ❌ Constant of type int64 is converted to int *)
1
(cons
(* ❌ Constant of type int64 is converted to int *)
1
(cons
(* ❌ Constant of type int64 is converted to int *)
1 []))) 10)
(fun function_parameter =>
let '(b, delegates) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
let del1 := op_startypeminuserrorstar delegates 0 in
let del2 := op_startypeminuserrorstar delegates 1 in
let del3 := op_startypeminuserrorstar delegates 2 in
op_gtgteqquestion
(map_s (fun del => op_startypeminuserrorstar del)
(cons del1 (cons del2 (cons del3 []))))
(fun pkhs =>
let policy := op_startypeminuserrorstar in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(op_startypeminuserrorstar delegates 3) del1
op_startypeminuserrorstar)
(fun op1 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(op_startypeminuserrorstar delegates 4) del2
op_startypeminuserrorstar)
(fun op2 =>
op_startypeminuserrorstar
(if there_is_a_winner then
op_startypeminuserrorstar op_startypeminuserrorstar
(* ❌ Constant of type int64 is converted to int *)
3
else
op_startypeminuserrorstar op_startypeminuserrorstar
(* ❌ Constant of type int64 is converted to int *)
2)
(fun bal3 =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
(op_startypeminuserrorstar delegates 5) del3 bal3)
(fun op3 =>
op_gtgteqquestion
(op_startypeminuserrorstar policy
(cons op1 (cons op2 (cons op3 []))) b)
(fun b =>
op_gtgteqquestion
(fold_left_s
(fun b =>
fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(Error_monad.map_s
(fun del =>
op_gtgteqquestion
(op_startypeminuserrorstar del)
(fun pkh =>
op_startypeminuserrorstar
op_startypeminuserrorstar
del (Some pkh))) delegates)
(fun ops =>
op_gtgteqquestion
(op_startypeminuserrorstar
policy ops b)
(fun b =>
op_startypeminuserrorstar
policy b))) b
(op_startypeminuserrorstar 1
(Int32.to_int
(Int32.div op_startypeminuserrorstar
op_startypeminuserrorstar))))
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar del1
(cons
(op_startypeminuserrorstar protos 0)
[]))
(fun ops1 =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar del2
(cons
(op_startypeminuserrorstar
protos 0) []))
(fun ops2 =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar del3
(cons
(op_startypeminuserrorstar
protos 1) []))
(fun ops3 =>
op_gtgteqquestion
(op_startypeminuserrorstar
policy
(cons ops1
(cons ops2
(cons ops3 []))) b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
policy
(op_minus
(Int32.to_int
op_startypeminuserrorstar)
1) b)
(fun b =>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun
function_parameter
=>
match
function_parameter
with
| _ =>
if
there_is_a_winner
then
return_unit
else
failwith
"%s - Expected period kind Proposal, obtained Testing_vote"
% string
__LOC__
| _ =>
if
not
there_is_a_winner
then
return_unit
else
failwith
"%s - Expected period kind Testing_vote, obtained Proposal"
% string
__LOC__
| _ =>
failwith
"%s - Unexpected period kind"
% string
__LOC__
end))
(fun
function_parameter
=>
let 'tt :=
function_parameter
in
return_unit))))))))))))))).
Definition test_quorum_in_proposal
(has_quorum : bool) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
let total_tokens :=
(* ❌ Constant of type int64 is converted to int *)
32000000000000 in
let half_tokens :=
Int64.div total_tokens
(* ❌ Constant of type int64 is converted to int *)
2 in
op_gtgteqquestion
(op_startypeminuserrorstar
(cons
(* ❌ Constant of type int64 is converted to int *)
1 (cons half_tokens (cons half_tokens []))) 3)
(fun function_parameter =>
let '(b, delegates) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
let del1 := op_startypeminuserrorstar delegates 0 in
let del2 := op_startypeminuserrorstar delegates 1 in
op_gtgteqquestion
(map_s (fun del => op_startypeminuserrorstar del)
(cons del1 (cons del2 [])))
(fun pkhs =>
let policy := op_startypeminuserrorstar in
let quorum :=
if has_quorum then
Int64.of_int32 op_startypeminuserrorstar
else
sub (of_int32 op_startypeminuserrorstar)
(* ❌ Constant of type int64 is converted to int *)
10 in
let bal :=
op_pipegt
(div (mul total_tokens quorum)
(* ❌ Constant of type int64 is converted to int *)
10000) op_startypeminuserrorstar in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar del2 del1
bal)
(fun op2 =>
op_gtgteqquestion
(op_startypeminuserrorstar policy (cons op2 []) b)
(fun b =>
op_gtgteqquestion
(fold_left_s
(fun b =>
fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(Error_monad.map_s
(fun del =>
op_gtgteqquestion
(op_startypeminuserrorstar del)
(fun pkh =>
op_startypeminuserrorstar
op_startypeminuserrorstar del
(Some pkh)))
(cons del1 (cons del2 [])))
(fun ops =>
op_gtgteqquestion
(op_startypeminuserrorstar policy ops b)
(fun b => op_startypeminuserrorstar policy b)))
b
(op_startypeminuserrorstar 1
(Int32.to_int
(Int32.div op_startypeminuserrorstar
op_startypeminuserrorstar))))
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
del1
(cons (op_startypeminuserrorstar protos 0) []))
(fun ops =>
op_gtgteqquestion
(op_startypeminuserrorstar policy (cons ops [])
b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar policy
(op_minus
(Int32.to_int op_startypeminuserrorstar)
1) b)
(fun b =>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ =>
if has_quorum then
return_unit
else
failwith
"%s - Expected period kind Proposal, obtained Testing_vote"
% string __LOC__
| _ =>
if not has_quorum then
return_unit
else
failwith
"%s - Expected period kind Testing_vote, obtained Proposal"
% string __LOC__
| _ =>
failwith
"%s - Unexpected period kind" %
string __LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))))))))).
Definition test_supermajority_in_testing_vote
(supermajority : bool) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
let min_proposal_quorum := op_atat of_int (op_div 10000 100) in
op_gtgteqquestion (op_startypeminuserrorstar min_proposal_quorum 100)
(fun function_parameter =>
let '(b, delegates) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
let del1 := op_startypeminuserrorstar delegates 0 in
let proposal := op_startypeminuserrorstar protos 0 in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar del1
(cons proposal []))
(fun ops1 =>
op_gtgteqquestion (op_startypeminuserrorstar (cons ops1 []) b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus (Int32.to_int op_startypeminuserrorstar) 1) b)
(fun b =>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ => return_unit
| _ =>
failwith "%s - Unexpected period kind" % string
__LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| Some v =>
if
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
proposal v then
return_unit
else
failwith "%s - Wrong proposal" % string
__LOC__
| None =>
failwith "%s - Missing proposal" % string
__LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion
(get_delegates_and_rolls_from_listings b)
(fun function_parameter =>
let '(delegates_p2, _olls_p2) :=
function_parameter in
let num_delegates := List.length delegates_p2
in
let num_nays := op_div num_delegates 5 in
let num_yays :=
op_div (op_star num_nays s_num)
(op_minus s_den s_num) in
let num_yays :=
if supermajority then
num_yays
else
op_minus num_yays 1 in
let '(nays_delegates, rest) :=
op_startypeminuserrorstar num_nays
delegates_p2 in
let '(yays_delegates, _) :=
op_startypeminuserrorstar num_yays rest in
op_gtgteqquestion
(map_s
(fun del =>
op_startypeminuserrorstar
op_startypeminuserrorstar del proposal
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
yays_delegates)
(fun operations_yays =>
op_gtgteqquestion
(map_s
(fun del =>
op_startypeminuserrorstar
op_startypeminuserrorstar del
proposal
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Nay)
nays_delegates)
(fun operations_nays =>
let operations :=
op_at operations_yays
operations_nays in
op_gtgteqquestion
(op_startypeminuserrorstar
operations b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus
(Int32.to_int
op_startypeminuserrorstar)
1) b)
(fun b =>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter
with
| _ =>
if supermajority then
return_unit
else
failwith
"%s - Expected period kind Proposal, obtained Testing"
% string __LOC__
| _ =>
if not supermajority
then
return_unit
else
failwith
"%s - Expected period kind Testing_vote, obtained Proposal"
% string __LOC__
| _ =>
failwith
"%s - Unexpected period kind"
% string __LOC__
end))
(fun function_parameter =>
let 'tt :=
function_parameter in
return_unit))))))))))))).
Definition test_no_winning_proposal
(num_delegates : Z) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
let min_proposal_quorum := op_atat of_int (op_div 10000 num_delegates) in
op_gtgteqquestion
(op_startypeminuserrorstar min_proposal_quorum num_delegates)
(fun function_parameter =>
let '(b, _) := function_parameter in
op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion (get_delegates_and_rolls_from_listings b)
(fun function_parameter =>
let '(delegates_p1, _rolls_p1) := function_parameter in
let props :=
List.map (fun i => op_startypeminuserrorstar protos i)
(op_startypeminuserrorstar 1
Constants.max_proposals_per_delegate) in
op_gtgteqquestion
(map_s
(fun del =>
op_startypeminuserrorstar op_startypeminuserrorstar del
props) delegates_p1)
(fun ops_list =>
op_gtgteqquestion (op_startypeminuserrorstar ops_list b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus (Int32.to_int op_startypeminuserrorstar) 2)
b)
(fun b =>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ => return_unit
| _ =>
failwith
"%s - Unexpected period kind" % string
__LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))))).
Definition test_quorum_capped_maximum
(num_delegates : Z) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
let min_proposal_quorum := op_atat of_int (op_div 10000 num_delegates) in
op_gtgteqquestion
(op_startypeminuserrorstar min_proposal_quorum num_delegates)
(fun function_parameter =>
let '(b, delegates) := function_parameter in
op_gtgteq
(op_startypeminuserrorstar b
(* ❌ Constant of type int32 is converted to int *)
10000)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ => return_unit
| _ =>
failwith "%s - Unexpected period kind" % string __LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
let protocol :=
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
in
let proposer := op_startypeminuserrorstar delegates 0 in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
proposer (cons protocol []))
(fun ops =>
op_gtgteqquestion
(op_startypeminuserrorstar (cons ops []) b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus (Int32.to_int op_startypeminuserrorstar)
1) b)
(fun b =>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ => return_unit
| _ =>
failwith
"%s - Unexpected period kind" % string
__LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
let minimum_to_pass :=
op_pipegt
(op_pipegt
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(List.length delegates))
(to_float op_startypeminuserrorstar))
(* ❌ Float constant 100_00. is approximated by the integer 10000 *)
10000) op_startypeminuserrorstar)
op_startypeminuserrorstar in
let voters :=
op_startypeminuserrorstar minimum_to_pass
delegates in
op_gtgteqquestion
(map_s
(fun del =>
op_startypeminuserrorstar
op_startypeminuserrorstar del protocol
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
voters)
(fun operations =>
op_gtgteqquestion
(op_startypeminuserrorstar operations b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus
(Int32.to_int
op_startypeminuserrorstar) 1)
b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ => return_unit
| _ =>
failwith
"%s - Unexpected period kind"
% string __LOC__
end)))))))))))).
Definition test_quorum_capped_minimum
(num_delegates : Z) (function_parameter : unit)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
let 'tt := function_parameter in
let min_proposal_quorum := op_atat of_int (op_div 10000 num_delegates) in
op_gtgteqquestion
(op_startypeminuserrorstar min_proposal_quorum num_delegates)
(fun function_parameter =>
let '(b, delegates) := function_parameter in
op_gtgteq
(op_startypeminuserrorstar b
(* ❌ Constant of type int32 is converted to int *)
0)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
let '_ := function_parameter in
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ => return_unit
| _ =>
failwith "%s - Unexpected period kind" % string __LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
let protocol :=
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
in
let proposer := op_startypeminuserrorstar delegates 0 in
op_gtgteqquestion
(op_startypeminuserrorstar op_startypeminuserrorstar
proposer (cons protocol []))
(fun ops =>
op_gtgteqquestion
(op_startypeminuserrorstar (cons ops []) b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus (Int32.to_int op_startypeminuserrorstar)
1) b)
(fun b =>
op_gtgteqquestion
(op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ => return_unit
| _ =>
failwith
"%s - Unexpected period kind" % string
__LOC__
end))
(fun function_parameter =>
let 'tt := function_parameter in
let minimum_to_pass :=
op_pipegt
(op_pipegt
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(op_startypeminuserrorstar
(List.length delegates))
(to_float op_startypeminuserrorstar))
(* ❌ Float constant 100_00. is approximated by the integer 10000 *)
10000) op_startypeminuserrorstar)
op_startypeminuserrorstar in
let voters :=
op_startypeminuserrorstar minimum_to_pass
delegates in
op_gtgteqquestion
(map_s
(fun del =>
op_startypeminuserrorstar
op_startypeminuserrorstar del protocol
Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
voters)
(fun operations =>
op_gtgteqquestion
(op_startypeminuserrorstar operations b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
(op_minus
(Int32.to_int
op_startypeminuserrorstar) 1)
b)
(fun b =>
op_gtgteqquestion
(op_startypeminuserrorstar
op_startypeminuserrorstar)
(fun function_parameter =>
match function_parameter with
| _ => return_unit
| _ =>
failwith
"%s - Unexpected period kind"
% string __LOC__
end)))))))))))).
Definition tests {A : Type} : list A :=
cons
(op_startypeminuserrorstar "voting successful_vote" % string
(* ❌ Variants not supported *)
variant (test_successful_vote 137))
(cons
(op_startypeminuserrorstar
"voting testing vote, not enough quorum" % string
(* ❌ Variants not supported *)
variant (test_not_enough_quorum_in_testing_vote 245))
(cons
(op_startypeminuserrorstar
"voting promotion vote, not enough quorum" % string
(* ❌ Variants not supported *)
variant (test_not_enough_quorum_in_promotion_vote 432))
(cons
(op_startypeminuserrorstar "voting counting double proposal" % string
(* ❌ Variants not supported *)
variant test_multiple_identical_proposals_count_as_one)
(cons
(op_startypeminuserrorstar
"voting proposal, with supermajority" % string
(* ❌ Variants not supported *)
variant (test_supermajority_in_proposal true))
(cons
(op_startypeminuserrorstar
"voting proposal, without supermajority" % string
(* ❌ Variants not supported *)
variant (test_supermajority_in_proposal false))
(cons
(op_startypeminuserrorstar
"voting proposal, with quorum" % string
(* ❌ Variants not supported *)
variant (test_quorum_in_proposal true))
(cons
(op_startypeminuserrorstar
"voting proposal, without quorum" % string
(* ❌ Variants not supported *)
variant (test_quorum_in_proposal false))
(cons
(op_startypeminuserrorstar
"voting testing vote, with supermajority" % string
(* ❌ Variants not supported *)
variant (test_supermajority_in_testing_vote true))
(cons
(op_startypeminuserrorstar
"voting testing vote, without supermajority" % string
(* ❌ Variants not supported *)
variant (test_supermajority_in_testing_vote false))
(cons
(op_startypeminuserrorstar
"voting proposal, no winning proposal" % string
(* ❌ Variants not supported *)
variant (test_no_winning_proposal 400))
(cons
(op_startypeminuserrorstar
"voting quorum, quorum capped maximum" % string
(* ❌ Variants not supported *)
variant (test_quorum_capped_maximum 400))
(cons
(op_startypeminuserrorstar
"voting quorum, quorum capped minimum" % string
(* ❌ Variants not supported *)
variant (test_quorum_capped_minimum 401)) [])))))))))))).
src/proto_alpha/lib_protocol/tez_repr.ml 2 errors
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) include Qty_repr.Make (struct let id = "tez" end) type t = qty type tez = qty let encoding = Data_encoding.def "mutez" @@ encoding
src/proto_alpha/lib_protocol/tez_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition t := qty.
Definition tez := qty.
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding qty :=
op_atat
(let arg := Data_encoding.def "mutez" % string in
fun eta => arg None None eta) encoding.
src/proto_alpha/lib_protocol/time_repr.ml 7 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
include Time
type time = t
type error += Timestamp_add (* `Permanent *)
type error += Timestamp_sub (* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"timestamp_add"
~title:"Timestamp add"
~description:"Overflow when adding timestamps."
~pp:(fun ppf () -> Format.fprintf ppf "Overflow when adding timestamps.")
Data_encoding.empty
(function Timestamp_add -> Some () | _ -> None)
(fun () -> Timestamp_add) ;
register_error_kind
`Permanent
~id:"timestamp_sub"
~title:"Timestamp sub"
~description:"Substracting timestamps resulted in negative period."
~pp:(fun ppf () ->
Format.fprintf ppf "Substracting timestamps resulted in negative period.")
Data_encoding.empty
(function Timestamp_sub -> Some () | _ -> None)
(fun () -> Timestamp_sub)
let of_seconds s = try Some (of_seconds (Int64.of_string s)) with _ -> None
let to_seconds = to_seconds
let to_seconds_string s = Int64.to_string (to_seconds s)
let pp = pp_hum
let ( +? ) x y =
try ok (add x (Period_repr.to_seconds y)) with _exn -> error Timestamp_add
let ( -? ) x y = record_trace Timestamp_sub (Period_repr.of_seconds (diff x y))
src/proto_alpha/lib_protocol/time_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `include` not handled. *)
include
Definition time := t.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition of_seconds (s : string) : option t :=
(* ❌ Try-with are not handled *)
try (Some (of_seconds (Int64.of_string s))).
Definition to_seconds : t -> int64 := to_seconds.
Definition to_seconds_string (s : t) : string := Int64.to_string (to_seconds s).
Definition pp
: Tezos_protocol_environment_alpha__Environment.Format.formatter -> t -> unit :=
pp_hum.
Definition op_plusquestion
(x : t) (y : Tezos_raw_protocol_alpha.Period_repr.period)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t :=
(* ❌ Try-with are not handled *)
try (ok (add x (Period_repr.to_seconds y))).
Definition op_minusquestion (x : t) (y : t)
: Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Period_repr.period :=
record_trace
Tezos_protocol_environment_alpha__Environment.Error_monad.Timestamp_sub
(Period_repr.of_seconds (diff x y)).
src/proto_alpha/lib_protocol/vote_repr.ml 2 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type proposal = Protocol_hash.t
type ballot = Yay | Nay | Pass
let ballot_encoding =
let of_int8 = function
| 0 ->
Yay
| 1 ->
Nay
| 2 ->
Pass
| _ ->
invalid_arg "ballot_of_int8"
in
let to_int8 = function Yay -> 0 | Nay -> 1 | Pass -> 2 in
let open Data_encoding in
(* union *)
splitted
~binary:(conv to_int8 of_int8 int8)
~json:(string_enum [("yay", Yay); ("nay", Nay); ("pass", Pass)])
src/proto_alpha/lib_protocol/vote_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition proposal :=
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).
Inductive ballot : Type :=
| Yay : ballot
| Nay : ballot
| Pass : ballot.
Definition ballot_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding ballot :=
let of_int8 (function_parameter : Z) : ballot :=
match function_parameter with
| 0 => Yay
| 1 => Nay
| 2 => Pass
| _ => invalid_arg "ballot_of_int8" % string
end in
let to_int8 (function_parameter : ballot) : Z :=
match function_parameter with
| Yay => 0
| Nay => 1
| Pass => 2
end in
splitted
(string_enum
(cons ("yay" % string, Yay)
(cons ("nay" % string, Nay) (cons ("pass" % string, Pass) []))))
(conv to_int8 of_int8 None int8).
src/proto_alpha/lib_protocol/vote_storage.ml 149 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let recorded_proposal_count_for_delegate ctxt proposer =
Storage.Vote.Proposals_count.get_option ctxt proposer
>>=? function None -> return 0 | Some count -> return count
let record_proposal ctxt proposal proposer =
recorded_proposal_count_for_delegate ctxt proposer
>>=? fun count ->
Storage.Vote.Proposals_count.init_set ctxt proposer (count + 1)
>>= fun ctxt ->
Storage.Vote.Proposals.add ctxt (proposal, proposer)
>>= fun ctxt -> return ctxt
let get_proposals ctxt =
Storage.Vote.Proposals.fold
ctxt
~init:(ok Protocol_hash.Map.empty)
~f:(fun (proposal, delegate) acc ->
(* Assuming the same listings is used at votings *)
Storage.Vote.Listings.get ctxt delegate
>>=? fun weight ->
Lwt.return
( acc
>>? fun acc ->
let previous =
match Protocol_hash.Map.find_opt proposal acc with
| None ->
0l
| Some x ->
x
in
ok (Protocol_hash.Map.add proposal (Int32.add weight previous) acc) ))
let clear_proposals ctxt =
Storage.Vote.Proposals_count.clear ctxt
>>= fun ctxt -> Storage.Vote.Proposals.clear ctxt
type ballots = {yay : int32; nay : int32; pass : int32}
let ballots_encoding =
let open Data_encoding in
conv
(fun {yay; nay; pass} -> (yay, nay, pass))
(fun (yay, nay, pass) -> {yay; nay; pass})
@@ obj3 (req "yay" int32) (req "nay" int32) (req "pass" int32)
let has_recorded_ballot = Storage.Vote.Ballots.mem
let record_ballot = Storage.Vote.Ballots.init
let get_ballots ctxt =
Storage.Vote.Ballots.fold
ctxt
~f:(fun delegate ballot (ballots : ballots tzresult) ->
(* Assuming the same listings is used at votings *)
Storage.Vote.Listings.get ctxt delegate
>>=? fun weight ->
let count = Int32.add weight in
Lwt.return
( ballots
>>? fun ballots ->
match ballot with
| Yay ->
ok {ballots with yay = count ballots.yay}
| Nay ->
ok {ballots with nay = count ballots.nay}
| Pass ->
ok {ballots with pass = count ballots.pass} ))
~init:(ok {yay = 0l; nay = 0l; pass = 0l})
let get_ballot_list = Storage.Vote.Ballots.bindings
let clear_ballots = Storage.Vote.Ballots.clear
let listings_encoding =
Data_encoding.(
list
(obj2 (req "pkh" Signature.Public_key_hash.encoding) (req "rolls" int32)))
let freeze_listings ctxt =
Roll_storage.fold ctxt (ctxt, 0l) ~f:(fun _roll delegate (ctxt, total) ->
(* TODO use snapshots *)
let delegate = Signature.Public_key.hash delegate in
Storage.Vote.Listings.get_option ctxt delegate
>>=? (function None -> return 0l | Some count -> return count)
>>=? fun count ->
Storage.Vote.Listings.init_set ctxt delegate (Int32.succ count)
>>= fun ctxt -> return (ctxt, Int32.succ total))
>>=? fun (ctxt, total) ->
Storage.Vote.Listings_size.init ctxt total >>=? fun ctxt -> return ctxt
let listing_size = Storage.Vote.Listings_size.get
let in_listings = Storage.Vote.Listings.mem
let get_listings = Storage.Vote.Listings.bindings
let clear_listings ctxt =
Storage.Vote.Listings.clear ctxt
>>= fun ctxt ->
Storage.Vote.Listings_size.remove ctxt >>= fun ctxt -> return ctxt
let get_current_period_kind = Storage.Vote.Current_period_kind.get
let set_current_period_kind = Storage.Vote.Current_period_kind.set
let get_current_quorum ctxt =
Storage.Vote.Participation_ema.get ctxt
>>=? fun participation_ema ->
let quorum_min = Constants_storage.quorum_min ctxt in
let quorum_max = Constants_storage.quorum_max ctxt in
let quorum_diff = Int32.sub quorum_max quorum_min in
return
Int32.(add quorum_min (div (mul participation_ema quorum_diff) 100_00l))
let get_participation_ema = Storage.Vote.Participation_ema.get
let set_participation_ema = Storage.Vote.Participation_ema.set
let get_current_proposal = Storage.Vote.Current_proposal.get
let init_current_proposal = Storage.Vote.Current_proposal.init
let clear_current_proposal = Storage.Vote.Current_proposal.delete
let init ctxt =
(* participation EMA is in centile of a percentage *)
let participation_ema = Constants_storage.quorum_max ctxt in
Storage.Vote.Participation_ema.init ctxt participation_ema
>>=? fun ctxt ->
Storage.Vote.Current_period_kind.init ctxt Proposal
>>=? fun ctxt -> return ctxt
src/proto_alpha/lib_protocol/vote_storage.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition recorded_proposal_count_for_delegate
(ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.context)
(proposer : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.value) :=
op_gtgteqquestion (Storage.Vote.Proposals_count.get_option ctxt proposer)
(fun function_parameter =>
match function_parameter with
| None => _return 0
| Some count => _return count
end).
Definition record_proposal
(ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.context)
(proposal :
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
(proposer : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.key)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteqquestion (recorded_proposal_count_for_delegate ctxt proposer)
(fun count =>
op_gtgteq
(Storage.Vote.Proposals_count.init_set ctxt proposer (op_plus count 1))
(fun ctxt =>
op_gtgteq (Storage.Vote.Proposals.add ctxt (proposal, proposer))
(fun ctxt => _return ctxt))).
Definition get_proposals
(ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Proposals.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
(Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t int32)) :=
Storage.Vote.Proposals.fold ctxt (ok Protocol_hash.Map.empty)
(fun function_parameter =>
let '(proposal, delegate) := function_parameter in
fun acc =>
op_gtgteqquestion (Storage.Vote.Listings.get ctxt delegate)
(fun weight =>
Lwt._return
(op_gtgtquestion acc
(fun acc =>
let previous :=
match Protocol_hash.Map.find_opt proposal acc with
| None =>
(* ❌ Constant of type int32 is converted to int *)
0
| Some x => x
end in
ok
(Protocol_hash.Map.add proposal (Int32.add weight previous)
acc))))).
Definition clear_proposals
(ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t :=
op_gtgteq (Storage.Vote.Proposals_count.clear ctxt)
(fun ctxt => Storage.Vote.Proposals.clear ctxt).
Record ballots := {
yay : int32;
nay : int32;
pass : int32 }.
Definition ballots_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding ballots :=
op_atat
(let arg :=
conv
(fun function_parameter =>
let '{| yay := yay; nay := nay; pass := pass |} := function_parameter
in
(yay, nay, pass))
(fun function_parameter =>
let '(yay, nay, pass) := function_parameter in
{| yay := yay; nay := nay; pass := pass |}) in
fun eta => arg None eta)
(obj3 (req None None "yay" % string int32)
(req None None "nay" % string int32) (req None None "pass" % string int32)).
Definition has_recorded_ballot
: Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context ->
Tezos_raw_protocol_alpha.Storage.Vote.Ballots.key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
Storage.Vote.Ballots.mem.
Definition record_ballot
: Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context ->
Tezos_raw_protocol_alpha.Storage.Vote.Ballots.key ->
Tezos_raw_protocol_alpha.Storage.Vote.Ballots.value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) := Storage.Vote.Ballots.init.
Definition get_ballots
(ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult ballots) :=
Storage.Vote.Ballots.fold ctxt
(ok
{|
yay :=
(* ❌ Constant of type int32 is converted to int *)
0;
nay :=
(* ❌ Constant of type int32 is converted to int *)
0;
pass :=
(* ❌ Constant of type int32 is converted to int *)
0 |})
(fun delegate =>
fun ballot =>
fun ballots =>
op_gtgteqquestion (Storage.Vote.Listings.get ctxt delegate)
(fun weight =>
let count := Int32.add weight in
Lwt._return
(op_gtgtquestion ballots
(fun ballots =>
match ballot with
| Tezos_raw_protocol_alpha.Vote_repr.Yay =>
ok
(* ❌ Record substitution not handled *)
record_substitution
| Tezos_raw_protocol_alpha.Vote_repr.Nay =>
ok
(* ❌ Record substitution not handled *)
record_substitution
| Tezos_raw_protocol_alpha.Vote_repr.Pass =>
ok
(* ❌ Record substitution not handled *)
record_substitution
end)))).
Definition get_ballot_list
: Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(list
(Tezos_raw_protocol_alpha.Storage.Vote.Ballots.key *
Tezos_raw_protocol_alpha.Storage.Vote.Ballots.value)) :=
Storage.Vote.Ballots.bindings.
Definition clear_ballots
: Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
Tezos_raw_protocol_alpha.Raw_context.t := Storage.Vote.Ballots.clear.
Definition listings_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
(list
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* int32)) :=
list None
(obj2 (req None None "pkh" % string Signature.Public_key_hash.encoding)
(req None None "rolls" % string int32)).
Definition freeze_listings (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteqquestion
(Roll_storage.fold ctxt
(fun _roll =>
fun delegate =>
fun function_parameter =>
let '(ctxt, total) := function_parameter in
let delegate := Signature.Public_key.hash delegate in
op_gtgteqquestion
(op_gtgteqquestion
(Storage.Vote.Listings.get_option ctxt delegate)
(fun function_parameter =>
match function_parameter with
| None =>
_return
(* ❌ Constant of type int32 is converted to int *)
0
| Some count => _return count
end))
(fun count =>
op_gtgteq
(Storage.Vote.Listings.init_set ctxt delegate
(Int32.succ count))
(fun ctxt => _return (ctxt, (Int32.succ total)))))
(ctxt,
(* ❌ Constant of type int32 is converted to int *)
0))
(fun function_parameter =>
let '(ctxt, total) := function_parameter in
op_gtgteqquestion (Storage.Vote.Listings_size.init ctxt total)
(fun ctxt => _return ctxt)).
Definition listing_size
: Tezos_raw_protocol_alpha.Storage.Vote.Listings_size.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Vote.Listings_size.value) :=
Storage.Vote.Listings_size.get.
Definition in_listings
: Tezos_raw_protocol_alpha.Storage.Vote.Listings.context ->
Tezos_raw_protocol_alpha.Storage.Vote.Listings.key ->
Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
Storage.Vote.Listings.mem.
Definition get_listings
: Tezos_raw_protocol_alpha.Storage.Vote.Listings.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(list
(Tezos_raw_protocol_alpha.Storage.Vote.Listings.key *
Tezos_raw_protocol_alpha.Storage.Vote.Listings.value)) :=
Storage.Vote.Listings.bindings.
Definition clear_listings
(ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Listings.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
op_gtgteq (Storage.Vote.Listings.clear ctxt)
(fun ctxt =>
op_gtgteq (Storage.Vote.Listings_size.remove ctxt)
(fun ctxt => _return ctxt)).
Definition get_current_period_kind
: Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.value) :=
Storage.Vote.Current_period_kind.get.
Definition set_current_period_kind
: Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.context ->
Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
Storage.Vote.Current_period_kind.set.
Definition get_current_quorum
(ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int32) :=
op_gtgteqquestion (Storage.Vote.Participation_ema.get ctxt)
(fun participation_ema =>
let quorum_min := Constants_storage.quorum_min ctxt in
let quorum_max := Constants_storage.quorum_max ctxt in
let quorum_diff := Int32.sub quorum_max quorum_min in
_return
(add quorum_min
(div (mul participation_ema quorum_diff)
(* ❌ Constant of type int32 is converted to int *)
10000))).
Definition get_participation_ema
: Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.value) :=
Storage.Vote.Participation_ema.get.
Definition set_participation_ema
: Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.context ->
Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
Storage.Vote.Participation_ema.set.
Definition get_current_proposal
: Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.value) :=
Storage.Vote.Current_proposal.get.
Definition init_current_proposal
: Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.context ->
Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.value ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
Storage.Vote.Current_proposal.init.
Definition clear_current_proposal
: Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.context ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
Storage.Vote.Current_proposal.delete.
Definition init (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
Tezos_raw_protocol_alpha.Raw_context.t) :=
let participation_ema := Constants_storage.quorum_max ctxt in
op_gtgteqquestion (Storage.Vote.Participation_ema.init ctxt participation_ema)
(fun ctxt =>
op_gtgteqquestion
(Storage.Vote.Current_period_kind.init ctxt
Tezos_raw_protocol_alpha.Voting_period_repr.Proposal)
(fun ctxt => _return ctxt)).
src/proto_alpha/lib_protocol/voting_period_repr.ml 7 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type t = int32
type voting_period = t
include (Compare.Int32 : Compare.S with type t := t)
let encoding = Data_encoding.int32
let pp ppf level = Format.fprintf ppf "%ld" level
let rpc_arg =
let construct voting_period = Int32.to_string voting_period in
let destruct str =
match Int32.of_string str with
| exception _ ->
Error "Cannot parse voting period"
| voting_period ->
Ok voting_period
in
RPC_arg.make
~descr:"A voting period"
~name:"voting_period"
~construct
~destruct
()
let root = 0l
let succ = Int32.succ
let to_int32 l = l
let of_int32_exn l =
if Compare.Int32.(l >= 0l) then l
else invalid_arg "Voting_period_repr.of_int32"
type kind = Proposal | Testing_vote | Testing | Promotion_vote
let kind_encoding =
let open Data_encoding in
union
~tag_size:`Uint8
[ case
(Tag 0)
~title:"Proposal"
(constant "proposal")
(function Proposal -> Some () | _ -> None)
(fun () -> Proposal);
case
(Tag 1)
~title:"Testing_vote"
(constant "testing_vote")
(function Testing_vote -> Some () | _ -> None)
(fun () -> Testing_vote);
case
(Tag 2)
~title:"Testing"
(constant "testing")
(function Testing -> Some () | _ -> None)
(fun () -> Testing);
case
(Tag 3)
~title:"Promotion_vote"
(constant "promotion_vote")
(function Promotion_vote -> Some () | _ -> None)
(fun () -> Promotion_vote) ]
src/proto_alpha/lib_protocol/voting_period_repr.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition t := int32.
Definition voting_period := t.
(* ❌ Structure item `include` not handled. *)
include
Definition encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
Data_encoding.int32.
Definition pp
(ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
(level : int32) : unit :=
Format.fprintf ppf
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
"%ld" % string) level.
Definition rpc_arg
: Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 :=
let construct (voting_period : int32) : string :=
Int32.to_string voting_period in
let destruct (str : string)
: Tezos_protocol_environment_alpha__Environment.Pervasives.result int32
string :=
let 'voting_period := Int32.of_string str in
Tezos_protocol_environment_alpha__Environment.Pervasives.Ok voting_period in
RPC_arg.make (Some "A voting period" % string) "voting_period" % string
destruct construct tt.
Definition root : int32 :=
(* ❌ Constant of type int32 is converted to int *)
0.
Definition succ : int32 -> int32 := Int32.succ.
Definition to_int32 {A : Type} (l : A) : A := l.
Definition of_int32_exn
(l :
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
: Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
if
Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
l
(* ❌ Constant of type int32 is converted to int *)
0 then
l
else
invalid_arg "Voting_period_repr.of_int32" % string.
Inductive kind : Type :=
| Proposal : kind
| Testing_vote : kind
| Testing : kind
| Promotion_vote : kind.
Definition kind_encoding
: Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding kind :=
union
(Some
(* ❌ Variants not supported *)
variant)
(cons
(case "Proposal" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
(constant "proposal" % string)
(fun function_parameter =>
match function_parameter with
| Proposal => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Proposal))
(cons
(case "Testing_vote" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
(constant "testing_vote" % string)
(fun function_parameter =>
match function_parameter with
| Testing_vote => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Testing_vote))
(cons
(case "Testing" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 2)
(constant "testing" % string)
(fun function_parameter =>
match function_parameter with
| Testing => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Testing))
(cons
(case "Promotion_vote" % string None
(Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 3)
(constant "promotion_vote" % string)
(fun function_parameter =>
match function_parameter with
| Promotion_vote => Some tt
| _ => None
end)
(fun function_parameter =>
let 'tt := function_parameter in
Promotion_vote)) [])))).
src/proto_alpha/lib_protocol/voting_services.ml 128 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Alpha_context
module S = struct
let path = RPC_path.(open_root / "votes")
let ballots =
RPC_service.get_service
~description:"Sum of ballots casted so far during a voting period."
~query:RPC_query.empty
~output:Vote.ballots_encoding
RPC_path.(path / "ballots")
let ballot_list =
RPC_service.get_service
~description:"Ballots casted so far during a voting period."
~query:RPC_query.empty
~output:
Data_encoding.(
list
(obj2
(req "pkh" Signature.Public_key_hash.encoding)
(req "ballot" Vote.ballot_encoding)))
RPC_path.(path / "ballot_list")
let current_period_kind =
RPC_service.get_service
~description:"Current period kind."
~query:RPC_query.empty
~output:Voting_period.kind_encoding
RPC_path.(path / "current_period_kind")
let current_quorum =
RPC_service.get_service
~description:"Current expected quorum."
~query:RPC_query.empty
~output:Data_encoding.int32
RPC_path.(path / "current_quorum")
let listings =
RPC_service.get_service
~description:
"List of delegates with their voting weight, in number of rolls."
~query:RPC_query.empty
~output:Vote.listings_encoding
RPC_path.(path / "listings")
let proposals =
RPC_service.get_service
~description:"List of proposals with number of supporters."
~query:RPC_query.empty
~output:(Protocol_hash.Map.encoding Data_encoding.int32)
RPC_path.(path / "proposals")
let current_proposal =
RPC_service.get_service
~description:"Current proposal under evaluation."
~query:RPC_query.empty
~output:(Data_encoding.option Protocol_hash.encoding)
RPC_path.(path / "current_proposal")
end
let register () =
let open Services_registration in
register0 S.ballots (fun ctxt () () -> Vote.get_ballots ctxt) ;
register0 S.ballot_list (fun ctxt () () -> Vote.get_ballot_list ctxt >|= ok) ;
register0 S.current_period_kind (fun ctxt () () ->
Vote.get_current_period_kind ctxt) ;
register0 S.current_quorum (fun ctxt () () -> Vote.get_current_quorum ctxt) ;
register0 S.proposals (fun ctxt () () -> Vote.get_proposals ctxt) ;
register0 S.listings (fun ctxt () () -> Vote.get_listings ctxt >|= ok) ;
register0 S.current_proposal (fun ctxt () () ->
(* this would be better implemented using get_option in get_current_proposal *)
Vote.get_current_proposal ctxt
>>= function
| Ok p ->
return_some p
| Error (Raw_context.Storage_error (Missing_key _) :: _) ->
return_none
| Error _ as e ->
Lwt.return e)
let ballots ctxt block = RPC_context.make_call0 S.ballots ctxt block () ()
let ballot_list ctxt block =
RPC_context.make_call0 S.ballot_list ctxt block () ()
let current_period_kind ctxt block =
RPC_context.make_call0 S.current_period_kind ctxt block () ()
let current_quorum ctxt block =
RPC_context.make_call0 S.current_quorum ctxt block () ()
let listings ctxt block = RPC_context.make_call0 S.listings ctxt block () ()
let proposals ctxt block = RPC_context.make_call0 S.proposals ctxt block () ()
let current_proposal ctxt block =
RPC_context.make_call0 S.current_proposal ctxt block () ()
src/proto_alpha/lib_protocol/voting_services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Alpha_context.
Module S.
Definition path
: Tezos_protocol_environment_alpha__Environment.RPC_path.path
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
op_div open_root "votes" % string.
Definition ballots
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
unit Tezos_raw_protocol_alpha.Alpha_context.Vote.ballots :=
RPC_service.get_service
(Some "Sum of ballots casted so far during a voting period." % string)
RPC_query.empty Vote.ballots_encoding (op_div path "ballots" % string).
Definition ballot_list
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
unit
(list
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot)) :=
RPC_service.get_service
(Some "Ballots casted so far during a voting period." % string)
RPC_query.empty
(list None
(obj2 (req None None "pkh" % string Signature.Public_key_hash.encoding)
(req None None "ballot" % string Vote.ballot_encoding)))
(op_div path "ballot_list" % string).
Definition current_period_kind
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
unit Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind :=
RPC_service.get_service (Some "Current period kind." % string)
RPC_query.empty Voting_period.kind_encoding
(op_div path "current_period_kind" % string).
Definition current_quorum
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
unit int32 :=
RPC_service.get_service (Some "Current expected quorum." % string)
RPC_query.empty Data_encoding.int32
(op_div path "current_quorum" % string).
Definition listings
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
unit
(list
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* int32)) :=
RPC_service.get_service
(Some
"List of delegates with their voting weight, in number of rolls." %
string) RPC_query.empty Vote.listings_encoding
(op_div path "listings" % string).
Definition proposals
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
unit
(Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t int32) :=
RPC_service.get_service
(Some "List of proposals with number of supporters." % string)
RPC_query.empty (Protocol_hash.Map.encoding Data_encoding.int32)
(op_div path "proposals" % string).
Definition current_proposal
: Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
unit
(option
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)) :=
RPC_service.get_service (Some "Current proposal under evaluation." % string)
RPC_query.empty
(Data_encoding.option
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding))
(op_div path "current_proposal" % string).
End S.
Definition register (function_parameter : unit) : unit :=
let 'tt := function_parameter in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.ballots
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Vote.get_ballots ctxt) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.ballot_list
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtpipeeq (Vote.get_ballot_list ctxt) ok) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.current_period_kind
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Vote.get_current_period_kind ctxt) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.current_quorum
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Vote.get_current_quorum ctxt) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.proposals
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
Vote.get_proposals ctxt) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
register0 S.listings
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtpipeeq (Vote.get_listings ctxt) ok) in
register0 S.current_proposal
(fun ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let 'tt := function_parameter in
op_gtgteq (Vote.get_current_proposal ctxt)
(fun function_parameter =>
match function_parameter with
| Tezos_protocol_environment_alpha__Environment.Pervasives.Ok p =>
return_some p
|
Tezos_protocol_environment_alpha__Environment.Pervasives.Error
(cons
(Tezos_protocol_environment_alpha__Environment.Error_monad.Storage_error
(Tezos_raw_protocol_alpha.Raw_context.Missing_key _ _)) _)
=> return_none
|
(Tezos_protocol_environment_alpha__Environment.Pervasives.Error
_) as e => Lwt._return e
end)).
Definition ballots {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Vote.ballots) :=
RPC_context.make_call0 S.ballots ctxt block tt tt.
Definition ballot_list {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(list
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot))) :=
RPC_context.make_call0 S.ballot_list ctxt block tt tt.
Definition current_period_kind {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind) :=
RPC_context.make_call0 S.current_period_kind ctxt block tt tt.
Definition current_quorum {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
int32) := RPC_context.make_call0 S.current_quorum ctxt block tt tt.
Definition listings {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(list
(Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
* int32))) := RPC_context.make_call0 S.listings ctxt block tt tt.
Definition proposals {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t int32)) :=
RPC_context.make_call0 S.proposals ctxt block tt tt.
Definition current_proposal {D E G I K L a b c i o q : Type}
(ctxt :
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
D ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (E * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
(Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
->
D ->
a ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (G * a * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
Tezos_protocol_environment_alpha__Environment.RPC_context.t
((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
q i o) ->
D ->
a ->
b ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (I * a * b * q * i * o)) *
((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
(((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
* b) * c) q i o) ->
D ->
a ->
b ->
c ->
q ->
i ->
Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
(block : D)
: Tezos_protocol_environment_alpha__Environment.Lwt.t
(Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
(option
Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))) :=
RPC_context.make_call0 S.current_proposal ctxt block tt tt.
src/proto_demo_noops/lib_protocol/main.ml 17 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
let max_block_length = 100
let max_operation_data_length = 0
let validation_passes = []
let acceptable_passes _op = []
type block_header_data = string
let block_header_data_encoding =
Data_encoding.(obj1 (req "block_header_data" string))
type block_header = {
shell : Block_header.shell_header;
protocol_data : block_header_data;
}
type block_header_metadata = unit
let block_header_metadata_encoding = Data_encoding.unit
type operation_data = unit
let operation_data_encoding = Data_encoding.unit
type operation_receipt = unit
let operation_receipt_encoding = Data_encoding.unit
let operation_data_and_receipt_encoding =
Data_encoding.conv
(function ((), ()) -> ())
(fun () -> ((), ()))
Data_encoding.unit
type operation = {
shell : Operation.shell_header;
protocol_data : operation_data;
}
let compare_operations _ _ = 0
type validation_state = {context : Context.t; fitness : Fitness.t}
let current_context {context; _} = return context
let begin_application ~chain_id:_ ~predecessor_context:context
~predecessor_timestamp:_ ~predecessor_fitness (raw_block : block_header) =
let fitness = raw_block.shell.fitness in
Logging.log_notice
"begin_application: pred_fitness = %a block_fitness = %a%!"
Fitness.pp
predecessor_fitness
Fitness.pp
fitness ;
(* Note: Logging is only available for debugging purposes and should
not appear in a real protocol. *)
return {context; fitness}
let begin_partial_application ~chain_id ~ancestor_context
~predecessor_timestamp ~predecessor_fitness block_header =
Logging.log_notice "begin_partial_application%!" ;
begin_application
~chain_id
~predecessor_context:ancestor_context
~predecessor_timestamp
~predecessor_fitness
block_header
let version_number = "\001"
let int64_to_bytes i =
let b = MBytes.create 8 in
MBytes.set_int64 b 0 i ; b
let fitness_from_level level =
[MBytes.of_string version_number; int64_to_bytes level]
let begin_construction ~chain_id:_ ~predecessor_context:context
~predecessor_timestamp:_ ~predecessor_level ~predecessor_fitness
~predecessor:_ ~timestamp:_ ?protocol_data () =
let fitness = fitness_from_level Int64.(succ (of_int32 predecessor_level)) in
let mode =
match protocol_data with Some _ -> "block" | None -> "mempool"
in
Logging.log_notice
"begin_construction (%s): pred_fitness = %a constructed fitness = %a%!"
mode
Fitness.pp
predecessor_fitness
Fitness.pp
fitness ;
return {context; fitness}
let apply_operation _state _op = Lwt.return (Error [])
let finalize_block state =
let fitness = state.fitness in
Logging.log_notice "finalize_block: fitness = %a%!" Fitness.pp fitness ;
return
( {
Updater.message = None;
context = state.context;
fitness;
max_operations_ttl = 0;
last_allowed_fork_level = 0l;
},
() )
let init context block_header =
let open Block_header in
let fitness = block_header.fitness in
Logging.log_notice "init: fitness = %a%!" Fitness.pp fitness ;
return
{
Updater.message = None;
context;
fitness;
max_operations_ttl = 0;
last_allowed_fork_level = 0l;
}
let rpc_services = RPC_directory.empty
src/proto_demo_noops/lib_protocol/main.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Definition max_block_length : Z := 100.
Definition max_operation_data_length : Z := 0.
Definition validation_passes {A : Type} : list A := [].
Definition acceptable_passes {A B : Type} (_op : A) : list B := [].
Definition block_header_data := string.
Definition block_header_data_encoding
: Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
string := obj1 (req None None "block_header_data" % string string).
Record block_header := {
shell :
Tezos_protocol_environment_demo_noops__Environment.Block_header.shell_header;
protocol_data : block_header_data }.
Definition block_header_metadata := unit.
Definition block_header_metadata_encoding
: Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
unit := Data_encoding.unit.
Definition operation_data := unit.
Definition operation_data_encoding
: Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
unit := Data_encoding.unit.
Definition operation_receipt := unit.
Definition operation_receipt_encoding
: Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
unit := Data_encoding.unit.
Definition operation_data_and_receipt_encoding
: Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
(unit * unit) :=
Data_encoding.conv
(fun function_parameter =>
let '(tt, tt) := function_parameter in
tt)
(fun function_parameter =>
let 'tt := function_parameter in
(tt, tt)) None Data_encoding.unit.
Record operation := {
shell :
Tezos_protocol_environment_demo_noops__Environment.Operation.shell_header;
protocol_data : operation_data }.
Definition compare_operations {A B : Type} (function_parameter : A) : B -> Z :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
0.
Record validation_state := {
context : Tezos_protocol_environment_demo_noops__Environment.Context.t;
fitness :
Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.t)
}.
Definition current_context (function_parameter : validation_state)
: Tezos_protocol_environment_demo_noops__Environment.Lwt.t
(Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
Tezos_protocol_environment_demo_noops__Environment.Context.t) :=
let '{| context := context |} := function_parameter in
_return context.
Definition begin_application {A B : Type} (function_parameter : A)
: Tezos_protocol_environment_demo_noops__Environment.Context.t ->
B ->
Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.t)
->
block_header ->
Tezos_protocol_environment_demo_noops__Environment.Lwt.t
(Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
validation_state) :=
let '_ := function_parameter in
fun context =>
fun function_parameter =>
let '_ := function_parameter in
fun predecessor_fitness =>
fun raw_block =>
let fitness := fitness (shell raw_block) in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Logging.log_notice
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
"begin_application: pred_fitness = " % string
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Alpha
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
" block_fitness = " % string
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Alpha
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Flush
Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.End_of_format)))))
"begin_application: pred_fitness = %a block_fitness = %a%!" %
string)
Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
predecessor_fitness
Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
fitness in
_return {| context := context; fitness := fitness |}.
Definition begin_partial_application {A B : Type}
(chain_id : A)
(ancestor_context :
Tezos_protocol_environment_demo_noops__Environment.Context.t)
(predecessor_timestamp : B)
(predecessor_fitness :
Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.t))
(block_header : block_header)
: Tezos_protocol_environment_demo_noops__Environment.Lwt.t
(Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
validation_state) :=
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Logging.log_notice
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
"begin_partial_application" % string
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Flush
Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.End_of_format))
"begin_partial_application%!" % string) in
begin_application chain_id ancestor_context predecessor_timestamp
predecessor_fitness block_header.
Definition version_number : string := "" % string.
Definition int64_to_bytes (i : int64)
: Tezos_protocol_environment_demo_noops__Environment.MBytes.t :=
let b := MBytes.create 8 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := MBytes.set_int64 b 0 i in
b.
Definition fitness_from_level (level : int64)
: list Tezos_protocol_environment_demo_noops__Environment.MBytes.t :=
cons (MBytes.of_string version_number) (cons (int64_to_bytes level) []).
Definition begin_construction {A B C D E : Type} (function_parameter : A)
: Tezos_protocol_environment_demo_noops__Environment.Context.t ->
B ->
int32 ->
Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.t)
->
C ->
D ->
(option E) ->
unit ->
Tezos_protocol_environment_demo_noops__Environment.Lwt.t
(Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
validation_state) :=
let '_ := function_parameter in
fun context =>
fun function_parameter =>
let '_ := function_parameter in
fun predecessor_level =>
fun predecessor_fitness =>
fun function_parameter =>
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun protocol_data =>
fun function_parameter =>
let 'tt := function_parameter in
let fitness :=
fitness_from_level (succ (of_int32 predecessor_level)) in
let mode :=
match protocol_data with
| Some _ => "block" % string
| None => "mempool" % string
end in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Logging.log_notice
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
"begin_construction (" % string
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String
Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.No_padding
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
"): pred_fitness = " % string
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Alpha
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
" constructed fitness = " % string
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Alpha
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Flush
Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.End_of_format)))))))
"begin_construction (%s): pred_fitness = %a constructed fitness = %a%!"
% string) mode
Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
predecessor_fitness
Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
fitness in
_return {| context := context; fitness := fitness |}.
Definition apply_operation {A B C D : Type} (_state : A) (_op : B)
: Tezos_protocol_environment_demo_noops__Environment.Lwt.t
(Tezos_protocol_environment_demo_noops__Environment.Pervasives.result C
(list D)) :=
Lwt._return
(Tezos_protocol_environment_demo_noops__Environment.Pervasives.Error []).
Definition finalize_block (state : validation_state)
: Tezos_protocol_environment_demo_noops__Environment.Lwt.t
(Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
(Tezos_protocol_environment_demo_noops__Environment.Updater.validation_result
* unit)) :=
let fitness := fitness state in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Logging.log_notice
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
"finalize_block: fitness = " % string
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Alpha
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Flush
Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.End_of_format)))
"finalize_block: fitness = %a%!" % string)
Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
fitness in
_return
({| Updater.context := context state; Updater.fitness := fitness;
Updater.message := None; Updater.max_operations_ttl := 0;
Updater.last_allowed_fork_level :=
(* ❌ Constant of type int32 is converted to int *)
0 |}, tt).
Definition init
(context : Tezos_protocol_environment_demo_noops__Environment.Context.t)
(block_header :
Tezos_protocol_environment_demo_noops__Environment.Block_header.shell_header)
: Tezos_protocol_environment_demo_noops__Environment.Lwt.t
(Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
Tezos_protocol_environment_demo_noops__Environment.Updater.validation_result) :=
let fitness := fitness block_header in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
Logging.log_notice
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
"init: fitness = " % string
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Alpha
(Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Flush
Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.End_of_format)))
"init: fitness = %a%!" % string)
Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
fitness in
_return
{| Updater.context := context; Updater.fitness := fitness;
Updater.message := None; Updater.max_operations_ttl := 0;
Updater.last_allowed_fork_level :=
(* ❌ Constant of type int32 is converted to int *)
0 |}.
Definition rpc_services {A : Type}
: Tezos_protocol_environment_demo_noops__Environment.RPC_directory.directory A :=
RPC_directory.empty.
src/proto_genesis/lib_client/client_proto_main.ml 45 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Protocol_client_context
let protocol =
Protocol_hash.of_b58check_exn
"ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im"
let bake cctxt ?timestamp block command sk =
let timestamp =
match timestamp with
| Some t ->
t
| None ->
Time.System.(to_protocol (Tezos_stdlib_unix.Systime_os.now ()))
in
let protocol_data = {command; signature = Signature.zero} in
Genesis_block_services.Helpers.Preapply.block
cctxt
~block
~timestamp
~protocol_data
[]
>>=? fun (shell_header, _) ->
let blk = Data.Command.forge shell_header command in
Shell_services.Chain.chain_id cctxt ~chain:`Main ()
>>=? fun chain_id ->
Client_keys.append cctxt sk ~watermark:(Block_header chain_id) blk
>>=? fun signed_blk -> Shell_services.Injection.block cctxt signed_blk []
let int64_parameter =
Clic.parameter (fun _ p ->
try return (Int64.of_string p) with _ -> failwith "Cannot read int64")
let file_parameter =
Clic.parameter (fun _ p ->
if not (Sys.file_exists p) then failwith "File doesn't exist: '%s'" p
else return p)
let fitness_from_int64 fitness =
(* definition taken from src/proto_alpha/lib_protocol/src/constants_repr.ml *)
let version_number = "\000" in
(* definitions taken from src/proto_alpha/lib_protocol/src/fitness_repr.ml *)
let int64_to_bytes i =
let b = Bytes.create 8 in
TzEndian.set_int64 b 0 i ; b
in
[Bytes.of_string version_number; int64_to_bytes fitness]
let timestamp_arg =
Clic.arg
~long:"timestamp"
~placeholder:"date"
~doc:"Set the timestamp of the block (and initial time of the chain)"
(Clic.parameter (fun _ t ->
match Time.System.of_notation_opt t with
| None ->
Error_monad.failwith
"Could not parse value provided to -timestamp option"
| Some t ->
return t))
let test_delay_arg =
Clic.default_arg
~long:"delay"
~placeholder:"time"
~doc:"Set the life span of the test chain (in seconds)"
~default:(Int64.to_string (Int64.mul 24L 3600L))
(Clic.parameter (fun _ t ->
match Int64.of_string_opt t with
| None ->
Error_monad.failwith
"Could not parse value provided to -delay option"
| Some t ->
return t))
let proto_param ~name ~desc t =
Clic.param
~name
~desc
(Clic.parameter (fun _ str -> Lwt.return (Protocol_hash.of_b58check str)))
t
let commands () =
let open Clic in
let args =
args1
(arg
~long:"timestamp"
~placeholder:"date"
~doc:"Set the timestamp of the block (and initial time of the chain)"
(parameter (fun _ t ->
match Time.Protocol.of_notation t with
| None ->
Error_monad.failwith
"Could not parse value provided to -timestamp option"
| Some t ->
return t)))
in
[ command
~desc:"Activate a protocol"
args
( prefixes ["activate"; "protocol"]
@@ proto_param ~name:"version" ~desc:"Protocol version (b58check)"
@@ prefixes ["with"; "fitness"]
@@ param
~name:"fitness"
~desc:"Hardcoded fitness of the first block (integer)"
int64_parameter
@@ prefixes ["and"; "key"]
@@ Client_keys.Secret_key.source_param
~name:"password"
~desc:"Activator's key"
@@ prefixes ["and"; "parameters"]
@@ param
~name:"parameters"
~desc:"Protocol parameters (as JSON file)"
file_parameter
@@ stop )
(fun timestamp
hash
fitness
sk
param_json_file
(cctxt : Client_context.full) ->
let fitness = fitness_from_int64 fitness in
Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file param_json_file
>>=? fun json ->
let protocol_parameters =
Data_encoding.Binary.to_bytes_exn Data_encoding.json json
in
bake
cctxt
?timestamp
cctxt#block
(Activate {protocol = hash; fitness; protocol_parameters})
sk
>>=? fun hash ->
cctxt#answer "Injected %a" Block_hash.pp_short hash
>>= fun () -> return_unit);
command
~desc:"Fork a test protocol"
(args2 timestamp_arg test_delay_arg)
( prefixes ["fork"; "test"; "protocol"]
@@ proto_param ~name:"version" ~desc:"Protocol version (b58check)"
@@ prefixes ["with"; "fitness"]
@@ param
~name:"fitness"
~desc:
"Hardcoded fitness of the first block of the testchain (integer)"
int64_parameter
@@ prefixes ["and"; "key"]
@@ Client_keys.Secret_key.source_param
~name:"password"
~desc:"Activator's key"
@@ prefixes ["and"; "parameters"]
@@ param
~name:"parameters"
~desc:"Testchain protocol parameters (as JSON file)"
file_parameter
@@ stop )
(fun (timestamp, delay) hash fitness sk param_json_file cctxt ->
let fitness = fitness_from_int64 fitness in
Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file param_json_file
>>=? fun json ->
let protocol_parameters =
Data_encoding.Binary.to_bytes_exn Data_encoding.json json
in
let timestamp = Option.map ~f:Time.System.to_protocol timestamp in
bake
cctxt
?timestamp
cctxt#block
(Activate_testchain
{protocol = hash; fitness; protocol_parameters; delay})
sk
>>=? fun hash ->
cctxt#answer "Injected %a" Block_hash.pp_short hash
>>= fun () -> return_unit) ]
let () = Client_commands.register protocol @@ fun _network -> commands ()
src/proto_genesis/lib_client/client_proto_main.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Import Protocol.
Import Protocol_client_context.
Definition protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
Protocol_hash.of_b58check_exn
"ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im" % string.
Definition bake {E G a i o p q : Type}
(cctxt :
((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
(E * p * q * i * o)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * G))))))
*
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
((option (Lwt_stream.t string)) *
((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
(((string ->
a ->
(Tezos_base__TzPervasives.Data_encoding.encoding a) ->
Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * G))))))
(timestamp : option Tezos_base__TzPervasives.Time.Protocol.t)
(block : Tezos_shell_services__Block_services.block)
(command : Tezos_raw_protocol_genesis.Data.Command.t)
(sk : Tezos_client_base.Client_keys.sk_uri)
: Lwt.t
(Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_hash.t) :=
let timestamp :=
match timestamp with
| Some t => t
| None => to_protocol (Tezos_stdlib_unix.Systime_os.now tt)
end in
let protocol_data := {| command := command; signature := Signature.zero |} in
op_gtgteqquestion
(Genesis_block_services.Helpers.Preapply.block cctxt None (Some block) None
(Some timestamp) protocol_data [])
(fun function_parameter =>
let '(shell_header, _) := function_parameter in
let blk := Data.Command.forge shell_header command in
op_gtgteqquestion
(Shell_services.Chain.chain_id cctxt
(Some
(* ❌ Variants not supported *)
variant) tt)
(fun chain_id =>
op_gtgteqquestion
(Client_keys.append cctxt
(Some (Tezos_base__TzPervasives.Signature.Block_header chain_id))
sk blk)
(fun signed_blk =>
Shell_services.Injection.block cctxt None None None signed_blk []))).
Definition int64_parameter
: Tezos_base__TzPervasives.Clic.parameter int64
Tezos_client_base.Client_context.full :=
Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun p =>
(* ❌ Try-with are not handled *)
try (_return (Int64.of_string p))).
Definition file_parameter
: Tezos_base__TzPervasives.Clic.parameter string
Tezos_client_base.Client_context.full :=
Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun p =>
if negb (Sys.file_exists p) then
failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"File doesn't exist: '" % string
(CamlinternalFormatBasics.String
CamlinternalFormatBasics.No_padding
(CamlinternalFormatBasics.Char_literal "'" % char
CamlinternalFormatBasics.End_of_format)))
"File doesn't exist: '%s'" % string) p
else
_return p).
Definition fitness_from_int64 (fitness : int64) : list string :=
let version_number := " " % string in
let int64_to_bytes (i : int64) : string :=
let b := Stdlib.Bytes.create 8 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := TzEndian.set_int64 b 0 i in
b in
cons (Stdlib.Bytes.of_string version_number)
(cons (int64_to_bytes fitness) []).
Definition timestamp_arg
: Tezos_base__TzPervasives.Clic.arg
(option Tezos_base__TzPervasives.Time.System.t)
Tezos_client_base.Client_context.full :=
Clic.arg
"Set the timestamp of the block (and initial time of the chain)" % string
None "timestamp" % string "date" % string
(Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun t =>
match Time.System.of_notation_opt t with
| None =>
Error_monad.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Could not parse value provided to -timestamp option" % string
CamlinternalFormatBasics.End_of_format)
"Could not parse value provided to -timestamp option" % string)
| Some t => _return t
end)).
Definition test_delay_arg
: Tezos_base__TzPervasives.Clic.arg int64
Tezos_client_base.Client_context.full :=
Clic.default_arg "Set the life span of the test chain (in seconds)" % string
None "delay" % string "time" % string
(Int64.to_string
(Int64.mul
(* ❌ Constant of type int64 is converted to int *)
24
(* ❌ Constant of type int64 is converted to int *)
3600))
(Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun t =>
match Int64.of_string_opt t with
| None =>
Error_monad.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Could not parse value provided to -delay option" % string
CamlinternalFormatBasics.End_of_format)
"Could not parse value provided to -delay option" % string)
| Some t => _return t
end)).
Definition proto_param {A B : Type}
(name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
: Tezos_base__TzPervasives.Clic.params
(Tezos_base__TzPervasives.Protocol_hash.t -> A) B :=
Clic.param name desc
(Clic.parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun str => Lwt._return (Protocol_hash.of_b58check str))) t.
Definition commands (function_parameter : unit)
: list
(Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
let 'tt := function_parameter in
let args :=
args1
(arg
"Set the timestamp of the block (and initial time of the chain)" %
string None "timestamp" % string "date" % string
(parameter None
(fun function_parameter =>
let '_ := function_parameter in
fun t =>
match Time.Protocol.of_notation t with
| None =>
Error_monad.failwith
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Could not parse value provided to -timestamp option" %
string CamlinternalFormatBasics.End_of_format)
"Could not parse value provided to -timestamp option" %
string)
| Some t => _return t
end))) in
cons
(command None "Activate a protocol" % string args
(apply (prefixes (cons "activate" % string (cons "protocol" % string [])))
(apply
(proto_param "version" % string "Protocol version (b58check)" % string)
(apply (prefixes (cons "with" % string (cons "fitness" % string [])))
(apply
(param "fitness" % string
"Hardcoded fitness of the first block (integer)" % string
int64_parameter)
(apply (prefixes (cons "and" % string (cons "key" % string [])))
(apply
(Client_keys.Secret_key.source_param
(Some "password" % string) (Some "Activator's key" % string))
(apply
(prefixes
(cons "and" % string (cons "parameters" % string [])))
(apply
(param "parameters" % string
"Protocol parameters (as JSON file)" % string
file_parameter) stop))))))))
(fun timestamp =>
fun hash =>
fun fitness =>
fun sk =>
fun param_json_file =>
fun cctxt =>
let fitness := fitness_from_int64 fitness in
op_gtgteqquestion
(Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file
param_json_file)
(fun json =>
let protocol_parameters :=
Data_encoding.Binary.to_bytes_exn Data_encoding.json
json in
op_gtgteqquestion
(bake cctxt timestamp
(* ❌ Sending method message is not handled *)
send
(Tezos_raw_protocol_genesis.Data.Command.Activate
{| protocol := hash; fitness := fitness;
protocol_parameters := protocol_parameters |}) sk)
(fun hash =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Injected " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Injected %a" % string) Block_hash.pp_short hash)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit)))))
(cons
(command None "Fork a test protocol" % string
(args2 timestamp_arg test_delay_arg)
(apply
(prefixes
(cons "fork" % string
(cons "test" % string (cons "protocol" % string []))))
(apply
(proto_param "version" % string
"Protocol version (b58check)" % string)
(apply
(prefixes (cons "with" % string (cons "fitness" % string [])))
(apply
(param "fitness" % string
"Hardcoded fitness of the first block of the testchain (integer)"
% string int64_parameter)
(apply (prefixes (cons "and" % string (cons "key" % string [])))
(apply
(Client_keys.Secret_key.source_param
(Some "password" % string)
(Some "Activator's key" % string))
(apply
(prefixes
(cons "and" % string (cons "parameters" % string [])))
(apply
(param "parameters" % string
"Testchain protocol parameters (as JSON file)" %
string file_parameter) stop))))))))
(fun function_parameter =>
let '(timestamp, delay) := function_parameter in
fun hash =>
fun fitness =>
fun sk =>
fun param_json_file =>
fun cctxt =>
let fitness := fitness_from_int64 fitness in
op_gtgteqquestion
(Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file
param_json_file)
(fun json =>
let protocol_parameters :=
Data_encoding.Binary.to_bytes_exn Data_encoding.json
json in
let timestamp :=
Option.map Time.System.to_protocol timestamp in
op_gtgteqquestion
(bake cctxt timestamp
(* ❌ Sending method message is not handled *)
send
(Tezos_raw_protocol_genesis.Data.Command.Activate_testchain
{| protocol := hash; fitness := fitness;
protocol_parameters := protocol_parameters;
delay := delay |}) sk)
(fun hash =>
op_gtgteq
((* ❌ Sending method message is not handled *)
send
(CamlinternalFormatBasics.Format
(CamlinternalFormatBasics.String_literal
"Injected " % string
(CamlinternalFormatBasics.Alpha
CamlinternalFormatBasics.End_of_format))
"Injected %a" % string) Block_hash.pp_short
hash)
(fun function_parameter =>
let 'tt := function_parameter in
return_unit))))) []).
src/proto_genesis/lib_client/protocol_client_context.ml 1 error
(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) module Genesis_block_services = Block_services.Make (Protocol) (Protocol)
src/proto_genesis/lib_client/protocol_client_context.ml.v
Require Import OCaml.OCaml. Local Open Scope Z_scope. Local Open Scope type_scope. Import ListNotations. (* ❌ Applications of functors are not handled. *) functor_application
src/proto_genesis/lib_protocol/data.ml 16 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Command = struct
type t =
(* Activate a protocol *)
| Activate of {
protocol: Protocol_hash.t ;
fitness: Fitness.t ;
protocol_parameters : MBytes.t ;
}
(* Activate a protocol as a testchain *)
| Activate_testchain of {
protocol: Protocol_hash.t ;
fitness: Fitness.t ;
protocol_parameters : MBytes.t ;
delay: Int64.t ;
}
let mk_case name args =
let open Data_encoding in
conv
(fun o -> ((), o))
(fun ((), o) -> o)
(merge_objs
(obj1 (req "command" (constant name)))
args)
let encoding =
let open Data_encoding in
union ~tag_size:`Uint8 [
case (Tag 0)
~title:"Activate"
(mk_case "activate"
(obj3
(req "hash" Protocol_hash.encoding)
(req "fitness" Fitness.encoding)
(req "protocol_parameters" Variable.bytes)
))
(function
| Activate { protocol ; fitness ; protocol_parameters} ->
Some (protocol, fitness, protocol_parameters)
| _ -> None)
(fun (protocol, fitness, protocol_parameters) ->
Activate { protocol ; fitness ; protocol_parameters }) ;
case (Tag 1)
~title:"Activate_testchain"
(mk_case "activate_testchain"
(obj4
(req "hash" Protocol_hash.encoding)
(req "fitness" Fitness.encoding)
(req "protocol_parameters" Variable.bytes)
(req "validity_time" int64)))
(function
| Activate_testchain { protocol ; fitness ; protocol_parameters ; delay } ->
Some (protocol, fitness, protocol_parameters, delay)
| _ -> None)
(fun (protocol, fitness, protocol_parameters, delay) ->
Activate_testchain { protocol ; fitness ; protocol_parameters ; delay }) ;
]
let signed_encoding =
let open Data_encoding in
obj2
(req "content" encoding)
(req "signature" Signature.encoding)
let forge shell command =
Data_encoding.Binary.to_bytes_exn
(Data_encoding.tup2 Block_header.shell_header_encoding encoding)
(shell, command)
end
module Pubkey = struct
let pubkey_key = ["genesis_key"]
let default =
Signature.Public_key.of_b58check_exn
"edpkvVCdQtDJHPnkmfRZuuHWKzFetH9N9nGP8F7zkwM2BJpjbvAU1N"
let get_pubkey ctxt =
Context.get ctxt pubkey_key >>= function
| None -> Lwt.return default
| Some b ->
match Data_encoding.Binary.of_bytes Signature.Public_key.encoding b with
| None -> Lwt.return default
| Some pk -> Lwt.return pk
let set_pubkey ctxt v =
Context.set ctxt pubkey_key @@
Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding v
let sandbox_encoding =
let open Data_encoding in
merge_objs
(obj1 (req "genesis_pubkey" Signature.Public_key.encoding))
Data_encoding.unit
let may_change_default ctxt json =
match Data_encoding.Json.destruct sandbox_encoding json with
| exception _ ->
Lwt.return ctxt
| (pubkey, ()) ->
set_pubkey ctxt pubkey >>= fun ctxt ->
Lwt.return ctxt
end
module Init = struct
type error += Incompatible_protocol_version
let version_key = ["version"]
(* This key should always be populated for every version of the
protocol. It's absence meaning that the context is empty. *)
let version_value = "genesis"
let check_inited ctxt =
Context.get ctxt version_key >>= function
| None -> failwith "Internal error: uninitialized context."
| Some version ->
if Compare.String.(version_value <> MBytes.to_string version) then
failwith "Internal error: incompatible protocol version" ;
return_unit
let tag_first_block ctxt =
Context.get ctxt version_key >>= function
| None ->
Context.set
ctxt version_key (MBytes.of_string version_value) >>= fun ctxt ->
return ctxt
| Some _version ->
failwith "Internal error: previously initialized context." ;
end
src/proto_genesis/lib_protocol/data.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Command.
Inductive t : Type :=
| Activate :
Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.t)
->
Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.t)
-> Tezos_protocol_environment_genesis__Environment.MBytes.t -> t
| Activate_testchain :
Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.t)
->
Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.t)
-> Tezos_protocol_environment_genesis__Environment.MBytes.t ->
Tezos_protocol_environment_genesis__Environment.Int64.t -> t.
Definition mk_case {A : Type}
(name : string)
(args :
Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding A)
: Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding A :=
conv (fun o => (tt, o))
(fun function_parameter =>
let '(tt, o) := function_parameter in
o) None
(merge_objs (obj1 (req None None "command" % string (constant name))) args).
Definition encoding
: Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding t :=
union
(Some
(* ❌ Variants not supported *)
variant)
(cons
(case "Activate" % string None
(Tezos_protocol_environment_genesis__Environment.Data_encoding.Tag 0)
(mk_case "activate" % string
(obj3
(req None None "hash" % string
Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.encoding))
(req None None "fitness" % string
Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.encoding))
(req None None "protocol_parameters" % string Variable.bytes)))
(fun function_parameter =>
match function_parameter with
|
Activate {|
protocol := protocol;
fitness := fitness;
protocol_parameters := protocol_parameters
|} => Some (protocol, fitness, protocol_parameters)
| _ => None
end)
(fun function_parameter =>
let '(protocol, fitness, protocol_parameters) := function_parameter
in
Activate
{| protocol := protocol; fitness := fitness;
protocol_parameters := protocol_parameters |}))
(cons
(case "Activate_testchain" % string None
(Tezos_protocol_environment_genesis__Environment.Data_encoding.Tag 1)
(mk_case "activate_testchain" % string
(obj4
(req None None "hash" % string
Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.encoding))
(req None None "fitness" % string
Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.encoding))
(req None None "protocol_parameters" % string Variable.bytes)
(req None None "validity_time" % string int64)))
(fun function_parameter =>
match function_parameter with
|
Activate_testchain {|
protocol := protocol;
fitness := fitness;
protocol_parameters := protocol_parameters;
delay := delay
|} => Some (protocol, fitness, protocol_parameters, delay)
| _ => None
end)
(fun function_parameter =>
let '(protocol, fitness, protocol_parameters, delay) :=
function_parameter in
Activate_testchain
{| protocol := protocol; fitness := fitness;
protocol_parameters := protocol_parameters; delay := delay |}))
[])).
Definition signed_encoding
: Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding
(t * Tezos_protocol_environment_genesis__Environment.Signature.t) :=
obj2 (req None None "content" % string encoding)
(req None None "signature" % string Signature.encoding).
Definition forge
(shell :
Tezos_protocol_environment_genesis__Environment.Block_header.shell_header)
(command : t) : Tezos_protocol_environment_genesis__Environment.MBytes.t :=
Data_encoding.Binary.to_bytes_exn
(Data_encoding.tup2 Block_header.shell_header_encoding encoding)
(shell, command).
End Command.
Module Pubkey.
Definition pubkey_key : list string := cons "genesis_key" % string [].
Definition default
: Tezos_protocol_environment_genesis__Environment.Signature.Public_key.t :=
Signature.Public_key.of_b58check_exn
"edpkvVCdQtDJHPnkmfRZuuHWKzFetH9N9nGP8F7zkwM2BJpjbvAU1N" % string.
Definition get_pubkey
(ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
: Tezos_protocol_environment_genesis__Environment.Lwt.t
Tezos_protocol_environment_genesis__Environment.Signature.Public_key.t :=
op_gtgteq (Context.get ctxt pubkey_key)
(fun function_parameter =>
match function_parameter with
| None => Lwt._return default
| Some b =>
match Data_encoding.Binary.of_bytes Signature.Public_key.encoding b
with
| None => Lwt._return default
| Some pk => Lwt._return pk
end
end).
Definition set_pubkey
(ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
(v : Tezos_protocol_environment_genesis__Environment.Signature.Public_key.t)
: Tezos_protocol_environment_genesis__Environment.Lwt.t
Tezos_protocol_environment_genesis__Environment.Context.t :=
op_atat (Context.set ctxt pubkey_key)
(Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding v).
Definition sandbox_encoding
: Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding
(Tezos_protocol_environment_genesis__Environment.Signature.Public_key.t *
unit) :=
merge_objs
(obj1
(req None None "genesis_pubkey" % string Signature.Public_key.encoding))
Data_encoding.unit.
Definition may_change_default
(ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
(json : Tezos_protocol_environment_genesis__Environment.Data_encoding.json)
: Tezos_protocol_environment_genesis__Environment.Lwt.t
Tezos_protocol_environment_genesis__Environment.Context.t :=
let '(pubkey, tt) := Data_encoding.Json.destruct sandbox_encoding json in
op_gtgteq (set_pubkey ctxt pubkey) (fun ctxt => Lwt._return ctxt).
End Pubkey.
Module Init.
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition version_key : list string := cons "version" % string [].
Definition version_value : string := "genesis" % string.
Definition check_inited
(ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
: Tezos_protocol_environment_genesis__Environment.Lwt.t
(Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult unit) :=
op_gtgteq (Context.get ctxt version_key)
(fun function_parameter =>
match function_parameter with
| None => failwith "Internal error: uninitialized context." % string
| Some version =>
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ :=
if
Tezos_protocol_environment_genesis__Environment.Compare.String.(Tezos_protocol_environment_genesis__Environment.S.Compare.op_ltgt)
version_value (MBytes.to_string version) then
failwith "Internal error: incompatible protocol version" % string
else
tt in
return_unit
end).
Definition tag_first_block
(ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
: Tezos_protocol_environment_genesis__Environment.Lwt.t
(Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
Tezos_protocol_environment_genesis__Environment.Context.t) :=
op_gtgteq (Context.get ctxt version_key)
(fun function_parameter =>
match function_parameter with
| None =>
op_gtgteq
(Context.set ctxt version_key (MBytes.of_string version_value))
(fun ctxt => _return ctxt)
| Some _version =>
failwith "Internal error: previously initialized context." % string
end).
End Init.
src/proto_genesis/lib_protocol/main.ml 22 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
type error += Parsing_error
type error += Invalid_signature
let () =
register_error_kind
`Permanent
~id:"parsing_error"
~title:"Parsing error"
~description:"Raised when a block header has not been parsed correctly"
~pp:(fun ppf () -> Format.fprintf ppf "Block header parsing error")
Data_encoding.empty
(function Parsing_error -> Some () | _ -> None)
(fun () -> Parsing_error)
let () =
register_error_kind
`Permanent
~id:"invalid_signature"
~title:"Invalid signature"
~description:"Raised when the provided signature is invalid"
~pp:(fun ppf () -> Format.fprintf ppf "Invalid signature")
Data_encoding.empty
(function Invalid_signature -> Some () | _ -> None)
(fun () -> Invalid_signature)
type operation_data = unit
let operation_data_encoding = Data_encoding.unit
type operation_receipt = unit
let operation_receipt_encoding = Data_encoding.unit
let operation_data_and_receipt_encoding =
Data_encoding.conv
(function ((), ()) -> ())
(fun () -> ((), ()))
Data_encoding.unit
type operation = {
shell: Operation.shell_header ;
protocol_data: operation_data ;
}
let acceptable_passes _op = []
let compare_operations _ _ = 0
let validation_passes = []
type block_header_data = {
command: Data.Command.t ;
signature: Signature.t ;
}
type block_header = {
shell: Block_header.shell_header ;
protocol_data: block_header_data ;
}
let block_header_data_encoding =
Data_encoding.conv
(fun { command ; signature } -> (command, signature))
(fun (command, signature) -> { command ; signature })
Data.Command.signed_encoding
type block_header_metadata = unit
let block_header_metadata_encoding = Data_encoding.unit
let max_block_length =
Data_encoding.Binary.length
Data.Command.encoding
(Activate_testchain { protocol = Protocol_hash.zero ;
fitness = [ MBytes.create 1 ] ;
protocol_parameters = MBytes.create 1 ;
delay = 0L })
+ Signature.size
let max_operation_data_length = 0
let check_signature ctxt ~chain_id { shell ; protocol_data = { command ; signature } } =
let bytes = Data.Command.forge shell command in
Data.Pubkey.get_pubkey ctxt >>= fun public_key ->
fail_unless
(Signature.check ~watermark:(Block_header chain_id) public_key signature bytes)
Invalid_signature
type validation_state = Updater.validation_result
let current_context ({ context ; _ } : validation_state) =
return context
(* temporary hardcoded key to be removed... *)
let protocol_parameters_key = [ "protocol_parameters" ]
let prepare_application ctxt command level timestamp _fitness =
match command with
| Data.Command.Activate { protocol = hash ; fitness ; protocol_parameters } ->
let message =
Some (Format.asprintf "activate %a" Protocol_hash.pp_short hash) in
Context.set ctxt protocol_parameters_key protocol_parameters >>= fun ctxt ->
Updater.activate ctxt hash >>= fun ctxt ->
return { Updater.message ; context = ctxt ;
fitness ; max_operations_ttl = 0 ;
last_allowed_fork_level = level ;
}
| Activate_testchain { protocol = hash ; fitness ; protocol_parameters ; delay } ->
let message =
Some (Format.asprintf "activate testchain %a" Protocol_hash.pp_short hash) in
Context.set ctxt protocol_parameters_key protocol_parameters >>= fun ctxt ->
let expiration = Time.add timestamp delay in
Updater.fork_test_chain ctxt ~protocol:hash ~expiration >>= fun ctxt ->
return { Updater.message ; context = ctxt ; fitness ;
max_operations_ttl = 0 ;
last_allowed_fork_level = level ;
}
let begin_application
~chain_id
~predecessor_context:ctxt
~predecessor_timestamp:_
~predecessor_fitness:_
block_header =
Data.Init.check_inited ctxt >>=? fun () ->
check_signature ctxt ~chain_id block_header >>=? fun () ->
prepare_application ctxt block_header.protocol_data.command
block_header.shell.level block_header.shell.timestamp block_header.shell.fitness
let begin_partial_application
~chain_id
~ancestor_context
~predecessor_timestamp
~predecessor_fitness
block_header =
begin_application
~chain_id
~predecessor_context:ancestor_context
~predecessor_timestamp
~predecessor_fitness
block_header
let begin_construction
~chain_id:_
~predecessor_context:ctxt
~predecessor_timestamp:_
~predecessor_level:level
~predecessor_fitness:fitness
~predecessor:_
~timestamp
?protocol_data
() =
match protocol_data with
| None ->
(* Dummy result. *)
return { Updater.message = None ; context = ctxt ;
fitness ; max_operations_ttl = 0 ;
last_allowed_fork_level = 0l ;
}
| Some { command ; _ }->
Data.Init.check_inited ctxt >>=? fun () ->
prepare_application ctxt command level timestamp fitness
let apply_operation _vctxt _ =
failwith "genesis.apply_operation" (* absurd *)
let finalize_block state = return (state, ())
let rpc_services = Services.rpc_services
(* temporary hardcoded key to be removed... *)
let sandbox_param_key = [ "sandbox_parameter" ]
let get_sandbox_param ctxt =
Context.get ctxt sandbox_param_key >>= function
| None -> return_none
| Some bytes ->
match Data_encoding.Binary.of_bytes Data_encoding.json bytes with
| None ->
failwith "Internal error: failed to parse the sandbox parameter."
| Some json -> return_some json
let init ctxt block_header =
Data.Init.tag_first_block ctxt >>=? fun ctxt ->
get_sandbox_param ctxt >>=? fun sandbox_param ->
begin
match sandbox_param with
| None -> return ctxt
| Some json ->
Data.Pubkey.may_change_default ctxt json >>= fun ctxt ->
return ctxt
end >>=? fun ctxt ->
return { Updater.message = None ; context = ctxt ;
fitness = block_header.Block_header.fitness ;
max_operations_ttl = 0 ;
last_allowed_fork_level = block_header.level ;
}
src/proto_genesis/lib_protocol/main.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
(* ❌ Structure item `typext` not handled. *)
type_extension
(* ❌ Structure item `typext` not handled. *)
type_extension
Definition operation_data := unit.
Definition operation_data_encoding
: Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding unit :=
Data_encoding.unit.
Definition operation_receipt := unit.
Definition operation_receipt_encoding
: Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding unit :=
Data_encoding.unit.
Definition operation_data_and_receipt_encoding
: Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding
(unit * unit) :=
Data_encoding.conv
(fun function_parameter =>
let '(tt, tt) := function_parameter in
tt)
(fun function_parameter =>
let 'tt := function_parameter in
(tt, tt)) None Data_encoding.unit.
Record operation := {
shell : Tezos_protocol_environment_genesis__Environment.Operation.shell_header;
protocol_data : operation_data }.
Definition acceptable_passes {A B : Type} (_op : A) : list B := [].
Definition compare_operations {A B : Type} (function_parameter : A) : B -> Z :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
0.
Definition validation_passes {A : Type} : list A := [].
Record block_header_data := {
command : Tezos_raw_protocol_genesis.Data.Command.t;
signature : Tezos_protocol_environment_genesis__Environment.Signature.t }.
Record block_header := {
shell :
Tezos_protocol_environment_genesis__Environment.Block_header.shell_header;
protocol_data : block_header_data }.
Definition block_header_data_encoding
: Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding
block_header_data :=
Data_encoding.conv
(fun function_parameter =>
let '{| command := command; signature := signature |} :=
function_parameter in
(command, signature))
(fun function_parameter =>
let '(command, signature) := function_parameter in
{| command := command; signature := signature |}) None
Data.Command.signed_encoding.
Definition block_header_metadata := unit.
Definition block_header_metadata_encoding
: Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding unit :=
Data_encoding.unit.
Definition max_block_length : Z :=
op_plus
(Data_encoding.Binary.length Data.Command.encoding
(Tezos_raw_protocol_genesis.Data.Command.Activate_testchain
{|
protocol :=
Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.zero);
fitness := cons (MBytes.create 1) [];
protocol_parameters := MBytes.create 1;
delay :=
(* ❌ Constant of type int64 is converted to int *)
0 |})) Signature.size.
Definition max_operation_data_length : Z := 0.
Definition check_signature
(ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
(chain_id :
Tezos_protocol_environment_genesis__Environment.Chain_id.(Tezos_protocol_environment_genesis__Environment.HASH.S.t))
(function_parameter : block_header)
: Tezos_protocol_environment_genesis__Environment.Lwt.t
(Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult unit) :=
let '{|
shell := shell;
protocol_data := {| command := command; signature := signature |}
|} := function_parameter in
let bytes := Data.Command.forge shell command in
op_gtgteq (Data.Pubkey.get_pubkey ctxt)
(fun public_key =>
fail_unless
(Signature.check
(Some
(Tezos_protocol_environment_genesis__Environment.Signature.Block_header
chain_id)) public_key signature string)
Tezos_protocol_environment_genesis__Environment.Error_monad.Invalid_signature).
Definition validation_state :=
Tezos_protocol_environment_genesis__Environment.Updater.validation_result.
Definition current_context (function_parameter : validation_state)
: Tezos_protocol_environment_genesis__Environment.Lwt.t
(Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
Tezos_protocol_environment_genesis__Environment.Context.t) :=
let '{| context := context |} := function_parameter in
_return context.
Definition protocol_parameters_key : list string :=
cons "protocol_parameters" % string [].
Definition prepare_application {A : Type}
(ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
(command : Tezos_raw_protocol_genesis.Data.Command.t)
(level : Tezos_protocol_environment_genesis__Environment.Int32.t)
(timestamp : Tezos_protocol_environment_genesis__Environment.Time.t)
(_fitness : A)
: Tezos_protocol_environment_genesis__Environment.Lwt.t
(Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
match command with
|
Tezos_raw_protocol_genesis.Data.Command.Activate {|
protocol := hash;
fitness := fitness;
protocol_parameters := protocol_parameters
|} =>
let message :=
Some
(Format.asprintf
(Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.String_literal
"activate " % string
(Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.Alpha
Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.End_of_format))
"activate %a" % string)
Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.pp_short)
hash) in
op_gtgteq (Context.set ctxt protocol_parameters_key protocol_parameters)
(fun ctxt =>
op_gtgteq (Updater.activate ctxt hash)
(fun ctxt =>
_return
{| Updater.context := ctxt; Updater.fitness := fitness;
Updater.message := message; Updater.max_operations_ttl := 0;
Updater.last_allowed_fork_level := level |}))
|
Tezos_raw_protocol_genesis.Data.Command.Activate_testchain {|
protocol := hash;
fitness := fitness;
protocol_parameters := protocol_parameters;
delay := delay
|} =>
let message :=
Some
(Format.asprintf
(Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.Format
(Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.String_literal
"activate testchain " % string
(Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.Alpha
Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.End_of_format))
"activate testchain %a" % string)
Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.pp_short)
hash) in
op_gtgteq (Context.set ctxt protocol_parameters_key protocol_parameters)
(fun ctxt =>
let expiration := Time.add timestamp delay in
op_gtgteq (Updater.fork_test_chain ctxt hash expiration)
(fun ctxt =>
_return
{| Updater.context := ctxt; Updater.fitness := fitness;
Updater.message := message; Updater.max_operations_ttl := 0;
Updater.last_allowed_fork_level := level |}))
end.
Definition begin_application {A B : Type}
(chain_id :
Tezos_protocol_environment_genesis__Environment.Chain_id.(Tezos_protocol_environment_genesis__Environment.HASH.S.t))
(ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
(function_parameter : A)
: B ->
block_header ->
Tezos_protocol_environment_genesis__Environment.Lwt.t
(Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
let '_ := function_parameter in
fun function_parameter =>
let '_ := function_parameter in
fun block_header =>
op_gtgteqquestion (Data.Init.check_inited ctxt)
(fun function_parameter =>
let 'tt := function_parameter in
op_gtgteqquestion (check_signature ctxt chain_id block_header)
(fun function_parameter =>
let 'tt := function_parameter in
prepare_application ctxt (command (protocol_data block_header))
(level (shell block_header)) (timestamp (shell block_header))
(fitness (shell block_header)))).
Definition begin_partial_application {A B : Type}
(chain_id :
Tezos_protocol_environment_genesis__Environment.Chain_id.(Tezos_protocol_environment_genesis__Environment.HASH.S.t))
(ancestor_context : Tezos_protocol_environment_genesis__Environment.Context.t)
(predecessor_timestamp : A) (predecessor_fitness : B)
(block_header : block_header)
: Tezos_protocol_environment_genesis__Environment.Lwt.t
(Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
begin_application chain_id ancestor_context predecessor_timestamp
predecessor_fitness block_header.
Definition begin_construction {A B C : Type} (function_parameter : A)
: Tezos_protocol_environment_genesis__Environment.Context.t ->
B ->
Tezos_protocol_environment_genesis__Environment.Int32.t ->
Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.t)
->
C ->
Tezos_protocol_environment_genesis__Environment.Time.t ->
(option block_header_data) ->
unit ->
Tezos_protocol_environment_genesis__Environment.Lwt.t
(Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
let '_ := function_parameter in
fun ctxt =>
fun function_parameter =>
let '_ := function_parameter in
fun level =>
fun fitness =>
fun function_parameter =>
let '_ := function_parameter in
fun timestamp =>
fun protocol_data =>
fun function_parameter =>
let 'tt := function_parameter in
match protocol_data with
| None =>
_return
{| Updater.context := ctxt; Updater.fitness := fitness;
Updater.message := None;
Updater.max_operations_ttl := 0;
Updater.last_allowed_fork_level :=
(* ❌ Constant of type int32 is converted to int *)
0 |}
| Some {| command := command |} =>
op_gtgteqquestion (Data.Init.check_inited ctxt)
(fun function_parameter =>
let 'tt := function_parameter in
prepare_application ctxt command level timestamp fitness)
end.
Definition apply_operation {A B C : Type} (_vctxt : A) (function_parameter : B)
: C :=
let '_ := function_parameter in
failwith "genesis.apply_operation" % string.
Definition finalize_block {A : Type} (state : A)
: Tezos_protocol_environment_genesis__Environment.Lwt.t
(Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
(A * unit)) := _return (state, tt).
Definition rpc_services
: Tezos_protocol_environment_genesis__Environment.RPC_directory.t
Tezos_protocol_environment_genesis__Environment.Updater.rpc_context :=
Services.rpc_services.
Definition sandbox_param_key : list string :=
cons "sandbox_parameter" % string [].
Definition get_sandbox_param
(ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
: Tezos_protocol_environment_genesis__Environment.Lwt.t
(Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
(option Tezos_protocol_environment_genesis__Environment.Data_encoding.json)) :=
op_gtgteq (Context.get ctxt sandbox_param_key)
(fun function_parameter =>
match function_parameter with
| None => return_none
| Some bytes =>
match Data_encoding.Binary.of_bytes Data_encoding.json string with
| None =>
failwith
"Internal error: failed to parse the sandbox parameter." % string
| Some json => return_some json
end
end).
Definition init
(ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
(block_header :
Tezos_protocol_environment_genesis__Environment.Block_header.shell_header)
: Tezos_protocol_environment_genesis__Environment.Lwt.t
(Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
op_gtgteqquestion (Data.Init.tag_first_block ctxt)
(fun ctxt =>
op_gtgteqquestion (get_sandbox_param ctxt)
(fun sandbox_param =>
op_gtgteqquestion
match sandbox_param with
| None => _return ctxt
| Some json =>
op_gtgteq (Data.Pubkey.may_change_default ctxt json)
(fun ctxt => _return ctxt)
end
(fun ctxt =>
_return
{| Updater.context := ctxt;
Updater.fitness := Block_header.fitness block_header;
Updater.message := None; Updater.max_operations_ttl := 0;
Updater.last_allowed_fork_level := level block_header |}))).
src/proto_genesis/lib_protocol/services.ml 14 errors
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
module Forge = struct
let block custom_root =
let open Data_encoding in
RPC_service.post_service
~description: "Forge a block"
~query: RPC_query.empty
~input:
(merge_objs
(obj6
(req "level" int32)
(req "proto_level" uint8)
(req "predecessor" Block_hash.encoding)
(req "timestamp" Time.encoding)
(req "fitness" Fitness.encoding)
(req "context" Context_hash.encoding))
Data.Command.encoding)
~output: (obj1 (req "payload" bytes))
RPC_path.(custom_root / "helpers" / "forge" / "block")
end
let int64_to_bytes i =
let b = MBytes.create 8 in
MBytes.set_int64 b 0 i;
b
let operations_hash =
Operation_list_list_hash.compute []
let rpc_services : Updater.rpc_context RPC_directory.t =
let dir = RPC_directory.empty in
let dir =
RPC_directory.register
dir
(Forge.block RPC_path.open_root)
(fun _ctxt () ((level, proto_level, predecessor,
timestamp, fitness, context), command) ->
let shell = { Block_header.level ; proto_level ; predecessor ;
timestamp ; fitness ; validation_passes = 0 ;
operations_hash ; context } in
let bytes = Data.Command.forge shell command in
return bytes) in
dir
src/proto_genesis/lib_protocol/services.ml.v
Require Import OCaml.OCaml.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.
Module Forge.
Definition block {A B : Type}
(custom_root :
Tezos_protocol_environment_genesis__Environment.RPC_path.path A B)
: Tezos_protocol_environment_genesis__Environment.RPC_service.service
variant A B unit
((int32 * Z *
Tezos_protocol_environment_genesis__Environment.Block_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.t)
* Tezos_protocol_environment_genesis__Environment.Time.t *
Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.t)
*
Tezos_protocol_environment_genesis__Environment.Context_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.t))
* Tezos_raw_protocol_genesis.Data.Command.t)
Tezos_protocol_environment_genesis__Environment.MBytes.t :=
RPC_service.post_service (Some "Forge a block" % string) RPC_query.empty
(merge_objs
(obj6 (req None None "level" % string int32)
(req None None "proto_level" % string uint8)
(req None None "predecessor" % string
Tezos_protocol_environment_genesis__Environment.Block_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.encoding))
(req None None "timestamp" % string Time.encoding)
(req None None "fitness" % string
Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.encoding))
(req None None "context" % string
Tezos_protocol_environment_genesis__Environment.Context_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.encoding)))
Data.Command.encoding) (obj1 (req None None "payload" % string bytes))
(op_div (op_div (op_div custom_root "helpers" % string) "forge" % string)
"block" % string).
End Forge.
Definition int64_to_bytes (i : int64)
: Tezos_protocol_environment_genesis__Environment.MBytes.t :=
let b := MBytes.create 8 in
(* ❌ Sequences of instructions are not handled (operator ";") *)
let _ := MBytes.set_int64 b 0 i in
b.
Definition operations_hash
: Tezos_protocol_environment_genesis__Environment.Operation_list_list_hash.(Tezos_protocol_environment_genesis__Environment.MERKLE_TREE.S.t) :=
Tezos_protocol_environment_genesis__Environment.Operation_list_list_hash.(Tezos_protocol_environment_genesis__Environment.MERKLE_TREE.S.compute)
[].
Definition rpc_services
: Tezos_protocol_environment_genesis__Environment.RPC_directory.t
Tezos_protocol_environment_genesis__Environment.Updater.rpc_context :=
let dir := RPC_directory.empty in
let dir :=
RPC_directory.register dir (Forge.block RPC_path.open_root)
(fun _ctxt =>
fun function_parameter =>
let 'tt := function_parameter in
fun function_parameter =>
let
'((level, proto_level, predecessor, timestamp, fitness, context),
command) := function_parameter in
let shell :=
{| Block_header.level := level;
Block_header.proto_level := proto_level;
Block_header.predecessor := predecessor;
Block_header.timestamp := timestamp;
Block_header.validation_passes := 0;
Block_header.operations_hash := operations_hash;
Block_header.fitness := fitness; Block_header.context := context
|} in
let bytes := Data.Command.forge shell command in
_return string) in
dir.